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.API.Ngrams.Types
  37 import Gargantext.Core.Types
  38 import Gargantext.Database.Prelude
  39 import Gargantext.Database.Query.Table.Node.Error (NodeError(..), HasNodeError(..))
  40 import Gargantext.Database.Query.Tree
  41 import Gargantext.Prelude
  42 import Servant
  43 import Servant.Job.Async
  44 import Servant.Job.Core (HasServerError(..), serverError)
  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