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