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