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