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