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 FunctionalDependencies #-}
  14 {-# LANGUAGE TemplateHaskell        #-}
  15 {-# LANGUAGE TypeOperators          #-}
  16 {-# LANGUAGE UndecidableInstances   #-}
  17
  18 module Gargantext.API.Prelude
  19   ( module Gargantext.API.Prelude
  20   , HasServerError(..)
  21   , serverError
  22   )
  23   where
  24
  25 import Control.Concurrent (threadDelay)
  26 import Control.Exception (Exception)
  27 import Control.Lens (Prism', (#))
  28 import Control.Lens.TH (makePrisms)
  29 import Control.Monad.Error.Class (MonadError(throwError))
  30 import Control.Monad.Except (ExceptT)
  31 import Control.Monad.Reader (ReaderT)
  32 import Crypto.JOSE.Error as Jose
  33 import Data.Aeson.Types
  34 import Data.Typeable
  35 import Data.Validity
  36 import Servant
  37 import Servant.Job.Async
  38 import Servant.Job.Core (HasServerError(..), serverError)
  39
  40 import Gargantext.API.Admin.Orchestrator.Types
  41 import Gargantext.API.Admin.Settings
  42 import Gargantext.API.Ngrams
  43 import Gargantext.Core.Types
  44 import Gargantext.Database.Prelude
  45 import Gargantext.Database.Query.Table.Node.Error (NodeError(..), HasNodeError(..))
  46 import Gargantext.Database.Query.Tree
  47 import Gargantext.Prelude
  48
  49 class HasJoseError e where
  50   _JoseError :: Prism' e Jose.Error
  51
  52 joseError :: (MonadError e m, HasJoseError e) => Jose.Error -> m a
  53 joseError = throwError . (_JoseError #)
  54
  55 class ThrowAll' e a | a -> e where
  56   -- | 'throwAll' is a convenience function to throw errors across an entire
  57   -- sub-API
  58   --
  59   --
  60   -- > throwAll err400 :: Handler a :<|> Handler b :<|> Handler c
  61   -- >    == throwError err400 :<|> throwError err400 :<|> err400
  62   throwAll' :: e -> a
  63
  64 instance (ThrowAll' e a, ThrowAll' e b) => ThrowAll' e (a :<|> b) where
  65   throwAll' e = throwAll' e :<|> throwAll' e
  66
  67 -- Really this shouldn't be necessary - ((->) a) should be an instance of
  68 -- MonadError, no?
  69 instance {-# OVERLAPPING #-} ThrowAll' e b => ThrowAll' e (a -> b) where
  70   throwAll' e = const $ throwAll' e
  71
  72 instance {-# OVERLAPPABLE #-} (MonadError e m) => ThrowAll' e (m a) where
  73   throwAll' = throwError
  74
  75 type GargServerC env err m =
  76     ( CmdM         env err m
  77     , HasNodeError     err
  78     , HasInvalidError  err
  79     , HasTreeError     err
  80     , HasServerError   err
  81     , HasJoseError     err
  82     , ToJSON           err -- TODO this is arguable
  83     , Exception        err
  84     , HasRepo      env
  85     , HasSettings  env
  86     , HasJobEnv    env JobLog JobLog
  87     , HasConfig    env
  88     )
  89
  90 type GargServerT env err m api = GargServerC env err m => ServerT api m
  91
  92 type GargServer api =
  93   forall env err m. GargServerT env err m api
  94
  95 -- This is the concrete monad. It needs to be used as little as possible,
  96 -- instead, prefer GargServer, GargServerT, GargServerC.
  97 type GargServerM env err = ReaderT env (ExceptT err IO)
  98
  99 type EnvC env =
 100   ( HasConnectionPool env
 101   , HasRepo           env
 102   , HasSettings       env
 103   , HasJobEnv         env JobLog JobLog
 104   , HasConfig         env
 105   )
 106
 107 -------------------------------------------------------------------
 108 runCmdReplEasy :: Cmd' DevEnv GargError a -> IO a
 109 runCmdReplEasy f = withDevEnv "gargantext.ini" $ \env -> runCmdDev env f
 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
 153
 154
 155 ------------------------------------------------------------------------
 156 -- | Utils
 157 -- | Simulate logs
 158 simuLogs  :: MonadBase IO m
 159          => (JobLog -> m ())
 160          -> Int
 161          -> m JobLog
 162 simuLogs logStatus t = do
 163   _ <- mapM (\n -> simuTask logStatus n t) $ take t [0,1..]
 164   pure $ JobLog { _scst_succeeded = Just t
 165                 , _scst_failed    = Just 0
 166                 , _scst_remaining = Just 0
 167                 , _scst_events    = Just []
 168                 }
 169
 170 simuTask :: MonadBase IO m
 171           => (JobLog -> m ())
 172           -> Int
 173           -> Int
 174           -> m ()
 175 simuTask logStatus cur total = do
 176   let m = (10 :: Int) ^ (6 :: Int)
 177   liftBase $ threadDelay (m*5)
 178
 179   let status =  JobLog { _scst_succeeded = Just cur
 180                        , _scst_failed    = Just 0
 181                        , _scst_remaining = (-) <$> Just total <*> Just cur
 182                        , _scst_events    = Just []
 183                        }
 184   printDebug "status" status
 185   logStatus status