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