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