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