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 FunctionalDependencies #-}
  14 {-# LANGUAGE TemplateHaskell        #-}
  15 {-# LANGUAGE TypeOperators          #-}
  16 {-# LANGUAGE UndecidableInstances   #-}
  17
  18 module Gargantext.API.Prelude
  19   ( module Gargantext.API.Prelude
  20   , HasServerError(..)
  21   , serverError
  22   )
  23   where
  24
  25 import Control.Exception (Exception)
  26 import Control.Lens (Prism', (#))
  27 import Control.Lens.TH (makePrisms)
  28 import Control.Monad.Error.Class (MonadError(throwError))
  29 import Control.Monad.Except (ExceptT)
  30 import Control.Monad.Reader (ReaderT)
  31 import Crypto.JOSE.Error as Jose
  32 import Data.Aeson.Types
  33 import Data.Typeable
  34 import Data.Validity
  35 import Gargantext.API.Admin.Orchestrator.Types
  36 import Gargantext.API.Admin.Settings
  37 import Gargantext.API.Ngrams
  38 import Gargantext.Core.Types
  39 import Gargantext.Database.Query.Tree
  40 import Gargantext.Database.Query.Table.Node.Error (NodeError(..), HasNodeError(..))
  41 import Gargantext.Database.Prelude
  42 import Gargantext.Prelude
  43 import Servant
  44 import Servant.Job.Async (HasJobEnv)
  45 import Servant.Job.Core (HasServerError(..), serverError)
  46
  47 class HasJoseError e where
  48   _JoseError :: Prism' e Jose.Error
  49
  50 joseError :: (MonadError e m, HasJoseError e) => Jose.Error -> m a
  51 joseError = throwError . (_JoseError #)
  52
  53 class ThrowAll' e a | a -> e where
  54   -- | 'throwAll' is a convenience function to throw errors across an entire
  55   -- sub-API
  56   --
  57   --
  58   -- > throwAll err400 :: Handler a :<|> Handler b :<|> Handler c
  59   -- >    == throwError err400 :<|> throwError err400 :<|> err400
  60   throwAll' :: e -> a
  61
  62 instance (ThrowAll' e a, ThrowAll' e b) => ThrowAll' e (a :<|> b) where
  63   throwAll' e = throwAll' e :<|> throwAll' e
  64
  65 -- Really this shouldn't be necessary - ((->) a) should be an instance of
  66 -- MonadError, no?
  67 instance {-# OVERLAPPING #-} ThrowAll' e b => ThrowAll' e (a -> b) where
  68   throwAll' e = const $ throwAll' e
  69
  70 instance {-# OVERLAPPABLE #-} (MonadError e m) => ThrowAll' e (m a) where
  71   throwAll' = throwError
  72
  73 type GargServerC env err m =
  74     ( CmdM         env err m
  75     , HasNodeError     err
  76     , HasInvalidError  err
  77     , HasTreeError     err
  78     , HasServerError   err
  79     , HasJoseError     err
  80     , ToJSON           err -- TODO this is arguable
  81     , Exception        err
  82     , HasRepo      env
  83     , HasSettings  env
  84     , HasJobEnv    env ScraperStatus ScraperStatus
  85     )
  86
  87 type GargServerT env err m api = GargServerC env err m => ServerT api m
  88
  89 type GargServer api =
  90   forall env err m. GargServerT env err m api
  91
  92 -- This is the concrete monad. It needs to be used as little as possible,
  93 -- instead, prefer GargServer, GargServerT, GargServerC.
  94 type GargServerM env err = ReaderT env (ExceptT err IO)
  95
  96 type EnvC env =
  97   ( HasConnectionPool env
  98   , HasRepo env
  99   , HasSettings env
 100   , HasJobEnv env ScraperStatus ScraperStatus
 101   )
 102
 103
 104
 105 -------------------------------------------------------------------
 106 -- | This Type is needed to prepare the function before the GargServer
 107 type GargNoServer' env err m =
 108   ( CmdM           env err m
 109   , HasRepo        env
 110   , HasSettings    env
 111   , HasNodeError       err
 112   )
 113
 114 type GargNoServer t =
 115   forall env err m. GargNoServer' env err m => m t
 116 -------------------------------------------------------------------
 117
 118 data GargError
 119   = GargNodeError    NodeError
 120   | GargTreeError    TreeError
 121   | GargInvalidError Validation
 122   | GargJoseError    Jose.Error
 123   | GargServerError  ServerError
 124   deriving (Show, Typeable)
 125
 126 makePrisms ''GargError
 127
 128 instance ToJSON GargError where
 129   toJSON _ = String "SomeGargErrorPleaseReport"
 130
 131 instance Exception GargError
 132
 133 instance HasNodeError GargError where
 134   _NodeError = _GargNodeError
 135
 136 instance HasInvalidError GargError where
 137   _InvalidError = _GargInvalidError
 138
 139 instance HasTreeError GargError where
 140   _TreeError = _GargTreeError
 141
 142 instance HasServerError GargError where
 143   _ServerError = _GargServerError
 144
 145 instance HasJoseError GargError where
 146   _JoseError = _GargJoseError