{-| Module : Gargantext.API Description : REST API declaration Copyright : (c) CNRS, 2017-Present License : AGPL + CECILL v3 Maintainer : team@gargantext.org Stability : experimental Portability : POSIX Main REST API of Gargantext (both Server and Client sides) Thanks @yannEsposito for our discussions at the beginning of this project :). -} {-# OPTIONS_GHC -fno-warn-name-shadowing #-} {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE KindSignatures #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} --------------------------------------------------------------------- module Gargantext.API where --------------------------------------------------------------------- import System.IO (FilePath) import GHC.Generics (D1, Meta (..), Rep) import GHC.TypeLits (AppendSymbol, Symbol) import Control.Lens import Control.Exception (finally) import Control.Monad.Except (withExceptT, ExceptT) import Control.Monad.IO.Class (liftIO) import Control.Monad.Reader (ReaderT, runReaderT) import Data.Aeson.Encode.Pretty (encodePretty) import qualified Data.ByteString.Lazy.Char8 as BL8 import Data.Swagger import Data.Text (Text) import qualified Data.Text.IO as T --import qualified Data.Set as Set import Data.Validity import Network.Wai import Network.Wai.Handler.Warp hiding (defaultSettings) import Servant import Servant.HTML.Blaze (HTML) import Servant.Mock (mock) --import Servant.Job.Server (WithCallbacks) import Servant.Static.TH.Internal.Server (fileTreeToServer) import Servant.Static.TH.Internal.FileTree (fileTypeToFileTree, FileType(FileTypeFile)) import Servant.Swagger import Servant.Swagger.UI -- import Servant.API.Stream import Text.Blaze.Html (Html) --import Gargantext.API.Swagger --import Gargantext.Database.Node.Contact (HyperdataContact) import Gargantext.API.Auth (AuthRequest, AuthResponse, auth) import Gargantext.API.Count ( CountAPI, count, Query) import Gargantext.API.FrontEnd (FrontEndAPI, frontEndServer) import Gargantext.API.Ngrams (HasRepo(..), HasRepoSaver(..), saveRepo, ApiNgramsTableDoc, apiNgramsTableDoc) import Gargantext.API.Node import Gargantext.API.Search ( SearchAPI, search, SearchQuery) import Gargantext.API.Types import Gargantext.API.Upload import Gargantext.Core.Types (HasInvalidError(..)) import Gargantext.Database.Facet import Gargantext.Database.Schema.Node (HasNodeError(..), NodeError) import Gargantext.Database.Tree (HasTreeError(..), TreeError) import Gargantext.Database.Types.Node import Gargantext.Database.Types.Node (NodeId, CorpusId, AnnuaireId) import Gargantext.Database.Utils (HasConnection) import Gargantext.Prelude import Gargantext.Viz.Graph.API --import Gargantext.API.Orchestrator --import Gargantext.API.Orchestrator.Types --------------------------------------------------------------------- import GHC.Base (Applicative) -- import Control.Lens import Data.List (lookup) import Data.Text.Encoding (encodeUtf8) --import Network.Wai (Request, requestHeaders, responseLBS) import Network.Wai (Request, requestHeaders) --import qualified Network.Wai.Handler.Warp as Warp import Network.Wai.Middleware.Cors import Network.Wai.Middleware.RequestLogger -- import qualified Network.Wai.Middleware.RequestLogger as RequestLogger import Network.HTTP.Types hiding (Query) import Gargantext.API.Settings data GargError = GargNodeError NodeError | GargTreeError TreeError | GargInvalidError Validation deriving (Show) makePrisms ''GargError instance HasNodeError GargError where _NodeError = _GargNodeError instance HasInvalidError GargError where _InvalidError = _GargInvalidError instance HasTreeError GargError where _TreeError = _GargTreeError showAsServantErr :: Show a => a -> ServantErr showAsServantErr a = err500 { errBody = BL8.pack $ show a } fireWall :: Applicative f => Request -> FireWall -> f Bool fireWall req fw = do let origin = lookup "Origin" (requestHeaders req) let host = lookup "Host" (requestHeaders req) let hostOk = Just (encodeUtf8 "localhost:3000") let originOk = Just (encodeUtf8 "http://localhost:8008") if origin == originOk && host == hostOk || (not $ unFireWall fw) then pure True else pure False -- makeMockApp :: Env -> IO (Warp.Settings, Application) makeMockApp :: MockEnv -> IO Application makeMockApp env = do let serverApp = appMock -- logWare <- mkRequestLogger def { destination = RequestLogger.Logger $ env^.logger } --logWare <- mkRequestLogger def { destination = RequestLogger.Logger "/tmp/logs.txt" } let checkOriginAndHost app req resp = do blocking <- fireWall req (env ^. menv_firewall) case blocking of True -> app req resp False -> resp ( responseLBS status401 [] "Invalid Origin or Host header") let corsMiddleware = cors $ \_ -> Just CorsResourcePolicy -- { corsOrigins = Just ([env^.settings.allowedOrigin], False) { corsOrigins = Nothing -- == /* , corsMethods = [ methodGet , methodPost , methodPut , methodDelete, methodOptions, methodHead] , corsRequestHeaders = ["authorization", "content-type"] , corsExposedHeaders = Nothing , corsMaxAge = Just ( 60*60*24 ) -- one day , corsVaryOrigin = False , corsRequireOrigin = False , corsIgnoreFailures = False } --let warpS = Warp.setPort (8008 :: Int) -- (env^.settings.appPort) -- $ Warp.defaultSettings --pure (warpS, logWare $ checkOriginAndHost $ corsMiddleware $ serverApp) pure $ logStdoutDev $ checkOriginAndHost $ corsMiddleware $ serverApp makeDevMiddleware :: IO Middleware makeDevMiddleware = do -- logWare <- mkRequestLogger def { destination = RequestLogger.Logger $ env^.logger } --logWare <- mkRequestLogger def { destination = RequestLogger.Logger "/tmp/logs.txt" } -- let checkOriginAndHost app req resp = do -- blocking <- fireWall req (env ^. menv_firewall) -- case blocking of -- True -> app req resp -- False -> resp ( responseLBS status401 [] -- "Invalid Origin or Host header") -- let corsMiddleware = cors $ \_ -> Just CorsResourcePolicy -- { corsOrigins = Just ([env^.settings.allowedOrigin], False) { corsOrigins = Nothing -- == /* , corsMethods = [ methodGet , methodPost , methodPut , methodDelete, methodOptions, methodHead] , corsRequestHeaders = ["authorization", "content-type"] , corsExposedHeaders = Nothing , corsMaxAge = Just ( 60*60*24 ) -- one day , corsVaryOrigin = False , corsRequireOrigin = False , corsIgnoreFailures = False } --let warpS = Warp.setPort (8008 :: Int) -- (env^.settings.appPort) -- $ Warp.defaultSettings --pure (warpS, logWare . checkOriginAndHost . corsMiddleware) pure $ logStdoutDev . corsMiddleware --------------------------------------------------------------------- -- | API Global -- | API for serving @swagger.json@ type SwaggerAPI = SwaggerSchemaUI "swagger-ui" "swagger.json" -- | API for serving main operational routes of @gargantext.org@ type GargAPI = "api" :> Summary "API " :> GargAPIVersion -- | TODO :<|> Summary "Latest API" :> GargAPI' type GargAPIVersion = "v1.0" :> Summary "v1.0: " :> GargAPI' type GargAPI' = -- Auth endpoint "auth" :> Summary "AUTH API" :> ReqBody '[JSON] AuthRequest :> Post '[JSON] AuthResponse -- Roots endpoint :<|> "user" :> Summary "First user endpoint" :> Roots -- Node endpoint :<|> "node" :> Summary "Node endpoint" :> Capture "id" NodeId :> NodeAPI HyperdataAny -- Corpus endpoint :<|> "corpus":> Summary "Corpus endpoint" :> Capture "id" CorpusId :> NodeAPI HyperdataCorpus -- Annuaire endpoint :<|> "annuaire":> Summary "Annuaire endpoint" :> Capture "id" AnnuaireId :> NodeAPI HyperdataAnnuaire -- Document endpoint :<|> "document":> Summary "Document endpoint" :> Capture "id" DocId :> "ngrams" :> ApiNgramsTableDoc -- Corpus endpoint :<|> "nodes" :> Summary "Nodes endpoint" :> ReqBody '[JSON] [NodeId] :> NodesAPI -- :<|> "counts" :> Stream GET NewLineFraming '[JSON] Count :> CountAPI -- Corpus endpoint :<|> "count" :> Summary "Count endpoint" :> ReqBody '[JSON] Query :> CountAPI -- Corpus endpoint :<|> "search":> Summary "Search endpoint" :> ReqBody '[JSON] SearchQuery :> QueryParam "offset" Int :> QueryParam "limit" Int :> QueryParam "order" OrderBy :> SearchAPI -- TODO move to NodeAPI? :<|> "graph" :> Summary "Graph endpoint" :> Capture "id" NodeId :> GraphAPI -- TODO move to NodeAPI? -- Tree endpoint :<|> "tree" :> Summary "Tree endpoint" :> Capture "id" NodeId :> TreeAPI :<|> "upload" :> ApiUpload -- :<|> "scraper" :> WithCallbacks ScraperAPI -- /mv// -- /merge// -- /rename/ -- :<|> "static" -- :<|> "list" :> Capture "id" Int :> NodeAPI -- :<|> "ngrams" :> Capture "id" Int :> NodeAPI -- :<|> "auth" :> Capture "id" Int :> NodeAPI --------------------------------------------------------------------- type SwaggerFrontAPI = SwaggerAPI :<|> FrontEndAPI type API = SwaggerFrontAPI :<|> GargAPI :<|> Get '[HTML] Html --------------------------------------------------------------------- -- | Server declarations server :: forall env. (HasConnection env, HasRepo env, HasSettings env) => env -> IO (Server API) server env = do -- orchestrator <- scrapyOrchestrator env pure $ swaggerFront :<|> hoistServer (Proxy :: Proxy GargAPI) transform serverGargAPI :<|> serverStatic where transform :: forall a. ReaderT env (ExceptT GargError IO) a -> Handler a transform = Handler . withExceptT showAsServantErr . (`runReaderT` env) serverGargAPI :: GargServer GargAPI serverGargAPI -- orchestrator = auth :<|> roots :<|> nodeAPI (Proxy :: Proxy HyperdataAny) fakeUserId :<|> nodeAPI (Proxy :: Proxy HyperdataCorpus) fakeUserId :<|> nodeAPI (Proxy :: Proxy HyperdataAnnuaire) fakeUserId :<|> apiNgramsTableDoc :<|> nodesAPI :<|> count -- TODO: undefined :<|> search :<|> graphAPI -- TODO: mock :<|> treeAPI :<|> upload -- :<|> orchestrator where fakeUserId = 1 -- TODO serverStatic :: Server (Get '[HTML] Html) serverStatic = $(do let path = "purescript-gargantext/dist/index.html" Just s <- liftIO (fileTypeToFileTree (FileTypeFile path)) fileTreeToServer s ) --------------------------------------------------------------------- swaggerFront :: Server SwaggerFrontAPI swaggerFront = schemaUiServer swaggerDoc :<|> frontEndServer gargMock :: Server GargAPI gargMock = mock apiGarg Proxy --------------------------------------------------------------------- makeApp :: (HasConnection env, HasRepo env, HasSettings env) => env -> IO Application makeApp = fmap (serve api) . server appMock :: Application appMock = serve api (swaggerFront :<|> gargMock :<|> serverStatic) --------------------------------------------------------------------- api :: Proxy API api = Proxy apiGarg :: Proxy GargAPI apiGarg = Proxy --------------------------------------------------------------------- schemaUiServer :: (Server api ~ Handler Swagger) => Swagger -> Server (SwaggerSchemaUI' dir api) schemaUiServer = swaggerSchemaUIServer -- Type Family for the Documentation type family TypeName (x :: *) :: Symbol where TypeName Int = "Int" TypeName Text = "Text" TypeName x = GenericTypeName x (Rep x ()) type family GenericTypeName t (r :: *) :: Symbol where GenericTypeName t (D1 ('MetaData name mod pkg nt) f x) = name type Desc t n = Description (AppendSymbol (TypeName t) (AppendSymbol " | " n)) -- | Swagger Specifications swaggerDoc :: Swagger swaggerDoc = toSwagger (Proxy :: Proxy GargAPI) & info.title .~ "Gargantext" & info.version .~ "4.0.2" -- TODO same version as Gargantext -- & info.base_url ?~ (URL "http://gargantext.org/") & info.description ?~ "REST API specifications" -- & tags .~ Set.fromList [Tag "Garg" (Just "Main perations") Nothing] & applyTagsFor (subOperations (Proxy :: Proxy GargAPI)(Proxy :: Proxy GargAPI)) ["Gargantext" & description ?~ "Main operations"] & info.license ?~ ("AGPLV3 (English) and CECILL (French)" & url ?~ URL urlLicence ) where urlLicence = "https://gitlab.iscpif.fr/gargantext/haskell-gargantext/blob/master/LICENSE" -- | Output generated @swagger.json@ file for the @'TodoAPI'@. swaggerWriteJSON :: IO () swaggerWriteJSON = BL8.writeFile "swagger.json" (encodePretty swaggerDoc) portRouteInfo :: PortNumber -> IO () portRouteInfo port = do T.putStrLn " ----Main Routes----- " T.putStrLn $ "http://localhost:" <> toUrlPiece port <> "/index.html" T.putStrLn $ "http://localhost:" <> toUrlPiece port <> "/swagger-ui" stopGargantext :: HasRepoSaver env => env -> IO () stopGargantext env = do T.putStrLn "----- Stopping gargantext -----" runReaderT saveRepo env -- | startGargantext takes as parameters port number and Ini file. startGargantext :: PortNumber -> FilePath -> IO () startGargantext port file = do env <- newEnv port file portRouteInfo port app <- makeApp env mid <- makeDevMiddleware run port (mid app) `finally` stopGargantext env startGargantextMock :: PortNumber -> IO () startGargantextMock port = do portRouteInfo port application <- makeMockApp . MockEnv $ FireWall False run port application