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