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