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