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 CmdRandom env err m =
  84   ( CmdM'             env err m
  85   , HasConnectionPool env
  86   , HasConfig         env
  87   , MonadRandom             m
  88   )
  89
  90 type Cmd'' env err a = forall m.     CmdM'' env err m => m a
  91 type Cmd'  env err a = forall m.     CmdM'  env err m => m a
  92 type Cmd       err a = forall m env. CmdM   env err m => m a
  93 type CmdR      err a = forall m env. CmdRandom   env err m => m a
  94
  95
  96
  97 fromInt64ToInt :: Int64 -> Int
  98 fromInt64ToInt = fromIntegral
  99
 100 -- TODO: ideally there should be very few calls to this functions.
 101 mkCmd :: (Connection -> IO a) -> Cmd err a
 102 mkCmd k = do
 103   pool <- view connPool
 104   withResource pool (liftBase . k)
 105
 106 runCmd :: (HasConnectionPool env)
 107        => env
 108        -> Cmd'' env err a
 109        -> IO (Either err a)
 110 runCmd env m = runExceptT $ runReaderT m env
 111
 112 runOpaQuery :: Default FromFields fields haskells
 113             => Select fields
 114             -> Cmd err [haskells]
 115 runOpaQuery q = mkCmd $ \c -> runQuery c q
 116
 117 runCountOpaQuery :: Select a -> Cmd err Int
 118 runCountOpaQuery q = do
 119   counts <- mkCmd $ \c -> runQuery c $ countRows q
 120   -- countRows is guaranteed to return a list with exactly one row so DL.head is safe here
 121   pure $ fromInt64ToInt $ DL.head counts
 122
 123 formatPGSQuery :: PGS.ToRow a => PGS.Query -> a -> Cmd err DB.ByteString
 124 formatPGSQuery q a = mkCmd $ \conn -> PGS.formatQuery conn q a
 125
 126 -- TODO use runPGSQueryDebug everywhere
 127 runPGSQuery' :: (PGS.ToRow a, PGS.FromRow b) => PGS.Query -> a -> Cmd err [b]
 128 runPGSQuery' q a = mkCmd $ \conn -> PGS.query conn q a
 129
 130 runPGSQuery :: ( CmdM env err m
 131                , PGS.FromRow r, PGS.ToRow q
 132                )
 133                => PGS.Query -> q -> m [r]
 134 runPGSQuery q a = mkCmd $ \conn -> catch (PGS.query conn q a) (printError conn)
 135   where
 136     printError c (SomeException e) = do
 137       q' <- PGS.formatQuery c q a
 138       hPutStrLn stderr q'
 139       throw (SomeException e)
 140
 141
 142 execPGSQuery :: PGS.ToRow a => PGS.Query -> a -> Cmd err Int64
 143 execPGSQuery q a = mkCmd $ \conn -> PGS.execute conn q a
 144
 145 ------------------------------------------------------------------------
 146
 147 databaseParameters :: FilePath -> IO PGS.ConnectInfo
 148 databaseParameters fp = do
 149   ini         <- readIniFile fp
 150   let ini'' = case ini of
 151         Left e     -> panic (pack $ "No ini file error" <> show e)
 152         Right ini' -> ini'
 153
 154   let val x = case (lookupValue (pack "database") (pack x) ini'') of
 155         Left _ -> panic (pack $ "no" <> x)
 156         Right p' -> unpack p'
 157
 158   pure $ PGS.ConnectInfo { PGS.connectHost     = val       "DB_HOST"
 159                          , PGS.connectPort     = read (val "DB_PORT") :: Word16
 160                          , PGS.connectUser     = val       "DB_USER"
 161                          , PGS.connectPassword = val       "DB_PASS"
 162                          , PGS.connectDatabase = val       "DB_NAME"
 163                          }
 164
 165 connectGargandb :: FilePath -> IO Connection
 166 connectGargandb fp = databaseParameters fp >>= \params -> connect params
 167
 168 fromField' :: (Typeable b, FromJSON b) => Field -> Maybe DB.ByteString -> Conversion b
 169 fromField' field mb = do
 170     v <- fromField field mb
 171     valueToHyperdata v
 172       where
 173           valueToHyperdata v = case fromJSON v of
 174              Success a  -> pure a
 175              Error _err -> returnError ConversionFailed field
 176                          $ DL.intercalate " " [ "cannot parse hyperdata for JSON: "
 177                                               , show v
 178                                               ]
 179
 180 printSqlOpa :: Default Unpackspec a a => Query a -> IO ()
 181 printSqlOpa = putStrLn . maybe "Empty query" identity . showSqlForPostgres
 182