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