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.AddWithQuery
 299            :<|> New.AddWithFile
 300            :<|> New.AddWithForm
 301        --  :<|> "scraper" :> WithCallbacks ScraperAPI
 302        --  :<|> "new"  :> New.Api
 303
 304 -- /mv/<id>/<id>
 305 -- /merge/<id>/<id>
 306 -- /rename/<id>
 307        -- :<|> "static"
 308        -- :<|> "list"     :> Capture "node_id" Int  :> NodeAPI
 309        -- :<|> "ngrams"   :> Capture "node_id" Int  :> NodeAPI
 310        -- :<|> "auth"     :> Capture "node_id" Int  :> NodeAPI
 311 ---------------------------------------------------------------------
 312 type SwaggerFrontAPI = SwaggerAPI :<|> FrontEndAPI
 313
 314 type API = SwaggerFrontAPI :<|> GargAPI :<|> Get '[HTML] Html
 315
 316 -- This is the concrete monad. It needs to be used as little as possible,
 317 -- instead, prefer GargServer, GargServerT, GargServerC.
 318 type GargServerM env err = ReaderT env (ExceptT err IO)
 319
 320 type EnvC env =
 321   ( HasConnection env
 322   , HasRepo env
 323   , HasSettings env
 324   , HasJobEnv env ScraperStatus ScraperStatus
 325   )
 326
 327 ---------------------------------------------------------------------
 328 -- | Server declarations
 329
 330 server :: forall env. EnvC env => env -> IO (Server API)
 331 server env = do
 332   -- orchestrator <- scrapyOrchestrator env
 333   pure $  swaggerFront
 334      :<|> hoistServerWithContext (Proxy :: Proxy GargAPI) (Proxy :: Proxy AuthContext) transform serverGargAPI
 335      :<|> serverStatic
 336   where
 337     transform :: forall a. GargServerM env GargError a -> Handler a
 338     transform = Handler . withExceptT showAsServantErr . (`runReaderT` env)
 339
 340 serverGargAPI :: GargServerT env err (GargServerM env err) GargAPI
 341 serverGargAPI -- orchestrator
 342        =  auth :<|> serverPrivateGargAPI
 343   --   :<|> orchestrator
 344
 345 serverPrivateGargAPI :: GargServerT env err (GargServerM env err) GargPrivateAPI
 346 serverPrivateGargAPI (Authenticated auser) = serverPrivateGargAPI' auser
 347 serverPrivateGargAPI _                     = throwAll' (_ServerError # err401)
 348 -- Here throwAll' requires a concrete type for the monad.
 349
 350 -- TODO-SECURITY admin only: withAdmin
 351 -- Question: How do we mark admins?
 352 serverGargAdminAPI :: GargServer GargAdminAPI
 353 serverGargAdminAPI
 354    =  roots
 355  :<|> nodesAPI
 356
 357 serverPrivateGargAPI' :: AuthenticatedUser -> GargServer GargPrivateAPI'
 358 serverPrivateGargAPI' (AuthenticatedUser (NodeId uid))
 359        =  serverGargAdminAPI
 360      :<|> nodeAPI     (Proxy :: Proxy HyperdataAny)      uid
 361      :<|> nodeAPI     (Proxy :: Proxy HyperdataCorpus)   uid
 362      :<|> nodeNodeAPI (Proxy :: Proxy HyperdataAny)      uid
 363      :<|> nodeAPI     (Proxy :: Proxy HyperdataAnnuaire) uid
 364      :<|> nodeNodeAPI (Proxy :: Proxy HyperdataContact)  uid
 365
 366      :<|> withAccess  (Proxy :: Proxy TableNgramsApi) Proxy uid
 367           <$> PathNode <*> apiNgramsTableDoc
 368
 369      :<|> count -- TODO: undefined
 370
 371      :<|> withAccess (Proxy :: Proxy SearchPairsAPI) Proxy uid
 372           <$> PathNode <*> searchPairs -- TODO: move elsewhere
 373
 374      :<|> withAccess (Proxy :: Proxy GraphAPI)       Proxy uid
 375           <$> PathNode <*> graphAPI uid -- TODO: mock
 376
 377      :<|> withAccess (Proxy :: Proxy TreeAPI)        Proxy uid
 378           <$> PathNode <*> treeAPI
 379      -- TODO access
 380      :<|> addWithQuery
 381      :<|> addWithFile
 382      :<|> addWithForm
 383      -- :<|> addToCorpus
 384      -- :<|> New.api  uid -- TODO-SECURITY
 385      -- :<|> New.info uid -- TODO-SECURITY
 386
 387 addWithQuery :: GargServer New.AddWithQuery
 388 addWithQuery cid =
 389   serveJobsAPI $
 390     JobFunction (\i log -> New.addToCorpusJobFunction cid i (liftIO . log))
 391
 392 addWithFile :: GargServer New.AddWithFile
 393 addWithFile cid i f =
 394   serveJobsAPI $
 395     JobFunction (\_i log -> New.addToCorpusWithFile cid i f (liftIO . log))
 396
 397 addWithForm :: GargServer New.AddWithForm
 398 addWithForm cid =
 399   serveJobsAPI $
 400     JobFunction (\i log -> New.addToCorpusWithForm cid i (liftIO . log))
 401
 402 serverStatic :: Server (Get '[HTML] Html)
 403 serverStatic = $(do
 404                   let path = "purescript-gargantext/dist/index.html"
 405                   Just s <- liftIO (fileTypeToFileTree (FileTypeFile path))
 406                   fileTreeToServer s
 407                 )
 408
 409 ---------------------------------------------------------------------
 410 swaggerFront :: Server SwaggerFrontAPI
 411 swaggerFront = schemaUiServer swaggerDoc
 412            :<|> frontEndServer
 413
 414 --gargMock :: Server GargAPI
 415 --gargMock = mock apiGarg Proxy
 416
 417 ---------------------------------------------------------------------
 418 makeApp :: EnvC env => env -> IO Application
 419 makeApp env = serveWithContext api cfg <$> server env
 420   where
 421     cfg :: Servant.Context AuthContext
 422     cfg = env ^. settings . jwtSettings
 423        :. env ^. settings . cookieSettings
 424     -- :. authCheck env
 425        :. EmptyContext
 426
 427 --appMock :: Application
 428 --appMock = serve api (swaggerFront :<|> gargMock :<|> serverStatic)
 429
 430 ---------------------------------------------------------------------
 431 api :: Proxy API
 432 api  = Proxy
 433
 434 apiGarg :: Proxy GargAPI
 435 apiGarg  = Proxy
 436 ---------------------------------------------------------------------
 437
 438 schemaUiServer :: (Server api ~ Handler Swagger)
 439         => Swagger -> Server (SwaggerSchemaUI' dir api)
 440 schemaUiServer = swaggerSchemaUIServer
 441
 442
 443 -- Type Family for the Documentation
 444 type family TypeName (x :: *) :: Symbol where
 445     TypeName Int  = "Int"
 446     TypeName Text = "Text"
 447     TypeName x    = GenericTypeName x (Rep x ())
 448
 449 type family GenericTypeName t (r :: *) :: Symbol where
 450     GenericTypeName t (D1 ('MetaData name mod pkg nt) f x) = name
 451
 452 type Desc t n = Description (AppendSymbol (TypeName t) (AppendSymbol " | " n))
 453
 454
 455 -- | Swagger Specifications
 456 swaggerDoc :: Swagger
 457 swaggerDoc = toSwagger (Proxy :: Proxy GargAPI)
 458   & info.title       .~ "Gargantext"
 459   & info.version     .~ "4.0.2" -- TODO same version as Gargantext
 460   -- & info.base_url     ?~ (URL "http://gargantext.org/")
 461   & info.description ?~ "REST API specifications"
 462   -- & tags             .~ Set.fromList [Tag "Garg" (Just "Main perations") Nothing]
 463   & applyTagsFor (subOperations (Proxy :: Proxy GargAPI)(Proxy :: Proxy GargAPI))
 464                  ["Gargantext" & description ?~ "Main operations"]
 465   & info.license     ?~ ("AGPLV3 (English) and CECILL (French)" & url ?~ URL urlLicence )
 466     where
 467         urlLicence = "https://gitlab.iscpif.fr/gargantext/haskell-gargantext/blob/master/LICENSE"
 468
 469 -- | Output generated @swagger.json@ file for the @'TodoAPI'@.
 470 swaggerWriteJSON :: IO ()
 471 swaggerWriteJSON = BL8.writeFile "swagger.json" (encodePretty swaggerDoc)
 472
 473 portRouteInfo :: PortNumber -> IO ()
 474 portRouteInfo port = do
 475   T.putStrLn "      ----Main Routes-----      "
 476   T.putStrLn $ "http://localhost:" <> toUrlPiece port <> "/index.html"
 477   T.putStrLn $ "http://localhost:" <> toUrlPiece port <> "/swagger-ui"
 478
 479 stopGargantext :: HasRepoSaver env => env -> IO ()
 480 stopGargantext env = do
 481   T.putStrLn "----- Stopping gargantext -----"
 482   runReaderT saveRepo env
 483
 484 -- | startGargantext takes as parameters port number and Ini file.
 485 startGargantext :: PortNumber -> FilePath -> IO ()
 486 startGargantext port file = do
 487   env <- newEnv port file
 488   portRouteInfo port
 489   app <- makeApp env
 490   mid <- makeDevMiddleware
 491   run port (mid app) `finally` stopGargantext env
 492
 493 {-
 494 startGargantextMock :: PortNumber -> IO ()
 495 startGargantextMock port = do
 496   portRouteInfo port
 497   application <- makeMockApp . MockEnv $ FireWall False
 498   run port application
 499 -}