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