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 (RESTful) API of the instance Gargantext.
  11
  12 The Garg-API is typed to derive the documentation, the mock and tests.
  13
  14 This API is indeed typed in order to be able to derive both the server
  15 and the client sides.
  16
  17 The Garg-API-Monad enables:
  18   - Security (WIP)
  19   - Features (WIP)
  20   - Database connection (long term)
  21   - In Memory stack management (short term)
  22   - Logs (WIP)
  23
  24 Thanks to Yann Esposito for our discussions at the start and to Nicolas
  25 Pouillard (who mainly made it).
  26
  27 -}
  28
  29 {-# OPTIONS_GHC -fno-warn-name-shadowing #-}
  30
  31 {-# LANGUAGE ConstraintKinds      #-}
  32 {-# LANGUAGE NoImplicitPrelude    #-}
  33 {-# LANGUAGE DataKinds            #-}
  34 {-# LANGUAGE DeriveGeneric        #-}
  35 {-# LANGUAGE FlexibleContexts     #-}
  36 {-# LANGUAGE FlexibleInstances    #-}
  37 {-# LANGUAGE OverloadedStrings    #-}
  38 {-# LANGUAGE TemplateHaskell      #-}
  39 {-# LANGUAGE TypeOperators        #-}
  40 {-# LANGUAGE KindSignatures       #-}
  41 {-# LANGUAGE RankNTypes           #-}
  42 {-# LANGUAGE ScopedTypeVariables  #-}
  43 {-# LANGUAGE TypeFamilies         #-}
  44 {-# LANGUAGE UndecidableInstances #-}
  45
  46 ---------------------------------------------------------------------
  47 module Gargantext.API
  48       where
  49 ---------------------------------------------------------------------
  50 import Control.Exception (finally)
  51 import Control.Lens
  52 import Control.Monad.Except (withExceptT)
  53 import Control.Monad.Reader (runReaderT)
  54 import Data.Aeson.Encode.Pretty (encodePretty)
  55 import Data.List (lookup)
  56 import Data.Swagger
  57 import Data.Text (Text)
  58 import Data.Text.Encoding (encodeUtf8)
  59 import Data.Validity
  60 import Data.Version (showVersion)
  61 import GHC.Base (Applicative)
  62 import GHC.Generics (D1, Meta (..), Rep)
  63 import GHC.TypeLits (AppendSymbol, Symbol)
  64 import Gargantext.API.Admin.Auth (AuthContext, auth)
  65 import Gargantext.API.Admin.FrontEnd (frontEndServer)
  66 import Gargantext.API.Admin.Settings
  67 import Gargantext.API.Ngrams (HasRepoSaver(..), saveRepo)
  68 import Gargantext.API.Prelude
  69 import Gargantext.API.Routes
  70 import Gargantext.Prelude
  71 import Network.HTTP.Types hiding (Query)
  72 import Network.Wai
  73 import Network.Wai (Request, requestHeaders)
  74 import Network.Wai.Handler.Warp hiding (defaultSettings)
  75 import Network.Wai.Middleware.Cors
  76 import Network.Wai.Middleware.RequestLogger
  77 import Servant
  78 import Servant.Auth.Server (AuthResult(..))
  79 import Servant.Auth.Swagger ()
  80 import Servant.Swagger
  81 import Servant.Swagger.UI
  82 import System.IO (FilePath)
  83 import qualified Data.ByteString.Lazy.Char8 as BL8
  84 import qualified Data.Text.IO               as T
  85 import qualified Paths_gargantext           as PG -- cabal magic build module
  86
  87
  88 -- | startGargantext takes as parameters port number and Ini file.
  89 startGargantext :: PortNumber -> FilePath -> IO ()
  90 startGargantext port file = do
  91   env <- newEnv port file
  92   portRouteInfo port
  93   app <- makeApp env
  94   mid <- makeDevMiddleware
  95   run port (mid app) `finally` stopGargantext env
  96
  97 portRouteInfo :: PortNumber -> IO ()
  98 portRouteInfo port = do
  99   T.putStrLn "      ----Main Routes-----      "
 100   T.putStrLn $ "http://localhost:" <> toUrlPiece port <> "/index.html"
 101   T.putStrLn $ "http://localhost:" <> toUrlPiece port <> "/swagger-ui"
 102
 103 -- TODO clean this Monad condition (more generic) ?
 104 stopGargantext :: HasRepoSaver env => env -> IO ()
 105 stopGargantext env = do
 106   T.putStrLn "----- Stopping gargantext -----"
 107   runReaderT saveRepo env
 108
 109
 110 -- | Output generated @swagger.json@ file for the @'TodoAPI'@.
 111 swaggerWriteJSON :: IO ()
 112 swaggerWriteJSON = BL8.writeFile "swagger.json" (encodePretty swaggerDoc)
 113
 114 -- | Swagger Specifications
 115 swaggerDoc :: Swagger
 116 swaggerDoc = toSwagger (Proxy :: Proxy GargAPI)
 117   & info.title       .~ "Gargantext"
 118   & info.version     .~ (cs $ showVersion PG.version)
 119   -- & info.base_url     ?~ (URL "http://gargantext.org/")
 120   & info.description ?~ "REST API specifications"
 121   -- & tags             .~ Set.fromList [Tag "Garg" (Just "Main perations") Nothing]
 122   & applyTagsFor (subOperations (Proxy :: Proxy GargAPI)(Proxy :: Proxy GargAPI))
 123                  ["Gargantext" & description ?~ "Main operations"]
 124   & info.license     ?~ ("AGPLV3 (English) and CECILL (French)" & url ?~ URL urlLicence )
 125     where
 126         urlLicence = "https://gitlab.iscpif.fr/gargantext/haskell-gargantext/blob/master/LICENSE"
 127
 128 {-
 129 startGargantextMock :: PortNumber -> IO ()
 130 startGargantextMock port = do
 131   portRouteInfo port
 132   application <- makeMockApp . MockEnv $ FireWall False
 133   run port application
 134 -}
 135
 136 ----------------------------------------------------------------------
 137
 138 fireWall :: Applicative f => Request -> FireWall -> f Bool
 139 fireWall req fw = do
 140     let origin = lookup "Origin" (requestHeaders req)
 141     let host   = lookup "Host"   (requestHeaders req)
 142
 143     if  origin == Just (encodeUtf8 "http://localhost:8008")
 144        && host == Just (encodeUtf8 "localhost:3000")
 145        || (not $ unFireWall fw)
 146
 147        then pure True
 148        else pure False
 149
 150 {-
 151 -- makeMockApp :: Env -> IO (Warp.Settings, Application)
 152 makeMockApp :: MockEnv -> IO Application
 153 makeMockApp env = do
 154     let serverApp = appMock
 155
 156     -- logWare <- mkRequestLogger def { destination = RequestLogger.Logger $ env^.logger }
 157     --logWare <- mkRequestLogger def { destination = RequestLogger.Logger "/tmp/logs.txt" }
 158     let checkOriginAndHost app req resp = do
 159             blocking <- fireWall req (env ^. menv_firewall)
 160             case blocking  of
 161                 True  -> app req resp
 162                 False -> resp ( responseLBS status401 []
 163                               "Invalid Origin or Host header")
 164
 165     let corsMiddleware = cors $ \_ -> Just CorsResourcePolicy
 166 --          { corsOrigins        = Just ([env^.settings.allowedOrigin], False)
 167             { corsOrigins        = Nothing --  == /*
 168             , corsMethods        = [ methodGet   , methodPost   , methodPut
 169                                    , methodDelete, methodOptions, methodHead]
 170             , corsRequestHeaders = ["authorization", "content-type"]
 171             , corsExposedHeaders = Nothing
 172             , corsMaxAge         = Just ( 60*60*24 ) -- one day
 173             , corsVaryOrigin     = False
 174             , corsRequireOrigin  = False
 175             , corsIgnoreFailures = False
 176             }
 177
 178     --let warpS = Warp.setPort (8008 :: Int)   -- (env^.settings.appPort)
 179     --          $ Warp.defaultSettings
 180
 181     --pure (warpS, logWare $ checkOriginAndHost $ corsMiddleware $ serverApp)
 182     pure $ logStdoutDev $ checkOriginAndHost $ corsMiddleware $ serverApp
 183 -}
 184
 185
 186 makeDevMiddleware :: IO Middleware
 187 makeDevMiddleware = do
 188
 189     -- logWare <- mkRequestLogger def { destination = RequestLogger.Logger $ env^.logger }
 190     --logWare <- mkRequestLogger def { destination = RequestLogger.Logger "/tmp/logs.txt" }
 191 --    let checkOriginAndHost app req resp = do
 192 --            blocking <- fireWall req (env ^. menv_firewall)
 193 --            case blocking  of
 194 --                True  -> app req resp
 195 --                False -> resp ( responseLBS status401 []
 196 --                              "Invalid Origin or Host header")
 197 --
 198     let corsMiddleware = cors $ \_ -> Just CorsResourcePolicy
 199 --          { corsOrigins        = Just ([env^.settings.allowedOrigin], False)
 200             { corsOrigins        = Nothing --  == /*
 201             , corsMethods        = [ methodGet   , methodPost   , methodPut
 202                                    , methodDelete, methodOptions, methodHead]
 203             , corsRequestHeaders = ["authorization", "content-type"]
 204             , corsExposedHeaders = Nothing
 205             , corsMaxAge         = Just ( 60*60*24 ) -- one day
 206             , corsVaryOrigin     = False
 207             , corsRequireOrigin  = False
 208             , corsIgnoreFailures = False
 209             }
 210
 211     --let warpS = Warp.setPort (8008 :: Int)   -- (env^.settings.appPort)
 212     --          $ Warp.defaultSettings
 213
 214     --pure (warpS, logWare . checkOriginAndHost . corsMiddleware)
 215     pure $ logStdoutDev . corsMiddleware
 216
 217 ---------------------------------------------------------------------
 218 -- | API Global
 219 ---------------------------------------------------------------------
 220 -- | Server declarations
 221 server :: forall env. EnvC env => env -> IO (Server API)
 222 server env = do
 223   -- orchestrator <- scrapyOrchestrator env
 224   pure $  schemaUiServer swaggerDoc
 225      :<|> hoistServerWithContext
 226             (Proxy :: Proxy GargAPI)
 227             (Proxy :: Proxy AuthContext)
 228             transform
 229             serverGargAPI
 230      :<|> frontEndServer
 231   where
 232     transform :: forall a. GargServerM env GargError a -> Handler a
 233     transform = Handler . withExceptT showAsServantErr . (`runReaderT` env)
 234
 235 showAsServantErr :: GargError -> ServerError
 236 showAsServantErr (GargServerError err) = err
 237 showAsServantErr a = err500 { errBody = BL8.pack $ show a }
 238
 239 ---------------------------
 240
 241 serverGargAPI :: GargServerT env err (GargServerM env err) GargAPI
 242 serverGargAPI -- orchestrator
 243        =  auth
 244      :<|> gargVersion
 245      :<|> serverPrivateGargAPI
 246   --   :<|> orchestrator
 247   where
 248
 249     gargVersion :: GargServer GargVersion
 250     gargVersion = pure (cs $ showVersion PG.version)
 251
 252     serverPrivateGargAPI :: GargServerT env err (GargServerM env err) GargPrivateAPI
 253     serverPrivateGargAPI (Authenticated auser) = serverPrivateGargAPI' auser
 254     serverPrivateGargAPI _                     = throwAll' (_ServerError # err401)
 255 -- Here throwAll' requires a concrete type for the monad.
 256
 257
 258 -- TODO-SECURITY admin only: withAdmin
 259 -- Question: How do we mark admins?
 260 {-
 261 serverGargAdminAPI :: GargServer GargAdminAPI
 262 serverGargAdminAPI =  roots
 263                  :<|> nodesAPI
 264 -}
 265
 266 ---------------------------------------------------------------------
 267 --gargMock :: Server GargAPI
 268 --gargMock = mock apiGarg Proxy
 269 ---------------------------------------------------------------------
 270 makeApp :: EnvC env => env -> IO Application
 271 makeApp env = serveWithContext api cfg <$> server env
 272   where
 273     cfg :: Servant.Context AuthContext
 274     cfg = env ^. settings . jwtSettings
 275        :. env ^. settings . cookieSettings
 276     -- :. authCheck env
 277        :. EmptyContext
 278
 279 --appMock :: Application
 280 --appMock = serve api (swaggerFront :<|> gargMock :<|> serverStatic)
 281 ---------------------------------------------------------------------
 282 api :: Proxy API
 283 api  = Proxy
 284
 285 apiGarg :: Proxy GargAPI
 286 apiGarg  = Proxy
 287 ---------------------------------------------------------------------
 288 schemaUiServer :: (Server api ~ Handler Swagger)
 289         => Swagger -> Server (SwaggerSchemaUI' dir api)
 290 schemaUiServer = swaggerSchemaUIServer
 291
 292 ---------------------------------------------------------------------
 293 -- Type Family for the Documentation
 294 type family TypeName (x :: *) :: Symbol where
 295     TypeName Int  = "Int"
 296     TypeName Text = "Text"
 297     TypeName x    = GenericTypeName x (Rep x ())
 298
 299 type family GenericTypeName t (r :: *) :: Symbol where
 300     GenericTypeName t (D1 ('MetaData name mod pkg nt) f x) = name
 301
 302 type Desc t n = Description (AppendSymbol (TypeName t) (AppendSymbol " | " n))
 303
 304