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