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