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