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)
  77        => env -> Cmd' env err a
  78        -> IO (Either err a)
  79 runCmd env m = runExceptT $ runReaderT m env
  80
  81 runOpaQuery :: Default FromFields fields haskells
  82             => Select fields -> Cmd err [haskells]
  83 runOpaQuery q = mkCmd $ \c -> runQuery c q
  84
  85 formatPGSQuery :: PGS.ToRow a => PGS.Query -> a -> Cmd err DB.ByteString
  86 formatPGSQuery q a = mkCmd $ \conn -> PGS.formatQuery conn q a
  87
  88 -- TODO use runPGSQueryDebug everywhere
  89 runPGSQuery' :: (PGS.ToRow a, PGS.FromRow b) => PGS.Query -> a -> Cmd err [b]
  90 runPGSQuery' q a = mkCmd $ \conn -> PGS.query conn q a
  91
  92 runPGSQuery :: (MonadError err m, MonadReader env m,
  93                 PGS.FromRow r, PGS.ToRow q, MonadIO m, HasConnection env)
  94                 => PGS.Query -> q -> m [r]
  95 runPGSQuery q a = mkCmd $ \conn -> catch (PGS.query conn q a) (printError conn)
  96   where
  97     printError c (SomeException e) = do
  98       q' <- PGS.formatQuery c q a
  99       hPutStrLn stderr q'
 100       throw (SomeException e)
 101
 102
 103 execPGSQuery :: PGS.ToRow a => PGS.Query -> a -> Cmd err Int64
 104 execPGSQuery q a = mkCmd $ \conn -> PGS.execute conn q a
 105
 106 ------------------------------------------------------------------------
 107
 108 databaseParameters :: FilePath -> IO PGS.ConnectInfo
 109 databaseParameters fp = do
 110   ini         <- readIniFile fp
 111   let ini'' = case ini of
 112         Left e     -> panic (pack $ "No ini file error" <> show e)
 113         Right ini' -> ini'
 114
 115   let val x = case (lookupValue (pack "django") (pack x) ini'') of
 116         Left _ -> panic (pack $ "no" <> x)
 117         Right p' -> unpack p'
 118
 119   pure $ PGS.ConnectInfo { PGS.connectHost     = val       "DB_HOST"
 120                          , PGS.connectPort     = read (val "DB_PORT") :: Word16
 121                          , PGS.connectUser     = val       "DB_USER"
 122                          , PGS.connectPassword = val       "DB_PASS"
 123                          , PGS.connectDatabase = val       "DB_NAME"
 124                          }
 125
 126 connectGargandb :: FilePath -> IO Connection
 127 connectGargandb fp = databaseParameters fp >>= \params -> connect params
 128
 129 fromField' :: (Typeable b, FromJSON b) => Field -> Maybe DB.ByteString -> Conversion b
 130 fromField' field mb = do
 131     v <- fromField field mb
 132     valueToHyperdata v
 133       where
 134           valueToHyperdata v = case fromJSON v of
 135              Success a  -> pure a
 136              Error _err -> returnError ConversionFailed field "cannot parse hyperdata"
 137
 138 printSqlOpa :: Default Unpackspec a a => Query a -> IO ()
 139 printSqlOpa = putStrLn . maybe "Empty query" identity . showSqlForPostgres
 140