[API][FLOW][Upload] just for CsvHal
[gargantext.git] / src / Gargantext / Database / Utils.hs
index 095aa0c26af7e3641d78df8e535c6fde8701a062..76bb1dd0d7270a4c0a96590cb65995dfed5ef54c 100644 (file)
+{-|
+Module      : Gargantext.Database.Util
+Description : 
+Copyright   : (c) CNRS, 2017-Present
+License     : AGPL + CECILL v3
+Maintainer  : team@gargantext.org
+Stability   : experimental
+Portability : POSIX
+
+Here is a longer description of this module, containing some
+commentary with @some markup@.
+-}
+
+{-# LANGUAGE ConstraintKinds   #-}
+{-# LANGUAGE FlexibleContexts  #-}
+{-# LANGUAGE NoImplicitPrelude #-}
 {-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE FlexibleContexts   #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE RankNTypes                 #-}
 
 module Gargantext.Database.Utils where
 
-import qualified Database.PostgreSQL.Simple as PGS
-
-import Data.Monoid ((<>))
+import Data.ByteString.Char8 (hPutStrLn)
+import System.IO (stderr)
+import Control.Exception 
+import Control.Monad.Error.Class -- (MonadError(..), Error)
+import Control.Lens (Getter, view)
+import Control.Monad.Reader
+import Control.Monad.Except
+import Data.Aeson (Result(Error,Success), fromJSON, FromJSON)
 import Data.Either.Extra (Either(Left, Right))
-import Gargantext.Prelude
-import Data.Text (unpack, pack)
-import Text.Read (read)
 import Data.Ini (readIniFile, lookupValue)
+import qualified Data.List as DL
+import Data.Maybe (maybe)
+import Data.Monoid ((<>))
+import Data.Profunctor.Product.Default (Default)
+import Data.Text (unpack, pack)
+import Data.Typeable (Typeable)
 import Data.Word (Word16)
-import System.IO (FilePath)
 import Database.PostgreSQL.Simple (Connection, connect)
+import Database.PostgreSQL.Simple.FromField ( Conversion, ResultError(ConversionFailed), fromField, returnError)
+import Database.PostgreSQL.Simple.Internal  (Field)
+import Gargantext.Prelude
+import Opaleye (Query, Unpackspec, showSqlForPostgres, FromFields, Select, runQuery)
+import Opaleye.Aggregate (countRows)
+import System.IO (FilePath)
+import Text.Read (read)
+import qualified Data.ByteString      as DB
+import qualified Database.PostgreSQL.Simple as PGS
 
--- Utilities
-import Opaleye (Query, Unpackspec, showSqlForPostgres)
-import Data.Profunctor.Product.Default (Default)
-import Data.Maybe (maybe)
-import Prelude (id, putStrLn)
--- TODO add a reader Monad here
--- read this in the init file
+class HasConnection env where
+  connection :: Getter env Connection
+
+instance HasConnection Connection where
+  connection = identity
+
+type CmdM' env err m =
+  ( MonadReader env m
+  , MonadError err m
+  , MonadIO m
+  )
+
+type CmdM env err m =
+  ( CmdM' env err m
+  , HasConnection env
+  )
+
+type Cmd' env err a = forall m. CmdM' env err m => m a
+
+type Cmd err a = forall m env. CmdM env err m => m a
+
+fromInt64ToInt :: Int64 -> Int
+fromInt64ToInt = fromIntegral
+
+-- TODO: ideally there should be very few calls to this functions.
+mkCmd :: (Connection -> IO a) -> Cmd err a
+mkCmd k = do
+  conn <- view connection
+  liftIO $ k conn
+
+runCmd :: (HasConnection env)
+       => env -> Cmd' env err a
+       -> IO (Either err a)
+runCmd env m = runExceptT $ runReaderT m env
+
+runOpaQuery :: Default FromFields fields haskells
+            => Select fields -> Cmd err [haskells]
+runOpaQuery q = mkCmd $ \c -> runQuery c q
+
+runCountOpaQuery :: Select a -> Cmd err Int
+runCountOpaQuery q = do
+  counts <- mkCmd $ \c -> runQuery c $ countRows q
+  -- countRows is guaranteed to return a list with exactly one row so DL.head is safe here
+  pure $ fromInt64ToInt $ DL.head counts
+
+formatPGSQuery :: PGS.ToRow a => PGS.Query -> a -> Cmd err DB.ByteString
+formatPGSQuery q a = mkCmd $ \conn -> PGS.formatQuery conn q a
+
+-- TODO use runPGSQueryDebug everywhere
+runPGSQuery' :: (PGS.ToRow a, PGS.FromRow b) => PGS.Query -> a -> Cmd err [b]
+runPGSQuery' q a = mkCmd $ \conn -> PGS.query conn q a
+
+runPGSQuery :: (MonadError err m, MonadReader env m,
+                PGS.FromRow r, PGS.ToRow q, MonadIO m, HasConnection env)
+                => PGS.Query -> q -> m [r]
+runPGSQuery q a = mkCmd $ \conn -> catch (PGS.query conn q a) (printError conn)
+  where
+    printError c (SomeException e) = do
+      q' <- PGS.formatQuery c q a
+      hPutStrLn stderr q'
+      throw (SomeException e)
+
+
+execPGSQuery :: PGS.ToRow a => PGS.Query -> a -> Cmd err Int64
+execPGSQuery q a = mkCmd $ \conn -> PGS.execute conn q a
+
+------------------------------------------------------------------------
 
 databaseParameters :: FilePath -> IO PGS.ConnectInfo
 databaseParameters fp = do
@@ -34,19 +127,25 @@ databaseParameters fp = do
         Left _ -> panic (pack $ "no" <> x)
         Right p' -> unpack p'
 
-  pure $ PGS.ConnectInfo { PGS.connectHost = val "DB_HOST"
-                               , PGS.connectPort = read (val "DB_PORT") :: Word16
-                               , PGS.connectUser = val "DB_USER"
-                               , PGS.connectPassword = val "DB_PASS"
-                               , PGS.connectDatabase = val "DB_NAME" }
+  pure $ PGS.ConnectInfo { PGS.connectHost     = val       "DB_HOST"
+                         , PGS.connectPort     = read (val "DB_PORT") :: Word16
+                         , PGS.connectUser     = val       "DB_USER"
+                         , PGS.connectPassword = val       "DB_PASS"
+                         , PGS.connectDatabase = val       "DB_NAME"
+                         }
 
 connectGargandb :: FilePath -> IO Connection
-connectGargandb fp = do
-    parameters <- databaseParameters fp
-    connect parameters
-
+connectGargandb fp = databaseParameters fp >>= \params -> connect params
 
-printSql :: Default Unpackspec a a => Query a -> IO ()
-printSql = putStrLn . maybe "Empty query" id . showSqlForPostgres
+fromField' :: (Typeable b, FromJSON b) => Field -> Maybe DB.ByteString -> Conversion b
+fromField' field mb = do
+    v <- fromField field mb
+    valueToHyperdata v
+      where
+          valueToHyperdata v = case fromJSON v of
+             Success a  -> pure a
+             Error _err -> returnError ConversionFailed field "cannot parse hyperdata"
 
+printSqlOpa :: Default Unpackspec a a => Query a -> IO ()
+printSqlOpa = putStrLn . maybe "Empty query" identity . showSqlForPostgres