src/Gargantext/API/Prelude.hs

   1 {-|
   2 Module      : Gargantext.API.Prelude
   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.Prelude
  25   ( module Gargantext.API.Prelude
  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 Control.Monad.Except (ExceptT)
  36 import Control.Monad.Reader (ReaderT)
  37 import Crypto.JOSE.Error as Jose
  38 import Data.Aeson.Types
  39 import Data.Typeable
  40 import Data.Validity
  41 import Gargantext.API.Admin.Orchestrator.Types
  42 import Gargantext.API.Admin.Settings
  43 import Gargantext.API.Ngrams
  44 import Gargantext.Core.Types
  45 import Gargantext.Database.Query.Tree
  46 import Gargantext.Database.Query.Table.Node.Error (NodeError(..), HasNodeError(..))
  47 import Gargantext.Database.Prelude
  48 import Gargantext.Prelude
  49 import Servant
  50 import Servant.Job.Async (HasJobEnv)
  51 import Servant.Job.Core (HasServerError(..), serverError)
  52
  53 class HasJoseError e where
  54   _JoseError :: Prism' e Jose.Error
  55
  56 joseError :: (MonadError e m, HasJoseError e) => Jose.Error -> m a
  57 joseError = throwError . (_JoseError #)
  58
  59 class ThrowAll' e a | a -> e where
  60   -- | 'throwAll' is a convenience function to throw errors across an entire
  61   -- sub-API
  62   --
  63   --
  64   -- > throwAll err400 :: Handler a :<|> Handler b :<|> Handler c
  65   -- >    == throwError err400 :<|> throwError err400 :<|> err400
  66   throwAll' :: e -> a
  67
  68 instance (ThrowAll' e a, ThrowAll' e b) => ThrowAll' e (a :<|> b) where
  69   throwAll' e = throwAll' e :<|> throwAll' e
  70
  71 -- Really this shouldn't be necessary - ((->) a) should be an instance of
  72 -- MonadError, no?
  73 instance {-# OVERLAPPING #-} ThrowAll' e b => ThrowAll' e (a -> b) where
  74   throwAll' e = const $ throwAll' e
  75
  76 instance {-# OVERLAPPABLE #-} (MonadError e m) => ThrowAll' e (m a) where
  77   throwAll' = throwError
  78
  79 type GargServerC env err m =
  80     ( CmdM         env err m
  81     , HasNodeError     err
  82     , HasInvalidError  err
  83     , HasTreeError     err
  84     , HasServerError   err
  85     , HasJoseError     err
  86     , ToJSON           err -- TODO this is arguable
  87     , Exception        err
  88     , HasRepo      env
  89     , HasSettings  env
  90     , HasJobEnv    env ScraperStatus ScraperStatus
  91     )
  92
  93 type GargServerT env err m api = GargServerC env err m => ServerT api m
  94
  95 type GargServer api =
  96   forall env err m. GargServerT env err m api
  97
  98 -- This is the concrete monad. It needs to be used as little as possible,
  99 -- instead, prefer GargServer, GargServerT, GargServerC.
 100 type GargServerM env err = ReaderT env (ExceptT err IO)
 101
 102 type EnvC env =
 103   ( HasConnectionPool env
 104   , HasRepo env
 105   , HasSettings env
 106   , HasJobEnv env ScraperStatus ScraperStatus
 107   )
 108
 109
 110
 111 -------------------------------------------------------------------
 112 -- | This Type is needed to prepare the function before the GargServer
 113 type GargNoServer' env err m =
 114   ( CmdM           env err m
 115   , HasRepo        env
 116   , HasSettings    env
 117   , HasNodeError       err
 118   )
 119
 120 type GargNoServer t =
 121   forall env err m. GargNoServer' env err m => m t
 122 -------------------------------------------------------------------
 123
 124 data GargError
 125   = GargNodeError    NodeError
 126   | GargTreeError    TreeError
 127   | GargInvalidError Validation
 128   | GargJoseError    Jose.Error
 129   | GargServerError  ServerError
 130   deriving (Show, Typeable)
 131
 132 makePrisms ''GargError
 133
 134 instance ToJSON GargError where
 135   toJSON _ = String "SomeGargErrorPleaseReport"
 136
 137 instance Exception GargError
 138
 139 instance HasNodeError GargError where
 140   _NodeError = _GargNodeError
 141
 142 instance HasInvalidError GargError where
 143   _InvalidError = _GargInvalidError
 144
 145 instance HasTreeError GargError where
 146   _TreeError = _GargTreeError
 147
 148 instance HasServerError GargError where
 149   _ServerError = _GargServerError
 150
 151 instance HasJoseError GargError where
 152   _JoseError = _GargJoseError