src/Gargantext/API/Admin/Types.hs

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