aboutsummaryrefslogtreecommitdiff
path: root/src/Sproxy
diff options
context:
space:
mode:
Diffstat (limited to 'src/Sproxy')
-rw-r--r--src/Sproxy/Application.hs24
1 files changed, 14 insertions, 10 deletions
diff --git a/src/Sproxy/Application.hs b/src/Sproxy/Application.hs
index ad3bec7..7376657 100644
--- a/src/Sproxy/Application.hs
+++ b/src/Sproxy/Application.hs
@@ -55,14 +55,13 @@ import qualified Sproxy.Logging as Log
redirect :: Word16 -> W.Application
redirect p req resp =
- case W.requestHeaderHost req of
+ case requestDomain req of
Nothing -> badRequest "missing host" req resp
- Just host -> do
+ Just domain -> do
Log.info $ "redirecting to " ++ show location ++ ": " ++ showReq req
resp $ W.responseBuilder status [(hLocation, location)] mempty
where
status = if W.requestMethod req == methodGet then movedPermanently301 else temporaryRedirect307
- (domain, _) = BS.break (== _colon) host
newhost = if p == 443 then domain else domain <> ":" <> pack (show p)
location = "https://" <> newhost <> W.rawPathInfo req <> W.rawQueryString req
@@ -70,10 +69,10 @@ redirect p req resp =
sproxy :: ByteString -> Database -> HashMap Text OAuth2Client -> [(Pattern, BackendConf, BE.Manager)] -> W.Application
sproxy key db oa2 backends = logException $ \req resp -> do
Log.debug $ "sproxy <<< " ++ showReq req
- case W.requestHeaderHost req of
+ case requestDomain req of
Nothing -> badRequest "missing host" req resp
- Just host ->
- case find (\(p, _, _) -> match p (unpack host)) backends of
+ Just domain ->
+ case find (\(p, _, _) -> match p (unpack domain)) backends of
Nothing -> notFound "backend" req resp
Just (_, be, mgr) -> do
let cookieName = pack $ beCookieName be
@@ -145,8 +144,7 @@ extractCookie key now name req = do
authenticate :: ByteString -> BackendConf -> AuthUser -> ByteString -> W.Application
authenticate key be user path req resp = do
now <- epochTime
- let host = fromJust $ W.requestHeaderHost req
- domain = pack <$> beCookieDomain be
+ let domain = pack <$> beCookieDomain be
expiry = now + CTime (beCookieMaxAge be)
authCookie = AuthCookie { acUser = user, acExpiry = expiry }
cookie = WC.def {
@@ -160,7 +158,7 @@ authenticate key be user path req resp = do
, WC.setCookieExpires = Just . posixSecondsToUTCTime . realToFrac $ expiry
}
resp $ W.responseLBS seeOther303 [
- (hLocation, "https://" <> host <> path)
+ (hLocation, "https://" <> fromJust (W.requestHeaderHost req) <> path)
, ("Set-Cookie", toByteString $ WC.renderSetCookie cookie)
] ""
@@ -169,7 +167,7 @@ authorize :: Database -> (AuthCookie, Cookies) -> W.Request -> IO (Maybe W.Reque
authorize db (authCookie, otherCookies) req = do
let
user = acUser authCookie
- domain = decodeUtf8 . fromJust $ W.requestHeaderHost req
+ domain = decodeUtf8 . fromJust $ requestDomain req
email = getEmail user
emailUtf8 = getEmailUtf8 user
familyUtf8 = getFamilyNameUtf8 user
@@ -388,6 +386,12 @@ redirectURL req provider =
<> "/.sproxy/oauth2/" <> encodeUtf8 provider
+requestDomain :: W.Request -> Maybe ByteString
+requestDomain req = do
+ h <- W.requestHeaderHost req
+ return . fst . BS.break (== _colon) $ h
+
+
-- XXX: make sure not to reveal the cookie, which can be valid (!)
showReq :: W.Request -> String
showReq req =