Prelude.hs 6.06 KB
Newer Older
1
{-|
2
Module      : Gargantext.Database.Prelude
3
Description : Specific Prelude for Database management
4 5 6 7 8 9 10 11
Copyright   : (c) CNRS, 2017-Present
License     : AGPL + CECILL v3
Maintainer  : team@gargantext.org
Stability   : experimental
Portability : POSIX

-}

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)
25
import Data.Pool (Pool, withResource)
26
import Data.Profunctor.Product.Default (Default)
27
import Data.Text (unpack, Text)
28
import Data.Word (Word16)
29
import Database.PostgreSQL.Simple (Connection, connect)
30 31
import Database.PostgreSQL.Simple.FromField ( Conversion, ResultError(ConversionFailed), fromField, returnError)
import Database.PostgreSQL.Simple.Internal  (Field)
32
import Gargantext.Core.Mail.Types (HasMail)
33
import Gargantext.Prelude
34
import Gargantext.Prelude.Config (readIniFile', val)
35
import Opaleye (Query, Unpackspec, showSql, FromFields, Select, runSelect, PGJsonb, DefaultFromField)
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
import Gargantext.Prelude.Config (GargConfig())

46
-------------------------------------------------------
47 48
class HasConnectionPool env where
  connPool :: Getter env (Pool Connection)
49

50 51
instance HasConnectionPool (Pool Connection) where
  connPool = identity
52

53
class HasConfig env where
54
  hasConfig :: Getter env GargConfig
55 56

instance HasConfig GargConfig where
57
  hasConfig = identity
58

59
-------------------------------------------------------
60
type JSONB = DefaultFromField PGJsonb
61
-------------------------------------------------------
62 63 64 65 66 67 68 69

type CmdM'' env err m =
  ( MonadReader     env     m
  , MonadError          err m
  , MonadBaseControl IO     m
  , MonadRandom             m
  )

70
type CmdM' env err m =
71 72 73 74
  ( MonadReader     env     m
  , MonadError          err m
  , MonadBaseControl IO     m
  -- , MonadRandom             m
75
  )
76

77
type CmdM env err m =
78
  ( CmdM'             env err m
79
  , HasConnectionPool env
80
  , HasConfig         env
81
  , HasMail           env
82 83
  )

84 85 86 87
type CmdRandom env err m =
  ( CmdM'             env err m
  , HasConnectionPool env
  , HasConfig         env
88 89
  , MonadRandom       m
  , HasMail           env
90 91
  )

92 93 94 95
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
96

97

98

99 100 101
fromInt64ToInt :: Int64 -> Int
fromInt64ToInt = fromIntegral

102 103 104
-- TODO: ideally there should be very few calls to this functions.
mkCmd :: (Connection -> IO a) -> Cmd err a
mkCmd k = do
105
  pool <- view connPool
106
  withResource pool (liftBase . k)
107

108
runCmd :: (HasConnectionPool env)
109
       => env
110
       -> Cmd'' env err a
111 112
       -> IO (Either err a)
runCmd env m = runExceptT $ runReaderT m env
113

114
runOpaQuery :: Default FromFields fields haskells
115 116
            => Select fields
            -> Cmd err [haskells]
117
runOpaQuery q = mkCmd $ \c -> runSelect c q
118

119 120
runCountOpaQuery :: Select a -> Cmd err Int
runCountOpaQuery q = do
121
  counts <- mkCmd $ \c -> runSelect c $ countRows q
122 123 124
  -- countRows is guaranteed to return a list with exactly one row so DL.head is safe here
  pure $ fromInt64ToInt $ DL.head counts

125 126
formatPGSQuery :: PGS.ToRow a => PGS.Query -> a -> Cmd err DB.ByteString
formatPGSQuery q a = mkCmd $ \conn -> PGS.formatQuery conn q a
127

128 129 130 131
-- TODO use runPGSQueryDebug everywhere
runPGSQuery' :: (PGS.ToRow a, PGS.FromRow b) => PGS.Query -> a -> Cmd err [b]
runPGSQuery' q a = mkCmd $ \conn -> PGS.query conn q a

132 133 134 135
runPGSQuery :: ( CmdM env err m
               , PGS.FromRow r, PGS.ToRow q
               )
               => PGS.Query -> q -> m [r]
136 137 138 139 140 141 142
runPGSQuery q a = mkCmd $ \conn -> catch (PGS.query conn q a) (printError conn)
  where
    printError c (SomeException e) = do
      q' <- PGS.formatQuery c q a
      hPutStrLn stderr q'
      throw (SomeException e)

143 144 145 146 147 148 149 150 151 152 153 154
-- | TODO catch error
runPGSQuery_ :: ( CmdM env err m
               , PGS.FromRow r
               )
               => PGS.Query -> m [r]
runPGSQuery_ q = mkCmd $ \conn -> catch (PGS.query_ conn q) printError
  where
    printError (SomeException e) = do
      printDebug "[G.D.P.runPGSQuery_]" ("TODO: format query error query" :: Text)
      throw (SomeException e)


155

156 157 158
execPGSQuery :: PGS.ToRow a => PGS.Query -> a -> Cmd err Int64
execPGSQuery q a = mkCmd $ \conn -> PGS.execute conn q a

159
------------------------------------------------------------------------
160 161 162

databaseParameters :: FilePath -> IO PGS.ConnectInfo
databaseParameters fp = do
163 164 165 166 167 168 169 170
  ini <- readIniFile' fp
  let val' key = unpack $ val ini "database" key

  pure $ PGS.ConnectInfo { PGS.connectHost     = val' "DB_HOST"
                         , PGS.connectPort     = read (val' "DB_PORT") :: Word16
                         , PGS.connectUser     = val' "DB_USER"
                         , PGS.connectPassword = val' "DB_PASS"
                         , PGS.connectDatabase = val' "DB_NAME"
Alexandre Delanoë's avatar
Alexandre Delanoë committed
171
                         }
172

173
connectGargandb :: FilePath -> IO Connection
174
connectGargandb fp = databaseParameters fp >>= \params -> connect params
175

176 177 178 179 180 181 182
fromField' :: (Typeable b, FromJSON b) => Field -> Maybe DB.ByteString -> Conversion b
fromField' field mb = do
    v <- fromField field mb
    valueToHyperdata v
      where
          valueToHyperdata v = case fromJSON v of
             Success a  -> pure a
Alexandre Delanoë's avatar
Alexandre Delanoë committed
183 184 185 186
             Error _err -> returnError ConversionFailed field
                         $ DL.intercalate " " [ "cannot parse hyperdata for JSON: "
                                              , show v
                                              ]
187

188
printSqlOpa :: Default Unpackspec a a => Query a -> IO ()
189
printSqlOpa = putStrLn . maybe "Empty query" identity . showSql
190