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
  25 {-# LANGUAGE NoImplicitPrelude    #-}
  26 {-# LANGUAGE DataKinds            #-}
  27 {-# LANGUAGE DeriveGeneric        #-}
  28 {-# LANGUAGE FlexibleInstances    #-}
  29 {-# LANGUAGE OverloadedStrings    #-}
  30 {-# LANGUAGE TemplateHaskell      #-}
  31 {-# LANGUAGE TypeOperators        #-}
  32 {-# LANGUAGE KindSignatures       #-}
  33 {-# LANGUAGE TypeFamilies         #-}
  34 {-# LANGUAGE UndecidableInstances #-}
  35
  36 ---------------------------------------------------------------------
  37 module Gargantext.API
  38       where
  39 ---------------------------------------------------------------------
  40 import           Gargantext.Prelude
  41
  42 import           System.IO (FilePath)
  43
  44 import           GHC.Generics (D1, Meta (..), Rep)
  45 import           GHC.TypeLits (AppendSymbol, Symbol)
  46
  47 import           Control.Lens
  48 import           Data.Aeson.Encode.Pretty (encodePretty)
  49 import qualified Data.ByteString.Lazy.Char8 as BL8
  50 import           Data.Swagger
  51 import           Data.Text (Text)
  52 import qualified Data.Text.IO as T
  53 --import qualified Data.Set as Set
  54
  55 import           Network.Wai
  56 import           Network.Wai.Handler.Warp hiding (defaultSettings)
  57
  58 import           Servant
  59 import           Servant.Mock (mock)
  60 --import           Servant.Job.Server (WithCallbacks)
  61 import           Servant.Swagger
  62 import           Servant.Swagger.UI
  63 -- import Servant.API.Stream
  64
  65 --import Gargantext.API.Swagger
  66 import Gargantext.API.FrontEnd (FrontEndAPI, frontEndServer)
  67
  68 import Gargantext.API.Node ( Roots    , roots
  69                            , NodeAPI  , nodeAPI
  70                            , NodesAPI , nodesAPI
  71                            )
  72 import Gargantext.API.Count  ( CountAPI, count, Query)
  73 import Gargantext.API.Search ( SearchAPI, search, SearchQuery)
  74 --import Gargantext.API.Orchestrator
  75 --import Gargantext.API.Orchestrator.Types
  76
  77 ---------------------------------------------------------------------
  78
  79 import GHC.Base (Applicative)
  80 -- import Control.Lens
  81
  82 import Data.List (lookup)
  83 import Data.Text.Encoding (encodeUtf8)
  84
  85 --import Network.Wai (Request, requestHeaders, responseLBS)
  86 import Network.Wai (Request, requestHeaders)
  87 --import qualified Network.Wai.Handler.Warp as Warp
  88 import Network.Wai.Middleware.Cors
  89
  90 import Network.Wai.Middleware.RequestLogger
  91 -- import qualified Network.Wai.Middleware.RequestLogger as RequestLogger
  92
  93 import Network.HTTP.Types hiding (Query)
  94
  95
  96 import Gargantext.API.Settings
  97
  98 fireWall :: Applicative f => Request -> FireWall -> f Bool
  99 fireWall req fw = do
 100     let origin = lookup "Origin" (requestHeaders req)
 101     let host   = lookup "Host"   (requestHeaders req)
 102
 103     let hostOk   = Just (encodeUtf8 "localhost:3000")
 104     let originOk = Just (encodeUtf8 "http://localhost:8008")
 105
 106     if  origin == originOk
 107        && host == hostOk
 108        || (not $ unFireWall fw)
 109
 110        then pure True
 111        else pure False
 112
 113
 114 -- makeMockApp :: Env -> IO (Warp.Settings, Application)
 115 makeMockApp :: MockEnv -> IO Application
 116 makeMockApp env = do
 117     let serverApp = appMock
 118
 119     -- logWare <- mkRequestLogger def { destination = RequestLogger.Logger $ env^.logger }
 120     --logWare <- mkRequestLogger def { destination = RequestLogger.Logger "/tmp/logs.txt" }
 121     let checkOriginAndHost app req resp = do
 122             blocking <- fireWall req (env ^. menv_firewall)
 123             case blocking  of
 124                 True  -> app req resp
 125                 False -> resp ( responseLBS status401 []
 126                               "Invalid Origin or Host header")
 127
 128     let corsMiddleware = cors $ \_ -> Just CorsResourcePolicy
 129 --          { corsOrigins        = Just ([env^.settings.allowedOrigin], False)
 130             { corsOrigins        = Nothing --  == /*
 131             , corsMethods        = [ methodGet   , methodPost   , methodPut
 132                                    , methodDelete, methodOptions, methodHead]
 133             , corsRequestHeaders = ["authorization", "content-type"]
 134             , corsExposedHeaders = Nothing
 135             , corsMaxAge         = Just ( 60*60*24 ) -- one day
 136             , corsVaryOrigin     = False
 137             , corsRequireOrigin  = False
 138             , corsIgnoreFailures = False
 139             }
 140
 141     --let warpS = Warp.setPort (8008 :: Int)   -- (env^.settings.appPort)
 142     --          $ Warp.defaultSettings
 143
 144     --pure (warpS, logWare $ checkOriginAndHost $ corsMiddleware $ serverApp)
 145     pure $ logStdoutDev $ checkOriginAndHost $ corsMiddleware $ serverApp
 146
 147
 148 --
 149 makeDevApp :: Env -> IO Application
 150 makeDevApp env = do
 151     serverApp <- makeApp env
 152
 153     -- logWare <- mkRequestLogger def { destination = RequestLogger.Logger $ env^.logger }
 154     --logWare <- mkRequestLogger def { destination = RequestLogger.Logger "/tmp/logs.txt" }
 155 --    let checkOriginAndHost app req resp = do
 156 --            blocking <- fireWall req (env ^. menv_firewall)
 157 --            case blocking  of
 158 --                True  -> app req resp
 159 --                False -> resp ( responseLBS status401 []
 160 --                              "Invalid Origin or Host header")
 161 --
 162     let corsMiddleware = cors $ \_ -> Just CorsResourcePolicy
 163 --          { corsOrigins        = Just ([env^.settings.allowedOrigin], False)
 164             { corsOrigins        = Nothing --  == /*
 165             , corsMethods        = [ methodGet   , methodPost   , methodPut
 166                                    , methodDelete, methodOptions, methodHead]
 167             , corsRequestHeaders = ["authorization", "content-type"]
 168             , corsExposedHeaders = Nothing
 169             , corsMaxAge         = Just ( 60*60*24 ) -- one day
 170             , corsVaryOrigin     = False
 171             , corsRequireOrigin  = False
 172             , corsIgnoreFailures = False
 173             }
 174
 175     --let warpS = Warp.setPort (8008 :: Int)   -- (env^.settings.appPort)
 176     --          $ Warp.defaultSettings
 177
 178     --pure (warpS, logWare $ checkOriginAndHost $ corsMiddleware $ serverApp)
 179     pure $ logStdoutDev $ corsMiddleware $ serverApp
 180
 181 --
 182
 183 ---------------------------------------------------------------------
 184 -- | API Global
 185
 186 -- | API for serving @swagger.json@
 187 type SwaggerAPI = SwaggerSchemaUI "swagger-ui" "swagger.json"
 188
 189 -- | API for serving main operational routes of @gargantext.org@
 190 type GargAPI =
 191
 192            -- Roots endpoint
 193                 "user"  :> Summary "First user endpoint"
 194                         :> Roots
 195
 196
 197            -- Node endpoint
 198            :<|> "node"  :> Summary "Node endpoint"
 199                         :> Capture "id" Int      :> NodeAPI
 200
 201
 202            -- Corpus endpoint
 203            :<|> "corpus":> Summary "Corpus endpoint"
 204                         :> Capture "id" Int      :> NodeAPI
 205
 206            -- Corpus endpoint
 207            :<|> "nodes" :> Summary "Nodes endpoint"
 208                         :> ReqBody '[JSON] [Int] :> NodesAPI
 209
 210         -- :<|> "counts" :> Stream GET NewLineFraming '[JSON] Count :> CountAPI
 211            -- Corpus endpoint
 212            :<|> "count" :> Summary "Count endpoint"
 213                         :> ReqBody '[JSON] Query :> CountAPI
 214
 215            -- Corpus endpoint
 216            :<|> "search":> Summary "Search endpoint"
 217                         :> ReqBody '[JSON] SearchQuery :> SearchAPI
 218
 219        --    :<|> "scraper" :> WithCallbacks ScraperAPI
 220
 221 -- /mv/<id>/<id>
 222 -- /merge/<id>/<id>
 223 -- /rename/<id>
 224        -- :<|> "static"
 225        -- :<|> "list"     :> Capture "id" Int  :> NodeAPI
 226        -- :<|> "ngrams"   :> Capture "id" Int  :> NodeAPI
 227        -- :<|> "auth"     :> Capture "id" Int  :> NodeAPI
 228 ---------------------------------------------------------------------
 229 type SwaggerFrontAPI = SwaggerAPI :<|> FrontEndAPI
 230
 231 type API = SwaggerFrontAPI :<|> GargAPI
 232
 233 ---------------------------------------------------------------------
 234 -- | Server declaration
 235 server :: Env -> IO (Server API)
 236 server env = do
 237   -- orchestrator <- scrapyOrchestrator env
 238   pure $ swaggerFront
 239      :<|> roots    conn
 240      :<|> nodeAPI  conn
 241      :<|> nodeAPI  conn
 242      :<|> nodesAPI conn
 243      :<|> count
 244      :<|> search conn
 245   --   :<|> orchestrator
 246   where
 247     conn = env ^. env_conn
 248
 249 ---------------------------------------------------------------------
 250 swaggerFront :: Server SwaggerFrontAPI
 251 swaggerFront = schemaUiServer swaggerDoc
 252            :<|> frontEndServer
 253
 254 gargMock :: Server GargAPI
 255 gargMock = mock apiGarg Proxy
 256
 257 ---------------------------------------------------------------------
 258 makeApp :: Env -> IO Application
 259 makeApp = fmap (serve api) . server
 260
 261 appMock :: Application
 262 appMock = serve api (swaggerFront :<|> gargMock)
 263
 264 ---------------------------------------------------------------------
 265 api :: Proxy API
 266 api  = Proxy
 267
 268 apiGarg :: Proxy GargAPI
 269 apiGarg  = Proxy
 270 ---------------------------------------------------------------------
 271
 272 schemaUiServer :: (Server api ~ Handler Swagger)
 273         => Swagger -> Server (SwaggerSchemaUI' dir api)
 274 schemaUiServer = swaggerSchemaUIServer
 275
 276
 277 -- Type Family for the Documentation
 278 type family TypeName (x :: *) :: Symbol where
 279     TypeName Int  = "Int"
 280     TypeName Text = "Text"
 281     TypeName x    = GenericTypeName x (Rep x ())
 282
 283 type family GenericTypeName t (r :: *) :: Symbol where
 284     GenericTypeName t (D1 ('MetaData name mod pkg nt) f x) = name
 285
 286 type Desc t n = Description (AppendSymbol (TypeName t) (AppendSymbol " | " n))
 287
 288
 289 -- | Swagger Specifications
 290 swaggerDoc :: Swagger
 291 swaggerDoc = toSwagger (Proxy :: Proxy GargAPI)
 292   & info.title       .~ "Gargantext"
 293   & info.version     .~ "0.1.0"
 294   -- & info.base_url     ?~ (URL "http://gargantext.org/")
 295   & info.description ?~ "REST API specifications"
 296   -- & tags             .~ Set.fromList [Tag "Garg" (Just "Main perations") Nothing]
 297   & applyTagsFor (subOperations (Proxy :: Proxy GargAPI)(Proxy :: Proxy GargAPI))
 298                  ["Garg" & description ?~ "Main operations"]
 299   & info.license     ?~ ("AGPLV3 (English) and CECILL (French)" & url ?~ URL urlLicence )
 300     where
 301         urlLicence = "https://gitlab.iscpif.fr/gargantext/haskell-gargantext/blob/master/LICENSE"
 302
 303 -- | Output generated @swagger.json@ file for the @'TodoAPI'@.
 304 swaggerWriteJSON :: IO ()
 305 swaggerWriteJSON = BL8.writeFile "swagger.json" (encodePretty swaggerDoc)
 306
 307 portRouteInfo :: PortNumber -> IO ()
 308 portRouteInfo port = do
 309   T.putStrLn "      ----Main Routes-----      "
 310   T.putStrLn $ "http://localhost:" <> toUrlPiece port <> "/index.html"
 311   T.putStrLn $ "http://localhost:" <> toUrlPiece port <> "/swagger-ui"
 312
 313 -- | startGargantext takes as parameters port number and Ini file.
 314 startGargantext :: PortNumber -> FilePath -> IO ()
 315 startGargantext port file = do
 316   env <- newEnv port file
 317   portRouteInfo port
 318   app <- makeDevApp env
 319   run port app
 320
 321 startGargantextMock :: PortNumber -> IO ()
 322 startGargantextMock port = do
 323   portRouteInfo port
 324   application <- makeMockApp . MockEnv $ FireWall False
 325   run port application
 326