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