src/Gargantext/API/Prelude.hs

   1 {-|
   2 Module      : Gargantext.API.Prelude
   3 Description : Server API main Types
   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 #-}
  13 {-# LANGUAGE TemplateHaskell #-}
  14 {-# LANGUAGE MonoLocalBinds  #-}
  15
  16 module Gargantext.API.Prelude
  17   ( module Gargantext.API.Prelude
  18   , HasServerError(..)
  19   , serverError
  20   )
  21   where
  22
  23 import Control.Concurrent (threadDelay)
  24 import Control.Exception (Exception)
  25 import Control.Lens (Prism', (#))
  26 import Control.Lens.TH (makePrisms)
  27 import Control.Monad (mapM_)
  28 import Control.Monad.Except (ExceptT)
  29 import Control.Monad.Reader (ReaderT)
  30 import Control.Monad.Error.Class (MonadError(..))
  31 import Crypto.JOSE.Error as Jose
  32 import Data.Aeson.Types
  33 import qualified Data.Text as Text
  34 import Data.Typeable
  35 import Data.Validity
  36 import Gargantext.API.Admin.Orchestrator.Types
  37 import Gargantext.API.Admin.Types
  38 import Gargantext.Core.NLP (HasNLPServer)
  39 import Gargantext.Core.NodeStory
  40 import Gargantext.Core.Mail.Types (HasMail)
  41 import Gargantext.Core.Types
  42 import Gargantext.Database.Prelude
  43 import Gargantext.Database.Query.Table.Node.Error (NodeError(..), HasNodeError(..))
  44 import Gargantext.Database.Query.Tree
  45 import Gargantext.Prelude
  46 import           Gargantext.Utils.Jobs.Monad (MonadJobStatus(..), JobHandle)
  47 import qualified Gargantext.Utils.Jobs.Monad as Jobs
  48 import Servant
  49 import Servant.Job.Async
  50 import Servant.Job.Core (HasServerError(..), serverError)
  51
  52 class HasJoseError e where
  53   _JoseError :: Prism' e Jose.Error
  54
  55 joseError :: (MonadError e m, HasJoseError e) => Jose.Error -> m a
  56 joseError = throwError . (_JoseError #)
  57
  58 type HasJobEnv' env = HasJobEnv env JobLog JobLog
  59
  60 type EnvC env =
  61   ( HasConnectionPool env
  62   , HasSettings       env  -- TODO rename HasDbSettings
  63   , HasJobEnv         env JobLog JobLog
  64   , HasConfig         env
  65   , HasNodeStoryEnv   env
  66   , HasMail           env
  67   , HasNLPServer      env
  68   )
  69
  70 type ErrC err =
  71   ( HasNodeError     err
  72   , HasInvalidError  err
  73   , HasTreeError     err
  74   , HasServerError   err
  75   , HasJoseError     err
  76 --  , ToJSON           err -- TODO this is arguable
  77   , Exception        err
  78   )
  79
  80 type GargServerC env err m =
  81   ( CmdRandom    env err m
  82   , HasNodeStory env err m
  83   , EnvC         env
  84   , ErrC             err
  85   , ToJSON           err
  86   )
  87
  88 type GargServerT env err m api = GargServerC env err m => ServerT api m
  89
  90 type GargServer api = forall env err m. GargServerT env err m api
  91
  92 -- This is the concrete monad. It needs to be used as little as possible.
  93 type GargM env err = ReaderT env (ExceptT err IO)
  94 -- This is the server type using GargM. It needs to be used as little as possible.
  95 -- Instead, prefer GargServer, GargServerT.
  96 type GargServerM env err api = (EnvC env, ErrC err) => ServerT api (GargM env err)
  97
  98 -------------------------------------------------------------------
  99 -- | This Type is needed to prepare the function before the GargServer
 100 type GargNoServer t =
 101   forall env err m. GargNoServer' env err m => m t
 102
 103 type GargNoServer' env err m =
 104   ( CmdM           env err m
 105   , HasNodeStory   env err m
 106   , HasSettings    env
 107   , HasNodeError       err
 108   )
 109
 110 -------------------------------------------------------------------
 111 data GargError
 112   = GargNodeError    NodeError
 113   | GargTreeError    TreeError
 114   | GargInvalidError Validation
 115   | GargJoseError    Jose.Error
 116   | GargServerError  ServerError
 117   | GargJobError     Jobs.JobError
 118   deriving (Show, Typeable)
 119
 120 makePrisms ''GargError
 121
 122 instance ToJSON GargError where
 123   toJSON err = object [("error", String $ Text.pack $ show err)]
 124
 125 instance Exception GargError
 126
 127 instance HasNodeError GargError where
 128   _NodeError = _GargNodeError
 129
 130 instance HasInvalidError GargError where
 131   _InvalidError = _GargInvalidError
 132
 133 instance HasTreeError GargError where
 134   _TreeError = _GargTreeError
 135
 136 instance HasServerError GargError where
 137   _ServerError = _GargServerError
 138
 139 instance HasJoseError GargError where
 140   _JoseError = _GargJoseError
 141
 142 ------------------------------------------------------------------------
 143 -- | Utils
 144 -- | Simulate logs
 145 simuLogs  :: (MonadBase IO m, MonadJobStatus m) => JobHandle m -> Int -> m ()
 146 simuLogs jobHandle t = do
 147   markStarted t jobHandle
 148   mapM_ (const simuTask) $ take t ([0,1..] :: [Int])
 149   markComplete jobHandle
 150   where
 151     simuTask = do
 152       let m = (10 :: Int) ^ (6 :: Int)
 153       liftBase $ threadDelay (m*5)
 154       markProgress 1 jobHandle