{-|
Module      : Gargantext.Database.Prelude
Description : Specific Prelude for Database management
Copyright   : (c) CNRS, 2017-Present
License     : AGPL + CECILL v3
Maintainer  : team@gargantext.org
Stability   : experimental
Portability : POSIX

-}

{-# LANGUAGE ConstraintKinds   #-}

module Gargantext.Database.Prelude where

import Control.Exception
import Control.Lens (Getter, view)
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)
import Data.Pool (Pool, withResource)
import Data.Profunctor.Product.Default (Default)
import Data.Text (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 Gargantext.Core.Mail.Types (HasMail)
import Gargantext.Prelude
import Gargantext.Prelude.Config (readIniFile', val)
import Opaleye (Query, Unpackspec, showSql, FromFields, Select, runSelect, PGJsonb, DefaultFromField)
import Opaleye.Aggregate (countRows)
import System.IO (FilePath)
import System.IO (stderr)
import Text.Read (read)
import qualified Data.ByteString      as DB
import qualified Data.List as DL
import qualified Database.PostgreSQL.Simple as PGS

import Gargantext.Prelude.Config (GargConfig())

-------------------------------------------------------
class HasConnectionPool env where
  connPool :: Getter env (Pool Connection)

instance HasConnectionPool (Pool Connection) where
  connPool :: (Pool Connection -> f (Pool Connection))
-> Pool Connection -> f (Pool Connection)
connPool = (Pool Connection -> f (Pool Connection))
-> Pool Connection -> f (Pool Connection)
forall a. a -> a
identity

class HasConfig env where
  hasConfig :: Getter env GargConfig

instance HasConfig GargConfig where
  hasConfig :: (GargConfig -> f GargConfig) -> GargConfig -> f GargConfig
hasConfig = (GargConfig -> f GargConfig) -> GargConfig -> f GargConfig
forall a. a -> a
identity

-------------------------------------------------------
type JSONB = DefaultFromField 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
  -- , MonadRandom             m
  )

type CmdM env err 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
  , HasMail           env
  )

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



fromInt64ToInt :: Int64 -> Int
fromInt64ToInt :: Int64 -> Int
fromInt64ToInt = Int64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral

-- TODO: ideally there should be very few calls to this functions.
mkCmd :: (Connection -> IO a) -> Cmd err a
mkCmd :: (Connection -> IO a) -> Cmd err a
mkCmd Connection -> IO a
k = do
  Pool Connection
pool <- Getting (Pool Connection) env (Pool Connection)
-> m (Pool Connection)
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting (Pool Connection) env (Pool Connection)
forall env. HasConnectionPool env => Getter env (Pool Connection)
connPool
  Pool Connection -> (Connection -> m a) -> m a
forall (m :: * -> *) a b.
MonadBaseControl IO m =>
Pool a -> (a -> m b) -> m b
withResource Pool Connection
pool (IO a -> m a
forall (b :: * -> *) (m :: * -> *) α. MonadBase b m => b α -> m α
liftBase (IO a -> m a) -> (Connection -> IO a) -> Connection -> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Connection -> IO a
k)

runCmd :: (HasConnectionPool env)
       => env
       -> Cmd'' env err a
       -> IO (Either err a)
runCmd :: env -> Cmd'' env err a -> IO (Either err a)
runCmd env
env Cmd'' env err a
m = ExceptT err IO a -> IO (Either err a)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT err IO a -> IO (Either err a))
-> ExceptT err IO a -> IO (Either err a)
forall a b. (a -> b) -> a -> b
$ ReaderT env (ExceptT err IO) a -> env -> ExceptT err IO a
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT ReaderT env (ExceptT err IO) a
Cmd'' env err a
m env
env

runOpaQuery :: Default FromFields fields haskells
            => Select fields
            -> Cmd err [haskells]
runOpaQuery :: Select fields -> Cmd err [haskells]
runOpaQuery Select fields
q = (Connection -> IO [haskells]) -> Cmd err [haskells]
forall a err. (Connection -> IO a) -> Cmd err a
mkCmd ((Connection -> IO [haskells]) -> Cmd err [haskells])
-> (Connection -> IO [haskells]) -> Cmd err [haskells]
forall a b. (a -> b) -> a -> b
$ \Connection
c -> Connection -> Select fields -> IO [haskells]
forall fields haskells.
Default FromFields fields haskells =>
Connection -> Select fields -> IO [haskells]
runSelect Connection
c Select fields
q

runCountOpaQuery :: Select a -> Cmd err Int
runCountOpaQuery :: Select a -> Cmd err Int
runCountOpaQuery Select a
q = do
  [Int64]
