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