]> Git — Sourcephile - gargantext.git/blob - src/Gargantext/API/Prelude.hs
Merge branch 'dev' into 86-dev-graphql
[gargantext.git] / 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.Error.Class (MonadError(..))
28 import Control.Monad.Except (ExceptT)
29 import Control.Monad.Reader (ReaderT)
30 import Crypto.JOSE.Error as Jose
31 import Data.Aeson.Types
32 import Data.Typeable
33 import Data.Validity
34 import Gargantext.API.Admin.Orchestrator.Types
35 import Gargantext.API.Admin.Types
36 import Gargantext.Core.NodeStory
37 import Gargantext.Core.Types
38 import Gargantext.Database.Prelude
39 import Gargantext.Database.Query.Table.Node.Error (NodeError(..), HasNodeError(..))
40 import Gargantext.Database.Query.Tree
41 import Gargantext.Prelude
42 import Servant
43 import Servant.Job.Async
44 import Servant.Job.Core (HasServerError(..), serverError)
45
46 class HasJoseError e where
47 _JoseError :: Prism' e Jose.Error
48
49 joseError :: (MonadError e m, HasJoseError e) => Jose.Error -> m a
50 joseError = throwError . (_JoseError #)
51
52 type EnvC env =
53 ( HasConnectionPool env
54 , HasSettings env -- TODO rename HasDbSettings
55 , HasJobEnv env JobLog JobLog
56 , HasConfig env
57 , HasNodeStoryEnv env
58 )
59
60 type ErrC err =
61 ( HasNodeError err
62 , HasInvalidError err
63 , HasTreeError err
64 , HasServerError err
65 , HasJoseError err
66 , ToJSON err -- TODO this is arguable
67 , Exception err
68 )
69
70 type GargServerC env err m =
71 ( CmdRandom env err m
72 , HasNodeStory env err m
73 , EnvC env
74 , ErrC err
75 , MimeRender JSON err
76 )
77
78 type GargServerT env err m api = GargServerC env err m => ServerT api m
79
80 type GargServer api = forall env err m. GargServerT env err m api
81
82 -- This is the concrete monad. It needs to be used as little as possible.
83 type GargM env err = ReaderT env (ExceptT err IO)
84 -- This is the server type using GargM. It needs to be used as little as possible.
85 -- Instead, prefer GargServer, GargServerT.
86 type GargServerM env err api = (EnvC env, ErrC err) => ServerT api (GargM env err)
87
88 -------------------------------------------------------------------
89 -- | This Type is needed to prepare the function before the GargServer
90 type GargNoServer t =
91 forall env err m. GargNoServer' env err m => m t
92
93 type GargNoServer' env err m =
94 ( CmdM env err m
95 , HasNodeStory env err m
96 , HasSettings env
97 , HasNodeError err
98 )
99
100 -------------------------------------------------------------------
101
102 data GargError
103 = GargNodeError NodeError
104 | GargTreeError TreeError
105 | GargInvalidError Validation
106 | GargJoseError Jose.Error
107 | GargServerError ServerError
108 deriving (Show, Typeable)
109
110 makePrisms ''GargError
111
112 instance ToJSON GargError where
113 toJSON _ = String "SomeGargErrorPleaseReport"
114
115 instance Exception GargError
116
117 instance HasNodeError GargError where
118 _NodeError = _GargNodeError
119
120 instance HasInvalidError GargError where
121 _InvalidError = _GargInvalidError
122
123 instance HasTreeError GargError where
124 _TreeError = _GargTreeError
125
126 instance HasServerError GargError where
127 _ServerError = _GargServerError
128
129 instance HasJoseError GargError where
130 _JoseError = _GargJoseError
131
132
133 ------------------------------------------------------------------------
134 -- | Utils
135 -- | Simulate logs
136 simuLogs :: MonadBase IO m
137 => (JobLog -> m ())
138 -> Int
139 -> m JobLog
140 simuLogs logStatus t = do
141 _ <- mapM (\n -> simuTask logStatus n t) $ take t [0,1..]
142 pure $ JobLog { _scst_succeeded = Just t
143 , _scst_failed = Just 0
144 , _scst_remaining = Just 0
145 , _scst_events = Just []
146 }
147
148 simuTask :: MonadBase IO m
149 => (JobLog -> m ())
150 -> Int
151 -> Int
152 -> m ()
153 simuTask logStatus cur total = do
154 let m = (10 :: Int) ^ (6 :: Int)
155 liftBase $ threadDelay (m*5)
156
157 let status = JobLog { _scst_succeeded = Just cur
158 , _scst_failed = Just 0
159 , _scst_remaining = (-) <$> Just total <*> Just cur
160 , _scst_events = Just []
161 }
162 printDebug "status" status
163 logStatus status