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