]> Git — Sourcephile - gargantext.git/blob - src/Gargantext/Database/Utils.hs
issues with hidden module when trying to make a bin file
[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 Data.Maybe (maybe)
34 import Data.Monoid ((<>))
35 import Data.Profunctor.Product.Default (Default)
36 import Data.Text (unpack, pack)
37 import Data.Typeable (Typeable)
38 import Data.Word (Word16)
39 import Database.PostgreSQL.Simple (Connection, connect)
40 import Database.PostgreSQL.Simple.FromField ( Conversion, ResultError(ConversionFailed), fromField, returnError)
41 import Database.PostgreSQL.Simple.Internal (Field)
42 import Gargantext.Prelude
43 import Opaleye (Query, Unpackspec, showSqlForPostgres, FromFields, Select, runQuery)
44 import System.IO (FilePath)
45 import Text.Read (read)
46 import qualified Data.ByteString as DB
47 import qualified Database.PostgreSQL.Simple as PGS
48
49 class HasConnection env where
50 connection :: Getter env Connection
51
52 instance HasConnection Connection where
53 connection = identity
54
55 type CmdM' env err m =
56 ( MonadReader env m
57 , MonadError err m
58 , MonadIO m
59 )
60
61 type CmdM env err m =
62 ( CmdM' env err m
63 , HasConnection env
64 )
65
66 type Cmd' env err a = forall m. CmdM' env err m => m a
67
68 type Cmd err a = forall m env. CmdM env err m => m a
69
70 -- TODO: ideally there should be very few calls to this functions.
71 mkCmd :: (Connection -> IO a) -> Cmd err a
72 mkCmd k = do
73 conn <- view connection
74 liftIO $ k conn
75
76 runCmd :: (HasConnection env) => env
77 -> Cmd' env err a
78 -> IO (Either err a)
79 runCmd env m = runExceptT $ runReaderT m env
80
81 runOpaQuery :: Default FromFields fields haskells => Select fields -> Cmd err [haskells]
82 runOpaQuery q = mkCmd $ \c -> runQuery c q
83
84 formatPGSQuery :: PGS.ToRow a => PGS.Query -> a -> Cmd err DB.ByteString
85 formatPGSQuery q a = mkCmd $ \conn -> PGS.formatQuery conn q a
86
87 -- TODO use runPGSQueryDebug everywhere
88 runPGSQuery' :: (PGS.ToRow a, PGS.FromRow b) => PGS.Query -> a -> Cmd err [b]
89 runPGSQuery' q a = mkCmd $ \conn -> PGS.query conn q a
90
91 runPGSQuery :: (MonadError err m, MonadReader env m,
92 PGS.FromRow r, PGS.ToRow q, MonadIO m, HasConnection env)
93 => PGS.Query -> q -> m [r]
94 runPGSQuery q a = mkCmd $ \conn -> catch (PGS.query conn q a) (printError conn)
95 where
96 printError c (SomeException e) = do
97 q' <- PGS.formatQuery c q a
98 hPutStrLn stderr q'
99 throw (SomeException e)
100
101
102 execPGSQuery :: PGS.ToRow a => PGS.Query -> a -> Cmd err Int64
103 execPGSQuery q a = mkCmd $ \conn -> PGS.execute conn q a
104
105 ------------------------------------------------------------------------
106
107 databaseParameters :: FilePath -> IO PGS.ConnectInfo
108 databaseParameters fp = do
109 ini <- readIniFile fp
110 let ini'' = case ini of
111 Left e -> panic (pack $ "No ini file error" <> show e)
112 Right ini' -> ini'
113
114 let val x = case (lookupValue (pack "django") (pack x) ini'') of
115 Left _ -> panic (pack $ "no" <> x)
116 Right p' -> unpack p'
117
118 pure $ PGS.ConnectInfo { PGS.connectHost = val "DB_HOST"
119 , PGS.connectPort = read (val "DB_PORT") :: Word16
120 , PGS.connectUser = val "DB_USER"
121 , PGS.connectPassword = val "DB_PASS"
122 , PGS.connectDatabase = val "DB_NAME"
123 }
124
125 connectGargandb :: FilePath -> IO Connection
126 connectGargandb fp = databaseParameters fp >>= \params -> connect params
127
128 fromField' :: (Typeable b, FromJSON b) => Field -> Maybe DB.ByteString -> Conversion b
129 fromField' field mb = do
130 v <- fromField field mb
131 valueToHyperdata v
132 where
133 valueToHyperdata v = case fromJSON v of
134 Success a -> pure a
135 Error _err -> returnError ConversionFailed field "cannot parse hyperdata"
136
137 printSqlOpa :: Default Unpackspec a a => Query a -> IO ()
138 printSqlOpa = putStrLn . maybe "Empty query" identity . showSqlForPostgres
139