]> Git — Sourcephile - gargantext.git/blob - src/Gargantext/Database/Prelude.hs
[FIX] warnings
[gargantext.git] / src / Gargantext / Database / Prelude.hs
1 {-|
2 Module : Gargantext.Database.Prelude
3 Description : Specific Prelude for Database management
4 Copyright : (c) CNRS, 2017-Present
5 License : AGPL + CECILL v3
6 Maintainer : team@gargantext.org
7 Stability : experimental
8 Portability : POSIX
9
10 -}
11
12 {-# LANGUAGE ConstraintKinds #-}
13
14 module Gargantext.Database.Prelude where
15
16 import Control.Exception
17 import Control.Lens (Getter, view)
18 import Control.Monad.Error.Class -- (MonadError(..), Error)
19 import Control.Monad.Except
20 import Control.Monad.Reader
21 import Control.Monad.Trans.Control (MonadBaseControl)
22 import Data.Aeson (Result(Error,Success), fromJSON, FromJSON)
23 import Data.ByteString.Char8 (hPutStrLn)
24 import Data.Either.Extra (Either(Left, Right))
25 import Data.Ini (readIniFile, lookupValue)
26 import Data.Maybe (maybe)
27 import Data.Monoid ((<>))
28 import Data.Pool (Pool, withResource)
29 import Data.Profunctor.Product.Default (Default)
30 import Data.Text (unpack, pack)
31 import Data.Typeable (Typeable)
32 import Data.Word (Word16)
33 import Database.PostgreSQL.Simple (Connection, connect)
34 import Database.PostgreSQL.Simple.FromField ( Conversion, ResultError(ConversionFailed), fromField, returnError)
35 import Database.PostgreSQL.Simple.Internal (Field)
36 import Gargantext.Prelude
37 import Gargantext.Prelude.Config (GargConfig())
38 import Opaleye (Query, Unpackspec, showSqlForPostgres, FromFields, Select, runQuery)
39 import Opaleye.Aggregate (countRows)
40 import System.IO (FilePath)
41 import System.IO (stderr)
42 import Text.Read (read)
43 import qualified Data.ByteString as DB
44 import qualified Data.List as DL
45 import qualified Database.PostgreSQL.Simple as PGS
46
47 -------------------------------------------------------
48 class HasConnectionPool env where
49 connPool :: Getter env (Pool Connection)
50
51 instance HasConnectionPool (Pool Connection) where
52 connPool = identity
53
54 class HasConfig env where
55 hasConfig :: Getter env GargConfig
56
57 instance HasConfig GargConfig where
58 hasConfig = identity
59
60 -------------------------------------------------------
61 type CmdM' env err m =
62 ( MonadReader env m
63 , MonadError err m
64 , MonadBaseControl IO m
65 )
66
67 type CmdM env err m =
68 ( CmdM' env err m
69 , HasConnectionPool env
70 , HasConfig env
71 )
72
73 type Cmd' env err a = forall m. CmdM' env err m => m a
74
75 type Cmd err a = forall m env. CmdM env err m => m a
76
77 fromInt64ToInt :: Int64 -> Int
78 fromInt64ToInt = fromIntegral
79
80 -- TODO: ideally there should be very few calls to this functions.
81 mkCmd :: (Connection -> IO a) -> Cmd err a
82 mkCmd k = do
83 pool <- view connPool
84 withResource pool (liftBase . k)
85
86 runCmd :: (HasConnectionPool env)
87 => env
88 -> Cmd' env err a
89 -> IO (Either err a)
90 runCmd env m = runExceptT $ runReaderT m env
91
92 runOpaQuery :: Default FromFields fields haskells
93 => Select fields
94 -> Cmd err [haskells]
95 runOpaQuery q = mkCmd $ \c -> runQuery c q
96
97 runCountOpaQuery :: Select a -> Cmd err Int
98 runCountOpaQuery q = do
99 counts <- mkCmd $ \c -> runQuery c $ countRows q
100 -- countRows is guaranteed to return a list with exactly one row so DL.head is safe here
101 pure $ fromInt64ToInt $ DL.head counts
102
103 formatPGSQuery :: PGS.ToRow a => PGS.Query -> a -> Cmd err DB.ByteString
104 formatPGSQuery q a = mkCmd $ \conn -> PGS.formatQuery conn q a
105
106 -- TODO use runPGSQueryDebug everywhere
107 runPGSQuery' :: (PGS.ToRow a, PGS.FromRow b) => PGS.Query -> a -> Cmd err [b]
108 runPGSQuery' q a = mkCmd $ \conn -> PGS.query conn q a
109
110 runPGSQuery :: (MonadError err m, MonadReader env m, MonadBaseControl IO m,
111 PGS.FromRow r, PGS.ToRow q, HasConnectionPool env, HasConfig env)
112 => PGS.Query -> q -> m [r]
113 runPGSQuery q a = mkCmd $ \conn -> catch (PGS.query conn q a) (printError conn)
114 where
115 printError c (SomeException e) = do
116 q' <- PGS.formatQuery c q a
117 hPutStrLn stderr q'
118 throw (SomeException e)
119
120
121 execPGSQuery :: PGS.ToRow a => PGS.Query -> a -> Cmd err Int64
122 execPGSQuery q a = mkCmd $ \conn -> PGS.execute conn q a
123
124 ------------------------------------------------------------------------
125
126 databaseParameters :: FilePath -> IO PGS.ConnectInfo
127 databaseParameters fp = do
128 ini <- readIniFile fp
129 let ini'' = case ini of
130 Left e -> panic (pack $ "No ini file error" <> show e)
131 Right ini' -> ini'
132
133 let val x = case (lookupValue (pack "database") (pack x) ini'') of
134 Left _ -> panic (pack $ "no" <> x)
135 Right p' -> unpack p'
136
137 pure $ PGS.ConnectInfo { PGS.connectHost = val "DB_HOST"
138 , PGS.connectPort = read (val "DB_PORT") :: Word16
139 , PGS.connectUser = val "DB_USER"
140 , PGS.connectPassword = val "DB_PASS"
141 , PGS.connectDatabase = val "DB_NAME"
142 }
143
144 connectGargandb :: FilePath -> IO Connection
145 connectGargandb fp = databaseParameters fp >>= \params -> connect params
146
147 fromField' :: (Typeable b, FromJSON b) => Field -> Maybe DB.ByteString -> Conversion b
148 fromField' field mb = do
149 v <- fromField field mb
150 valueToHyperdata v
151 where
152 valueToHyperdata v = case fromJSON v of
153 Success a -> pure a
154 Error _err -> returnError ConversionFailed field
155 $ DL.intercalate " " [ "cannot parse hyperdata for JSON: "
156 , show v
157 ]
158
159 printSqlOpa :: Default Unpackspec a a => Query a -> IO ()
160 printSqlOpa = putStrLn . maybe "Empty query" identity . showSqlForPostgres
161