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.Except
  19 import Control.Monad.Random
  20 import Control.Monad.Reader
  21 import Control.Monad.Trans.Control (MonadBaseControl)
  22 import Data.Aeson (Result(Error,Success), fromJSON, FromJSON)
  23 import Data.ByteString.Char8 (hPutStrLn)
  24 import Data.Either.Extra (Either)
  25 import Data.Pool (Pool, withResource)
  26 import Data.Profunctor.Product.Default (Default)
  27 import Data.Text (unpack, Text)
  28 import Data.Word (Word16)
  29 import Database.PostgreSQL.Simple (Connection, connect)
  30 import Database.PostgreSQL.Simple.FromField ( Conversion, ResultError(ConversionFailed), fromField, returnError)
  31 import Database.PostgreSQL.Simple.Internal  (Field)
  32 import Gargantext.Core.Mail.Types (HasMail)
  33 import Gargantext.Prelude
  34 import Gargantext.Prelude.Config (readIniFile', val)
  35 import Opaleye (Unpackspec, showSql, FromFields, Select, runSelect, SqlJsonb, DefaultFromField)
  36 import Opaleye.Aggregate (countRows)
  37 import System.IO (FilePath)
  38 import System.IO (stderr)
  39 import Text.Read (read)
  40 import qualified Data.ByteString      as DB
  41 import qualified Data.List as DL
  42 import qualified Database.PostgreSQL.Simple as PGS
  43
  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   hasConfig :: Getter env GargConfig
  55
  56 instance HasConfig GargConfig where
  57   hasConfig = identity
  58
  59 -------------------------------------------------------
  60 type JSONB = DefaultFromField SqlJsonb
  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   , HasMail           env
  82   )
  83
  84 type CmdRandom env err m =
  85   ( CmdM'             env err m
  86   , HasConnectionPool env
  87   , HasConfig         env
  88   , MonadRandom       m
  89   , HasMail           env
  90   )
  91
  92 type Cmd'' env err a = forall m.     CmdM''    env err m => m a
  93 type Cmd'  env err a = forall m.     CmdM'     env err m => m a
  94 type Cmd       err a = forall m env. CmdM      env err m => m a
  95 type CmdR      err a = forall m env. CmdRandom env err m => m a
  96
  97
  98
  99 fromInt64ToInt :: Int64 -> Int
 100 fromInt64ToInt = fromIntegral
 101
 102 -- TODO: ideally there should be very few calls to this functions.
 103 mkCmd :: (Connection -> IO a) -> Cmd err a
 104 mkCmd k = do
 105   pool <- view connPool
 106   withResource pool (liftBase . k)
 107
 108 runCmd :: (HasConnectionPool env)
 109        => env
 110        -> Cmd'' env err a
 111        -> IO (Either err a)
 112 runCmd env m = runExceptT $ runReaderT m env
 113
 114 runOpaQuery :: Default FromFields fields haskells
 115             => Select fields
 116             -> Cmd err [haskells]
 117 runOpaQuery q = mkCmd $ \c -> runSelect c q
 118
 119 runCountOpaQuery :: Select a -> Cmd err Int
 120 runCountOpaQuery q = do
 121   counts <- mkCmd $ \c -> runSelect c $ countRows q
 122   -- countRows is guaranteed to return a list with exactly one row so DL.head is safe here
 123   pure $ fromInt64ToInt $ DL.head counts
 124
 125 formatPGSQuery :: PGS.ToRow a => PGS.Query -> a -> Cmd err DB.ByteString
 126 formatPGSQuery q a = mkCmd $ \conn -> PGS.formatQuery conn q a
 127
 128 -- TODO use runPGSQueryDebug everywhere
 129 runPGSQuery' :: (PGS.ToRow a, PGS.FromRow b) => PGS.Query -> a -> Cmd err [b]
 130 runPGSQuery' q a = mkCmd $ \conn -> PGS.query conn q a
 131
 132 runPGSQuery :: ( CmdM env err m
 133                , PGS.FromRow r, PGS.ToRow q
 134                )
 135                => PGS.Query -> q -> m [r]
 136 runPGSQuery q a = mkCmd $ \conn -> catch (PGS.query conn q a) (printError conn)
 137   where
 138     printError c (SomeException e) = do
 139       q' <- PGS.formatQuery c q a
 140       hPutStrLn stderr q'
 141       throw (SomeException e)
 142
 143 -- | TODO catch error
 144 runPGSQuery_ :: ( CmdM env err m
 145                , PGS.FromRow r
 146                )
 147                => PGS.Query -> m [r]
 148 runPGSQuery_ q = mkCmd $ \conn -> catch (PGS.query_ conn q) printError
 149   where
 150     printError (SomeException e) = do
 151       printDebug "[G.D.P.runPGSQuery_]" ("TODO: format query error query" :: Text)
 152       throw (SomeException e)
 153
 154
 155
 156 execPGSQuery :: PGS.ToRow a => PGS.Query -> a -> Cmd err Int64
 157 execPGSQuery q a = mkCmd $ \conn -> PGS.execute conn q a
 158
 159 ------------------------------------------------------------------------
 160
 161 databaseParameters :: FilePath -> IO PGS.ConnectInfo
 162 databaseParameters fp = do
 163   ini <- readIniFile' fp
 164   let val' key = unpack $ val ini "database" key
 165
 166   pure $ PGS.ConnectInfo { PGS.connectHost     = val' "DB_HOST"
 167                          , PGS.connectPort     = read (val' "DB_PORT") :: Word16
 168                          , PGS.connectUser     = val' "DB_USER"
 169                          , PGS.connectPassword = val' "DB_PASS"
 170                          , PGS.connectDatabase = val' "DB_NAME"
 171                          }
 172
 173 connectGargandb :: FilePath -> IO Connection
 174 connectGargandb fp = databaseParameters fp >>= \params -> connect params
 175
 176 fromField' :: (Typeable b, FromJSON b) => Field -> Maybe DB.ByteString -> Conversion b
 177 fromField' field mb = do
 178     v <- fromField field mb
 179     valueToHyperdata v
 180       where
 181           valueToHyperdata v = case fromJSON v of
 182              Success a  -> pure a
 183              Error _err -> returnError ConversionFailed field
 184                          $ DL.intercalate " " [ "cannot parse hyperdata for JSON: "
 185                                               , show v
 186                                               ]
 187
 188 printSqlOpa :: Default Unpackspec a a => Select a -> IO ()
 189 printSqlOpa = putStrLn . maybe "Empty query" identity . showSql
 190