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 FlexibleContexts  #-}
  15 {-# LANGUAGE NoImplicitPrelude #-}
  16 {-# LANGUAGE OverloadedStrings #-}
  17 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
  18
  19 module Gargantext.Database.Utils where
  20
  21 import Control.Applicative (Applicative)
  22 import Control.Monad.Reader
  23 import Data.Aeson (Result(Error,Success), fromJSON, FromJSON)
  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.Profunctor.Product.Default (Default)
  29 import Data.Text (unpack, pack)
  30 import Data.Typeable (Typeable)
  31 import Data.Word (Word16)
  32 import Database.PostgreSQL.Simple (Connection, connect)
  33 import Database.PostgreSQL.Simple.FromField ( Conversion, ResultError(ConversionFailed), fromField, returnError)
  34 import Database.PostgreSQL.Simple.Internal  (Field)
  35 import Gargantext.Prelude
  36 import Opaleye (Query, Unpackspec, showSqlForPostgres)
  37 import System.IO (FilePath)
  38 import Text.Read (read)
  39 import qualified Data.ByteString      as DB
  40 import qualified Database.PostgreSQL.Simple as PGS
  41
  42 ------------------------------------------------------------------------
  43 {- | Reader Monad reinvented here:
  44
  45 newtype Cmd a = Cmd { unCmd :: Connection -> IO a }
  46
  47 instance Monad Cmd where
  48   return a = Cmd $ \_ -> return a
  49
  50   m >>= f = Cmd $ \c -> do
  51     a <- unCmd m c
  52     unCmd (f a) c
  53 -}
  54
  55 newtype Cmd a = Cmd (ReaderT Connection IO a)
  56   deriving (Functor, Applicative, Monad, MonadReader Connection, MonadIO)
  57
  58 runCmd :: Connection -> Cmd a -> IO a
  59 runCmd c (Cmd f) = runReaderT f c
  60
  61 mkCmd :: (Connection -> IO a) -> Cmd a
  62 mkCmd = Cmd . ReaderT
  63
  64 ------------------------------------------------------------------------
  65
  66 databaseParameters :: FilePath -> IO PGS.ConnectInfo
  67 databaseParameters fp = do
  68   ini         <- readIniFile fp
  69   let ini'' = case ini of
  70         Left e     -> panic (pack $ "No ini file error" <> show e)
  71         Right ini' -> ini'
  72
  73   let val x = case (lookupValue (pack "django") (pack x) ini'') of
  74         Left _ -> panic (pack $ "no" <> x)
  75         Right p' -> unpack p'
  76
  77   pure $ PGS.ConnectInfo { PGS.connectHost     = val       "DB_HOST"
  78                          , PGS.connectPort     = read (val "DB_PORT") :: Word16
  79                          , PGS.connectUser     = val       "DB_USER"
  80                          , PGS.connectPassword = val       "DB_PASS"
  81                          , PGS.connectDatabase = val       "DB_NAME"
  82                          }
  83
  84 connectGargandb :: FilePath -> IO Connection
  85 connectGargandb fp = databaseParameters fp >>= \params -> connect params
  86
  87 printSql :: Default Unpackspec a a => Query a -> IO ()
  88 printSql = putStrLn . maybe "Empty query" identity . showSqlForPostgres
  89
  90 fromField' :: (Typeable b, FromJSON b) => Field -> Maybe DB.ByteString -> Conversion b
  91 fromField' field mb = do
  92     v <- fromField field mb
  93     valueToHyperdata v
  94       where
  95           valueToHyperdata v = case fromJSON v of
  96              Success a  -> pure a
  97              Error _err -> returnError ConversionFailed field "cannot parse hyperdata"
  98
  99 -- | Opaleye leftJoin* functions
 100 -- TODO add here from Node.hs