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