-}
-{-# LANGUAGE ConstraintKinds #-}
+{-# LANGUAGE ConstraintKinds, ScopedTypeVariables #-}
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.Reader
+--import Control.Monad.Logger (MonadLogger)
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.Either.Extra (Either)
import Data.Pool (Pool, withResource)
import Data.Profunctor.Product.Default (Default)
-import Data.Text (unpack, pack)
+import Data.Text (pack, unpack, 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 Opaleye (Query, Unpackspec, showSqlForPostgres, FromFields, Select, runQuery, PGJsonb, QueryRunnerColumnDefault)
+import Database.PostgreSQL.Simple.Types (Query(..))
+import Gargantext.Core.Mail.Types (HasMail)
+import Gargantext.Prelude
+import Gargantext.Prelude.Config (readIniFile', val)
+import Opaleye (Unpackspec, showSql, FromFields, Select, runSelect, SqlJsonb, DefaultFromField)
import Opaleye.Aggregate (countRows)
import System.IO (FilePath)
import System.IO (stderr)
-import Text.Read (read)
+import Text.Read (readMaybe)
import qualified Data.ByteString as DB
import qualified Data.List as DL
import qualified Database.PostgreSQL.Simple as PGS
-import Gargantext.Prelude
import Gargantext.Prelude.Config (GargConfig())
-------------------------------------------------------
hasConfig = identity
-------------------------------------------------------
-type JSONB = QueryRunnerColumnDefault PGJsonb
+type JSONB = DefaultFromField SqlJsonb
-------------------------------------------------------
type CmdM'' env err m =
, MonadError err m
, MonadBaseControl IO m
, MonadRandom m
+ --, MonadLogger m
)
type CmdM' env err m =
( MonadReader env m
, MonadError err m
, MonadBaseControl IO m
+ --, MonadLogger m
-- , MonadRandom m
)
( CmdM' env err m
, HasConnectionPool env
, HasConfig env
+ , HasMail env
)
type CmdRandom env err m =
( CmdM' env err m
, HasConnectionPool env
, HasConfig env
- , MonadRandom m
+ , MonadRandom m
+ , HasMail env
)
type Cmd'' env err a = forall m. CmdM'' env err m => m a
runOpaQuery :: Default FromFields fields haskells
=> Select fields
-> Cmd err [haskells]
-runOpaQuery q = mkCmd $ \c -> runQuery c q
+runOpaQuery q = mkCmd $ \c -> runSelect c q
runCountOpaQuery :: Select a -> Cmd err Int
runCountOpaQuery q = do
- counts <- mkCmd $ \c -> runQuery c $ countRows q
+ counts <- mkCmd $ \c -> runSelect c $ countRows q
-- countRows is guaranteed to return a list with exactly one row so DL.head is safe here
pure $ fromInt64ToInt $ DL.head counts
hPutStrLn stderr q'
throw (SomeException e)
+{-
+-- TODO
+runPGSQueryFold :: ( CmdM env err m
+ , PGS.FromRow r
+ )
+ => PGS.Query -> a -> (a -> r -> IO a) -> m a
+runPGSQueryFold q initialState consume = mkCmd $ \conn -> catch (PGS.fold_ conn initialState consume) (printError conn)
+ where
+ printError c (SomeException e) = do
+ q' <- PGS.formatQuery c q
+ 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
+ hPutStrLn stderr (fromQuery q)
+ throw (SomeException e)
execPGSQuery :: PGS.ToRow a => PGS.Query -> a -> Cmd err Int64
execPGSQuery q a = mkCmd $ \conn -> PGS.execute conn q a
------------------------------------------------------------------------
-
databaseParameters :: FilePath -> IO PGS.ConnectInfo
databaseParameters fp = do
- ini <- readIniFile fp
- let ini'' = case ini of
- Left e -> panic (pack $ "No ini file error" <> show e)
- Right ini' -> ini'
-
- let val x = case (lookupValue (pack "database") (pack x) ini'') of
- Left _ -> panic (pack $ "no" <> x)
- Right p' -> unpack p'
-
- pure $ PGS.ConnectInfo { PGS.connectHost = val "DB_HOST"
- , PGS.connectPort = read (val "DB_PORT") :: Word16
- , PGS.connectUser = val "DB_USER"
- , PGS.connectPassword = val "DB_PASS"
- , PGS.connectDatabase = val "DB_NAME"
+ ini <- readIniFile' fp
+ let val' key = unpack $ val ini "database" key
+ let dbPortRaw = val' "DB_PORT"
+ let dbPort = case (readMaybe dbPortRaw :: Maybe Word16) of
+ Nothing -> panic $ "DB_PORT incorrect: " <> (pack dbPortRaw)
+ Just d -> d
+
+ pure $ PGS.ConnectInfo { PGS.connectHost = val' "DB_HOST"
+ , PGS.connectPort = dbPort
+ , PGS.connectUser = val' "DB_USER"
+ , PGS.connectPassword = val' "DB_PASS"
+ , PGS.connectDatabase = val' "DB_NAME"
}
connectGargandb :: FilePath -> IO Connection
, show v
]
-printSqlOpa :: Default Unpackspec a a => Query a -> IO ()
-printSqlOpa = putStrLn . maybe "Empty query" identity . showSqlForPostgres
+printSqlOpa :: Default Unpackspec a a => Select a -> IO ()
+printSqlOpa = putStrLn . maybe "Empty query" identity . showSql
+dbCheck :: CmdM env err m => m Bool
+dbCheck = do
+ r :: [PGS.Only Text] <- runPGSQuery_ "select username from public.auth_user"
+ case r of
+ [] -> return False
+ _ -> return True