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 Gargantext.API.Admin.Orchestrator.Types
  37 import Gargantext.API.Admin.Settings
  38 import Gargantext.API.Ngrams
  39 import Gargantext.Core.Types
  40 import Gargantext.Database.Prelude
  41 import Gargantext.Database.Query.Table.Node.Error (NodeError(..), HasNodeError(..))
  42 import Gargantext.Database.Query.Tree
  43 import Gargantext.Prelude
  44 import Servant
  45 import Servant.Job.Async (HasJobEnv)
  46 import Servant.Job.Core (HasServerError(..), serverError)
  47
  48 class HasJoseError e where
  49   _JoseError :: Prism' e Jose.Error
  50
  51 joseError :: (MonadError e m, HasJoseError e) => Jose.Error -> m a
  52 joseError = throwError . (_JoseError #)
  53
  54 class ThrowAll' e a | a -> e where
  55   -- | 'throwAll' is a convenience function to throw errors across an entire
  56   -- sub-API
  57   --
  58   --
  59   -- > throwAll err400 :: Handler a :<|> Handler b :<|> Handler c
  60   -- >    == throwError err400 :<|> throwError err400 :<|> err400
  61   throwAll' :: e -> a
  62
  63 instance (ThrowAll' e a, ThrowAll' e b) => ThrowAll' e (a :<|> b) where
  64   throwAll' e = throwAll' e :<|> throwAll' e
  65
  66 -- Really this shouldn't be necessary - ((->) a) should be an instance of
  67 -- MonadError, no?
  68 instance {-# OVERLAPPING #-} ThrowAll' e b => ThrowAll' e (a -> b) where
  69   throwAll' e = const $ throwAll' e
  70
  71 instance {-# OVERLAPPABLE #-} (MonadError e m) => ThrowAll' e (m a) where
  72   throwAll' = throwError
  73
  74 type GargServerC env err m =
  75     ( CmdM         env err m
  76     , HasNodeError     err
  77     , HasInvalidError  err
  78     , HasTreeError     err
  79     , HasServerError   err
  80     , HasJoseError     err
  81     , ToJSON           err -- TODO this is arguable
  82     , Exception        err
  83     , HasRepo      env
  84     , HasSettings  env
  85     , HasJobEnv    env JobLog JobLog
  86     , HasConfig    env
  87     )
  88
  89 type GargServerT env err m api = GargServerC env err m => ServerT api m
  90
  91 type GargServer api =
  92   forall env err m. GargServerT env err m api
  93
  94 -- This is the concrete monad. It needs to be used as little as possible,
  95 -- instead, prefer GargServer, GargServerT, GargServerC.
  96 type GargServerM env err = ReaderT env (ExceptT err IO)
  97
  98 type EnvC env =
  99   ( HasConnectionPool env
 100   , HasRepo           env
 101   , HasSettings       env
 102   , HasJobEnv         env JobLog JobLog
 103   , HasConfig         env
 104   )
 105
 106 -------------------------------------------------------------------
 107 runCmdReplEasy :: Cmd' DevEnv GargError a -> IO a
 108 runCmdReplEasy f = withDevEnv "gargantext.ini" $ \env -> runCmdDev env f
 109
 110 -------------------------------------------------------------------
 111 -- | This Type is needed to prepare the function before the GargServer
 112 type GargNoServer' env err m =
 113   ( CmdM           env err m
 114   , HasRepo        env
 115   , HasSettings    env
 116   , HasNodeError       err
 117   )
 118
 119 type GargNoServer t =
 120   forall env err m. GargNoServer' env err m => m t
 121 -------------------------------------------------------------------
 122
 123 data GargError
 124   = GargNodeError    NodeError
 125   | GargTreeError    TreeError
 126   | GargInvalidError Validation
 127   | GargJoseError    Jose.Error
 128   | GargServerError  ServerError
 129   deriving (Show, Typeable)
 130
 131 makePrisms ''GargError
 132
 133 instance ToJSON GargError where
 134   toJSON _ = String "SomeGargErrorPleaseReport"
 135
 136 instance Exception GargError
 137
 138 instance HasNodeError GargError where
 139   _NodeError = _GargNodeError
 140
 141 instance HasInvalidError GargError where
 142   _InvalidError = _GargInvalidError
 143
 144 instance HasTreeError GargError where
 145   _TreeError = _GargTreeError
 146
 147 instance HasServerError GargError where
 148   _ServerError = _GargServerError
 149
 150 instance HasJoseError GargError where
 151   _JoseError = _GargJoseError
 152
 153
 154 ------------------------------------------------------------------------
 155 -- | Utils
 156 -- | Simulate logs
 157 simuLogs  :: MonadBase IO m
 158          => (JobLog -> m ())
 159          -> Int
 160          -> m JobLog
 161 simuLogs logStatus t = do
 162   _ <- mapM (\n -> simuTask logStatus n t) $ take t [0,1..]
 163   pure $ JobLog { _scst_succeeded = Just t
 164                 , _scst_failed    = Just 0
 165                 , _scst_remaining = Just 0
 166                 , _scst_events    = Just []
 167                 }
 168
 169 simuTask :: MonadBase IO m
 170           => (JobLog -> m ())
 171           -> Int
 172           -> Int
 173           -> m ()
 174 simuTask logStatus cur total = do
 175   let m = (10 :: Int) ^ (6 :: Int)
 176   liftBase $ threadDelay (m*5)
 177
 178   let status =  JobLog { _scst_succeeded = Just cur
 179                        , _scst_failed    = Just 0
 180                        , _scst_remaining = (-) <$> Just total <*> Just cur
 181                        , _scst_events    = Just []
 182                        }
 183   printDebug "status" status
 184   logStatus status