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