counts <- (Connection -> IO [Int64]) -> Cmd err [Int64]
forall a err. (Connection -> IO a) -> Cmd err a
mkCmd ((Connection -> IO [Int64]) -> Cmd err [Int64])
-> (Connection -> IO [Int64]) -> Cmd err [Int64]
forall a b. (a -> b) -> a -> b
$ \Connection
c -> Connection -> Select (Column SqlInt8) -> IO [Int64]
forall fields haskells.
Default FromFields fields haskells =>
Connection -> Select fields -> IO [haskells]
runSelect Connection
c (Select (Column SqlInt8) -> IO [Int64])
-> Select (Column SqlInt8) -> IO [Int64]
forall a b. (a -> b) -> a -> b
$ Select a -> Select (Column SqlInt8)
forall a. Select a -> Select (Column SqlInt8)
countRows Select a
q
  -- countRows is guaranteed to return a list with exactly one row so DL.head is safe here
  Int -> m Int
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int -> m Int) -> Int -> m Int
forall a b. (a -> b) -> a -> b
$ Int64 -> Int
fromInt64ToInt (Int64 -> Int) -> Int64 -> Int
forall a b. (a -> b) -> a -> b
$ [Int64] -> Int64
forall a. [a] -> a
DL.head [Int64]
counts

formatPGSQuery :: PGS.ToRow a => PGS.Query -> a -> Cmd err DB.ByteString
formatPGSQuery :: Query -> a -> Cmd err ByteString
formatPGSQuery Query
q a
a = (Connection -> IO ByteString) -> Cmd err ByteString
forall a err. (Connection -> IO a) -> Cmd err a
mkCmd ((Connection -> IO ByteString) -> Cmd err ByteString)
-> (Connection -> IO ByteString) -> Cmd err ByteString
forall a b. (a -> b) -> a -> b
$ \Connection
conn -> Connection -> Query -> a -> IO ByteString
forall q. ToRow q => Connection -> Query -> q -> IO ByteString
PGS.formatQuery Connection
conn Query
q a
a

-- TODO use runPGSQueryDebug everywhere
runPGSQuery' :: (PGS.ToRow a, PGS.FromRow b) => PGS.Query -> a -> Cmd err [b]
runPGSQuery' :: Query -> a -> Cmd err [b]
runPGSQuery' Query
q a
a = (Connection -> IO [b]) -> Cmd err [b]
forall a err. (Connection -> IO a) -> Cmd err a
mkCmd ((Connection -> IO [b]) -> Cmd err [b])
-> (Connection -> IO [b]) -> Cmd err [b]
forall a b. (a -> b) -> a -> b
$ \Connection
conn -> Connection -> Query -> a -> IO [b]
forall q r.
(ToRow q, FromRow r) =>
Connection -> Query -> q -> IO [r]
PGS.query Connection
conn Query
q a
a

runPGSQuery :: ( CmdM env err m
               , PGS.FromRow r, PGS.ToRow q
               )
               => PGS.Query -> q -> m [r]
runPGSQuery :: Query -> q -> m [r]
runPGSQuery Query
q q
a = (Connection -> IO [r]) -> Cmd err [r]
forall a err. (Connection -> IO a) -> Cmd err a
mkCmd ((Connection -> IO [r]) -> Cmd err [r])
-> (Connection -> IO [r]) -> Cmd err [r]
forall a b. (a -> b) -> a -> b
$ \Connection
conn -> IO [r] -> (SomeException -> IO [r]) -> IO [r]
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
catch (Connection -> Query -> q -> IO [r]
forall q r.
(ToRow q, FromRow r) =>
Connection -> Query -> q -> IO [r]
PGS.query Connection
conn Query
q q
a) (Connection -> SomeException -> IO [r]
forall b. Connection -> SomeException -> IO b
printError Connection
conn)
  where
    printError :: Connection -> SomeException -> IO b
printError Connection
c (SomeException e
e) = do
      ByteString
q' <- Connection -> Query -> q -> IO ByteString
forall q. ToRow q => Connection -> Query -> q -> IO ByteString
PGS.formatQuery Connection
c Query
q q
a
      Handle -> ByteString -> IO ()
hPutStrLn Handle
stderr ByteString
q'
      SomeException -> IO b
forall a e. Exception e => e -> a
throw (e -> SomeException
forall e. Exception e => e -> SomeException
SomeException e
e)

-- | TODO catch error
runPGSQuery_ :: ( CmdM env err m
               , PGS.FromRow r
               )
               => PGS.Query -> m [r]
runPGSQuery_ :: Query -> m [r]
runPGSQuery_ Query
q = (Connection -> IO [r]) -> Cmd err [r]
forall a err. (Connection -> IO a) -> Cmd err a
mkCmd ((Connection -> IO [r]) -> Cmd err [r])
-> (Connection -> IO [r]) -> Cmd err [r]
forall a b. (a -> b) -> a -> b
$ \Connection
conn -> IO [r] -> (SomeException -> IO [r]) -> IO [r]
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
catch (Connection -> Query -> IO [r]
forall r. FromRow r => Connection -> Query -> IO [r]
PGS.query_ Connection
conn Query
q) SomeException -> IO [r]
forall (m :: * -> *) b. MonadBase IO m => SomeException -> m b
printError
  where
    printError :: SomeException -> m b
printError (SomeException e
e) = do
      [Char] -> Text -> m ()
forall a (m :: * -> *).
(Show a, MonadBase IO m) =>
[Char] -> a -> m ()
printDebug [Char]
"[G.D.P.runPGSQuery_]" (Text
"TODO: format query error query" :: Text)
      SomeException -> m b
