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