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.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
  49 class HasConnectionPool env where
  50   connPool :: Getter env (Pool Connection)
  51
  52 instance HasConnectionPool (Pool Connection) where
  53   connPool = identity
  54
  55 class HasConfig env where
  56   hasConfig :: Getter env GargConfig
  57
  58 instance HasConfig GargConfig where
  59   hasConfig = identity
  60
  61 -------------------------------------------------------
  62 type CmdM' env err m =
  63   ( MonadReader env m
  64   , MonadError err m
  65   , MonadBaseControl IO m
  66   )
  67
  68 type CmdM env err m =
  69   ( CmdM' env err m
  70   , HasConnectionPool env
  71   , HasConfig         env
  72   )
  73
  74 type Cmd' env err a = forall m. CmdM' env err m => m a
  75
  76 type Cmd err a = forall m env. CmdM env err m => m a
  77
  78 fromInt64ToInt :: Int64 -> Int
  79 fromInt64ToInt = fromIntegral
  80
  81 -- TODO: ideally there should be very few calls to this functions.
  82 mkCmd :: (Connection -> IO a) -> Cmd err a
  83 mkCmd k = do
  84   pool <- view connPool
  85   withResource pool (liftBase . k)
  86
  87 runCmd :: (HasConnectionPool env)
  88        => env -> 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 -> Cmd err [haskells]
  94 runOpaQuery q = mkCmd $ \c -> runQuery c q
  95
  96 runCountOpaQuery :: Select a -> Cmd err Int
  97 runCountOpaQuery q = do
  98   counts <- mkCmd $ \c -> runQuery c $ countRows q
  99   -- countRows is guaranteed to return a list with exactly one row so DL.head is safe here
 100   pure $ fromInt64ToInt $ DL.head counts
 101
 102 formatPGSQuery :: PGS.ToRow a => PGS.Query -> a -> Cmd err DB.ByteString
 103 formatPGSQuery q a = mkCmd $ \conn -> PGS.formatQuery conn q a
 104
 105 -- TODO use runPGSQueryDebug everywhere
 106 runPGSQuery' :: (PGS.ToRow a, PGS.FromRow b) => PGS.Query -> a -> Cmd err [b]
 107 runPGSQuery' q a = mkCmd $ \conn -> PGS.query conn q a
 108
 109 runPGSQuery :: (MonadError err m, MonadReader env m, MonadBaseControl IO m,
 110                 PGS.FromRow r, PGS.ToRow q, HasConnectionPool env, HasConfig env)
 111                 => PGS.Query -> q -> m [r]
 112 runPGSQuery q a = mkCmd $ \conn -> catch (PGS.query conn q a) (printError conn)
 113   where
 114     printError c (SomeException e) = do
 115       q' <- PGS.formatQuery c q a
 116       hPutStrLn stderr q'
 117       throw (SomeException e)
 118
 119
 120 execPGSQuery :: PGS.ToRow a => PGS.Query -> a -> Cmd err Int64
 121 execPGSQuery q a = mkCmd $ \conn -> PGS.execute conn q a
 122
 123 ------------------------------------------------------------------------
 124
 125 databaseParameters :: FilePath -> IO PGS.ConnectInfo
 126 databaseParameters fp = do
 127   ini         <- readIniFile fp
 128   let ini'' = case ini of
 129         Left e     -> panic (pack $ "No ini file error" <> show e)
 130         Right ini' -> ini'
 131
 132   let val x = case (lookupValue (pack "database") (pack x) ini'') of
 133         Left _ -> panic (pack $ "no" <> x)
 134         Right p' -> unpack p'
 135
 136   pure $ PGS.ConnectInfo { PGS.connectHost     = val       "DB_HOST"
 137                          , PGS.connectPort     = read (val "DB_PORT") :: Word16
 138                          , PGS.connectUser     = val       "DB_USER"
 139                          , PGS.connectPassword = val       "DB_PASS"
 140                          , PGS.connectDatabase = val       "DB_NAME"
 141                          }
 142
 143 connectGargandb :: FilePath -> IO Connection
 144 connectGargandb fp = databaseParameters fp >>= \params -> connect params
 145
 146 fromField' :: (Typeable b, FromJSON b) => Field -> Maybe DB.ByteString -> Conversion b
 147 fromField' field mb = do
 148     v <- fromField field mb
 149     valueToHyperdata v
 150       where
 151           valueToHyperdata v = case fromJSON v of
 152              Success a  -> pure a
 153              Error _err -> returnError ConversionFailed field
 154                          $ DL.intercalate " " [ "cannot parse hyperdata for JSON: "
 155                                               , show v
 156                                               ]
 157
 158 printSqlOpa :: Default Unpackspec a a => Query a -> IO ()
 159 printSqlOpa = putStrLn . maybe "Empty query" identity . showSqlForPostgres
 160