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