]> Git — Sourcephile - gargantext.git/blob - src/Gargantext/API.hs
[FIX] merge
[gargantext.git] / src / Gargantext / API.hs
1 {-|
2 Module : Gargantext.API
3 Description : REST API declaration
4 Copyright : (c) CNRS, 2017-Present
5 License : AGPL + CECILL v3
6 Maintainer : team@gargantext.org
7 Stability : experimental
8 Portability : POSIX
9
10 Main (RESTful) API of the instance Gargantext.
11
12 The Garg-API is typed to derive the documentation, the mock and tests.
13
14 This API is indeed typed in order to be able to derive both the server
15 and the client sides.
16
17 The Garg-API-Monad enables:
18 - Security (WIP)
19 - Features (WIP)
20 - Database connection (long term)
21 - In Memory stack management (short term)
22 - Logs (WIP)
23
24 Thanks to Yann Esposito for our discussions at the start and to Nicolas
25 Pouillard (who mainly made it).
26
27 -}
28
29 {-# OPTIONS_GHC -fno-warn-name-shadowing #-}
30
31 {-# LANGUAGE ConstraintKinds #-}
32 {-# LANGUAGE NoImplicitPrelude #-}
33 {-# LANGUAGE DataKinds #-}
34 {-# LANGUAGE DeriveGeneric #-}
35 {-# LANGUAGE FlexibleContexts #-}
36 {-# LANGUAGE FlexibleInstances #-}
37 {-# LANGUAGE OverloadedStrings #-}
38 {-# LANGUAGE TemplateHaskell #-}
39 {-# LANGUAGE TypeOperators #-}
40 {-# LANGUAGE KindSignatures #-}
41 {-# LANGUAGE RankNTypes #-}
42 {-# LANGUAGE ScopedTypeVariables #-}
43 {-# LANGUAGE TypeFamilies #-}
44 {-# LANGUAGE UndecidableInstances #-}
45
46 ---------------------------------------------------------------------
47 module Gargantext.API
48 where
49 ---------------------------------------------------------------------
50
51 import System.IO (FilePath)
52
53 import GHC.Generics (D1, Meta (..), Rep)
54 import GHC.TypeLits (AppendSymbol, Symbol)
55
56 import Control.Lens
57 import Control.Exception (finally)
58 import Control.Monad.Except (withExceptT, ExceptT)
59 import Control.Monad.IO.Class (liftIO)
60 import Control.Monad.Reader (ReaderT, runReaderT)
61 import Data.Aeson.Encode.Pretty (encodePretty)
62 import qualified Data.ByteString.Lazy.Char8 as BL8
63 import Data.Swagger
64 import Data.Text (Text)
65 import qualified Data.Text.IO as T
66 --import qualified Data.Set as Set
67 import Data.Validity
68
69 import Network.Wai
70 import Network.Wai.Handler.Warp hiding (defaultSettings)
71
72 import Servant
73 import Servant.Auth as SA
74 import Servant.Auth.Server (AuthResult(..))
75 import Servant.Auth.Swagger ()
76 --import Servant.Mock (mock)
77 --import Servant.Job.Server (WithCallbacks)
78 import Servant.Job.Async
79 import Servant.Swagger
80 import Servant.Swagger.UI
81 -- import Servant.API.Stream
82
83 --import Gargantext.API.Swagger
84
85 import Gargantext.Database.Node.Contact (HyperdataContact)
86 import Gargantext.API.Auth (AuthRequest, AuthResponse, AuthenticatedUser(..), AuthContext, auth, withAccess, PathId(..))
87 import Gargantext.API.Count ( CountAPI, count, Query)
88 import Gargantext.API.FrontEnd (FrontEndAPI, frontEndServer)
89 import Gargantext.API.Ngrams (HasRepo(..), HasRepoSaver(..), saveRepo, TableNgramsApi, apiNgramsTableDoc)
90 import Gargantext.API.Node
91 import Gargantext.API.Search (SearchPairsAPI, searchPairs)
92 import Gargantext.API.Types
93 import qualified Gargantext.API.Annuaire as Annuaire
94 import qualified Gargantext.API.Export as Export
95 import qualified Gargantext.API.Corpus.New as New
96 import Gargantext.Database.Types.Node
97 import Gargantext.Database.Types.Node (NodeId, CorpusId, AnnuaireId)
98 import Gargantext.Database.Utils (HasConnection)
99 import Gargantext.Prelude
100 import Gargantext.Viz.Graph.API
101
102 --import Gargantext.API.Orchestrator
103 import Gargantext.API.Orchestrator.Types
104
105 ---------------------------------------------------------------------
106
107 import GHC.Base (Applicative)
108 -- import Control.Lens
109
110 import Data.List (lookup)
111 import Data.Text.Encoding (encodeUtf8)
112
113 --import Network.Wai (Request, requestHeaders, responseLBS)
114 import Network.Wai (Request, requestHeaders)
115 --import qualified Network.Wai.Handler.Warp as Warp
116 import Network.Wai.Middleware.Cors
117
118 import Network.Wai.Middleware.RequestLogger
119 -- import qualified Network.Wai.Middleware.RequestLogger as RequestLogger
120
121 import Network.HTTP.Types hiding (Query)
122
123 import Gargantext.API.Settings
124
125 showAsServantErr :: GargError -> ServerError
126 showAsServantErr (GargServerError err) = err
127 showAsServantErr a = err500 { errBody = BL8.pack $ show a }
128
129 fireWall :: Applicative f => Request -> FireWall -> f Bool
130 fireWall req fw = do
131 let origin = lookup "Origin" (requestHeaders req)
132 let host = lookup "Host" (requestHeaders req)
133
134 let hostOk = Just (encodeUtf8 "localhost:3000")
135 let originOk = Just (encodeUtf8 "http://localhost:8008")
136
137 if origin == originOk
138 && host == hostOk
139 || (not $ unFireWall fw)
140
141 then pure True
142 else pure False
143
144 {-
145 -- makeMockApp :: Env -> IO (Warp.Settings, Application)
146 makeMockApp :: MockEnv -> IO Application
147 makeMockApp env = do
148 let serverApp = appMock
149
150 -- logWare <- mkRequestLogger def { destination = RequestLogger.Logger $ env^.logger }
151 --logWare <- mkRequestLogger def { destination = RequestLogger.Logger "/tmp/logs.txt" }
152 let checkOriginAndHost app req resp = do
153 blocking <- fireWall req (env ^. menv_firewall)
154 case blocking of
155 True -> app req resp
156 False -> resp ( responseLBS status401 []
157 "Invalid Origin or Host header")
158
159 let corsMiddleware = cors $ \_ -> Just CorsResourcePolicy
160 -- { corsOrigins = Just ([env^.settings.allowedOrigin], False)
161 { corsOrigins = Nothing -- == /*
162 , corsMethods = [ methodGet , methodPost , methodPut
163 , methodDelete, methodOptions, methodHead]
164 , corsRequestHeaders = ["authorization", "content-type"]
165 , corsExposedHeaders = Nothing
166 , corsMaxAge = Just ( 60*60*24 ) -- one day
167 , corsVaryOrigin = False
168 , corsRequireOrigin = False
169 , corsIgnoreFailures = False
170 }
171
172 --let warpS = Warp.setPort (8008 :: Int) -- (env^.settings.appPort)
173 -- $ Warp.defaultSettings
174
175 --pure (warpS, logWare $ checkOriginAndHost $ corsMiddleware $ serverApp)
176 pure $ logStdoutDev $ checkOriginAndHost $ corsMiddleware $ serverApp
177 -}
178
179
180 makeDevMiddleware :: IO Middleware
181 makeDevMiddleware = do
182
183 -- logWare <- mkRequestLogger def { destination = RequestLogger.Logger $ env^.logger }
184 --logWare <- mkRequestLogger def { destination = RequestLogger.Logger "/tmp/logs.txt" }
185 -- let checkOriginAndHost app req resp = do
186 -- blocking <- fireWall req (env ^. menv_firewall)
187 -- case blocking of
188 -- True -> app req resp
189 -- False -> resp ( responseLBS status401 []
190 -- "Invalid Origin or Host header")
191 --
192 let corsMiddleware = cors $ \_ -> Just CorsResourcePolicy
193 -- { corsOrigins = Just ([env^.settings.allowedOrigin], False)
194 { corsOrigins = Nothing -- == /*
195 , corsMethods = [ methodGet , methodPost , methodPut
196 , methodDelete, methodOptions, methodHead]
197 , corsRequestHeaders = ["authorization", "content-type"]
198 , corsExposedHeaders = Nothing
199 , corsMaxAge = Just ( 60*60*24 ) -- one day
200 , corsVaryOrigin = False
201 , corsRequireOrigin = False
202 , corsIgnoreFailures = False
203 }
204
205 --let warpS = Warp.setPort (8008 :: Int) -- (env^.settings.appPort)
206 -- $ Warp.defaultSettings
207
208 --pure (warpS, logWare . checkOriginAndHost . corsMiddleware)
209 pure $ logStdoutDev . corsMiddleware
210
211 ---------------------------------------------------------------------
212 -- | API Global
213
214 -- | API for serving @swagger.json@
215 type SwaggerAPI = SwaggerSchemaUI "swagger-ui" "swagger.json"
216
217 -- | API for serving main operational routes of @gargantext.org@
218
219
220 type GargAPI = "api" :> Summary "API " :> GargAPIVersion
221 -- | TODO :<|> Summary "Latest API" :> GargAPI'
222
223
224 type GargAPIVersion = "v1.0" :> Summary "v1.0: " :> GargAPI'
225
226 type GargAPI' =
227 -- Auth endpoint
228 "auth" :> Summary "AUTH API"
229 :> ReqBody '[JSON] AuthRequest
230 :> Post '[JSON] AuthResponse
231 -- TODO-ACCESS here we want to request a particular header for
232 -- auth and capabilities.
233 :<|> GargPrivateAPI
234
235 type GargPrivateAPI = SA.Auth '[SA.JWT] AuthenticatedUser :> GargPrivateAPI'
236
237 type GargAdminAPI
238 -- Roots endpoint
239 = "user" :> Summary "First user endpoint"
240 :> Roots
241 :<|> "nodes" :> Summary "Nodes endpoint"
242 :> ReqBody '[JSON] [NodeId] :> NodesAPI
243
244 type GargPrivateAPI' =
245 GargAdminAPI
246
247 -- Node endpoint
248 :<|> "node" :> Summary "Node endpoint"
249 :> Capture "node_id" NodeId
250 :> NodeAPI HyperdataAny
251
252 -- Corpus endpoint
253 :<|> "corpus":> Summary "Corpus endpoint"
254 :> Capture "corpus_id" CorpusId
255 :> NodeAPI HyperdataCorpus
256
257 :<|> "corpus":> Summary "Corpus endpoint"
258 :> Capture "node1_id" NodeId
259 :> "document"
260 :> Capture "node2_id" NodeId
261 :> NodeNodeAPI HyperdataAny
262
263 :<|> "corpus" :> Capture "node_id" CorpusId
264 :> Export.API
265
266 -- Annuaire endpoint
267 :<|> "annuaire":> Summary "Annuaire endpoint"
268 :> Capture "annuaire_id" AnnuaireId
269 :> NodeAPI HyperdataAnnuaire
270
271 :<|> "annuaire" :> Summary "Contact endpoint"
272 :> Capture "annuaire_id" NodeId
273 :> "contact" :> Capture "contact_id" NodeId
274 :> NodeNodeAPI HyperdataContact
275
276 -- Document endpoint
277 :<|> "document":> Summary "Document endpoint"
278 :> Capture "doc_id" DocId
279 :> "ngrams" :> TableNgramsApi
280
281 -- :<|> "counts" :> Stream GET NewLineFraming '[JSON] Count :> CountAPI
282 -- TODO-SECURITY
283 :<|> "count" :> Summary "Count endpoint"
284 :> ReqBody '[JSON] Query :> CountAPI
285
286 -- Corpus endpoint --> TODO rename s/search/filter/g
287 :<|> "search":> Capture "corpus" NodeId
288 :> SearchPairsAPI
289
290 -- TODO move to NodeAPI?
291 :<|> "graph" :> Summary "Graph endpoint"
292 :> Capture "graph_id" NodeId
293 :> GraphAPI
294
295 -- TODO move to NodeAPI?
296 -- Tree endpoint
297 :<|> "tree" :> Summary "Tree endpoint"
298 :> Capture "tree_id" NodeId
299 :> TreeAPI
300
301 -- :<|> New.Upload
302 :<|> New.AddWithForm
303 :<|> New.AddWithQuery
304
305 :<|> Annuaire.AddWithForm
306 -- :<|> New.AddWithFile
307 -- :<|> "scraper" :> WithCallbacks ScraperAPI
308 -- :<|> "new" :> New.Api
309
310 -- /mv/<id>/<id>
311 -- /merge/<id>/<id>
312 -- /rename/<id>
313 -- :<|> "static"
314 -- :<|> "list" :> Capture "node_id" Int :> NodeAPI
315 -- :<|> "ngrams" :> Capture "node_id" Int :> NodeAPI
316 -- :<|> "auth" :> Capture "node_id" Int :> NodeAPI
317 ---------------------------------------------------------------------
318
319 type API = SwaggerAPI
320 :<|> GargAPI
321 :<|> FrontEndAPI
322
323 -- This is the concrete monad. It needs to be used as little as possible,
324 -- instead, prefer GargServer, GargServerT, GargServerC.
325 type GargServerM env err = ReaderT env (ExceptT err IO)
326
327 type EnvC env =
328 ( HasConnection env
329 , HasRepo env
330 , HasSettings env
331 , HasJobEnv env ScraperStatus ScraperStatus
332 )
333
334 ---------------------------------------------------------------------
335 -- | Server declarations
336
337 server :: forall env. EnvC env => env -> IO (Server API)
338 server env = do
339 -- orchestrator <- scrapyOrchestrator env
340 pure $ schemaUiServer swaggerDoc
341 :<|> hoistServerWithContext (Proxy :: Proxy GargAPI) (Proxy :: Proxy AuthContext) transform serverGargAPI
342 :<|> frontEndServer
343 where
344 transform :: forall a. GargServerM env GargError a -> Handler a
345 transform = Handler . withExceptT showAsServantErr . (`runReaderT` env)
346
347 serverGargAPI :: GargServerT env err (GargServerM env err) GargAPI
348 serverGargAPI -- orchestrator
349 = auth :<|> serverPrivateGargAPI
350 -- :<|> orchestrator
351
352 serverPrivateGargAPI :: GargServerT env err (GargServerM env err) GargPrivateAPI
353 serverPrivateGargAPI (Authenticated auser) = serverPrivateGargAPI' auser
354 serverPrivateGargAPI _ = throwAll' (_ServerError # err401)
355 -- Here throwAll' requires a concrete type for the monad.
356
357 -- TODO-SECURITY admin only: withAdmin
358 -- Question: How do we mark admins?
359 serverGargAdminAPI :: GargServer GargAdminAPI
360 serverGargAdminAPI
361 = roots
362 :<|> nodesAPI
363
364 serverPrivateGargAPI' :: AuthenticatedUser -> GargServer GargPrivateAPI'
365 serverPrivateGargAPI' (AuthenticatedUser (NodeId uid))
366 = serverGargAdminAPI
367 :<|> nodeAPI (Proxy :: Proxy HyperdataAny) uid
368 :<|> nodeAPI (Proxy :: Proxy HyperdataCorpus) uid
369 :<|> nodeNodeAPI (Proxy :: Proxy HyperdataAny) uid
370 :<|> Export.getCorpus -- uid
371 :<|> nodeAPI (Proxy :: Proxy HyperdataAnnuaire) uid
372 :<|> nodeNodeAPI (Proxy :: Proxy HyperdataContact) uid
373
374 :<|> withAccess (Proxy :: Proxy TableNgramsApi) Proxy uid
375 <$> PathNode <*> apiNgramsTableDoc
376
377 :<|> count -- TODO: undefined
378
379 :<|> withAccess (Proxy :: Proxy SearchPairsAPI) Proxy uid
380 <$> PathNode <*> searchPairs -- TODO: move elsewhere
381
382 :<|> withAccess (Proxy :: Proxy GraphAPI) Proxy uid
383 <$> PathNode <*> graphAPI uid -- TODO: mock
384
385 :<|> withAccess (Proxy :: Proxy TreeAPI) Proxy uid
386 <$> PathNode <*> treeAPI
387 -- TODO access
388 -- :<|> addUpload
389 -- :<|> (\corpus -> addWithQuery corpus :<|> addWithFile corpus)
390 :<|> addCorpusWithForm
391 :<|> addCorpusWithQuery
392
393 :<|> addAnnuaireWithForm
394 -- :<|> New.api uid -- TODO-SECURITY
395 -- :<|> New.info uid -- TODO-SECURITY
396
397 {-
398 addUpload :: GargServer New.Upload
399 addUpload cId = (serveJobsAPI $ JobFunction (\i log -> New.addToCorpusJobFunction cid i (liftIO . log)))
400 :<|> (serveJobsAPI $ JobFunction (\i log -> New.addToCorpusWithForm cid i (liftIO . log)))
401 --}
402
403 addCorpusWithQuery :: GargServer New.AddWithQuery
404 addCorpusWithQuery cid =
405 serveJobsAPI $
406 JobFunction (\i log -> New.addToCorpusJobFunction cid i (liftIO . log))
407
408 addWithFile :: GargServer New.AddWithFile
409 addWithFile cid i f =
410 serveJobsAPI $
411 JobFunction (\_i log -> New.addToCorpusWithFile cid i f (liftIO . log))
412
413 addCorpusWithForm :: GargServer New.AddWithForm
414 addCorpusWithForm cid =
415 serveJobsAPI $
416 JobFunction (\i log -> New.addToCorpusWithForm cid i (liftIO . log))
417
418 addAnnuaireWithForm :: GargServer Annuaire.AddWithForm
419 addAnnuaireWithForm cid =
420 serveJobsAPI $
421 JobFunction (\i log -> Annuaire.addToAnnuaireWithForm cid i (liftIO . log))
422
423 {-
424 serverStatic :: Server (Get '[HTML] Html)
425 serverStatic = $(do
426 let path = "purescript-gargantext/dist/index.html"
427 Just s <- liftIO (fileTypeToFileTree (FileTypeFile path))
428 fileTreeToServer s
429 )
430 -}
431 ---------------------------------------------------------------------
432 --gargMock :: Server GargAPI
433 --gargMock = mock apiGarg Proxy
434 ---------------------------------------------------------------------
435 makeApp :: EnvC env => env -> IO Application
436 makeApp env = serveWithContext api cfg <$> server env
437 where
438 cfg :: Servant.Context AuthContext
439 cfg = env ^. settings . jwtSettings
440 :. env ^. settings . cookieSettings
441 -- :. authCheck env
442 :. EmptyContext
443
444 --appMock :: Application
445 --appMock = serve api (swaggerFront :<|> gargMock :<|> serverStatic)
446 ---------------------------------------------------------------------
447 api :: Proxy API
448 api = Proxy
449
450 apiGarg :: Proxy GargAPI
451 apiGarg = Proxy
452 ---------------------------------------------------------------------
453 schemaUiServer :: (Server api ~ Handler Swagger)
454 => Swagger -> Server (SwaggerSchemaUI' dir api)
455 schemaUiServer = swaggerSchemaUIServer
456
457 -- Type Family for the Documentation
458 type family TypeName (x :: *) :: Symbol where
459 TypeName Int = "Int"
460 TypeName Text = "Text"
461 TypeName x = GenericTypeName x (Rep x ())
462
463 type family GenericTypeName t (r :: *) :: Symbol where
464 GenericTypeName t (D1 ('MetaData name mod pkg nt) f x) = name
465
466 type Desc t n = Description (AppendSymbol (TypeName t) (AppendSymbol " | " n))
467
468
469 -- | Swagger Specifications
470 swaggerDoc :: Swagger
471 swaggerDoc = toSwagger (Proxy :: Proxy GargAPI)
472 & info.title .~ "Gargantext"
473 & info.version .~ "4.0.2" -- TODO same version as Gargantext
474 -- & info.base_url ?~ (URL "http://gargantext.org/")
475 & info.description ?~ "REST API specifications"
476 -- & tags .~ Set.fromList [Tag "Garg" (Just "Main perations") Nothing]
477 & applyTagsFor (subOperations (Proxy :: Proxy GargAPI)(Proxy :: Proxy GargAPI))
478 ["Gargantext" & description ?~ "Main operations"]
479 & info.license ?~ ("AGPLV3 (English) and CECILL (French)" & url ?~ URL urlLicence )
480 where
481 urlLicence = "https://gitlab.iscpif.fr/gargantext/haskell-gargantext/blob/master/LICENSE"
482
483 -- | Output generated @swagger.json@ file for the @'TodoAPI'@.
484 swaggerWriteJSON :: IO ()
485 swaggerWriteJSON = BL8.writeFile "swagger.json" (encodePretty swaggerDoc)
486
487 portRouteInfo :: PortNumber -> IO ()
488 portRouteInfo port = do
489 T.putStrLn " ----Main Routes----- "
490 T.putStrLn $ "http://localhost:" <> toUrlPiece port <> "/index.html"
491 T.putStrLn $ "http://localhost:" <> toUrlPiece port <> "/swagger-ui"
492
493 stopGargantext :: HasRepoSaver env => env -> IO ()
494 stopGargantext env = do
495 T.putStrLn "----- Stopping gargantext -----"
496 runReaderT saveRepo env
497
498 -- | startGargantext takes as parameters port number and Ini file.
499 startGargantext :: PortNumber -> FilePath -> IO ()
500 startGargantext port file = do
501 env <- newEnv port file
502 portRouteInfo port
503 app <- makeApp env
504 mid <- makeDevMiddleware
505 run port (mid app) `finally` stopGargantext env
506
507 {-
508 startGargantextMock :: PortNumber -> IO ()
509 startGargantextMock port = do
510 portRouteInfo port
511 application <- makeMockApp . MockEnv $ FireWall False
512 run port application
513 -}