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