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   #-}
  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.Random
  20 import Control.Monad.Reader
  21 import Control.Monad.Trans.Control (MonadBaseControl)
  22 import Data.Aeson (Result(Error,Success), fromJSON, FromJSON)
  23 import Data.ByteString.Char8 (hPutStrLn)
  24 import Data.Either.Extra (Either(Left, Right))
  25 import Data.Ini (readIniFile, lookupValue)
  26 import Data.Pool (Pool, withResource)
  27 import Data.Profunctor.Product.Default (Default)
  28 import Data.Text (unpack, pack, 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 Gargantext.Prelude
  34 import Gargantext.Prelude.Config (GargConfig())
  35 import Opaleye (Query, Unpackspec, showSqlForPostgres, FromFields, Select, runQuery, PGJsonb, QueryRunnerColumnDefault)
  36 import Opaleye.Aggregate (countRows)
  37 import System.IO (FilePath)
  38 import System.IO (stderr)
  39 import Text.Read (read)
  40 import qualified Data.ByteString      as DB
  41 import qualified Data.List as DL
  42 import qualified Database.PostgreSQL.Simple as PGS
  43
  44 -------------------------------------------------------
  45 class HasConnectionPool env where
  46   connPool :: Getter env (Pool Connection)
  47
  48 instance HasConnectionPool (Pool Connection) where
  49   connPool = identity
  50
  51 class HasConfig env where
  52   hasConfig :: Getter env GargConfig
  53
  54 instance HasConfig GargConfig where
  55   hasConfig = identity
  56
  57 -------------------------------------------------------
  58 type JSONB = QueryRunnerColumnDefault PGJsonb
  59 -------------------------------------------------------
  60
  61 type CmdM'' env err m =
  62   ( MonadReader     env     m
  63   , MonadError          err m
  64   , MonadBaseControl IO     m
  65   , MonadRandom             m
  66   )
  67
  68 type CmdM' env err m =
  69   ( MonadReader     env     m
  70   , MonadError          err m
  71   , MonadBaseControl IO     m
  72   -- , MonadRandom             m
  73   )
  74
  75 type CmdM env err m =
  76   ( CmdM'             env err m
  77   , HasConnectionPool env
  78   , HasConfig         env
  79   )
  80
  81 type CmdRandom env err m =
  82   ( CmdM'             env err m
  83   , HasConnectionPool env
  84   , HasConfig         env
  85   , MonadRandom             m
  86   )
  87
  88 type Cmd'' env err a = forall m.     CmdM''    env err m => m a
  89 type Cmd'  env err a = forall m.     CmdM'     env err m => m a
  90 type Cmd       err a = forall m env. CmdM      env err m => m a
  91 type CmdR      err a = forall m env. CmdRandom env err m => m a
  92
  93
  94
  95 fromInt64ToInt :: Int64 -> Int
  96 fromInt64ToInt = fromIntegral
  97
  98 -- TODO: ideally there should be very few calls to this functions.
  99 mkCmd :: (Connection -> IO a) -> Cmd err a
 100 mkCmd k = do
 101   pool <- view connPool
 102   withResource pool (liftBase . k)
 103
 104 runCmd :: (HasConnectionPool env)
 105        => env
 106        -> Cmd'' env err a
 107        -> IO (Either err a)
 108 runCmd env m = runExceptT $ runReaderT m env
 109
 110 runOpaQuery :: Default FromFields fields haskells
 111             => Select fields
 112             -> Cmd err [haskells]
 113 runOpaQuery q = mkCmd $ \c -> runQuery c q
 114
 115 runCountOpaQuery :: Select a -> Cmd err Int
 116 runCountOpaQuery q = do
 117   counts <- mkCmd $ \c -> runQuery c $ countRows q
 118   -- countRows is guaranteed to return a list with exactly one row so DL.head is safe here
 119   pure $ fromInt64ToInt $ DL.head counts
 120
 121 formatPGSQuery :: PGS.ToRow a => PGS.Query -> a -> Cmd err DB.ByteString
 122 formatPGSQuery q a = mkCmd $ \conn -> PGS.formatQuery conn q a
 123
 124 -- TODO use runPGSQueryDebug everywhere
 125 runPGSQuery' :: (PGS.ToRow a, PGS.FromRow b) => PGS.Query -> a -> Cmd err [b]
 126 runPGSQuery' q a = mkCmd $ \conn -> PGS.query conn q a
 127
 128 runPGSQuery :: ( CmdM env err m
 129                , PGS.FromRow r, PGS.ToRow q
 130                )
 131                => PGS.Query -> q -> m [r]
 132 runPGSQuery q a = mkCmd $ \conn -> catch (PGS.query conn q a) (printError conn)
 133   where
 134     printError c (SomeException e) = do
 135       q' <- PGS.formatQuery c q a
 136       hPutStrLn stderr q'
 137       throw (SomeException e)
 138
 139 -- | TODO catch error
 140 runPGSQuery_ :: ( CmdM env err m
 141                , PGS.FromRow r
 142                )
 143                => PGS.Query -> m [r]
 144 runPGSQuery_ q = mkCmd $ \conn -> catch (PGS.query_ conn q) printError
 145   where
 146     printError (SomeException e) = do
 147       printDebug "[G.D.P.runPGSQuery_]" ("TODO: format query error query" :: Text)
 148       throw (SomeException e)
 149
 150
 151
 152 execPGSQuery :: PGS.ToRow a => PGS.Query -> a -> Cmd err Int64
 153 execPGSQuery q a = mkCmd $ \conn -> PGS.execute conn q a
 154
 155 ------------------------------------------------------------------------
 156
 157 databaseParameters :: FilePath -> IO PGS.ConnectInfo
 158 databaseParameters fp = do
 159   ini         <- readIniFile fp
 160   let ini'' = case ini of
 161         Left e     -> panic (pack $ "No ini file error" <> show e)
 162         Right ini' -> ini'
 163
 164   let val x = case (lookupValue (pack "database") (pack x) ini'') of
 165         Left _ -> panic (pack $ "no" <> x)
 166         Right p' -> unpack p'
 167
 168   pure $ PGS.ConnectInfo { PGS.connectHost     = val       "DB_HOST"
 169                          , PGS.connectPort     = read (val "DB_PORT") :: Word16
 170                          , PGS.connectUser     = val       "DB_USER"
 171                          , PGS.connectPassword = val       "DB_PASS"
 172                          , PGS.connectDatabase = val       "DB_NAME"
 173                          }
 174
 175 connectGargandb :: FilePath -> IO Connection
 176 connectGargandb fp = databaseParameters fp >>= \params -> connect params
 177
 178 fromField' :: (Typeable b, FromJSON b) => Field -> Maybe DB.ByteString -> Conversion b
 179 fromField' field mb = do
 180     v <- fromField field mb
 181     valueToHyperdata v
 182       where
 183           valueToHyperdata v = case fromJSON v of
 184              Success a  -> pure a
 185              Error _err -> returnError ConversionFailed field
 186                          $ DL.intercalate " " [ "cannot parse hyperdata for JSON: "
 187                                               , show v
 188                                               ]
 189
 190 printSqlOpa :: Default Unpackspec a a => Query a -> IO ()
 191 printSqlOpa = putStrLn . maybe "Empty query" identity . showSqlForPostgres
 192