forall a e. Exception e => e -> a
throw (e -> SomeException
forall e. Exception e => e -> SomeException
SomeException e
e)



execPGSQuery :: PGS.ToRow a => PGS.Query -> a -> Cmd err Int64
execPGSQuery :: Query -> a -> Cmd err Int64
execPGSQuery Query
q a
a = (Connection -> IO Int64) -> Cmd err Int64
forall a err. (Connection -> IO a) -> Cmd err a
mkCmd ((Connection -> IO Int64) -> Cmd err Int64)
-> (Connection -> IO Int64) -> Cmd err Int64
forall a b. (a -> b) -> a -> b
$ \Connection
conn -> Connection -> Query -> a -> IO Int64
forall q. ToRow q => Connection -> Query -> q -> IO Int64
PGS.execute Connection
conn Query
q a
a

------------------------------------------------------------------------

databaseParameters :: FilePath -> IO PGS.ConnectInfo
databaseParameters :: [Char] -> IO ConnectInfo
databaseParameters [Char]
fp = do
  Ini
ini <- [Char] -> IO Ini
readIniFile' [Char]
fp
  let val' :: Text -> [Char]
val' Text
key = Text -> [Char]
unpack (Text -> [Char]) -> Text -> [Char]
forall a b. (a -> b) -> a -> b
$ Ini -> Text -> Text -> Text
val Ini
ini Text
"database" Text
key

  ConnectInfo -> IO ConnectInfo
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ConnectInfo -> IO ConnectInfo) -> ConnectInfo -> IO ConnectInfo
forall a b. (a -> b) -> a -> b
$ ConnectInfo :: [Char] -> Word16 -> [Char] -> [Char] -> [Char] -> ConnectInfo
PGS.ConnectInfo { connectHost :: [Char]
PGS.connectHost     = Text -> [Char]
val' Text
"DB_HOST"
                         , connectPort :: Word16
PGS.connectPort     = [Char] -> Word16
forall a. Read a => [Char] -> a
read (Text -> [Char]
val' Text
"DB_PORT") :: Word16
                         , connectUser :: [Char]
PGS.connectUser     = Text -> [Char]
val' Text
"DB_USER"
                         , connectPassword :: [Char]
PGS.connectPassword = Text -> [Char]
val' Text
"DB_PASS"
                         , connectDatabase :: [Char]
PGS.connectDatabase = Text -> [Char]
val' Text
"DB_NAME"
                         }

connectGargandb :: FilePath -> IO Connection
connectGargandb :: [Char] -> IO Connection
connectGargandb [Char]
fp = [Char] -> IO ConnectInfo
databaseParameters [Char]
fp IO ConnectInfo -> (ConnectInfo -> IO Connection) -> IO Connection
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \ConnectInfo
params -> ConnectInfo -> IO Connection
connect ConnectInfo
params

fromField' :: (Typeable b, FromJSON b) => Field -> Maybe DB.ByteString -> Conversion b
fromField' :: Field -> Maybe ByteString -> Conversion b
fromField' Field
field Maybe ByteString
mb = do
    Value
v <- FieldParser Value
forall a. FromField a => FieldParser a
fromField Field
field Maybe ByteString
mb
    Value -> Conversion b
forall a. (FromJSON a, Typeable a) => Value -> Conversion a
valueToHyperdata Value
v
      where
          valueToHyperdata :: Value -> Conversion a
valueToHyperdata Value
v = case Value -> Result a
forall a. FromJSON a => Value -> Result a
fromJSON Value
v of
             Success a
a  -> a -> Conversion a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
a
             Error [Char]
_err -> ([Char] -> Maybe Oid -> [Char] -> [Char] -> [Char] -> ResultError)
-> Field -> [Char] -> Conversion a
forall a err.
(Typeable a, Exception err) =>
([Char] -> Maybe Oid -> [Char] -> [Char] -> [Char] -> err)
-> Field -> [Char] -> Conversion a
returnError [Char] -> Maybe Oid -> [Char] -> [Char] -> [Char] -> ResultError
ConversionFailed Field
field
                         ([Char] -> Conversion a) -> [Char] -> Conversion a
forall a b. (a -> b) -> a -> b
$ [Char] -> [[Char]] -> [Char]
forall a. [a] -> [[a]] -> [a]
DL.intercalate [Char]
" " [ [Char]
"cannot parse hyperdata for JSON: "
                                              , Value -> [Char]
forall a. Show a => a -> [Char]
show Value
v
                                              ]

printSqlOpa :: Default Unpackspec a a => Query a -> IO ()
printSqlOpa :: Query a -> IO ()
printSqlOpa = [Char] -> IO ()
putStrLn ([Char] -> IO ()) -> (Query a -> [Char]) -> Query a -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> ([Char] -> [Char]) -> Maybe [Char] -> [Char]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [Char]
"Empty query" [Char] -> [Char]
forall a. a -> a
identity (Maybe [Char] -> [Char])
-> (Query a -> Maybe [Char]) -> Query a -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Query a -> Maybe [Char]
forall fields.
Default Unpackspec fields fields =>
Select fields -> Maybe [Char]
showSql