src/Gargantext/API/Types.hs

   1 {-|
   2 Module      : Gargantext.API.Types
   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
  13 {-# LANGUAGE ConstraintKinds        #-}
  14 {-# LANGUAGE FlexibleInstances      #-}
  15 {-# LANGUAGE FunctionalDependencies #-}
  16 {-# LANGUAGE MultiParamTypeClasses  #-}
  17 {-# LANGUAGE NoImplicitPrelude      #-}
  18 {-# LANGUAGE RankNTypes             #-}
  19 {-# LANGUAGE TemplateHaskell        #-}
  20 {-# LANGUAGE TypeOperators          #-}
  21 {-# LANGUAGE UndecidableInstances   #-}
  22
  23 module Gargantext.API.Types
  24   where
  25
  26 import Control.Lens (Prism', (#))
  27 import Control.Lens.TH (makePrisms)
  28 import Control.Monad.Error.Class (MonadError(throwError))
  29 import Crypto.JOSE.Error as Jose
  30 import Data.Validity
  31 import Servant
  32 import Gargantext.Prelude
  33 import Gargantext.API.Settings
  34 import Gargantext.API.Ngrams
  35 import Gargantext.Database.Tree
  36 import Gargantext.Core.Types
  37 import Gargantext.Database.Utils
  38 import Gargantext.Database.Schema.Node
  39
  40 class HasServerError e where
  41   _ServerError :: Prism' e ServerError
  42
  43 serverError :: (MonadError e m, HasServerError e) => ServerError -> m a
  44 serverError e = throwError $ _ServerError # e
  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 class ThrowAll' e a | a -> e where
  53   -- | 'throwAll' is a convenience function to throw errors across an entire
  54   -- sub-API
  55   --
  56   --
  57   -- > throwAll err400 :: Handler a :<|> Handler b :<|> Handler c
  58   -- >    == throwError err400 :<|> throwError err400 :<|> err400
  59   throwAll' :: e -> a
  60
  61 instance (ThrowAll' e a, ThrowAll' e b) => ThrowAll' e (a :<|> b) where
  62   throwAll' e = throwAll' e :<|> throwAll' e
  63
  64 -- Really this shouldn't be necessary - ((->) a) should be an instance of
  65 -- MonadError, no?
  66 instance {-# OVERLAPPING #-} ThrowAll' e b => ThrowAll' e (a -> b) where
  67   throwAll' e = const $ throwAll' e
  68
  69 instance {-# OVERLAPPABLE #-} (MonadError e m) => ThrowAll' e (m a) where
  70   throwAll' = throwError
  71
  72 type GargServerC env err m =
  73     ( CmdM env err m
  74     , HasNodeError err
  75     , HasInvalidError err
  76     , HasTreeError err
  77     , HasServerError err
  78     , HasJoseError err
  79     , HasRepo env
  80     , HasSettings env
  81     )
  82
  83 type GargServerT env err m api = GargServerC env err m => ServerT api m
  84
  85 type GargServer api =
  86   forall env err m. GargServerT env err m api
  87
  88 data GargError
  89   = GargNodeError NodeError
  90   | GargTreeError TreeError
  91   | GargInvalidError Validation
  92   | GargJoseError Jose.Error
  93   | GargServerError ServerError
  94   deriving (Show)
  95
  96 makePrisms ''GargError
  97
  98 instance HasNodeError GargError where
  99   _NodeError = _GargNodeError
 100
 101 instance HasInvalidError GargError where
 102   _InvalidError = _GargInvalidError
 103
 104 instance HasTreeError GargError where
 105   _TreeError = _GargTreeError
 106
 107 instance HasServerError GargError where
 108   _ServerError = _GargServerError
 109
 110 instance HasJoseError GargError where
 111   _JoseError = _GargJoseError