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   , HasConnection env
  54   , MonadError err m
  55   , MonadIO m
  56   )
  57
  58 type Cmd err a = forall m env. CmdM env err m => m a
  59
  60 -- TODO: ideally there should be very few calls to this functions.
  61 mkCmd :: (Connection -> IO a) -> Cmd err a
  62 mkCmd k = do
  63   conn <- view connection
  64   liftIO $ k conn
  65
  66 runCmd :: Connection -> Cmd err a -> IO (Either err a)
  67 runCmd conn m = runExceptT $ runReaderT m conn
  68
  69 -- Use only for dev
  70 runCmdDev :: Show err => Cmd err a -> IO a
  71 runCmdDev f = do
  72   conn <- connectGargandb "gargantext.ini"
  73   either (fail . show) pure =<< runCmd conn f
  74
  75 -- Use only for dev
  76 runCmdDevNoErr :: Cmd () a -> IO a
  77 runCmdDevNoErr = runCmdDev
  78
  79 runOpaQuery :: Default FromFields fields haskells => Select fields -> Cmd err [haskells]
  80 runOpaQuery q = mkCmd $ \c -> runQuery c q
  81
  82 formatPGSQuery :: PGS.ToRow a => PGS.Query -> a -> Cmd err DB.ByteString
  83 formatPGSQuery q a = mkCmd $ \conn -> PGS.formatQuery conn q a
  84
  85 runPGSQuery :: (PGS.ToRow a, PGS.FromRow b) => PGS.Query -> a -> Cmd err [b]
  86 runPGSQuery q a = mkCmd $ \conn -> PGS.query conn q a
  87
  88 execPGSQuery :: PGS.ToRow a => PGS.Query -> a -> Cmd err Int64
  89 execPGSQuery q a = mkCmd $ \conn -> PGS.execute conn q a
  90
  91 ------------------------------------------------------------------------
  92
  93 databaseParameters :: FilePath -> IO PGS.ConnectInfo
  94 databaseParameters fp = do
  95   ini         <- readIniFile fp
  96   let ini'' = case ini of
  97         Left e     -> panic (pack $ "No ini file error" <> show e)
  98         Right ini' -> ini'
  99
 100   let val x = case (lookupValue (pack "django") (pack x) ini'') of
 101         Left _ -> panic (pack $ "no" <> x)
 102         Right p' -> unpack p'
 103
 104   pure $ PGS.ConnectInfo { PGS.connectHost     = val       "DB_HOST"
 105                          , PGS.connectPort     = read (val "DB_PORT") :: Word16
 106                          , PGS.connectUser     = val       "DB_USER"
 107                          , PGS.connectPassword = val       "DB_PASS"
 108                          , PGS.connectDatabase = val       "DB_NAME"
 109                          }
 110
 111 connectGargandb :: FilePath -> IO Connection
 112 connectGargandb fp = databaseParameters fp >>= \params -> connect params
 113
 114 fromField' :: (Typeable b, FromJSON b) => Field -> Maybe DB.ByteString -> Conversion b
 115 fromField' field mb = do
 116     v <- fromField field mb
 117     valueToHyperdata v
 118       where
 119           valueToHyperdata v = case fromJSON v of
 120              Success a  -> pure a
 121              Error _err -> returnError ConversionFailed field "cannot parse hyperdata"
 122
 123 printSqlOpa :: Default Unpackspec a a => Query a -> IO ()
 124 printSqlOpa = putStrLn . maybe "Empty query" identity . showSqlForPostgres
 125
 126