src/Gargantext/Database/Prelude.hs

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