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