]> Git — Sourcephile - gargantext.git/blob - src/Gargantext/API/ThrowAll.hs
Merge branch 'dev-phylo' into dev
[gargantext.git] / src / Gargantext / API / ThrowAll.hs
1 {-|
2 Module : Gargantext.API.ThrowAll
3 Description : ThrowAll class and instance
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 FunctionalDependencies #-}
13 {-# LANGUAGE TypeOperators #-}
14 {-# LANGUAGE UndecidableInstances #-}
15
16 module Gargantext.API.ThrowAll where
17
18 import Control.Monad.Error.Class (MonadError(..))
19 import Control.Lens ((#))
20 import Servant
21 import Servant.Auth.Server (AuthResult(..))
22 import Gargantext.Prelude
23 import Gargantext.API.Prelude (GargServerM, _ServerError)
24 import Gargantext.API.Routes (GargPrivateAPI, serverPrivateGargAPI')
25
26 class ThrowAll' e a | a -> e where
27 -- | 'throwAll' is a convenience function to throw errors across an entire
28 -- sub-API
29 --
30 --
31 -- > throwAll err400 :: Handler a :<|> Handler b :<|> Handler c
32 -- > == throwError err400 :<|> throwError err400 :<|> err400
33 throwAll' :: e -> a
34
35 instance (ThrowAll' e a, ThrowAll' e b) => ThrowAll' e (a :<|> b) where
36 throwAll' e = throwAll' e :<|> throwAll' e
37
38 -- Really this shouldn't be necessary - ((->) a) should be an instance of
39 -- MonadError, no?
40 instance {-# OVERLAPPING #-} ThrowAll' e b => ThrowAll' e (a -> b) where
41 throwAll' e = const $ throwAll' e
42
43 instance {-# OVERLAPPABLE #-} (MonadError e m) => ThrowAll' e (m a) where
44 throwAll' = throwError
45
46 serverPrivateGargAPI :: GargServerM env err GargPrivateAPI
47 serverPrivateGargAPI (Authenticated auser) = serverPrivateGargAPI' auser
48 serverPrivateGargAPI _ = throwAll' (_ServerError # err401)
49 -- Here throwAll' requires a concrete type for the monad.