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 -}