2 Module : Gargantext.Database.Util
4 Copyright : (c) CNRS, 2017-Present
5 License : AGPL + CECILL v3
6 Maintainer : team@gargantext.org
7 Stability : experimental
10 Here is a longer description of this module, containing some
11 commentary with @some markup@.
14 {-# LANGUAGE ConstraintKinds #-}
15 {-# LANGUAGE FlexibleContexts #-}
16 {-# LANGUAGE NoImplicitPrelude #-}
17 {-# LANGUAGE OverloadedStrings #-}
18 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
19 {-# LANGUAGE RankNTypes #-}
21 module Gargantext.Database.Utils where
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
46 class HasConnection env where
47 connection :: Getter env Connection
49 instance HasConnection Connection where
59 type Cmd err a = forall m env. CmdM env err m => m a
61 -- TODO: ideally there should be very few calls to this functions.
62 mkCmd :: (Connection -> IO a) -> Cmd err a
64 conn <- view connection
67 runCmd :: Connection -> Cmd err a -> IO (Either err a)
68 runCmd conn m = runExceptT $ runReaderT m conn
71 runCmdDev :: Show err => Cmd err a -> IO a
73 conn <- connectGargandb "gargantext.ini"
74 either (fail . show) pure =<< runCmd conn f
76 runCmdDev' :: Cmd ServantErr a -> IO a
78 conn <- connectGargandb "gargantext.ini"
79 either (fail . show) pure =<< runCmd conn f
82 runCmdDevNoErr :: Cmd () a -> IO a
83 runCmdDevNoErr = runCmdDev
85 runOpaQuery :: Default FromFields fields haskells => Select fields -> Cmd err [haskells]
86 runOpaQuery q = mkCmd $ \c -> runQuery c q
88 formatPGSQuery :: PGS.ToRow a => PGS.Query -> a -> Cmd err DB.ByteString
89 formatPGSQuery q a = mkCmd $ \conn -> PGS.formatQuery conn q a
91 runPGSQuery :: (PGS.ToRow a, PGS.FromRow b) => PGS.Query -> a -> Cmd err [b]
92 runPGSQuery q a = mkCmd $ \conn -> PGS.query conn q a
94 execPGSQuery :: PGS.ToRow a => PGS.Query -> a -> Cmd err Int64
95 execPGSQuery q a = mkCmd $ \conn -> PGS.execute conn q a
97 ------------------------------------------------------------------------
99 databaseParameters :: FilePath -> IO PGS.ConnectInfo
100 databaseParameters fp = do
101 ini <- readIniFile fp
102 let ini'' = case ini of
103 Left e -> panic (pack $ "No ini file error" <> show e)
106 let val x = case (lookupValue (pack "django") (pack x) ini'') of
107 Left _ -> panic (pack $ "no" <> x)
108 Right p' -> unpack p'
110 pure $ PGS.ConnectInfo { PGS.connectHost = val "DB_HOST"
111 , PGS.connectPort = read (val "DB_PORT") :: Word16
112 , PGS.connectUser = val "DB_USER"
113 , PGS.connectPassword = val "DB_PASS"
114 , PGS.connectDatabase = val "DB_NAME"
117 connectGargandb :: FilePath -> IO Connection
118 connectGargandb fp = databaseParameters fp >>= \params -> connect params
120 fromField' :: (Typeable b, FromJSON b) => Field -> Maybe DB.ByteString -> Conversion b
121 fromField' field mb = do
122 v <- fromField field mb
125 valueToHyperdata v = case fromJSON v of
127 Error _err -> returnError ConversionFailed field "cannot parse hyperdata"
129 printSqlOpa :: Default Unpackspec a a => Query a -> IO ()
130 printSqlOpa = putStrLn . maybe "Empty query" identity . showSqlForPostgres