]> Git — Sourcephile - gargantext.git/blob - src/Gargantext/Database/Prelude.hs
[ngrams] add r_history %~ mempty to ngrams POST
[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.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 -> Cmd' env err a
88 -> IO (Either err a)
89 runCmd env m = runExceptT $ runReaderT m env
90
91 runOpaQuery :: Default FromFields fields haskells
92 => Select fields -> Cmd err [haskells]
93 runOpaQuery q = mkCmd $ \c -> runQuery c q
94
95 runCountOpaQuery :: Select a -> Cmd err Int
96 runCountOpaQuery q = do
97 counts <- mkCmd $ \c -> runQuery c $ countRows q
98 -- countRows is guaranteed to return a list with exactly one row so DL.head is safe here
99 pure $ fromInt64ToInt $ DL.head counts
100
101 formatPGSQuery :: PGS.ToRow a => PGS.Query -> a -> Cmd err DB.ByteString
102 formatPGSQuery q a = mkCmd $ \conn -> PGS.formatQuery conn q a
103
104 -- TODO use runPGSQueryDebug everywhere
105 runPGSQuery' :: (PGS.ToRow a, PGS.FromRow b) => PGS.Query -> a -> Cmd err [b]
106 runPGSQuery' q a = mkCmd $ \conn -> PGS.query conn q a
107
108 runPGSQuery :: (MonadError err m, MonadReader env m, MonadBaseControl IO m,
109 PGS.FromRow r, PGS.ToRow q, HasConnectionPool env, HasConfig env)
110 => PGS.Query -> q -> m [r]
111 runPGSQuery q a = mkCmd $ \conn -> catch (PGS.query conn q a) (printError conn)
112 where
113 printError c (SomeException e) = do
114 q' <- PGS.formatQuery c q a
115 hPutStrLn stderr q'
116 throw (SomeException e)
117
118
119 execPGSQuery :: PGS.ToRow a => PGS.Query -> a -> Cmd err Int64
120 execPGSQuery q a = mkCmd $ \conn -> PGS.execute conn q a
121
122 ------------------------------------------------------------------------
123
124 databaseParameters :: FilePath -> IO PGS.ConnectInfo
125 databaseParameters fp = do
126 ini <- readIniFile fp
127 let ini'' = case ini of
128 Left e -> panic (pack $ "No ini file error" <> show e)
129 Right ini' -> ini'
130
131 let val x = case (lookupValue (pack "database") (pack x) ini'') of
132 Left _ -> panic (pack $ "no" <> x)
133 Right p' -> unpack p'
134
135 pure $ PGS.ConnectInfo { PGS.connectHost = val "DB_HOST"
136 , PGS.connectPort = read (val "DB_PORT") :: Word16
137 , PGS.connectUser = val "DB_USER"
138 , PGS.connectPassword = val "DB_PASS"
139 , PGS.connectDatabase = val "DB_NAME"
140 }
141
142 connectGargandb :: FilePath -> IO Connection
143 connectGargandb fp = databaseParameters fp >>= \params -> connect params
144
145 fromField' :: (Typeable b, FromJSON b) => Field -> Maybe DB.ByteString -> Conversion b
146 fromField' field mb = do
147 v <- fromField field mb
148 valueToHyperdata v
149 where
150 valueToHyperdata v = case fromJSON v of
151 Success a -> pure a
152 Error _err -> returnError ConversionFailed field
153 $ DL.intercalate " " [ "cannot parse hyperdata for JSON: "
154 , show v
155 ]
156
157 printSqlOpa :: Default Unpackspec a a => Query a -> IO ()
158 printSqlOpa = putStrLn . maybe "Empty query" identity . showSqlForPostgres
159