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 System.IO (FilePath)
41 import Text.Read (read)
42 import qualified Data.ByteString as DB
43 import qualified Database.PostgreSQL.Simple as PGS
45 class HasConnection env where
46 connection :: Getter env Connection
48 instance HasConnection Connection where
58 type Cmd err a = forall m env. CmdM env err m => m a
60 -- TODO: ideally there should be very few calls to this functions.
61 mkCmd :: (Connection -> IO a) -> Cmd err a
63 conn <- view connection
66 runCmd :: Connection -> Cmd err a -> IO (Either err a)
67 runCmd conn m = runExceptT $ runReaderT m conn
70 runCmdDev :: Show err => Cmd err a -> IO a
72 conn <- connectGargandb "gargantext.ini"
73 either (fail . show) pure =<< runCmd conn f
76 runCmdDevNoErr :: Cmd () a -> IO a
77 runCmdDevNoErr = runCmdDev
79 runOpaQuery :: Default FromFields fields haskells => Select fields -> Cmd err [haskells]
80 runOpaQuery q = mkCmd $ \c -> runQuery c q
82 formatPGSQuery :: PGS.ToRow a => PGS.Query -> a -> Cmd err DB.ByteString
83 formatPGSQuery q a = mkCmd $ \conn -> PGS.formatQuery conn q a
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
88 ------------------------------------------------------------------------
90 databaseParameters :: FilePath -> IO PGS.ConnectInfo
91 databaseParameters fp = do
93 let ini'' = case ini of
94 Left e -> panic (pack $ "No ini file error" <> show e)
97 let val x = case (lookupValue (pack "django") (pack x) ini'') of
98 Left _ -> panic (pack $ "no" <> x)
101 pure $ PGS.ConnectInfo { PGS.connectHost = val "DB_HOST"
102 , PGS.connectPort = read (val "DB_PORT") :: Word16
103 , PGS.connectUser = val "DB_USER"
104 , PGS.connectPassword = val "DB_PASS"
105 , PGS.connectDatabase = val "DB_NAME"
108 connectGargandb :: FilePath -> IO Connection
109 connectGargandb fp = databaseParameters fp >>= \params -> connect params
111 fromField' :: (Typeable b, FromJSON b) => Field -> Maybe DB.ByteString -> Conversion b
112 fromField' field mb = do
113 v <- fromField field mb
116 valueToHyperdata v = case fromJSON v of
118 Error _err -> returnError ConversionFailed field "cannot parse hyperdata"
120 printSqlOpa :: Default Unpackspec a a => Query a -> IO ()
121 printSqlOpa = putStrLn . maybe "Empty query" identity . showSqlForPostgres