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