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