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