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 TemplateHaskell #-}
  14 {-# LANGUAGE MonoLocalBinds  #-}
  15
  16 module Gargantext.API.Prelude
  17   ( module Gargantext.API.Prelude
  18   , HasServerError(..)
  19   , serverError
  20   )
  21   where
  22
  23 import Control.Concurrent (threadDelay)
  24 import Control.Exception (Exception)
  25 import Control.Lens (Prism', (#))
  26 import Control.Lens.TH (makePrisms)
  27 import Control.Monad (mapM_)
  28 import Control.Monad.Except (ExceptT)
  29 import Control.Monad.Reader (ReaderT)
  30 import Control.Monad.Error.Class (MonadError(..))
  31 import Crypto.JOSE.Error as Jose
  32 import Data.Aeson.Types
  33 import qualified Data.Text as Text
  34 import Data.Typeable
  35 import Data.Validity
  36 import Gargantext.API.Admin.Orchestrator.Types
  37 import Gargantext.API.Admin.Types
  38 import Gargantext.Core.NLP (HasNLPServer)
  39 import Gargantext.Core.NodeStory
  40 import Gargantext.Core.Mail.Types (HasMail)
  41 import Gargantext.Core.Types
  42 import Gargantext.Database.Prelude
  43 import Gargantext.Database.Query.Table.Node.Error (NodeError(..), HasNodeError(..))
  44 import Gargantext.Database.Query.Tree
  45 import Gargantext.Prelude
  46 import           Gargantext.Utils.Jobs.Monad (MonadJobStatus(..), JobHandle)
  47 import qualified Gargantext.Utils.Jobs.Monad as Jobs
  48 import Servant
  49 import Servant.Job.Async
  50 import Servant.Job.Core (HasServerError(..), serverError)
  51 import qualified Servant.Job.Types as SJ
  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 type HasJobEnv' env = HasJobEnv env JobLog JobLog
  60
  61 type EnvC env =
  62   ( HasConnectionPool env
  63   , HasSettings       env  -- TODO rename HasDbSettings
  64   , HasJobEnv         env JobLog JobLog
  65   , HasConfig         env
  66   , HasNodeStoryEnv   env
  67   , HasMail           env
  68   , HasNLPServer      env
  69   )
  70
  71 type ErrC err =
  72   ( HasNodeError     err
  73   , HasInvalidError  err
  74   , HasTreeError     err
  75   , HasServerError   err
  76   , HasJoseError     err
  77 --  , ToJSON           err -- TODO this is arguable
  78   , Exception        err
  79   )
  80
  81 type GargServerC env err m =
  82   ( CmdRandom    env err m
  83   , HasNodeStory env err m
  84   , EnvC         env
  85   , ErrC             err
  86   , ToJSON           err
  87   )
  88
  89 type GargServerT env err m api = GargServerC env err m => ServerT api m
  90
  91 type GargServer api = forall env err m. GargServerT env err m api
  92
  93 -- This is the concrete monad. It needs to be used as little as possible.
  94 type GargM env err = ReaderT env (ExceptT err IO)
  95 -- This is the server type using GargM. It needs to be used as little as possible.
  96 -- Instead, prefer GargServer, GargServerT.
  97 type GargServerM env err api = (EnvC env, ErrC err) => ServerT api (GargM env err)
  98
  99 -------------------------------------------------------------------
 100 -- | This Type is needed to prepare the function before the GargServer
 101 type GargNoServer t =
 102   forall env err m. GargNoServer' env err m => m t
 103
 104 type GargNoServer' env err m =
 105   ( CmdM           env err m
 106   , HasNodeStory   env err m
 107   , HasSettings    env
 108   , HasNodeError       err
 109   )
 110
 111 -------------------------------------------------------------------
 112 data GargError
 113   = GargNodeError    NodeError
 114   | GargTreeError    TreeError
 115   | GargInvalidError Validation
 116   | GargJoseError    Jose.Error
 117   | GargServerError  ServerError
 118   | GargJobError     Jobs.JobError
 119   deriving (Show, Typeable)
 120
 121 makePrisms ''GargError
 122
 123 instance ToJSON GargError where
 124   toJSON (GargJobError s) =
 125     object [ ("status", toJSON SJ.IsFailure)
 126            , ("log", emptyArray)
 127            , ("id", String id)
 128            , ("error", String $ Text.pack $ show s) ]
 129     where
 130       id = case s of
 131         Jobs.InvalidMacID i -> i
 132         _ -> ""
 133   toJSON err = object [("error", String $ Text.pack $ show err)]
 134
 135 instance Exception GargError
 136
 137 instance HasNodeError GargError where
 138   _NodeError = _GargNodeError
 139
 140 instance HasInvalidError GargError where
 141   _InvalidError = _GargInvalidError
 142
 143 instance HasTreeError GargError where
 144   _TreeError = _GargTreeError
 145
 146 instance HasServerError GargError where
 147   _ServerError = _GargServerError
 148
 149 instance HasJoseError GargError where
 150   _JoseError = _GargJoseError
 151
 152 ------------------------------------------------------------------------
 153 -- | Utils
 154 -- | Simulate logs
 155 simuLogs  :: (MonadBase IO m, MonadJobStatus m) => JobHandle m -> Int -> m ()
 156 simuLogs jobHandle t = do
 157   markStarted t jobHandle
 158   mapM_ (const simuTask) $ take t ([0,1..] :: [Int])
 159   markComplete jobHandle
 160   where
 161     simuTask = do
 162       let m = (10 :: Int) ^ (6 :: Int)
 163       liftBase $ threadDelay (m*5)
 164       markProgress 1 jobHandle