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