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