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 MonoLocalBinds         #-}
  14 {-# LANGUAGE TypeOperators          #-}
  15 {-# LANGUAGE UndecidableInstances   #-}
  16
  17 module Gargantext.API.ThrowAll where
  18
  19 import Control.Monad.Except (MonadError(..))
  20 import Control.Lens ((#))
  21 import Data.Aeson
  22 import Servant
  23 import Servant.Auth.Server (AuthResult(..))
  24
  25 import Gargantext.Prelude
  26 import Gargantext.API.Prelude (GargServerM, _ServerError)
  27 import Gargantext.API.Routes (GargPrivateAPI, serverPrivateGargAPI')
  28
  29 class ThrowAll' e a | a -> e where
  30   -- | 'throwAll' is a convenience function to throw errors across an entire
  31   -- sub-API
  32   --
  33   --
  34   -- > throwAll err400 :: Handler a :<|> Handler b :<|> Handler c
  35   -- >    == throwError err400 :<|> throwError err400 :<|> err400
  36   throwAll' :: e -> a
  37
  38 instance (ThrowAll' e a, ThrowAll' e b) => ThrowAll' e (a :<|> b) where
  39   throwAll' e = throwAll' e :<|> throwAll' e
  40
  41 -- Really this shouldn't be necessary - ((->) a) should be an instance of
  42 -- MonadError, no?
  43 instance {-# OVERLAPPING #-} ThrowAll' e b => ThrowAll' e (a -> b) where
  44   throwAll' e = const $ throwAll' e
  45
  46 instance {-# OVERLAPPABLE #-} (MonadError e m) => ThrowAll' e (m a) where
  47   throwAll' = throwError
  48
  49 serverPrivateGargAPI :: ToJSON err => GargServerM env err GargPrivateAPI
  50 serverPrivateGargAPI (Authenticated auser) = serverPrivateGargAPI' auser
  51 serverPrivateGargAPI _                     = throwAll' (_ServerError # err401)
  52 -- Here throwAll' requires a concrete type for the monad.