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 Control.Lens (Getter, view)
  24 import Control.Monad.Reader
  25 import Control.Monad.Except
  26 import Data.Aeson (Result(Error,Success), fromJSON, FromJSON)
  27 import Data.Either.Extra (Either(Left, Right))
  28 import Data.Ini (readIniFile, lookupValue)
  29 import Data.Maybe (maybe)
  30 import Data.Monoid ((<>))
  31 import Data.Profunctor.Product.Default (Default)
  32 import Data.Text (unpack, pack)
  33 import Data.Typeable (Typeable)
  34 import Data.Word (Word16)
  35 import Database.PostgreSQL.Simple (Connection, connect)
  36 import Database.PostgreSQL.Simple.FromField ( Conversion, ResultError(ConversionFailed), fromField, returnError)
  37 import Database.PostgreSQL.Simple.Internal  (Field)
  38 import Gargantext.Prelude
  39 import Opaleye (Query, Unpackspec, showSqlForPostgres, FromFields, Select, runQuery)
  40 import System.IO (FilePath)
  41 import Text.Read (read)
  42 import qualified Data.ByteString      as DB
  43 import qualified Database.PostgreSQL.Simple as PGS
  44
  45 class HasConnection env where
  46   connection :: Getter env Connection
  47
  48 instance HasConnection Connection where
  49   connection = identity
  50
  51 type CmdM' env err m =
  52   ( MonadReader env m
  53   , MonadError err m
  54   , MonadIO m
  55   )
  56
  57 type CmdM env err m =
  58   ( CmdM' env err m
  59   , HasConnection env
  60   )
  61
  62 type Cmd' env err a = forall m. CmdM' env err m => m a
  63
  64 type Cmd err a = forall m env. CmdM env err m => m a
  65
  66 -- TODO: ideally there should be very few calls to this functions.
  67 mkCmd :: (Connection -> IO a) -> Cmd err a
  68 mkCmd k = do
  69   conn <- view connection
  70   liftIO $ k conn
  71
  72 runCmd :: HasConnection env => env
  73        -> Cmd' env err a
  74        -> IO (Either err a)
  75 runCmd env m = runExceptT $ runReaderT m env
  76
  77 runOpaQuery :: Default FromFields fields haskells => Select fields -> Cmd err [haskells]
  78 runOpaQuery q = mkCmd $ \c -> runQuery c q
  79
  80 formatPGSQuery :: PGS.ToRow a => PGS.Query -> a -> Cmd err DB.ByteString
  81 formatPGSQuery q a = mkCmd $ \conn -> PGS.formatQuery conn q a
  82
  83 runPGSQuery :: (PGS.ToRow a, PGS.FromRow b) => PGS.Query -> a -> Cmd err [b]
  84 runPGSQuery q a = mkCmd $ \conn -> PGS.query conn q a
  85
  86 execPGSQuery :: PGS.ToRow a => PGS.Query -> a -> Cmd err Int64
  87 execPGSQuery q a = mkCmd $ \conn -> PGS.execute conn q a
  88
  89 ------------------------------------------------------------------------
  90
  91 databaseParameters :: FilePath -> IO PGS.ConnectInfo
  92 databaseParameters fp = do
  93   ini         <- readIniFile fp
  94   let ini'' = case ini of
  95         Left e     -> panic (pack $ "No ini file error" <> show e)
  96         Right ini' -> ini'
  97
  98   let val x = case (lookupValue (pack "django") (pack x) ini'') of
  99         Left _ -> panic (pack $ "no" <> x)
 100         Right p' -> unpack p'
 101
 102   pure $ PGS.ConnectInfo { PGS.connectHost     = val       "DB_HOST"
 103                          , PGS.connectPort     = read (val "DB_PORT") :: Word16
 104                          , PGS.connectUser     = val       "DB_USER"
 105                          , PGS.connectPassword = val       "DB_PASS"
 106                          , PGS.connectDatabase = val       "DB_NAME"
 107                          }
 108
 109 connectGargandb :: FilePath -> IO Connection
 110 connectGargandb fp = databaseParameters fp >>= \params -> connect params
 111
 112 fromField' :: (Typeable b, FromJSON b) => Field -> Maybe DB.ByteString -> Conversion b
 113 fromField' field mb = do
 114     v <- fromField field mb
 115     valueToHyperdata v
 116       where
 117           valueToHyperdata v = case fromJSON v of
 118              Success a  -> pure a
 119              Error _err -> returnError ConversionFailed field "cannot parse hyperdata"
 120
 121 printSqlOpa :: Default Unpackspec a a => Query a -> IO ()
 122 printSqlOpa = putStrLn . maybe "Empty query" identity . showSqlForPostgres
 123