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