src/Gargantext/Database/Prelude.hs

   1 {-|
   2 Module      : Gargantext.Database.Prelude
   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 -}
  11
  12 {-# LANGUAGE ConstraintKinds   #-}
  13 {-# LANGUAGE FlexibleContexts  #-}
  14 {-# LANGUAGE FlexibleInstances #-}
  15 {-# LANGUAGE NoImplicitPrelude #-}
  16 {-# LANGUAGE OverloadedStrings #-}
  17 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
  18 {-# LANGUAGE RankNTypes                 #-}
  19
  20 module Gargantext.Database.Prelude where
  21
  22 import Control.Exception
  23 import Control.Lens (Getter, view)
  24 import Control.Monad.Error.Class -- (MonadError(..), Error)
  25 import Control.Monad.Except
  26 import Control.Monad.Reader
  27 import Control.Monad.Trans.Control (MonadBaseControl)
  28 import Data.Aeson (Result(Error,Success), fromJSON, FromJSON)
  29 import Data.ByteString.Char8 (hPutStrLn)
  30 import Data.Either.Extra (Either(Left, Right))
  31 import Data.Ini (readIniFile, lookupValue)
  32 import Data.Maybe (maybe)
  33 import Data.Monoid ((<>))
  34 import Data.Pool (Pool, withResource)
  35 import Data.Profunctor.Product.Default (Default)
  36 import Data.Text (unpack, pack)
  37 import Data.Typeable (Typeable)
  38 import Data.Word (Word16)
  39 import Database.PostgreSQL.Simple (Connection, connect)
  40 import Database.PostgreSQL.Simple.FromField ( Conversion, ResultError(ConversionFailed), fromField, returnError)
  41 import Database.PostgreSQL.Simple.Internal  (Field)
  42 import Gargantext.Prelude
  43 import Opaleye (Query, Unpackspec, showSqlForPostgres, FromFields, Select, runQuery)
  44 import Opaleye.Aggregate (countRows)
  45 import System.IO (FilePath)
  46 import System.IO (stderr)
  47 import Text.Read (read)
  48 import qualified Data.ByteString      as DB
  49 import qualified Data.List as DL
  50 import qualified Database.PostgreSQL.Simple as PGS
  51
  52
  53 class HasConnectionPool env where
  54   connPool :: Getter env (Pool Connection)
  55
  56 instance HasConnectionPool (Pool Connection) where
  57   connPool = identity
  58
  59 type CmdM' env err m =
  60   ( MonadReader env m
  61   , MonadError err m
  62   , MonadBaseControl IO m
  63   )
  64
  65 type CmdM env err m =
  66   ( CmdM' env err m
  67   , HasConnectionPool env
  68   )
  69
  70 type Cmd' env err a = forall m. CmdM' env err m => m a
  71
  72 type Cmd err a = forall m env. CmdM env err m => m a
  73
  74 fromInt64ToInt :: Int64 -> Int
  75 fromInt64ToInt = fromIntegral
  76
  77 -- TODO: ideally there should be very few calls to this functions.
  78 mkCmd :: (Connection -> IO a) -> Cmd err a
  79 mkCmd k = do
  80   pool <- view connPool
  81   withResource pool (liftBase . k)
  82
  83 runCmd :: (HasConnectionPool env)
  84        => env -> Cmd' env err a
  85        -> IO (Either err a)
  86 runCmd env m = runExceptT $ runReaderT m env
  87
  88 runOpaQuery :: Default FromFields fields haskells
  89             => Select fields -> Cmd err [haskells]
  90 runOpaQuery q = mkCmd $ \c -> runQuery c q
  91
  92 runCountOpaQuery :: Select a -> Cmd err Int
  93 runCountOpaQuery q = do
  94   counts <- mkCmd $ \c -> runQuery c $ countRows q
  95   -- countRows is guaranteed to return a list with exactly one row so DL.head is safe here
  96   pure $ fromInt64ToInt $ DL.head counts
  97
  98 formatPGSQuery :: PGS.ToRow a => PGS.Query -> a -> Cmd err DB.ByteString
  99 formatPGSQuery q a = mkCmd $ \conn -> PGS.formatQuery conn q a
 100
 101 -- TODO use runPGSQueryDebug everywhere
 102 runPGSQuery' :: (PGS.ToRow a, PGS.FromRow b) => PGS.Query -> a -> Cmd err [b]
 103 runPGSQuery' q a = mkCmd $ \conn -> PGS.query conn q a
 104
 105 runPGSQuery :: (MonadError err m, MonadReader env m, MonadBaseControl IO m,
 106                 PGS.FromRow r, PGS.ToRow q, HasConnectionPool env)
 107                 => PGS.Query -> q -> m [r]
 108 runPGSQuery q a = mkCmd $ \conn -> catch (PGS.query conn q a) (printError conn)
 109   where
 110     printError c (SomeException e) = do
 111       q' <- PGS.formatQuery c q a
 112       hPutStrLn stderr q'
 113       throw (SomeException e)
 114
 115
 116 execPGSQuery :: PGS.ToRow a => PGS.Query -> a -> Cmd err Int64
 117 execPGSQuery q a = mkCmd $ \conn -> PGS.execute conn q a
 118
 119 ------------------------------------------------------------------------
 120
 121 databaseParameters :: FilePath -> IO PGS.ConnectInfo
 122 databaseParameters fp = do
 123   ini         <- readIniFile fp
 124   let ini'' = case ini of
 125         Left e     -> panic (pack $ "No ini file error" <> show e)
 126         Right ini' -> ini'
 127
 128   let val x = case (lookupValue (pack "django") (pack x) ini'') of
 129         Left _ -> panic (pack $ "no" <> x)
 130         Right p' -> unpack p'
 131
 132   pure $ PGS.ConnectInfo { PGS.connectHost     = val       "DB_HOST"
 133                          , PGS.connectPort     = read (val "DB_PORT") :: Word16
 134                          , PGS.connectUser     = val       "DB_USER"
 135                          , PGS.connectPassword = val       "DB_PASS"
 136                          , PGS.connectDatabase = val       "DB_NAME"
 137                          }
 138
 139 connectGargandb :: FilePath -> IO Connection
 140 connectGargandb fp = databaseParameters fp >>= \params -> connect params
 141
 142 fromField' :: (Typeable b, FromJSON b) => Field -> Maybe DB.ByteString -> Conversion b
 143 fromField' field mb = do
 144     v <- fromField field mb
 145     valueToHyperdata v
 146       where
 147           valueToHyperdata v = case fromJSON v of
 148              Success a  -> pure a
 149              Error _err -> returnError ConversionFailed field
 150                          $ DL.intercalate " " [ "cannot parse hyperdata for JSON: "
 151                                               , show v
 152                                               ]
 153
 154 printSqlOpa :: Default Unpackspec a a => Query a -> IO ()
 155 printSqlOpa = putStrLn . maybe "Empty query" identity . showSqlForPostgres
 156