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