{-|
Module : Gargantext.Database.Prelude
-Description :
+Description : Specific Prelude for Database management
Copyright : (c) CNRS, 2017-Present
License : AGPL + CECILL v3
Maintainer : team@gargantext.org
module Gargantext.Database.Prelude where
-
import Control.Exception
import Control.Lens (Getter, view)
-import Control.Monad.Error.Class -- (MonadError(..), Error)
import Control.Monad.Except
+import Control.Monad.Random
import Control.Monad.Reader
import Control.Monad.Trans.Control (MonadBaseControl)
import Data.Aeson (Result(Error,Success), fromJSON, FromJSON)
import Data.ByteString.Char8 (hPutStrLn)
import Data.Either.Extra (Either(Left, Right))
import Data.Ini (readIniFile, lookupValue)
-import Data.Maybe (maybe)
-import Data.Monoid ((<>))
import Data.Pool (Pool, withResource)
import Data.Profunctor.Product.Default (Default)
-import Data.Text (unpack, pack)
-import Data.Typeable (Typeable)
+import Data.Text (unpack, pack, Text)
import Data.Word (Word16)
import Database.PostgreSQL.Simple (Connection, connect)
import Database.PostgreSQL.Simple.FromField ( Conversion, ResultError(ConversionFailed), fromField, returnError)
import Database.PostgreSQL.Simple.Internal (Field)
import Gargantext.Prelude
-import Opaleye (Query, Unpackspec, showSqlForPostgres, FromFields, Select, runQuery)
+import Gargantext.Prelude.Config (GargConfig())
+import Opaleye (Query, Unpackspec, showSqlForPostgres, FromFields, Select, runQuery, PGJsonb, QueryRunnerColumnDefault)
import Opaleye.Aggregate (countRows)
import System.IO (FilePath)
import System.IO (stderr)
import qualified Database.PostgreSQL.Simple as PGS
-------------------------------------------------------
-
class HasConnectionPool env where
connPool :: Getter env (Pool Connection)
instance HasConnectionPool (Pool Connection) where
connPool = identity
+class HasConfig env where
+ hasConfig :: Getter env GargConfig
+
+instance HasConfig GargConfig where
+ hasConfig = identity
+
+-------------------------------------------------------
+type JSONB = QueryRunnerColumnDefault PGJsonb
+-------------------------------------------------------
+
+type CmdM'' env err m =
+ ( MonadReader env m
+ , MonadError err m
+ , MonadBaseControl IO m
+ , MonadRandom m
+ )
+
type CmdM' env err m =
- ( MonadReader env m
- , MonadError err m
- , MonadBaseControl IO m
+ ( MonadReader env m
+ , MonadError err m
+ , MonadBaseControl IO m
+ -- , MonadRandom m
)
type CmdM env err m =
- ( CmdM' env err m
+ ( CmdM' env err m
, HasConnectionPool env
+ , HasConfig env
)
-type Cmd' env err a = forall m. CmdM' env err m => m a
+type CmdRandom env err m =
+ ( CmdM' env err m
+ , HasConnectionPool env
+ , HasConfig env
+ , MonadRandom m
+ )
+
+type Cmd'' env err a = forall m. CmdM'' env err m => m a
+type Cmd' env err a = forall m. CmdM' env err m => m a
+type Cmd err a = forall m env. CmdM env err m => m a
+type CmdR err a = forall m env. CmdRandom env err m => m a
+
-type Cmd err a = forall m env. CmdM env err m => m a
fromInt64ToInt :: Int64 -> Int
fromInt64ToInt = fromIntegral
withResource pool (liftBase . k)
runCmd :: (HasConnectionPool env)
- => env -> Cmd' env err a
+ => env
+ -> Cmd'' env err a
-> IO (Either err a)
runCmd env m = runExceptT $ runReaderT m env
runOpaQuery :: Default FromFields fields haskells
- => Select fields -> Cmd err [haskells]
+ => Select fields
+ -> Cmd err [haskells]
runOpaQuery q = mkCmd $ \c -> runQuery c q
runCountOpaQuery :: Select a -> Cmd err Int
runPGSQuery' :: (PGS.ToRow a, PGS.FromRow b) => PGS.Query -> a -> Cmd err [b]
runPGSQuery' q a = mkCmd $ \conn -> PGS.query conn q a
-runPGSQuery :: (MonadError err m, MonadReader env m, MonadBaseControl IO m,
- PGS.FromRow r, PGS.ToRow q, HasConnectionPool env)
- => PGS.Query -> q -> m [r]
+runPGSQuery :: ( CmdM env err m
+ , PGS.FromRow r, PGS.ToRow q
+ )
+ => PGS.Query -> q -> m [r]
runPGSQuery q a = mkCmd $ \conn -> catch (PGS.query conn q a) (printError conn)
where
printError c (SomeException e) = do
hPutStrLn stderr q'
throw (SomeException e)
+-- | TODO catch error
+runPGSQuery_ :: ( CmdM env err m
+ , PGS.FromRow r
+ )
+ => PGS.Query -> m [r]
+runPGSQuery_ q = mkCmd $ \conn -> catch (PGS.query_ conn q) printError
+ where
+ printError (SomeException e) = do
+ printDebug "[G.D.P.runPGSQuery_]" ("TODO: format query error query" :: Text)
+ throw (SomeException e)
+
+
execPGSQuery :: PGS.ToRow a => PGS.Query -> a -> Cmd err Int64
execPGSQuery q a = mkCmd $ \conn -> PGS.execute conn q a
Left e -> panic (pack $ "No ini file error" <> show e)
Right ini' -> ini'
- let val x = case (lookupValue (pack "django") (pack x) ini'') of
+ let val x = case (lookupValue (pack "database") (pack x) ini'') of
Left _ -> panic (pack $ "no" <> x)
Right p' -> unpack p'