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 TemplateHaskell      #-}
  33 {-# LANGUAGE TypeOperators        #-}
  34 {-# LANGUAGE KindSignatures       #-}
  35 {-# LANGUAGE ScopedTypeVariables  #-}
  36 {-# LANGUAGE TypeFamilies         #-}
  37 {-# LANGUAGE UndecidableInstances #-}
  38
  39 ---------------------------------------------------------------------
  40 module Gargantext.API
  41       where
  42 ---------------------------------------------------------------------
  43 import Control.Exception (finally)
  44 import Control.Lens
  45 import Control.Monad.Except (withExceptT)
  46 import Control.Monad.Reader (runReaderT)
  47 import Data.List (lookup)
  48 import Data.Text (Text)
  49 import Data.Text.Encoding (encodeUtf8)
  50 import Data.Validity
  51 import Data.Version (showVersion)
  52 import GHC.Base (Applicative)
  53 import GHC.Generics (D1, Meta (..), Rep, Generic)
  54 import GHC.TypeLits (AppendSymbol, Symbol)
  55 import Network.HTTP.Types hiding (Query)
  56 import Network.Wai
  57 import Network.Wai.Handler.Warp hiding (defaultSettings)
  58 import Network.Wai.Middleware.Cors
  59 import Network.Wai.Middleware.RequestLogger
  60 import Servant
  61 import Servant.Auth.Server (AuthResult(..))
  62 import Servant.Swagger.UI (swaggerSchemaUIServer)
  63 import System.IO (FilePath)
  64 import qualified Data.ByteString.Lazy.Char8 as BL8
  65 import qualified Data.Text.IO               as T
  66 import qualified Paths_gargantext           as PG -- cabal magic build module
  67
  68 import qualified Gargantext.API.Public      as Public
  69
  70 import Gargantext.Prelude.Config (gc_url_backend_api)
  71 import Gargantext.API.Admin.Auth (AuthContext, auth)
  72 import Gargantext.API.Admin.FrontEnd (frontEndServer)
  73 import Gargantext.API.Admin.Settings (newEnv)
  74 import Gargantext.API.Admin.Types (FireWall(..), PortNumber, cookieSettings, env_gargConfig, jwtSettings, settings)
  75 import Gargantext.API.Ngrams (saveRepo)
  76 import Gargantext.API.Ngrams.Types (HasRepoSaver(..))
  77 import Gargantext.API.Prelude
  78 import Gargantext.API.Routes
  79 import Gargantext.API.Swagger (swaggerDoc)
  80 import Gargantext.Prelude
  81
  82
  83 data Mode = Dev | Mock | Prod
  84        deriving (Show, Read, Generic)
  85
  86 -- | startGargantext takes as parameters port number and Ini file.
  87 startGargantext :: Mode -> PortNumber -> FilePath -> IO ()
  88 startGargantext mode port file = do
  89   env <- newEnv port file
  90   portRouteInfo port
  91
  92   let baseUrl = env ^. env_gargConfig . gc_url_backend_api
  93   app <- makeApp env baseUrl
  94
  95   mid <- makeDevMiddleware mode
  96   run port (mid app) `finally` stopGargantext env
  97
  98 portRouteInfo :: PortNumber -> IO ()
  99 portRouteInfo port = do
 100   T.putStrLn "      ----Main Routes-----      "
 101   T.putStrLn $ "http://localhost:" <> toUrlPiece port <> "/index.html"
 102   T.putStrLn $ "http://localhost:" <> toUrlPiece port <> "/swagger-ui"
 103
 104 -- TODO clean this Monad condition (more generic) ?
 105 stopGargantext :: HasRepoSaver env => env -> IO ()
 106 stopGargantext env = do
 107   T.putStrLn "----- Stopping gargantext -----"
 108   runReaderT saveRepo env
 109
 110 {-
 111 startGargantextMock :: PortNumber -> IO ()
 112 startGargantextMock port = do
 113   portRouteInfo port
 114   application <- makeMockApp . MockEnv $ FireWall False
 115   run port application
 116 -}
 117
 118 ----------------------------------------------------------------------
 119
 120 fireWall :: Applicative f => Request -> FireWall -> f Bool
 121 fireWall req fw = do
 122     let origin = lookup "Origin" (requestHeaders req)
 123     let host   = lookup "Host"   (requestHeaders req)
 124
 125     if  origin == Just (encodeUtf8 "http://localhost:8008")
 126        && host == Just (encodeUtf8 "localhost:3000")
 127        || (not $ unFireWall fw)
 128
 129        then pure True
 130        else pure False
 131
 132 {-
 133 -- makeMockApp :: Env -> IO (Warp.Settings, Application)
 134 makeMockApp :: MockEnv -> IO Application
 135 makeMockApp env = do
 136     let serverApp = appMock
 137
 138     -- logWare <- mkRequestLogger def { destination = RequestLogger.Logger $ env^.logger }
 139     --logWare <- mkRequestLogger def { destination = RequestLogger.Logger "/tmp/logs.txt" }
 140     let checkOriginAndHost app req resp = do
 141             blocking <- fireWall req (env ^. menv_firewall)
 142             case blocking  of
 143                 True  -> app req resp
 144                 False -> resp ( responseLBS status401 []
 145                               "Invalid Origin or Host header")
 146
 147     let corsMiddleware = cors $ \_ -> Just CorsResourcePolicy
 148 --          { corsOrigins        = Just ([env^.settings.allowedOrigin], False)
 149             { corsOrigins        = Nothing --  == /*
 150             , corsMethods        = [ methodGet   , methodPost   , methodPut
 151                                    , methodDelete, methodOptions, methodHead]
 152             , corsRequestHeaders = ["authorization", "content-type"]
 153             , corsExposedHeaders = Nothing
 154             , corsMaxAge         = Just ( 60*60*24 ) -- one day
 155             , corsVaryOrigin     = False
 156             , corsRequireOrigin  = False
 157             , corsIgnoreFailures = False
 158             }
 159
 160     --let warpS = Warp.setPort (8008 :: Int)   -- (env^.settings.appPort)
 161     --          $ Warp.defaultSettings
 162
 163     --pure (warpS, logWare $ checkOriginAndHost $ corsMiddleware $ serverApp)
 164     pure $ logStdoutDev $ checkOriginAndHost $ corsMiddleware $ serverApp
 165 -}
 166
 167
 168 makeDevMiddleware :: Mode -> IO Middleware
 169 makeDevMiddleware mode = do
 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     case mode of
 197       Prod -> pure $ logStdout . corsMiddleware
 198       _    -> pure $ logStdoutDev . corsMiddleware
 199
 200 ---------------------------------------------------------------------
 201 -- | API Global
 202 ---------------------------------------------------------------------
 203 -- | Server declarations
 204 server :: forall env. EnvC env => env -> Text -> IO (Server API)
 205 server env baseUrl = do
 206   -- orchestrator <- scrapyOrchestrator env
 207   pure $  swaggerSchemaUIServer swaggerDoc
 208      :<|> hoistServerWithContext
 209             (Proxy :: Proxy GargAPI)
 210             (Proxy :: Proxy AuthContext)
 211             transform
 212             (serverGargAPI baseUrl)
 213      :<|> frontEndServer
 214   where
 215     transform :: forall a. GargServerM env GargError a -> Handler a
 216     transform = Handler . withExceptT showAsServantErr . (`runReaderT` env)
 217
 218
 219
 220 showAsServantErr :: GargError -> ServerError
 221 showAsServantErr (GargServerError err) = err
 222 showAsServantErr a = err500 { errBody = BL8.pack $ show a }
 223
 224 ---------------------------
 225
 226 serverGargAPI :: Text -> GargServerT env err (GargServerM env err) GargAPI
 227 serverGargAPI baseUrl -- orchestrator
 228        =  auth
 229      :<|> gargVersion
 230      :<|> serverPrivateGargAPI
 231      :<|> (Public.api baseUrl)
 232
 233   --   :<|> orchestrator
 234   where
 235     gargVersion :: GargServer GargVersion
 236     gargVersion = pure (cs $ showVersion PG.version)
 237
 238     serverPrivateGargAPI :: GargServerT env err (GargServerM env err) GargPrivateAPI
 239     serverPrivateGargAPI (Authenticated auser) = serverPrivateGargAPI' auser
 240     serverPrivateGargAPI _                     = throwAll' (_ServerError # err401)
 241 -- Here throwAll' requires a concrete type for the monad.
 242
 243
 244 -- TODO-SECURITY admin only: withAdmin
 245 -- Question: How do we mark admins?
 246 {-
 247 serverGargAdminAPI :: GargServer GargAdminAPI
 248 serverGargAdminAPI =  roots
 249                  :<|> nodesAPI
 250 -}
 251
 252 ---------------------------------------------------------------------
 253 --gargMock :: Server GargAPI
 254 --gargMock = mock apiGarg Proxy
 255 ---------------------------------------------------------------------
 256 makeApp :: EnvC env => env -> Text -> IO Application
 257 makeApp env baseUrl = serveWithContext api cfg <$> server env baseUrl
 258   where
 259     cfg :: Servant.Context AuthContext
 260     cfg = env ^. settings . jwtSettings
 261        :. env ^. settings . cookieSettings
 262     -- :. authCheck env
 263        :. EmptyContext
 264
 265 --appMock :: Application
 266 --appMock = serve api (swaggerFront :<|> gargMock :<|> serverStatic)
 267 ---------------------------------------------------------------------
 268 api :: Proxy API
 269 api  = Proxy
 270
 271 apiGarg :: Proxy GargAPI
 272 apiGarg  = Proxy
 273 ---------------------------------------------------------------------
 274
 275 ---------------------------------------------------------------------
 276 -- Type Family for the Documentation
 277 type family TypeName (x :: *) :: Symbol where
 278     TypeName Int  = "Int"
 279     TypeName Text = "Text"
 280     TypeName x    = GenericTypeName x (Rep x ())
 281
 282 type family GenericTypeName t (r :: *) :: Symbol where
 283     GenericTypeName t (D1 ('MetaData name mod pkg nt) f x) = name
 284
 285 type Desc t n = Description (AppendSymbol (TypeName t) (AppendSymbol " | " n))
 286
 287