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 (pack, 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 (readMaybe)
  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 {-
 144 -- TODO
 145 runPGSQueryFold :: ( CmdM env err m
 146                , PGS.FromRow r
 147                )
 148                => PGS.Query -> a -> (a -> r -> IO a) -> m a
 149 runPGSQueryFold q initialState consume = mkCmd $ \conn -> catch (PGS.fold_ conn initialState consume) (printError conn)
 150   where
 151     printError c (SomeException e) = do
 152       q' <- PGS.formatQuery c q
 153       hPutStrLn stderr q'
 154       throw (SomeException e)
 155 -}
 156
 157
 158
 159 -- | TODO catch error
 160 runPGSQuery_ :: ( CmdM env err m
 161                , PGS.FromRow r
 162                )
 163                => PGS.Query -> m [r]
 164 runPGSQuery_ q = mkCmd $ \conn -> catch (PGS.query_ conn q) printError
 165   where
 166     printError (SomeException e) = do
 167       printDebug "[G.D.P.runPGSQuery_]" ("TODO: format query error" :: Text)
 168       throw (SomeException e)
 169
 170
 171 execPGSQuery :: PGS.ToRow a => PGS.Query -> a -> Cmd err Int64
 172 execPGSQuery q a = mkCmd $ \conn -> PGS.execute conn q a
 173
 174 ------------------------------------------------------------------------
 175 databaseParameters :: FilePath -> IO PGS.ConnectInfo
 176 databaseParameters fp = do
 177   ini <- readIniFile' fp
 178   let val' key = unpack $ val ini "database" key
 179   let dbPortRaw = val' "DB_PORT"
 180   let dbPort = case (readMaybe dbPortRaw :: Maybe Word16) of
 181         Nothing -> panic $ "DB_PORT incorrect: " <> (pack dbPortRaw)
 182         Just d  -> d
 183
 184   pure $ PGS.ConnectInfo { PGS.connectHost     = val' "DB_HOST"
 185                          , PGS.connectPort     = dbPort
 186                          , PGS.connectUser     = val' "DB_USER"
 187                          , PGS.connectPassword = val' "DB_PASS"
 188                          , PGS.connectDatabase = val' "DB_NAME"
 189                          }
 190
 191 connectGargandb :: FilePath -> IO Connection
 192 connectGargandb fp = databaseParameters fp >>= \params -> connect params
 193
 194 fromField' :: (Typeable b, FromJSON b) => Field -> Maybe DB.ByteString -> Conversion b
 195 fromField' field mb = do
 196     v <- fromField field mb
 197     valueToHyperdata v
 198       where
 199           valueToHyperdata v = case fromJSON v of
 200              Success a  -> pure a
 201              Error _err -> returnError ConversionFailed field
 202                          $ DL.intercalate " " [ "cannot parse hyperdata for JSON: "
 203                                               , show v
 204                                               ]
 205
 206 printSqlOpa :: Default Unpackspec a a => Select a -> IO ()
 207 printSqlOpa = putStrLn . maybe "Empty query" identity . showSql
 208