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