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 -------------------------------------------------------------------
  98 -- | This Type is needed to prepare the function before the GargServer
  99 type GargNoServer' env err m =
 100   ( CmdM           env err m
 101   , HasRepo        env
 102   , HasSettings    env
 103   , HasNodeError       err
 104   )
 105
 106 type GargNoServer t =
 107   forall env err m. GargNoServer' env err m => m t
 108 -------------------------------------------------------------------
 109
 110 data GargError
 111   = GargNodeError    NodeError
 112   | GargTreeError    TreeError
 113   | GargInvalidError Validation
 114   | GargJoseError    Jose.Error
 115   | GargServerError  ServerError
 116   deriving (Show, Typeable)
 117
 118 makePrisms ''GargError
 119
 120 instance ToJSON GargError where
 121   toJSON _ = String "SomeGargErrorPleaseReport"
 122
 123 instance Exception GargError
 124
 125 instance HasNodeError GargError where
 126   _NodeError = _GargNodeError
 127
 128 instance HasInvalidError GargError where
 129   _InvalidError = _GargInvalidError
 130
 131 instance HasTreeError GargError where
 132   _TreeError = _GargTreeError
 133
 134 instance HasServerError GargError where
 135   _ServerError = _GargServerError
 136
 137 instance HasJoseError GargError where
 138   _JoseError = _GargJoseError