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"
 263                            :> Capture "contact_id" NodeId
 264                            :> NodeNodeAPI HyperdataContact
 265
 266            -- Document endpoint
 267            :<|> "document" :> Summary "Document endpoint"
 268                            :> Capture "doc_id" DocId
 269                            :> "ngrams" :> TableNgramsApi
 270
 271         -- :<|> "counts" :> Stream GET NewLineFraming '[JSON] Count :> CountAPI
 272             -- TODO-SECURITY
 273            :<|> "count"    :> Summary "Count endpoint"
 274                            :> ReqBody '[JSON] Query
 275                            :> CountAPI
 276
 277            -- Corpus endpoint --> TODO rename s/search/filter/g
 278            :<|> "search"   :> Capture "corpus" NodeId
 279                            :> SearchPairsAPI
 280
 281            -- TODO move to NodeAPI?
 282            :<|> "graph"    :> Summary "Graph endpoint"
 283                            :> Capture "graph_id" NodeId
 284                            :> GraphAPI
 285
 286            -- TODO move to NodeAPI?
 287            -- Tree endpoint
 288            :<|> "tree"    :> Summary "Tree endpoint"
 289                           :> Capture "tree_id" NodeId
 290                           :> TreeAPI
 291
 292            -- :<|> New.Upload
 293            :<|> New.AddWithForm
 294            :<|> New.AddWithQuery
 295
 296            :<|> Annuaire.AddWithForm
 297            -- :<|> New.AddWithFile
 298        --  :<|> "scraper" :> WithCallbacks ScraperAPI
 299        --  :<|> "new"  :> New.Api
 300
 301            :<|> "lists"  :> Summary "List export API"
 302                          :> Capture "listId" ListId
 303                          :> List.API
 304
 305            :<|> "wait"   :> Summary "Wait test"
 306                          :> Capture "x" Int
 307                          :> WaitAPI -- Get '[JSON] Int
 308
 309 -- /mv/<id>/<id>
 310 -- /merge/<id>/<id>
 311 -- /rename/<id>
 312        -- :<|> "static"
 313        -- :<|> "list"     :> Capture "node_id" Int  :> NodeAPI
 314        -- :<|> "ngrams"   :> Capture "node_id" Int  :> NodeAPI
 315        -- :<|> "auth"     :> Capture "node_id" Int  :> NodeAPI
 316 ---------------------------------------------------------------------
 317
 318 type API = SwaggerAPI
 319        :<|> GargAPI
 320        :<|> FrontEndAPI
 321
 322 -- This is the concrete monad. It needs to be used as little as possible,
 323 -- instead, prefer GargServer, GargServerT, GargServerC.
 324 type GargServerM env err = ReaderT env (ExceptT err IO)
 325
 326 type EnvC env =
 327   ( HasConnection env
 328   , HasRepo env
 329   , HasSettings env
 330   , HasJobEnv env ScraperStatus ScraperStatus
 331   )
 332
 333 ---------------------------------------------------------------------
 334 -- | Server declarations
 335
 336 server :: forall env. EnvC env => env -> IO (Server API)
 337 server env = do
 338   -- orchestrator <- scrapyOrchestrator env
 339   pure $  schemaUiServer swaggerDoc
 340      :<|> hoistServerWithContext (Proxy :: Proxy GargAPI) (Proxy :: Proxy AuthContext) transform serverGargAPI
 341      :<|> frontEndServer
 342   where
 343     transform :: forall a. GargServerM env GargError a -> Handler a
 344     transform = Handler . withExceptT showAsServantErr . (`runReaderT` env)
 345
 346 serverGargAPI :: GargServerT env err (GargServerM env err) GargAPI
 347 serverGargAPI -- orchestrator
 348        =  auth :<|> serverPrivateGargAPI
 349   --   :<|> orchestrator
 350
 351 serverPrivateGargAPI :: GargServerT env err (GargServerM env err) GargPrivateAPI
 352 serverPrivateGargAPI (Authenticated auser) = serverPrivateGargAPI' auser
 353 serverPrivateGargAPI _                     = throwAll' (_ServerError # err401)
 354 -- Here throwAll' requires a concrete type for the monad.
 355
 356 -- TODO-SECURITY admin only: withAdmin
 357 -- Question: How do we mark admins?
 358 serverGargAdminAPI :: GargServer GargAdminAPI
 359 serverGargAdminAPI =  roots
 360                  :<|> nodesAPI
 361
 362
 363 serverPrivateGargAPI' :: AuthenticatedUser -> GargServer GargPrivateAPI'
 364 serverPrivateGargAPI' (AuthenticatedUser (NodeId uid))
 365        =  serverGargAdminAPI
 366      :<|> nodeAPI     (Proxy :: Proxy HyperdataAny)      uid
 367      :<|> nodeAPI     (Proxy :: Proxy HyperdataCorpus)   uid
 368      :<|> nodeNodeAPI (Proxy :: Proxy HyperdataAny)      uid
 369      :<|> Export.getCorpus   -- uid
 370      :<|> nodeAPI     (Proxy :: Proxy HyperdataAnnuaire) uid
 371      :<|> nodeNodeAPI (Proxy :: Proxy HyperdataContact)  uid
 372
 373      :<|> withAccess  (Proxy :: Proxy TableNgramsApi) Proxy uid
 374           <$> PathNode <*> apiNgramsTableDoc
 375
 376      :<|> count -- TODO: undefined
 377
 378      :<|> withAccess (Proxy :: Proxy SearchPairsAPI) Proxy uid
 379           <$> PathNode <*> searchPairs -- TODO: move elsewhere
 380
 381      :<|> withAccess (Proxy :: Proxy GraphAPI)       Proxy uid
 382           <$> PathNode <*> graphAPI uid -- TODO: mock
 383
 384      :<|> withAccess (Proxy :: Proxy TreeAPI)        Proxy uid
 385           <$> PathNode <*> treeAPI
 386      -- TODO access
 387      -- :<|> addUpload
 388      -- :<|> (\corpus -> addWithQuery corpus :<|> addWithFile corpus)
 389      :<|> addCorpusWithForm
 390      :<|> addCorpusWithQuery
 391
 392      :<|> addAnnuaireWithForm
 393      -- :<|> New.api  uid -- TODO-SECURITY
 394      -- :<|> New.info uid -- TODO-SECURITY
 395      :<|> List.api
 396      :<|> waitAPI
 397
 398
 399 {-
 400 addUpload :: GargServer New.Upload
 401 addUpload cId = (serveJobsAPI $ JobFunction (\i log -> New.addToCorpusJobFunction cid i (liftIO . log)))
 402            :<|> (serveJobsAPI $ JobFunction (\i log -> New.addToCorpusWithForm    cid i (liftIO . log)))
 403 --}
 404
 405 addCorpusWithQuery :: GargServer New.AddWithQuery
 406 addCorpusWithQuery cid =
 407   serveJobsAPI $
 408     JobFunction (\i log -> New.addToCorpusJobFunction cid i (liftIO . log))
 409
 410 addWithFile :: GargServer New.AddWithFile
 411 addWithFile cid i f =
 412   serveJobsAPI $
 413     JobFunction (\_i log -> New.addToCorpusWithFile cid i f (liftIO . log))
 414
 415 addCorpusWithForm :: GargServer New.AddWithForm
 416 addCorpusWithForm cid =
 417   serveJobsAPI $
 418     JobFunction (\i log -> New.addToCorpusWithForm cid i (liftIO . log))
 419
 420 addAnnuaireWithForm :: GargServer Annuaire.AddWithForm
 421 addAnnuaireWithForm cid =
 422   serveJobsAPI $
 423     JobFunction (\i log -> Annuaire.addToAnnuaireWithForm cid i (liftIO . log))
 424
 425 {-
 426 serverStatic :: Server (Get '[HTML] Html)
 427 serverStatic = $(do
 428                   let path = "purescript-gargantext/dist/index.html"
 429                   Just s <- liftIO (fileTypeToFileTree (FileTypeFile path))
 430                   fileTreeToServer s
 431                 )
 432 -}
 433 ---------------------------------------------------------------------
 434 --gargMock :: Server GargAPI
 435 --gargMock = mock apiGarg Proxy
 436 ---------------------------------------------------------------------
 437 makeApp :: EnvC env => env -> IO Application
 438 makeApp env = serveWithContext api cfg <$> server env
 439   where
 440     cfg :: Servant.Context AuthContext
 441     cfg = env ^. settings . jwtSettings
 442        :. env ^. settings . cookieSettings
 443     -- :. authCheck env
 444        :. EmptyContext
 445
 446 --appMock :: Application
 447 --appMock = serve api (swaggerFront :<|> gargMock :<|> serverStatic)
 448 ---------------------------------------------------------------------
 449 api :: Proxy API
 450 api  = Proxy
 451
 452 apiGarg :: Proxy GargAPI
 453 apiGarg  = Proxy
 454 ---------------------------------------------------------------------
 455 schemaUiServer :: (Server api ~ Handler Swagger)
 456         => Swagger -> Server (SwaggerSchemaUI' dir api)
 457 schemaUiServer = swaggerSchemaUIServer
 458
 459 -- Type Family for the Documentation
 460 type family TypeName (x :: *) :: Symbol where
 461     TypeName Int  = "Int"
 462     TypeName Text = "Text"
 463     TypeName x    = GenericTypeName x (Rep x ())
 464
 465 type family GenericTypeName t (r :: *) :: Symbol where
 466     GenericTypeName t (D1 ('MetaData name mod pkg nt) f x) = name
 467
 468 type Desc t n = Description (AppendSymbol (TypeName t) (AppendSymbol " | " n))
 469
 470
 471 -- | Swagger Specifications
 472 swaggerDoc :: Swagger
 473 swaggerDoc = toSwagger (Proxy :: Proxy GargAPI)
 474   & info.title       .~ "Gargantext"
 475   & info.version     .~ "0.0.1.3.1" -- TODO same version as Gargantext
 476   -- & info.base_url     ?~ (URL "http://gargantext.org/")
 477   & info.description ?~ "REST API specifications"
 478   -- & tags             .~ Set.fromList [Tag "Garg" (Just "Main perations") Nothing]
 479   & applyTagsFor (subOperations (Proxy :: Proxy GargAPI)(Proxy :: Proxy GargAPI))
 480                  ["Gargantext" & description ?~ "Main operations"]
 481   & info.license     ?~ ("AGPLV3 (English) and CECILL (French)" & url ?~ URL urlLicence )
 482     where
 483         urlLicence = "https://gitlab.iscpif.fr/gargantext/haskell-gargantext/blob/master/LICENSE"
 484
 485 -- | Output generated @swagger.json@ file for the @'TodoAPI'@.
 486 swaggerWriteJSON :: IO ()
 487 swaggerWriteJSON = BL8.writeFile "swagger.json" (encodePretty swaggerDoc)
 488
 489 portRouteInfo :: PortNumber -> IO ()
 490 portRouteInfo port = do
 491   T.putStrLn "      ----Main Routes-----      "
 492   T.putStrLn $ "http://localhost:" <> toUrlPiece port <> "/index.html"
 493   T.putStrLn $ "http://localhost:" <> toUrlPiece port <> "/swagger-ui"
 494
 495 stopGargantext :: HasRepoSaver env => env -> IO ()
 496 stopGargantext env = do
 497   T.putStrLn "----- Stopping gargantext -----"
 498   runReaderT saveRepo env
 499
 500 -- | startGargantext takes as parameters port number and Ini file.
 501 startGargantext :: PortNumber -> FilePath -> IO ()
 502 startGargantext port file = do
 503   env <- newEnv port file
 504   portRouteInfo port
 505   app <- makeApp env
 506   mid <- makeDevMiddleware
 507   run port (mid app) `finally` stopGargantext env
 508
 509 {-
 510 startGargantextMock :: PortNumber -> IO ()
 511 startGargantextMock port = do
 512   portRouteInfo port
 513   application <- makeMockApp . MockEnv $ FireWall False
 514   run port application
 515 -}
 516
 517
 518