src/Gargantext/Database/Prelude.hs

   1 {-|
   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
   8 Portability : POSIX
   9
  10 -}
  11
  12 {-# LANGUAGE Arrows #-}
  13 {-# LANGUAGE ConstraintKinds, ScopedTypeVariables #-}
  14 {-# LANGUAGE LambdaCase #-}
  15
  16 module Gargantext.Database.Prelude where
  17
  18 --import Control.Monad.Logger (MonadLogger)
  19 import Control.Exception
  20 import Control.Lens (Getter, view)
  21 import Control.Monad.Except
  22 import Control.Monad.Random
  23 import Control.Monad.Reader
  24 import Control.Monad.Trans.Control (MonadBaseControl)
  25 import Data.Aeson (Result(Error,Success), fromJSON, FromJSON)
  26 import Data.ByteString.Char8 (hPutStrLn)
  27 import Data.Either.Extra (Either)
  28 import Data.Pool (Pool, withResource)
  29 import Data.Profunctor.Product.Default (Default)
  30 import Data.Text (pack, unpack, Text)
  31 import Data.Word (Word16)
  32 import Database.PostgreSQL.Simple (Connection, connect)
  33 import Database.PostgreSQL.Simple.FromField ( Conversion, ResultError(ConversionFailed), fromField, returnError)
  34 import Database.PostgreSQL.Simple.Internal  (Field)
  35 import Database.PostgreSQL.Simple.Types (Query(..))
  36 import Gargantext.Core.Mail.Types (HasMail)
  37 import Gargantext.Core.NLP (HasNLPServer)
  38 import Gargantext.Prelude
  39 import Gargantext.Prelude.Config (GargConfig(), readIniFile', val)
  40 import Opaleye (Unpackspec, showSql, FromFields, Select, runSelect, SqlJsonb, DefaultFromField, toFields, matchMaybe, MaybeFields)
  41 import Opaleye.Aggregate (countRows)
  42 import System.IO (FilePath, stderr)
  43 import Text.Read (readMaybe)
  44 import qualified Data.ByteString      as DB
  45 import qualified Data.List as DL
  46 import qualified Database.PostgreSQL.Simple as PGS
  47 import qualified Opaleye.Internal.Constant
  48 import qualified Opaleye.Internal.Operators
  49
  50 -------------------------------------------------------
  51 class HasConnectionPool env where
  52   connPool :: Getter env (Pool Connection)
  53
  54 instance HasConnectionPool (Pool Connection) where
  55   connPool = identity
  56
  57 class HasConfig env where
  58   hasConfig :: Getter env GargConfig
  59
  60 instance HasConfig GargConfig where
  61   hasConfig = identity
  62
  63 -------------------------------------------------------
  64 type JSONB = DefaultFromField SqlJsonb
  65 -------------------------------------------------------
  66
  67 type CmdM'' env err m =
  68   ( MonadReader     env     m
  69   , MonadError          err m
  70   , MonadBaseControl IO     m
  71   , MonadRandom             m
  72   --, MonadLogger             m
  73   )
  74
  75 type CmdM' env err m =
  76   ( MonadReader     env     m
  77   , MonadError          err m
  78   , MonadBaseControl IO     m
  79   --, MonadLogger             m
  80   -- , MonadRandom             m
  81   )
  82
  83 type CmdCommon env =
  84   ( HasConnectionPool env
  85   , HasConfig         env
  86   , HasMail           env
  87   , HasNLPServer      env )
  88
  89 type CmdM env err m =
  90   ( CmdM'     env err m
  91   , CmdCommon env
  92   )
  93
  94 type CmdRandom env err m =
  95   ( CmdM'             env err m
  96   , HasConnectionPool env
  97   , HasConfig         env
  98   , MonadRandom       m
  99   , HasMail           env
 100   )
 101
 102 type Cmd'' env err a = forall m.     CmdM''    env err m => m a
 103 type Cmd'  env err a = forall m.     CmdM'     env err m => m a
 104 type Cmd       err a = forall m env. CmdM      env err m => m a
 105 type CmdR      err a = forall m env. CmdRandom env err m => m a
 106
 107
 108
 109 fromInt64ToInt :: Int64 -> Int
 110 fromInt64ToInt = fromIntegral
 111
 112 -- TODO: ideally there should be very few calls to this functions.
 113 mkCmd :: (Connection -> IO a) -> Cmd err a
 114 mkCmd k = do
 115   pool <- view connPool
 116   withResource pool (liftBase . k)
 117
 118 runCmd :: (HasConnectionPool env)
 119        => env
 120        -> Cmd'' env err a
 121        -> IO (Either err a)
 122 runCmd env m = runExceptT $ runReaderT m env
 123
 124 runOpaQuery :: Default FromFields fields haskells
 125             => Select fields
 126             -> Cmd err [haskells]
 127 runOpaQuery q = mkCmd $ \c -> runSelect c q
 128
 129 runCountOpaQuery :: Select a -> Cmd err Int
 130 runCountOpaQuery q = do
 131   counts <- mkCmd $ \c -> runSelect c $ countRows q
 132   -- countRows is guaranteed to return a list with exactly one row so DL.head is safe here
 133   pure $ fromInt64ToInt $ DL.head counts
 134
 135 formatPGSQuery :: PGS.ToRow a => PGS.Query -> a -> Cmd err DB.ByteString
 136 formatPGSQuery q a = mkCmd $ \conn -> PGS.formatQuery conn q a
 137
 138 -- TODO use runPGSQueryDebug everywhere
 139 runPGSQuery' :: (PGS.ToRow a, PGS.FromRow b) => PGS.Query -> a -> Cmd err [b]
 140 runPGSQuery' q a = mkCmd $ \conn -> PGS.query conn q a
 141
 142 runPGSQuery :: ( CmdM env err m
 143                , PGS.FromRow r, PGS.ToRow q
 144                )
 145                => PGS.Query -> q -> m [r]
 146 runPGSQuery q a = mkCmd $ \conn -> catch (PGS.query conn q a) (printError conn)
 147   where
 148     printError c (SomeException e) = do
 149       q' <- PGS.formatQuery c q a
 150       hPutStrLn stderr q'
 151       throw (SomeException e)
 152
 153 {-
 154 -- TODO
 155 runPGSQueryFold :: ( CmdM env err m
 156                , PGS.FromRow r
 157                )
 158                => PGS.Query -> a -> (a -> r -> IO a) -> m a
 159 runPGSQueryFold q initialState consume = mkCmd $ \conn -> catch (PGS.fold_ conn initialState consume) (printError conn)
 160   where
 161     printError c (SomeException e) = do
 162       q' <- PGS.formatQuery c q
 163       hPutStrLn stderr q'
 164       throw (SomeException e)
 165 -}
 166
 167
 168
 169 -- | TODO catch error
 170 runPGSQuery_ :: ( CmdM env err m
 171                , PGS.FromRow r
 172                )
 173                => PGS.Query -> m [r]
 174 runPGSQuery_ q = mkCmd $ \conn -> catch (PGS.query_ conn q) printError
 175   where
 176     printError (SomeException e) = do
 177       hPutStrLn stderr (fromQuery q)
 178       throw (SomeException e)
 179
 180 execPGSQuery :: PGS.ToRow a => PGS.Query -> a -> Cmd err Int64
 181 execPGSQuery q a = mkCmd $ \conn -> PGS.execute conn q a
 182
 183 ------------------------------------------------------------------------
 184 databaseParameters :: FilePath -> IO PGS.ConnectInfo
 185 databaseParameters fp = do
 186   ini <- readIniFile' fp
 187   let val' key = unpack $ val ini "database" key
 188   let dbPortRaw = val' "DB_PORT"
 189   let dbPort = case (readMaybe dbPortRaw :: Maybe Word16) of
 190         Nothing -> panic $ "DB_PORT incorrect: " <> (pack dbPortRaw)
 191         Just d  -> d
 192
 193   pure $ PGS.ConnectInfo { PGS.connectHost     = val' "DB_HOST"
 194                          , PGS.connectPort     = dbPort
 195                          , PGS.connectUser     = val' "DB_USER"
 196                          , PGS.connectPassword = val' "DB_PASS"
 197                          , PGS.connectDatabase = val' "DB_NAME"
 198                          }
 199
 200 connectGargandb :: FilePath -> IO Connection
 201 connectGargandb fp = databaseParameters fp >>= \params -> connect params
 202
 203 fromField' :: (Typeable b, FromJSON b) => Field -> Maybe DB.ByteString -> Conversion b
 204 fromField' field mb = do
 205     v <- fromField field mb
 206     valueToHyperdata v
 207       where
 208           valueToHyperdata v = case fromJSON v of
 209              Success a  -> pure a
 210              Error _err -> returnError ConversionFailed field
 211                          $ DL.intercalate " " [ "cannot parse hyperdata for JSON: "
 212                                               , show v
 213                                               ]
 214
 215 printSqlOpa :: Default Unpackspec a a => Select a -> IO ()
 216 printSqlOpa = putStrLn . maybe "Empty query" identity . showSql
 217
 218 dbCheck :: CmdM env err m => m Bool
 219 dbCheck = do
 220   r :: [PGS.Only Text] <- runPGSQuery_ "select username from public.auth_user"
 221   case r of
 222     [] -> return False
 223     _  -> return True
 224
 225 restrictMaybe :: ( Default Opaleye.Internal.Operators.IfPP b b
 226                  , (Default Opaleye.Internal.Constant.ToFields Bool b))
 227               => MaybeFields a -> (a -> b) -> b
 228 restrictMaybe v cond = matchMaybe v $ \case
 229   Nothing -> toFields True
 230   Just v' -> cond v'