src/Gargantext/Database/Utils.hs

   1 {-|
   2 Module      : Gargantext.Database.Util
   3 Description :
   4 Copyright   : (c) CNRS, 2017-Present
   5 License     : AGPL + CECILL v3
   6 Maintainer  : team@gargantext.org
   7 Stability   : experimental
   8 Portability : POSIX
   9
  10 Here is a longer description of this module, containing some
  11 commentary with @some markup@.
  12 -}
  13
  14 {-# LANGUAGE ConstraintKinds   #-}
  15 {-# LANGUAGE FlexibleContexts  #-}
  16 {-# LANGUAGE NoImplicitPrelude #-}
  17 {-# LANGUAGE OverloadedStrings #-}
  18 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
  19 {-# LANGUAGE RankNTypes                 #-}
  20
  21 module Gargantext.Database.Utils where
  22
  23 import Control.Lens (Getter, view)
  24 import Control.Monad.Reader
  25 import Control.Monad.Except
  26 import Data.Aeson (Result(Error,Success), fromJSON, FromJSON)
  27 import Data.Either.Extra (Either(Left, Right))
  28 import Data.Ini (readIniFile, lookupValue)
  29 import Data.Maybe (maybe)
  30 import Data.Monoid ((<>))
  31 import Data.Profunctor.Product.Default (Default)
  32 import Data.Text (unpack, pack)
  33 import Data.Typeable (Typeable)
  34 import Data.Word (Word16)
  35 import Database.PostgreSQL.Simple (Connection, connect)
  36 import Database.PostgreSQL.Simple.FromField ( Conversion, ResultError(ConversionFailed), fromField, returnError)
  37 import Database.PostgreSQL.Simple.Internal  (Field)
  38 import Gargantext.Prelude
  39 import Opaleye (Query, Unpackspec, showSqlForPostgres, FromFields, Select, runQuery)
  40 import Servant (ServantErr)
  41 import System.IO (FilePath)
  42 import Text.Read (read)
  43 import qualified Data.ByteString      as DB
  44 import qualified Database.PostgreSQL.Simple as PGS
  45
  46 class HasConnection env where
  47   connection :: Getter env Connection
  48
  49 instance HasConnection Connection where
  50   connection = identity
  51
  52 type CmdM' env err m =
  53   ( MonadReader env m
  54   , MonadError err m
  55   , MonadIO m
  56   )
  57
  58 type CmdM env err m =
  59   ( CmdM' env err m
  60   , HasConnection env
  61   )
  62
  63 type Cmd' env err a = forall m. CmdM' env err m => m a
  64
  65 type Cmd err a = forall m env. CmdM env err m => m a
  66
  67 -- TODO: ideally there should be very few calls to this functions.
  68 mkCmd :: (Connection -> IO a) -> Cmd err a
  69 mkCmd k = do
  70   conn <- view connection
  71   liftIO $ k conn
  72
  73 runCmd :: HasConnection env => env
  74        -> Cmd' env err a
  75        -> IO (Either err a)
  76 runCmd env m = runExceptT $ runReaderT m env
  77
  78 -- Use only for dev
  79 runCmdDev :: (HasConnection env, Show err) => env
  80           -> Cmd' env err a
  81           -> IO a
  82 runCmdDev env f = either (fail . show) pure =<< runCmd env f
  83
  84 -- Use only for dev
  85 runCmdDevNoErr :: HasConnection env => env -> Cmd' env () a -> IO a
  86 runCmdDevNoErr = runCmdDev
  87
  88 -- Use only for dev
  89 runCmdDevServantErr :: HasConnection env => env -> Cmd ServantErr a -> IO a
  90 runCmdDevServantErr = runCmdDev
  91
  92 runOpaQuery :: Default FromFields fields haskells => Select fields -> Cmd err [haskells]
  93 runOpaQuery q = mkCmd $ \c -> runQuery c q
  94
  95 formatPGSQuery :: PGS.ToRow a => PGS.Query -> a -> Cmd err DB.ByteString
  96 formatPGSQuery q a = mkCmd $ \conn -> PGS.formatQuery conn q a
  97
  98 runPGSQuery :: (PGS.ToRow a, PGS.FromRow b) => PGS.Query -> a -> Cmd err [b]
  99 runPGSQuery q a = mkCmd $ \conn -> PGS.query conn q a
 100
 101 execPGSQuery :: PGS.ToRow a => PGS.Query -> a -> Cmd err Int64
 102 execPGSQuery q a = mkCmd $ \conn -> PGS.execute conn q a
 103
 104 ------------------------------------------------------------------------
 105
 106 databaseParameters :: FilePath -> IO PGS.ConnectInfo
 107 databaseParameters fp = do
 108   ini         <- readIniFile fp
 109   let ini'' = case ini of
 110         Left e     -> panic (pack $ "No ini file error" <> show e)
 111         Right ini' -> ini'
 112
 113   let val x = case (lookupValue (pack "django") (pack x) ini'') of
 114         Left _ -> panic (pack $ "no" <> x)
 115         Right p' -> unpack p'
 116
 117   pure $ PGS.ConnectInfo { PGS.connectHost     = val       "DB_HOST"
 118                          , PGS.connectPort     = read (val "DB_PORT") :: Word16
 119                          , PGS.connectUser     = val       "DB_USER"
 120                          , PGS.connectPassword = val       "DB_PASS"
 121                          , PGS.connectDatabase = val       "DB_NAME"
 122                          }
 123
 124 connectGargandb :: FilePath -> IO Connection
 125 connectGargandb fp = databaseParameters fp >>= \params -> connect params
 126
 127 fromField' :: (Typeable b, FromJSON b) => Field -> Maybe DB.ByteString -> Conversion b
 128 fromField' field mb = do
 129     v <- fromField field mb
 130     valueToHyperdata v
 131       where
 132           valueToHyperdata v = case fromJSON v of
 133              Success a  -> pure a
 134              Error _err -> returnError ConversionFailed field "cannot parse hyperdata"
 135
 136 printSqlOpa :: Default Unpackspec a a => Query a -> IO ()
 137 printSqlOpa = putStrLn . maybe "Empty query" identity . showSqlForPostgres
 138