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 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 data GargError
 106   = GargNodeError    NodeError
 107   | GargTreeError    TreeError
 108   | GargInvalidError Validation
 109   | GargJoseError    Jose.Error
 110   | GargServerError  ServerError
 111   deriving (Show, Typeable)
 112
 113 makePrisms ''GargError
 114
 115 instance ToJSON GargError where
 116   toJSON _ = String "SomeGargErrorPleaseReport"
 117
 118 instance Exception GargError
 119
 120 instance HasNodeError GargError where
 121   _NodeError = _GargNodeError
 122
 123 instance HasInvalidError GargError where
 124   _InvalidError = _GargInvalidError
 125
 126 instance HasTreeError GargError where
 127   _TreeError = _GargTreeError
 128
 129 instance HasServerError GargError where
 130   _ServerError = _GargServerError
 131
 132 instance HasJoseError GargError where
 133   _JoseError = _GargJoseError
 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