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.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.Maybe (maybe)
  27 import Data.Monoid ((<>))
  28 import Data.Pool (Pool, withResource)
  29 import Data.Profunctor.Product.Default (Default)
  30 import Data.Text (unpack, pack)
  31 import Data.Typeable (Typeable)
  32 import Data.Word (Word16)
  33 import Database.PostgreSQL.Simple (Connection, connect)
  34 import Database.PostgreSQL.Simple.FromField ( Conversion, ResultError(ConversionFailed), fromField, returnError)
  35 import Database.PostgreSQL.Simple.Internal  (Field)
  36 import Gargantext.Prelude
  37 import Gargantext.Prelude.Config (GargConfig())
  38 import Opaleye (Query, Unpackspec, showSqlForPostgres, FromFields, Select, runQuery)
  39 import Opaleye.Aggregate (countRows)
  40 import System.IO (FilePath)
  41 import System.IO (stderr)
  42 import Text.Read (read)
  43 import qualified Data.ByteString      as DB
  44 import qualified Data.List as DL
  45 import qualified Database.PostgreSQL.Simple as PGS
  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 CmdM' env err m =
  62   ( MonadReader env m
  63   , MonadError err m
  64   , MonadBaseControl IO m
  65   )
  66
  67 type CmdM env err m =
  68   ( CmdM' env err m
  69   , HasConnectionPool env
  70   , HasConfig         env
  71   )
  72
  73 type Cmd' env err a = forall m. CmdM' env err m => m a
  74
  75 type Cmd err a = forall m env. CmdM env err m => m a
  76
  77 fromInt64ToInt :: Int64 -> Int
  78 fromInt64ToInt = fromIntegral
  79
  80 -- TODO: ideally there should be very few calls to this functions.
  81 mkCmd :: (Connection -> IO a) -> Cmd err a
  82 mkCmd k = do
  83   pool <- view connPool
  84   withResource pool (liftBase . k)
  85
  86 runCmd :: (HasConnectionPool env)
  87        => env
  88        -> Cmd' env err a
  89        -> IO (Either err a)
  90 runCmd env m = runExceptT $ runReaderT m env
  91
  92 runOpaQuery :: Default FromFields fields haskells
  93             => Select fields
  94             -> Cmd err [haskells]
  95 runOpaQuery q = mkCmd $ \c -> runQuery c q
  96
  97 runCountOpaQuery :: Select a -> Cmd err Int
  98 runCountOpaQuery q = do
  99   counts <- mkCmd $ \c -> runQuery c $ countRows q
 100   -- countRows is guaranteed to return a list with exactly one row so DL.head is safe here
 101   pure $ fromInt64ToInt $ DL.head counts
 102
 103 formatPGSQuery :: PGS.ToRow a => PGS.Query -> a -> Cmd err DB.ByteString
 104 formatPGSQuery q a = mkCmd $ \conn -> PGS.formatQuery conn q a
 105
 106 -- TODO use runPGSQueryDebug everywhere
 107 runPGSQuery' :: (PGS.ToRow a, PGS.FromRow b) => PGS.Query -> a -> Cmd err [b]
 108 runPGSQuery' q a = mkCmd $ \conn -> PGS.query conn q a
 109
 110 runPGSQuery :: (MonadError err m, MonadReader env m, MonadBaseControl IO m,
 111                 PGS.FromRow r, PGS.ToRow q, HasConnectionPool env, HasConfig env)
 112                 => PGS.Query -> q -> m [r]
 113 runPGSQuery q a = mkCmd $ \conn -> catch (PGS.query conn q a) (printError conn)
 114   where
 115     printError c (SomeException e) = do
 116       q' <- PGS.formatQuery c q a
 117       hPutStrLn stderr q'
 118       throw (SomeException e)
 119
 120
 121 execPGSQuery :: PGS.ToRow a => PGS.Query -> a -> Cmd err Int64
 122 execPGSQuery q a = mkCmd $ \conn -> PGS.execute conn q a
 123
 124 ------------------------------------------------------------------------
 125
 126 databaseParameters :: FilePath -> IO PGS.ConnectInfo
 127 databaseParameters fp = do
 128   ini         <- readIniFile fp
 129   let ini'' = case ini of
 130         Left e     -> panic (pack $ "No ini file error" <> show e)
 131         Right ini' -> ini'
 132
 133   let val x = case (lookupValue (pack "database") (pack x) ini'') of
 134         Left _ -> panic (pack $ "no" <> x)
 135         Right p' -> unpack p'
 136
 137   pure $ PGS.ConnectInfo { PGS.connectHost     = val       "DB_HOST"
 138                          , PGS.connectPort     = read (val "DB_PORT") :: Word16
 139                          , PGS.connectUser     = val       "DB_USER"
 140                          , PGS.connectPassword = val       "DB_PASS"
 141                          , PGS.connectDatabase = val       "DB_NAME"
 142                          }
 143
 144 connectGargandb :: FilePath -> IO Connection
 145 connectGargandb fp = databaseParameters fp >>= \params -> connect params
 146
 147 fromField' :: (Typeable b, FromJSON b) => Field -> Maybe DB.ByteString -> Conversion b
 148 fromField' field mb = do
 149     v <- fromField field mb
 150     valueToHyperdata v
 151       where
 152           valueToHyperdata v = case fromJSON v of
 153              Success a  -> pure a
 154              Error _err -> returnError ConversionFailed field
 155                          $ DL.intercalate " " [ "cannot parse hyperdata for JSON: "
 156                                               , show v
 157                                               ]
 158
 159 printSqlOpa :: Default Unpackspec a a => Query a -> IO ()
 160 printSqlOpa = putStrLn . maybe "Empty query" identity . showSqlForPostgres
 161