Prelude.hs 7.42 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 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 34
import Database.PostgreSQL.Simple.FromField ( Conversion, ResultError(ConversionFailed), fromField, returnError)
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 40
import Gargantext.Prelude.Config (GargConfig(), readIniFile', val)
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 48
import qualified Opaleye.Internal.Constant
import qualified Opaleye.Internal.Operators
49

50
-------------------------------------------------------
51 52
class HasConnectionPool env where
  connPool :: Getter env (Pool Connection)
53

54 55
instance HasConnectionPool (Pool Connection) where
  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 68 69 70 71

type CmdM'' env err m =
  ( MonadReader     env     m
  , MonadError          err m
  , MonadBaseControl IO     m
  , MonadRandom             m
72
  --, MonadLogger             m
73 74
  )

75
type CmdM' env err m =
76 77 78
  ( MonadReader     env     m
  , MonadError          err m
  , MonadBaseControl IO     m
79
  --, MonadLogger             m
80
  -- , MonadRandom             m
81
  )
82

83 84
type CmdCommon env =
  ( HasConnectionPool env
85
  , HasConfig         env
86
  , HasMail           env
87 88 89 90 91
  , HasNLPServer      env )

type CmdM env err m =
  ( CmdM'     env err m
  , CmdCommon env
92 93
  )

94 95 96 97
type CmdRandom env err m =
  ( CmdM'             env err m
  , HasConnectionPool env
  , HasConfig         env
98 99
  , MonadRandom       m
  , HasMail           env
100 101
  )

102 103 104 105
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
106

107

108

109 110 111
fromInt64ToInt :: Int64 -> Int
fromInt64ToInt = fromIntegral

112 113 114
-- TODO: ideally there should be very few calls to this functions.
mkCmd :: (Connection -> IO a) -> Cmd err a
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 122
       -> IO (Either err a)
runCmd env m = runExceptT $ runReaderT m env
123

124
runOpaQuery :: Default FromFields fields haskells
125 126
            => Select fields
            -> Cmd err [haskells]
127
runOpaQuery q = mkCmd $ \c -> runSelect c q
128

129 130
runCountOpaQuery :: Select a -> Cmd err Int
runCountOpaQuery q = do
131
  counts <- mkCmd $ \c -> runSelect c $ countRows q
132 133 134
  -- countRows is guaranteed to return a list with exactly one row so DL.head is safe here
  pure $ fromInt64ToInt $ DL.head counts

135 136
formatPGSQuery :: PGS.ToRow a => PGS.Query -> a -> Cmd err DB.ByteString
formatPGSQuery q a = mkCmd $ \conn -> PGS.formatQuery conn q a
137

138 139 140 141
-- 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

142 143 144 145
runPGSQuery :: ( CmdM env err m
               , PGS.FromRow r, PGS.ToRow q
               )
               => PGS.Query -> q -> m [r]
146 147 148 149 150 151 152
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)

153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168
{-
-- TODO
runPGSQueryFold :: ( CmdM env err m
               , PGS.FromRow r
               )
               => PGS.Query -> a -> (a -> r -> IO a) -> m a
runPGSQueryFold q initialState consume = mkCmd $ \conn -> catch (PGS.fold_ conn initialState consume) (printError conn)
  where
    printError c (SomeException e) = do
      q' <- PGS.formatQuery c q
      hPutStrLn stderr q'
      throw (SomeException e)
-}



169 170 171 172 173 174 175 176
-- | 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
177
      hPutStrLn stderr (fromQuery q)
178 179
      throw (SomeException e)

180 181 182
execPGSQuery :: PGS.ToRow a => PGS.Query -> a -> Cmd err Int64
execPGSQuery q a = mkCmd $ \conn -> PGS.execute conn q a

183
------------------------------------------------------------------------
184 185
databaseParameters :: FilePath -> IO PGS.ConnectInfo
databaseParameters fp = do
186 187
  ini <- readIniFile' fp
  let val' key = unpack $ val ini "database" key
188 189 190 191
  let dbPortRaw = val' "DB_PORT"
  let dbPort = case (readMaybe dbPortRaw :: Maybe Word16) of
        Nothing -> panic $ "DB_PORT incorrect: " <> (pack dbPortRaw)
        Just d  -> d
192 193

  pure $ PGS.ConnectInfo { PGS.connectHost     = val' "DB_HOST"
194
                         , PGS.connectPort     = dbPort
195 196 197
                         , PGS.connectUser     = val' "DB_USER"
                         , PGS.connectPassword = val' "DB_PASS"
                         , PGS.connectDatabase = val' "DB_NAME"
Alexandre Delanoë's avatar
Alexandre Delanoë committed
198
                         }
199

200
connectGargandb :: FilePath -> IO Connection
201
connectGargandb fp = databaseParameters fp >>= \params -> connect params
202

203 204 205 206 207 208 209
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
210 211 212 213
             Error _err -> returnError ConversionFailed field
                         $ DL.intercalate " " [ "cannot parse hyperdata for JSON: "
                                              , show v
                                              ]
214

215
printSqlOpa :: Default Unpackspec a a => Select a -> IO ()
216
printSqlOpa = putStrLn . maybe "Empty query" identity . showSql
217

218 219 220 221 222 223
dbCheck :: CmdM env err m => m Bool
dbCheck = do
  r :: [PGS.Only Text] <- runPGSQuery_ "select username from public.auth_user"
  case r of
    [] -> return False
    _  -> return True
224 225 226 227 228 229 230

restrictMaybe :: ( Default Opaleye.Internal.Operators.IfPP b b
                 , (Default Opaleye.Internal.Constant.ToFields Bool b))
              => MaybeFields a -> (a -> b) -> b
restrictMaybe v cond = matchMaybe v $ \case
  Nothing -> toFields True
  Just v' -> cond v'