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.Error.Class (MonadError(..))
  28 import Control.Monad.Except (ExceptT)
  29 import Control.Monad.Reader (ReaderT)
  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 Servant
  44 import Servant.Job.Async
  45 import Servant.Job.Core (HasServerError(..), serverError)
  46
  47 class HasJoseError e where
  48   _JoseError :: Prism' e Jose.Error
  49
  50 joseError :: (MonadError e m, HasJoseError e) => Jose.Error -> m a
  51 joseError = throwError . (_JoseError #)
  52
  53 type HasJobEnv' env = HasJobEnv env JobLog JobLog
  54
  55 type EnvC env =
  56   ( HasConnectionPool env
  57   , HasSettings       env  -- TODO rename HasDbSettings
  58   , HasJobEnv         env JobLog JobLog
  59   , HasConfig         env
  60   , HasNodeStoryEnv   env
  61   , HasMail           env
  62   )
  63
  64 type ErrC err =
  65   ( HasNodeError     err
  66   , HasInvalidError  err
  67   , HasTreeError     err
  68   , HasServerError   err
  69   , HasJoseError     err
  70 --  , ToJSON           err -- TODO this is arguable
  71   , Exception        err
  72   )
  73
  74 type GargServerC env err m =
  75   ( CmdRandom env err m
  76   , HasNodeStory env err m
  77   , EnvC  env
  78   , ErrC      err
  79   , ToJSON err
  80   )
  81
  82 type GargServerT env err m api = GargServerC env err m => ServerT api m
  83
  84 type GargServer api = forall env err m. GargServerT env err m api
  85
  86 -- This is the concrete monad. It needs to be used as little as possible.
  87 type GargM env err = ReaderT env (ExceptT err IO)
  88 -- This is the server type using GargM. It needs to be used as little as possible.
  89 -- Instead, prefer GargServer, GargServerT.
  90 type GargServerM env err api = (EnvC env, ErrC err) => ServerT api (GargM env err)
  91
  92 -------------------------------------------------------------------
  93 -- | This Type is needed to prepare the function before the GargServer
  94 type GargNoServer t =
  95   forall env err m. GargNoServer' env err m => m t
  96
  97 type GargNoServer' env err m =
  98   ( CmdM           env err m
  99   , HasNodeStory   env err m
 100   , HasSettings    env
 101   , HasNodeError       err
 102   )
 103
 104 -------------------------------------------------------------------
 105
 106 data GargError
 107   = GargNodeError    NodeError
 108   | GargTreeError    TreeError
 109   | GargInvalidError Validation
 110   | GargJoseError    Jose.Error
 111   | GargServerError  ServerError
 112   deriving (Show, Typeable)
 113
 114 makePrisms ''GargError
 115
 116 instance ToJSON GargError where
 117   toJSON _ = String "SomeGargErrorPleaseReport"
 118
 119 instance Exception GargError
 120
 121 instance HasNodeError GargError where
 122   _NodeError = _GargNodeError
 123
 124 instance HasInvalidError GargError where
 125   _InvalidError = _GargInvalidError
 126
 127 instance HasTreeError GargError where
 128   _TreeError = _GargTreeError
 129
 130 instance HasServerError GargError where
 131   _ServerError = _GargServerError
 132
 133 instance HasJoseError GargError where
 134   _JoseError = _GargJoseError
 135
 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