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