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.IO.Class (liftIO)
  55 import Control.Monad.Reader (ReaderT, runReaderT)
  56 import Data.Aeson.Encode.Pretty (encodePretty)
  57 import Data.Swagger
  58 import Data.Text (Text)
  59 import Data.Validity
  60 import GHC.Generics (D1, Meta (..), Rep)
  61 import GHC.TypeLits (AppendSymbol, Symbol)
  62 import Network.Wai
  63 import Network.Wai.Handler.Warp hiding (defaultSettings)
  64 import Servant
  65 import Servant.Auth as SA
  66 import Servant.Auth.Server (AuthResult(..))
  67 import Servant.Auth.Swagger ()
  68 import Servant.Job.Async
  69 import Servant.Swagger
  70 import Servant.Swagger.UI
  71 import System.IO (FilePath)
  72 import Data.List (lookup)
  73 import Data.Text.Encoding (encodeUtf8)
  74 import GHC.Base (Applicative)
  75 import Gargantext.API.Auth (AuthRequest, AuthResponse, AuthenticatedUser(..), AuthContext, auth, withAccess, PathId(..))
  76 import Gargantext.API.Count  ( CountAPI, count, Query)
  77 import Gargantext.API.FrontEnd (FrontEndAPI, frontEndServer)
  78 import Gargantext.API.Ngrams (HasRepo(..), HasRepoSaver(..), saveRepo, TableNgramsApi, apiNgramsTableDoc)
  79 import Gargantext.API.Node
  80 import Gargantext.API.Orchestrator.Types
  81 import Gargantext.API.Search (SearchPairsAPI, searchPairs)
  82 import Gargantext.API.Settings
  83 import Gargantext.API.Types
  84 import Gargantext.Database.Node.Contact (HyperdataContact)
  85 import Gargantext.Database.Types.Node
  86 import Gargantext.Database.Types.Node (NodeId, CorpusId, AnnuaireId)
  87 import Gargantext.Database.Utils (HasConnection)
  88 import Gargantext.Prelude
  89 import Gargantext.Viz.Graph.API
  90 import Network.HTTP.Types hiding (Query)
  91 import Network.Wai (Request, requestHeaders)
  92 import Network.Wai.Middleware.Cors
  93 import Network.Wai.Middleware.RequestLogger
  94 import qualified Data.ByteString.Lazy.Char8 as BL8
  95 import qualified Data.Text.IO               as T
  96 import qualified Gargantext.API.Annuaire    as Annuaire
  97 import qualified Gargantext.API.Corpus.New  as New
  98 import qualified Gargantext.API.Export      as Export
  99 import qualified Gargantext.API.Ngrams.List as List
 100
 101 showAsServantErr :: GargError -> ServerError
 102 showAsServantErr (GargServerError err) = err
 103 showAsServantErr a = err500 { errBody = BL8.pack $ show a }
 104
 105 fireWall :: Applicative f => Request -> FireWall -> f Bool
 106 fireWall req fw = do
 107     let origin = lookup "Origin" (requestHeaders req)
 108     let host   = lookup "Host"   (requestHeaders req)
 109
 110     let hostOk   = Just (encodeUtf8 "localhost:3000")
 111     let originOk = Just (encodeUtf8 "http://localhost:8008")
 112
 113     if  origin == originOk
 114        && host == hostOk
 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" :> Summary "v1.0: " :> GargAPI'
 201
 202 type GargAPI' =
 203            -- Auth endpoint
 204                 "auth"  :> Summary "AUTH API"
 205                         :> ReqBody '[JSON] AuthRequest
 206                         :> Post    '[JSON] AuthResponse
 207            -- TODO-ACCESS here we want to request a particular header for
 208            -- auth and capabilities.
 209           :<|> GargPrivateAPI
 210
 211 type GargPrivateAPI = SA.Auth '[SA.JWT, SA.Cookie] AuthenticatedUser :> GargPrivateAPI'
 212
 213 type GargAdminAPI
 214               -- Roots endpoint
 215              =  "user"  :> Summary "First user endpoint"
 216                         :> Roots
 217            :<|> "nodes" :> Summary "Nodes endpoint"
 218                         :> ReqBody '[JSON] [NodeId] :> NodesAPI
 219
 220 ----------------------------------------
 221 -- For Tests
 222 type WaitAPI = Get '[JSON] Text
 223
 224 waitAPI ::  Int -> GargServer WaitAPI
 225 waitAPI n = do
 226   let
 227     m = (10 :: Int) ^ (6 :: Int)
 228   _ <- liftIO $ threadDelay ( m * n)
 229   pure $ "Waited: " <> (cs $ show n)
 230 ----------------------------------------
 231
 232
 233 type GargPrivateAPI' =
 234                 GargAdminAPI
 235
 236            -- Node endpoint
 237            :<|> "node"  :> Summary "Node endpoint"
 238                         :> Capture "node_id" NodeId
 239                         :> NodeAPI HyperdataAny
 240
 241            -- Corpus endpoints
 242            :<|> "corpus":> Summary "Corpus endpoint"
 243                         :> Capture "corpus_id" CorpusId
 244                         :> NodeAPI HyperdataCorpus
 245
 246            :<|> "corpus":> Summary "Corpus endpoint"
 247                         :> Capture "node1_id" NodeId
 248                         :> "document"
 249                         :> Capture "node2_id" NodeId
 250                         :> NodeNodeAPI HyperdataAny
 251
 252            :<|> "corpus" :> Capture "node_id" CorpusId
 253                          :> Export.API
 254
 255            -- Annuaire endpoint
 256            :<|> "annuaire":> Summary "Annuaire endpoint"
 257                           :> Capture "annuaire_id" AnnuaireId
 258                           :> NodeAPI HyperdataAnnuaire
 259
 260            :<|> "annuaire" :> Summary "Contact endpoint"
 261                            :> Capture "annuaire_id" NodeId
 262                            :> "contact" :> Capture "contact_id" NodeId
 263                            :> NodeNodeAPI HyperdataContact
 264
 265            -- Document endpoint
 266            :<|> "document":> Summary "Document endpoint"
 267                           :> Capture "doc_id" DocId
 268                           :> "ngrams" :> TableNgramsApi
 269
 270         -- :<|> "counts" :> Stream GET NewLineFraming '[JSON] Count :> CountAPI
 271             -- TODO-SECURITY
 272            :<|> "count" :> Summary "Count endpoint"
 273                         :> ReqBody '[JSON] Query :> CountAPI
 274
 275            -- Corpus endpoint --> TODO rename s/search/filter/g
 276            :<|> "search":> Capture "corpus" NodeId
 277                         :> SearchPairsAPI
 278
 279            -- TODO move to NodeAPI?
 280            :<|> "graph" :> Summary "Graph endpoint"
 281                         :> Capture "graph_id" NodeId
 282                         :> GraphAPI
 283
 284            -- TODO move to NodeAPI?
 285            -- Tree endpoint
 286            :<|> "tree" :> Summary "Tree endpoint"
 287                        :> Capture "tree_id" NodeId
 288                        :> TreeAPI
 289
 290            -- :<|> New.Upload
 291            :<|> New.AddWithForm
 292            :<|> New.AddWithQuery
 293
 294            :<|> Annuaire.AddWithForm
 295            -- :<|> New.AddWithFile
 296        --  :<|> "scraper" :> WithCallbacks ScraperAPI
 297        --  :<|> "new"  :> New.Api
 298
 299            :<|> "lists" :> Summary "List export API"
 300                         :> Capture "listId" ListId
 301                         :> List.API
 302
 303            :<|> "wait" :> Summary "Wait test"
 304                       :> Capture "x" Int
 305                       :> WaitAPI -- Get '[JSON] Int
 306
 307 -- /mv/<id>/<id>
 308 -- /merge/<id>/<id>
 309 -- /rename/<id>
 310        -- :<|> "static"
 311        -- :<|> "list"     :> Capture "node_id" Int  :> NodeAPI
 312        -- :<|> "ngrams"   :> Capture "node_id" Int  :> NodeAPI
 313        -- :<|> "auth"     :> Capture "node_id" Int  :> NodeAPI
 314 ---------------------------------------------------------------------
 315
 316 type API = SwaggerAPI
 317        :<|> GargAPI
 318        :<|> FrontEndAPI
 319
 320 -- This is the concrete monad. It needs to be used as little as possible,
 321 -- instead, prefer GargServer, GargServerT, GargServerC.
 322 type GargServerM env err = ReaderT env (ExceptT err IO)
 323
 324 type EnvC env =
 325   ( HasConnection env
 326   , HasRepo env
 327   , HasSettings env
 328   , HasJobEnv env ScraperStatus ScraperStatus
 329   )
 330
 331 ---------------------------------------------------------------------
 332 -- | Server declarations
 333
 334 server :: forall env. EnvC env => env -> IO (Server API)
 335 server env = do
 336   -- orchestrator <- scrapyOrchestrator env
 337   pure $  schemaUiServer swaggerDoc
 338      :<|> hoistServerWithContext (Proxy :: Proxy GargAPI) (Proxy :: Proxy AuthContext) transform serverGargAPI
 339      :<|> frontEndServer
 340   where
 341     transform :: forall a. GargServerM env GargError a -> Handler a
 342     transform = Handler . withExceptT showAsServantErr . (`runReaderT` env)
 343
 344 serverGargAPI :: GargServerT env err (GargServerM env err) GargAPI
 345 serverGargAPI -- orchestrator
 346        =  auth :<|> serverPrivateGargAPI
 347   --   :<|> orchestrator
 348
 349 serverPrivateGargAPI :: GargServerT env err (GargServerM env err) GargPrivateAPI
 350 serverPrivateGargAPI (Authenticated auser) = serverPrivateGargAPI' auser
 351 serverPrivateGargAPI _                     = throwAll' (_ServerError # err401)
 352 -- Here throwAll' requires a concrete type for the monad.
 353
 354 -- TODO-SECURITY admin only: withAdmin
 355 -- Question: How do we mark admins?
 356 serverGargAdminAPI :: GargServer GargAdminAPI
 357 serverGargAdminAPI =  roots
 358                  :<|> nodesAPI
 359
 360
 361 serverPrivateGargAPI' :: AuthenticatedUser -> GargServer GargPrivateAPI'
 362 serverPrivateGargAPI' (AuthenticatedUser (NodeId uid))
 363        =  serverGargAdminAPI
 364      :<|> nodeAPI     (Proxy :: Proxy HyperdataAny)      uid
 365      :<|> nodeAPI     (Proxy :: Proxy HyperdataCorpus)   uid
 366      :<|> nodeNodeAPI (Proxy :: Proxy HyperdataAny)      uid
 367      :<|> Export.getCorpus   -- uid
 368      :<|> nodeAPI     (Proxy :: Proxy HyperdataAnnuaire) uid
 369      :<|> nodeNodeAPI (Proxy :: Proxy HyperdataContact)  uid
 370
 371      :<|> withAccess  (Proxy :: Proxy TableNgramsApi) Proxy uid
 372           <$> PathNode <*> apiNgramsTableDoc
 373
 374      :<|> count -- TODO: undefined
 375
 376      :<|> withAccess (Proxy :: Proxy SearchPairsAPI) Proxy uid
 377           <$> PathNode <*> searchPairs -- TODO: move elsewhere
 378
 379      :<|> withAccess (Proxy :: Proxy GraphAPI)       Proxy uid
 380           <$> PathNode <*> graphAPI uid -- TODO: mock
 381
 382      :<|> withAccess (Proxy :: Proxy TreeAPI)        Proxy uid
 383           <$> PathNode <*> treeAPI
 384      -- TODO access
 385      -- :<|> addUpload
 386      -- :<|> (\corpus -> addWithQuery corpus :<|> addWithFile corpus)
 387      :<|> addCorpusWithForm
 388      :<|> addCorpusWithQuery
 389
 390      :<|> addAnnuaireWithForm
 391      -- :<|> New.api  uid -- TODO-SECURITY
 392      -- :<|> New.info uid -- TODO-SECURITY
 393      :<|> List.api
 394      :<|> waitAPI
 395
 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 -}
 514
 515
 516