src/Gargantext/API.hs

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