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
12 {-# LANGUAGE ConstraintKinds #-}
14 module Gargantext.Database.Prelude where
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
47 -------------------------------------------------------
48 class HasConnectionPool env where
49 connPool :: Getter env (Pool Connection)
51 instance HasConnectionPool (Pool Connection) where
54 class HasConfig env where
55 hasConfig :: Getter env GargConfig
57 instance HasConfig GargConfig where
60 -------------------------------------------------------
61 type CmdM' env err m =
64 , MonadBaseControl IO m
69 , HasConnectionPool env
73 type Cmd' env err a = forall m. CmdM' env err m => m a
75 type Cmd err a = forall m env. CmdM env err m => m a
77 fromInt64ToInt :: Int64 -> Int
78 fromInt64ToInt = fromIntegral
80 -- TODO: ideally there should be very few calls to this functions.
81 mkCmd :: (Connection -> IO a) -> Cmd err a
84 withResource pool (liftBase . k)
86 runCmd :: (HasConnectionPool env)
90 runCmd env m = runExceptT $ runReaderT m env
92 runOpaQuery :: Default FromFields fields haskells
95 runOpaQuery q = mkCmd $ \c -> runQuery c q
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
103 formatPGSQuery :: PGS.ToRow a => PGS.Query -> a -> Cmd err DB.ByteString
104 formatPGSQuery q a = mkCmd $ \conn -> PGS.formatQuery conn q a
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
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)
115 printError c (SomeException e) = do
116 q' <- PGS.formatQuery c q a
118 throw (SomeException e)
121 execPGSQuery :: PGS.ToRow a => PGS.Query -> a -> Cmd err Int64
122 execPGSQuery q a = mkCmd $ \conn -> PGS.execute conn q a
124 ------------------------------------------------------------------------
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)
133 let val x = case (lookupValue (pack "database") (pack x) ini'') of
134 Left _ -> panic (pack $ "no" <> x)
135 Right p' -> unpack p'
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"
144 connectGargandb :: FilePath -> IO Connection
145 connectGargandb fp = databaseParameters fp >>= \params -> connect params
147 fromField' :: (Typeable b, FromJSON b) => Field -> Maybe DB.ByteString -> Conversion b
148 fromField' field mb = do
149 v <- fromField field mb
152 valueToHyperdata v = case fromJSON v of
154 Error _err -> returnError ConversionFailed field
155 $ DL.intercalate " " [ "cannot parse hyperdata for JSON: "
159 printSqlOpa :: Default Unpackspec a a => Query a -> IO ()
160 printSqlOpa = putStrLn . maybe "Empty query" identity . showSqlForPostgres