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