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