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