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