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