src/Gargantext/Database/Prelude.hs

   1 {-|
   2 Module      : Gargantext.Database.Prelude
   3 Description : Specific Prelude for Database management
   4 Copyright   : (c) CNRS, 2017-Present
   5 License     : AGPL + CECILL v3
   6 Maintainer  : team@gargantext.org
   7 Stability   : experimental
   8 Portability : POSIX
   9
  10 -}
  11
  12 {-# LANGUAGE ConstraintKinds   #-}
  13
  14 module Gargantext.Database.Prelude where
  15
  16 import Control.Exception
  17 import Control.Lens (Getter, view)
  18 import Control.Monad.Error.Class -- (MonadError(..), Error)
  19 import Control.Monad.Except
  20 import Control.Monad.Reader
  21 import Control.Monad.Random
  22 import Control.Monad.Trans.Control (MonadBaseControl)
  23 import Data.Aeson (Result(Error,Success), fromJSON, FromJSON)
  24 import Data.ByteString.Char8 (hPutStrLn)
  25 import Data.Either.Extra (Either(Left, Right))
  26 import Data.Ini (readIniFile, lookupValue)
  27 import Data.Pool (Pool, withResource)
  28 import Data.Profunctor.Product.Default (Default)
  29 import Data.Text (unpack, pack)
  30 import Data.Word (Word16)
  31 import Database.PostgreSQL.Simple (Connection, connect)
  32 import Database.PostgreSQL.Simple.FromField ( Conversion, ResultError(ConversionFailed), fromField, returnError)
  33 import Database.PostgreSQL.Simple.Internal  (Field)
  34 import Opaleye (Query, Unpackspec, showSqlForPostgres, FromFields, Select, runQuery, PGJsonb, QueryRunnerColumnDefault)
  35 import Opaleye.Aggregate (countRows)
  36 import System.IO (FilePath)
  37 import System.IO (stderr)
  38 import Text.Read (read)
  39 import qualified Data.ByteString      as DB
  40 import qualified Data.List as DL
  41 import qualified Database.PostgreSQL.Simple as PGS
  42
  43 import Gargantext.Prelude
  44 import Gargantext.Prelude.Config (GargConfig())
  45
  46 -------------------------------------------------------
  47 class HasConnectionPool env where
  48   connPool :: Getter env (Pool Connection)
  49
  50 instance HasConnectionPool (Pool Connection) where
  51   connPool = identity
  52
  53 class HasConfig env where
  54   config :: Getter env GargConfig
  55
  56 instance HasConfig GargConfig where
  57   config = identity
  58
  59 -------------------------------------------------------
  60 type JSONB = QueryRunnerColumnDefault PGJsonb
  61 -------------------------------------------------------
  62
  63 type CmdM'' env err m =
  64   ( MonadReader     env     m
  65   , MonadError          err m
  66   , MonadBaseControl IO     m
  67   , MonadRandom             m
  68   )
  69
  70 type CmdM' env err m =
  71   ( MonadReader     env     m
  72   , MonadError          err m
  73   , MonadBaseControl IO     m
  74   -- , MonadRandom             m
  75   )
  76
  77 type CmdM env err m =
  78   ( CmdM'             env err m
  79   , HasConnectionPool env
  80   , HasConfig         env
  81   )
  82
  83 type Cmd'' env err a = forall m.     CmdM'' env err m => m a
  84 type Cmd'  env err a = forall m.     CmdM'  env err m => m a
  85 type Cmd       err a = forall m env. CmdM   env err m => m a
  86
  87
  88
  89
  90 fromInt64ToInt :: Int64 -> Int
  91 fromInt64ToInt = fromIntegral
  92
  93 -- TODO: ideally there should be very few calls to this functions.
  94 mkCmd :: (Connection -> IO a) -> Cmd err a
  95 mkCmd k = do
  96   pool <- view connPool
  97   withResource pool (liftBase . k)
  98
  99 runCmd :: (HasConnectionPool env)
 100        => env
 101        -> Cmd'' env err a
 102        -> IO (Either err a)
 103 runCmd env m = runExceptT $ runReaderT m env
 104
 105 runOpaQuery :: Default FromFields fields haskells
 106             => Select fields
 107             -> Cmd err [haskells]
 108 runOpaQuery q = mkCmd $ \c -> runQuery c q
 109
 110 runCountOpaQuery :: Select a -> Cmd err Int
 111 runCountOpaQuery q = do
 112   counts <- mkCmd $ \c -> runQuery c $ countRows q
 113   -- countRows is guaranteed to return a list with exactly one row so DL.head is safe here
 114   pure $ fromInt64ToInt $ DL.head counts
 115
 116 formatPGSQuery :: PGS.ToRow a => PGS.Query -> a -> Cmd err DB.ByteString
 117 formatPGSQuery q a = mkCmd $ \conn -> PGS.formatQuery conn q a
 118
 119 -- TODO use runPGSQueryDebug everywhere
 120 runPGSQuery' :: (PGS.ToRow a, PGS.FromRow b) => PGS.Query -> a -> Cmd err [b]
 121 runPGSQuery' q a = mkCmd $ \conn -> PGS.query conn q a
 122
 123 runPGSQuery :: ( CmdM env err m
 124                , PGS.FromRow r, PGS.ToRow q
 125                )
 126                => PGS.Query -> q -> m [r]
 127 runPGSQuery q a = mkCmd $ \conn -> catch (PGS.query conn q a) (printError conn)
 128   where
 129     printError c (SomeException e) = do
 130       q' <- PGS.formatQuery c q a
 131       hPutStrLn stderr q'
 132       throw (SomeException e)
 133
 134
 135 execPGSQuery :: PGS.ToRow a => PGS.Query -> a -> Cmd err Int64
 136 execPGSQuery q a = mkCmd $ \conn -> PGS.execute conn q a
 137
 138 ------------------------------------------------------------------------
 139
 140 databaseParameters :: FilePath -> IO PGS.ConnectInfo
 141 databaseParameters fp = do
 142   ini         <- readIniFile fp
 143   let ini'' = case ini of
 144         Left e     -> panic (pack $ "No ini file error" <> show e)
 145         Right ini' -> ini'
 146
 147   let val x = case (lookupValue (pack "database") (pack x) ini'') of
 148         Left _ -> panic (pack $ "no" <> x)
 149         Right p' -> unpack p'
 150
 151   pure $ PGS.ConnectInfo { PGS.connectHost     = val       "DB_HOST"
 152                          , PGS.connectPort     = read (val "DB_PORT") :: Word16
 153                          , PGS.connectUser     = val       "DB_USER"
 154                          , PGS.connectPassword = val       "DB_PASS"
 155                          , PGS.connectDatabase = val       "DB_NAME"
 156                          }
 157
 158 connectGargandb :: FilePath -> IO Connection
 159 connectGargandb fp = databaseParameters fp >>= \params -> connect params
 160
 161 fromField' :: (Typeable b, FromJSON b) => Field -> Maybe DB.ByteString -> Conversion b
 162 fromField' field mb = do
 163     v <- fromField field mb
 164     valueToHyperdata v
 165       where
 166           valueToHyperdata v = case fromJSON v of
 167              Success a  -> pure a
 168              Error _err -> returnError ConversionFailed field
 169                          $ DL.intercalate " " [ "cannot parse hyperdata for JSON: "
 170                                               , show v
 171                                               ]
 172
 173 printSqlOpa :: Default Unpackspec a a => Query a -> IO ()
 174 printSqlOpa = putStrLn . maybe "Empty query" identity . showSqlForPostgres
 175