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.Reader (ReaderT, runReaderT)
  55 import Data.Aeson.Encode.Pretty (encodePretty)
  56 import Data.List (lookup)
  57 import Data.Swagger
  58 import Data.Text (Text)
  59 import Data.Text.Encoding (encodeUtf8)
  60 import Data.Validity
  61 import Data.Version (showVersion)
  62 import GHC.Base (Applicative)
  63 import GHC.Generics (D1, Meta (..), Rep)
  64 import GHC.TypeLits (AppendSymbol, Symbol)
  65 import Gargantext.API.Auth (AuthRequest, AuthResponse, AuthenticatedUser(..), AuthContext, auth, withAccess, PathId(..))
  66 import Gargantext.API.Count  ( CountAPI, count, Query)
  67 import Gargantext.API.FrontEnd (FrontEndAPI, frontEndServer)
  68 import Gargantext.API.Ngrams (HasRepo(..), HasRepoSaver(..), saveRepo, TableNgramsApi, apiNgramsTableDoc)
  69 import Gargantext.API.Node
  70 import Gargantext.API.Orchestrator.Types
  71 import Gargantext.API.Search (SearchPairsAPI, searchPairs)
  72 import Gargantext.API.Settings
  73 import Gargantext.API.Types
  74 import Gargantext.Core.Types.Individu (User(..))
  75 import Gargantext.Database.Node.Contact (HyperdataContact)
  76 import Gargantext.Database.Types.Node
  77 import Gargantext.Database.Types.Node (NodeId, CorpusId, AnnuaireId)
  78 import Gargantext.Database.Utils (HasConnectionPool)
  79 import Gargantext.Prelude
  80 import Gargantext.Viz.Graph.API
  81 import Network.HTTP.Types hiding (Query)
  82 import Network.Wai
  83 import Network.Wai (Request, requestHeaders)
  84 import Network.Wai.Handler.Warp hiding (defaultSettings)
  85 import Network.Wai.Middleware.Cors
  86 import Network.Wai.Middleware.RequestLogger
  87 import Servant
  88 import Servant.Auth as SA
  89 import Servant.Auth.Server (AuthResult(..))
  90 import Servant.Auth.Swagger ()
  91 import Servant.Job.Async
  92 import Servant.Swagger
  93 import Servant.Swagger.UI
  94 import System.IO (FilePath)
  95 import qualified Paths_gargantext as PG -- cabal magic build module
  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   _ <- liftBase $ 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" :> 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   ( HasConnectionPool 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  (UserDBId uid)
 410      :<|> addCorpusWithQuery (RootId   uid)
 411
 412      :<|> addAnnuaireWithForm
 413      -- :<|> New.api  uid -- TODO-SECURITY
 414      -- :<|> New.info uid -- TODO-SECURITY
 415      :<|> List.api
 416      :<|> waitAPI
 417
 418
 419 addCorpusWithQuery :: User -> GargServer New.AddWithQuery
 420 addCorpusWithQuery user cid =
 421   serveJobsAPI $
 422     JobFunction (\i log -> New.addToCorpusWithQuery user cid i (liftBase . log))
 423
 424 addWithFile :: GargServer New.AddWithFile
 425 addWithFile cid i f =
 426   serveJobsAPI $
 427     JobFunction (\_i log -> New.addToCorpusWithFile cid i f (liftBase . log))
 428
 429 addCorpusWithForm :: User -> GargServer New.AddWithForm
 430 addCorpusWithForm user cid =
 431   serveJobsAPI $
 432     JobFunction (\i log ->
 433       let
 434         log' x = do
 435           printDebug "addCorpusWithForm" x
 436           liftBase $ log x
 437       in New.addToCorpusWithForm user cid i log')
 438
 439 addAnnuaireWithForm :: GargServer Annuaire.AddWithForm
 440 addAnnuaireWithForm cid =
 441   serveJobsAPI $
 442     JobFunction (\i log -> Annuaire.addToAnnuaireWithForm cid i (liftBase . log))
 443
 444 {-
 445 serverStatic :: Server (Get '[HTML] Html)
 446 serverStatic = $(do
 447                   let path = "purescript-gargantext/dist/index.html"
 448                   Just s <- liftBase (fileTypeToFileTree (FileTypeFile path))
 449                   fileTreeToServer s
 450                 )
 451 -}
 452 ---------------------------------------------------------------------
 453 --gargMock :: Server GargAPI
 454 --gargMock = mock apiGarg Proxy
 455 ---------------------------------------------------------------------
 456 makeApp :: EnvC env => env -> IO Application
 457 makeApp env = serveWithContext api cfg <$> server env
 458   where
 459     cfg :: Servant.Context AuthContext
 460     cfg = env ^. settings . jwtSettings
 461        :. env ^. settings . cookieSettings
 462     -- :. authCheck env
 463        :. EmptyContext
 464
 465 --appMock :: Application
 466 --appMock = serve api (swaggerFront :<|> gargMock :<|> serverStatic)
 467 ---------------------------------------------------------------------
 468 api :: Proxy API
 469 api  = Proxy
 470
 471 apiGarg :: Proxy GargAPI
 472 apiGarg  = Proxy
 473 ---------------------------------------------------------------------
 474 schemaUiServer :: (Server api ~ Handler Swagger)
 475         => Swagger -> Server (SwaggerSchemaUI' dir api)
 476 schemaUiServer = swaggerSchemaUIServer
 477
 478 -- Type Family for the Documentation
 479 type family TypeName (x :: *) :: Symbol where
 480     TypeName Int  = "Int"
 481     TypeName Text = "Text"
 482     TypeName x    = GenericTypeName x (Rep x ())
 483
 484 type family GenericTypeName t (r :: *) :: Symbol where
 485     GenericTypeName t (D1 ('MetaData name mod pkg nt) f x) = name
 486
 487 type Desc t n = Description (AppendSymbol (TypeName t) (AppendSymbol " | " n))
 488
 489
 490 -- | Swagger Specifications
 491 swaggerDoc :: Swagger
 492 swaggerDoc = toSwagger (Proxy :: Proxy GargAPI)
 493   & info.title       .~ "Gargantext"
 494   & info.version     .~ "0.0.1.3.1" -- TODO same version as Gargantext
 495   -- & info.base_url     ?~ (URL "http://gargantext.org/")
 496   & info.description ?~ "REST API specifications"
 497   -- & tags             .~ Set.fromList [Tag "Garg" (Just "Main perations") Nothing]
 498   & applyTagsFor (subOperations (Proxy :: Proxy GargAPI)(Proxy :: Proxy GargAPI))
 499                  ["Gargantext" & description ?~ "Main operations"]
 500   & info.license     ?~ ("AGPLV3 (English) and CECILL (French)" & url ?~ URL urlLicence )
 501     where
 502         urlLicence = "https://gitlab.iscpif.fr/gargantext/haskell-gargantext/blob/master/LICENSE"
 503
 504 -- | Output generated @swagger.json@ file for the @'TodoAPI'@.
 505 swaggerWriteJSON :: IO ()
 506 swaggerWriteJSON = BL8.writeFile "swagger.json" (encodePretty swaggerDoc)
 507
 508 portRouteInfo :: PortNumber -> IO ()
 509 portRouteInfo port = do
 510   T.putStrLn "      ----Main Routes-----      "
 511   T.putStrLn $ "http://localhost:" <> toUrlPiece port <> "/index.html"
 512   T.putStrLn $ "http://localhost:" <> toUrlPiece port <> "/swagger-ui"
 513
 514 stopGargantext :: HasRepoSaver env => env -> IO ()
 515 stopGargantext env = do
 516   T.putStrLn "----- Stopping gargantext -----"
 517   runReaderT saveRepo env
 518
 519 -- | startGargantext takes as parameters port number and Ini file.
 520 startGargantext :: PortNumber -> FilePath -> IO ()
 521 startGargantext port file = do
 522   env <- newEnv port file
 523   portRouteInfo port
 524   app <- makeApp env
 525   mid <- makeDevMiddleware
 526   run port (mid app) `finally` stopGargantext env
 527
 528 {-
 529 startGargantextMock :: PortNumber -> IO ()
 530 startGargantextMock port = do
 531   portRouteInfo port
 532   application <- makeMockApp . MockEnv $ FireWall False
 533   run port application
 534 -}
 535
 536
 537