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