]> Git — Sourcephile - gargantext.git/blob - src/Gargantext/Database/Prelude.hs
[FIX] commenting to fix graph issue
[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, ScopedTypeVariables #-}
13
14 module Gargantext.Database.Prelude where
15
16 import Control.Exception
17 import Control.Lens (Getter, view)
18 import Control.Monad.Except
19 --import Control.Monad.Logger (MonadLogger)
20 import Control.Monad.Random
21 import Control.Monad.Reader
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)
26 import Data.Pool (Pool, withResource)
27 import Data.Profunctor.Product.Default (Default)
28 import Data.Text (pack, unpack, Text)
29 import Data.Word (Word16)
30 import Database.PostgreSQL.Simple (Connection, connect)
31 import Database.PostgreSQL.Simple.FromField ( Conversion, ResultError(ConversionFailed), fromField, returnError)
32 import Database.PostgreSQL.Simple.Internal (Field)
33 import Database.PostgreSQL.Simple.Types (Query(..))
34 import Gargantext.Core.Mail.Types (HasMail)
35 import Gargantext.Prelude
36 import Gargantext.Prelude.Config (readIniFile', val)
37 import Opaleye (Unpackspec, showSql, FromFields, Select, runSelect, SqlJsonb, DefaultFromField)
38 import Opaleye.Aggregate (countRows)
39 import System.IO (FilePath)
40 import System.IO (stderr)
41 import Text.Read (readMaybe)
42 import qualified Data.ByteString as DB
43 import qualified Data.List as DL
44 import qualified Database.PostgreSQL.Simple as PGS
45
46 import Gargantext.Prelude.Config (GargConfig())
47
48 -------------------------------------------------------
49 class HasConnectionPool env where
50 connPool :: Getter env (Pool Connection)
51
52 instance HasConnectionPool (Pool Connection) where
53 connPool = identity
54
55 class HasConfig env where
56 hasConfig :: Getter env GargConfig
57
58 instance HasConfig GargConfig where
59 hasConfig = identity
60
61 -------------------------------------------------------
62 type JSONB = DefaultFromField SqlJsonb
63 -------------------------------------------------------
64
65 type CmdM'' env err m =
66 ( MonadReader env m
67 , MonadError err m
68 , MonadBaseControl IO m
69 , MonadRandom m
70 --, MonadLogger m
71 )
72
73 type CmdM' env err m =
74 ( MonadReader env m
75 , MonadError err m
76 , MonadBaseControl IO m
77 --, MonadLogger m
78 -- , MonadRandom m
79 )
80
81 type CmdM env err m =
82 ( CmdM' env err m
83 , HasConnectionPool env
84 , HasConfig env
85 , HasMail env
86 )
87
88 type CmdRandom env err m =
89 ( CmdM' env err m
90 , HasConnectionPool env
91 , HasConfig env
92 , MonadRandom m
93 , HasMail env
94 )
95
96 type Cmd'' env err a = forall m. CmdM'' env err m => m a
97 type Cmd' env err a = forall m. CmdM' env err m => m a
98 type Cmd err a = forall m env. CmdM env err m => m a
99 type CmdR err a = forall m env. CmdRandom env err m => m a
100
101
102
103 fromInt64ToInt :: Int64 -> Int
104 fromInt64ToInt = fromIntegral
105
106 -- TODO: ideally there should be very few calls to this functions.
107 mkCmd :: (Connection -> IO a) -> Cmd err a
108 mkCmd k = do
109 pool <- view connPool
110 withResource pool (liftBase . k)
111
112 runCmd :: (HasConnectionPool env)
113 => env
114 -> Cmd'' env err a
115 -> IO (Either err a)
116 runCmd env m = runExceptT $ runReaderT m env
117
118 runOpaQuery :: Default FromFields fields haskells
119 => Select fields
120 -> Cmd err [haskells]
121 runOpaQuery q = mkCmd $ \c -> runSelect c q
122
123 runCountOpaQuery :: Select a -> Cmd err Int
124 runCountOpaQuery q = do
125 counts <- mkCmd $ \c -> runSelect c $ countRows q
126 -- countRows is guaranteed to return a list with exactly one row so DL.head is safe here
127 pure $ fromInt64ToInt $ DL.head counts
128
129 formatPGSQuery :: PGS.ToRow a => PGS.Query -> a -> Cmd err DB.ByteString
130 formatPGSQuery q a = mkCmd $ \conn -> PGS.formatQuery conn q a
131
132 -- TODO use runPGSQueryDebug everywhere
133 runPGSQuery' :: (PGS.ToRow a, PGS.FromRow b) => PGS.Query -> a -> Cmd err [b]
134 runPGSQuery' q a = mkCmd $ \conn -> PGS.query conn q a
135
136 runPGSQuery :: ( CmdM env err m
137 , PGS.FromRow r, PGS.ToRow q
138 )
139 => PGS.Query -> q -> m [r]
140 runPGSQuery q a = mkCmd $ \conn -> catch (PGS.query conn q a) (printError conn)
141 where
142 printError c (SomeException e) = do
143 q' <- PGS.formatQuery c q a
144 hPutStrLn stderr q'
145 throw (SomeException e)
146
147 {-
148 -- TODO
149 runPGSQueryFold :: ( CmdM env err m
150 , PGS.FromRow r
151 )
152 => PGS.Query -> a -> (a -> r -> IO a) -> m a
153 runPGSQueryFold q initialState consume = mkCmd $ \conn -> catch (PGS.fold_ conn initialState consume) (printError conn)
154 where
155 printError c (SomeException e) = do
156 q' <- PGS.formatQuery c q
157 hPutStrLn stderr q'
158 throw (SomeException e)
159 -}
160
161
162
163 -- | TODO catch error
164 runPGSQuery_ :: ( CmdM env err m
165 , PGS.FromRow r
166 )
167 => PGS.Query -> m [r]
168 runPGSQuery_ q = mkCmd $ \conn -> catch (PGS.query_ conn q) printError
169 where
170 printError (SomeException e) = do
171 hPutStrLn stderr (fromQuery q)
172 throw (SomeException e)
173
174 execPGSQuery :: PGS.ToRow a => PGS.Query -> a -> Cmd err Int64
175 execPGSQuery q a = mkCmd $ \conn -> PGS.execute conn q a
176
177 ------------------------------------------------------------------------
178 databaseParameters :: FilePath -> IO PGS.ConnectInfo
179 databaseParameters fp = do
180 ini <- readIniFile' fp
181 let val' key = unpack $ val ini "database" key
182 let dbPortRaw = val' "DB_PORT"
183 let dbPort = case (readMaybe dbPortRaw :: Maybe Word16) of
184 Nothing -> panic $ "DB_PORT incorrect: " <> (pack dbPortRaw)
185 Just d -> d
186
187 pure $ PGS.ConnectInfo { PGS.connectHost = val' "DB_HOST"
188 , PGS.connectPort = dbPort
189 , PGS.connectUser = val' "DB_USER"
190 , PGS.connectPassword = val' "DB_PASS"
191 , PGS.connectDatabase = val' "DB_NAME"
192 }
193
194 connectGargandb :: FilePath -> IO Connection
195 connectGargandb fp = databaseParameters fp >>= \params -> connect params
196
197 fromField' :: (Typeable b, FromJSON b) => Field -> Maybe DB.ByteString -> Conversion b
198 fromField' field mb = do
199 v <- fromField field mb
200 valueToHyperdata v
201 where
202 valueToHyperdata v = case fromJSON v of
203 Success a -> pure a
204 Error _err -> returnError ConversionFailed field
205 $ DL.intercalate " " [ "cannot parse hyperdata for JSON: "
206 , show v
207 ]
208
209 printSqlOpa :: Default Unpackspec a a => Select a -> IO ()
210 printSqlOpa = putStrLn . maybe "Empty query" identity . showSql
211
212 dbCheck :: CmdM env err m => m Bool
213 dbCheck = do
214 r :: [PGS.Only Text] <- runPGSQuery_ "select username from public.auth_user"
215 case r of
216 [] -> return False
217 _ -> return True