diff options
Diffstat (limited to 'src/Sproxy/Application.hs')
| -rw-r--r-- | src/Sproxy/Application.hs | 488 |
1 files changed, 277 insertions, 211 deletions
diff --git a/src/Sproxy/Application.hs b/src/Sproxy/Application.hs index 791e59c..3311f05 100644 --- a/src/Sproxy/Application.hs +++ b/src/Sproxy/Application.hs @@ -1,14 +1,17 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE QuasiQuotes #-} -module Sproxy.Application ( - sproxy -, redirect -) where + +module Sproxy.Application + ( sproxy + , redirect + ) where import Blaze.ByteString.Builder (toByteString) import Blaze.ByteString.Builder.ByteString (fromByteString) -import Control.Exception (Exception, Handler(..), SomeException, catches, displayException) +import Control.Exception + (Exception, Handler(..), SomeException, catches, displayException) +import qualified Data.Aeson as JSON import Data.ByteString (ByteString) import Data.ByteString as BS (break, intercalate) import Data.ByteString.Char8 (pack, unpack) @@ -16,7 +19,8 @@ import Data.ByteString.Lazy (fromStrict) import Data.Conduit (Flush(Chunk), mapOutput) import Data.HashMap.Strict as HM (HashMap, foldrWithKey, lookup) import Data.List (find, partition) -import Data.Map as Map (delete, fromListWith, insert, insertWith, toList) +import Data.Map as Map + (delete, fromListWith, insert, insertWith, toList) import Data.Maybe (fromJust, fromMaybe) import Data.Monoid ((<>)) import Data.Text (Text) @@ -25,34 +29,38 @@ import Data.Time.Clock.POSIX (posixSecondsToUTCTime) import Data.Word (Word16) import Data.Word8 (_colon) import Foreign.C.Types (CTime(..)) +import qualified Network.HTTP.Client as BE import Network.HTTP.Client.Conduit (bodyReaderSource) -import Network.HTTP.Conduit (requestBodySourceChunkedIO, requestBodySourceIO) -import Network.HTTP.Types (RequestHeaders, ResponseHeaders, methodGet, methodPost) -import Network.HTTP.Types.Header ( hConnection, - hContentLength, hContentType, hCookie, hLocation, hTransferEncoding ) -import Network.HTTP.Types.Status ( Status(..), badGateway502, badRequest400, forbidden403, - found302, internalServerError500, methodNotAllowed405, movedPermanently301, - networkAuthenticationRequired511, notFound404, ok200, seeOther303, temporaryRedirect307 ) +import Network.HTTP.Conduit + (requestBodySourceChunkedIO, requestBodySourceIO) +import Network.HTTP.Types + (RequestHeaders, ResponseHeaders, methodGet, methodPost) +import Network.HTTP.Types.Header + (hConnection, hContentLength, hContentType, hCookie, hLocation, + hTransferEncoding) +import Network.HTTP.Types.Status + (Status(..), badGateway502, badRequest400, forbidden403, found302, + internalServerError500, methodNotAllowed405, movedPermanently301, + networkAuthenticationRequired511, notFound404, ok200, seeOther303, + temporaryRedirect307) import Network.Socket (NameInfoFlag(NI_NUMERICHOST), getNameInfo) -import Network.Wai.Conduit (sourceRequestBody, responseSource) +import qualified Network.Wai as W +import Network.Wai.Conduit (responseSource, sourceRequestBody) import System.FilePath.Glob (Pattern, match) import System.Posix.Time (epochTime) import Text.InterpolatedString.Perl6 (qc) import Web.Cookie (Cookies, parseCookies, renderCookies) -import qualified Data.Aeson as JSON -import qualified Network.HTTP.Client as BE -import qualified Network.Wai as W import qualified Web.Cookie as WC -import Sproxy.Application.Cookie ( AuthCookie(..), AuthUser, - cookieDecode, cookieEncode, getEmail, getEmailUtf8, getFamilyNameUtf8, - getGivenNameUtf8 ) +import Sproxy.Application.Cookie + (AuthCookie(..), AuthUser, cookieDecode, cookieEncode, getEmail, + getEmailUtf8, getFamilyNameUtf8, getGivenNameUtf8) import Sproxy.Application.OAuth2.Common (OAuth2Client(..)) -import Sproxy.Config(BackendConf(..)) -import Sproxy.Server.DB (Database, userAccess, userExists, userGroups) import qualified Sproxy.Application.State as State +import Sproxy.Config (BackendConf(..)) import qualified Sproxy.Logging as Log - +import Sproxy.Server.DB + (Database, userAccess, userExists, userGroups) redirect :: Word16 -> W.Application redirect p req resp = @@ -61,151 +69,182 @@ redirect p req resp = 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 - newhost = if p == 443 then domain else domain <> ":" <> pack (show p) - location = "https://" <> newhost <> W.rawPathInfo req <> W.rawQueryString req - - -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 requestDomain req of - Nothing -> badRequest "missing host" req resp - 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 - cookieDomain = pack <$> beCookieDomain be - case W.pathInfo req of - ["robots.txt"] -> get robots req resp - (".sproxy":proxy) -> - case proxy of - - ["logout"] -> get (logout key cookieName cookieDomain) req resp - - ["oauth2", provider] -> + where status = + if W.requestMethod req == methodGet + then movedPermanently301 + else temporaryRedirect307 + newhost = + if p == 443 + then domain + else domain <> ":" <> pack (show p) + location = + "https://" <> newhost <> W.rawPathInfo req <> W.rawQueryString req + +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 requestDomain req of + Nothing -> badRequest "missing host" req resp + 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 + cookieDomain = pack <$> beCookieDomain be + case W.pathInfo req of + ["robots.txt"] -> get robots req resp + (".sproxy":proxy) -> + case proxy of + ["logout"] -> + get (logout key cookieName cookieDomain) req resp + ["oauth2", provider] -> case HM.lookup provider oa2 of Nothing -> notFound "OAuth2 provider" req resp - Just oa2c -> get (oauth2callback key db (provider, oa2c) be) req resp - - ["access"] -> do - now <- Just <$> epochTime - case extractCookie key now cookieName req of - Nothing -> authenticationRequired key oa2 req resp - Just (authCookie, _) -> post (checkAccess db authCookie) req resp - - _ -> notFound "proxy" req resp - - _ -> do - now <- Just <$> epochTime - case extractCookie key now cookieName req of - Nothing -> authenticationRequired key oa2 req resp - Just cs@(authCookie, _) -> - authorize db cs req >>= \case - Nothing -> forbidden authCookie req resp - Just req' -> forward mgr req' resp - + Just oa2c -> + get (oauth2callback key db (provider, oa2c) be) req resp + ["access"] -> do + now <- Just <$> epochTime + case extractCookie key now cookieName req of + Nothing -> authenticationRequired key oa2 req resp + Just (authCookie, _) -> + post (checkAccess db authCookie) req resp + _ -> notFound "proxy" req resp + _ -> do + now <- Just <$> epochTime + case extractCookie key now cookieName req of + Nothing -> authenticationRequired key oa2 req resp + Just cs@(authCookie, _) -> + authorize db cs req >>= \case + Nothing -> forbidden authCookie req resp + Just req' -> forward mgr req' resp robots :: W.Application -robots _ resp = resp $ - W.responseLBS ok200 [(hContentType, "text/plain; charset=utf-8")] - "User-agent: *\nDisallow: /" - - -oauth2callback :: ByteString -> Database -> (Text, OAuth2Client) -> BackendConf -> W.Application +robots _ resp = + resp $ + W.responseLBS + ok200 + [(hContentType, "text/plain; charset=utf-8")] + "User-agent: *\nDisallow: /" + +oauth2callback :: + ByteString + -> Database + -> (Text, OAuth2Client) + -> BackendConf + -> W.Application oauth2callback key db (provider, oa2c) be req resp = case param "code" of - Nothing -> badRequest "missing auth code" req resp - Just code -> + Nothing -> badRequest "missing auth code" req resp + Just code -> case param "state" of - Nothing -> badRequest "missing auth state" req resp + Nothing -> badRequest "missing auth state" req resp Just state -> case State.decode key state of - Left msg -> badRequest ("invalid state: " ++ msg) req resp + Left msg -> badRequest ("invalid state: " ++ msg) req resp Right url -> do au <- oauth2Authenticate oa2c code (redirectURL req provider) let email = getEmail au Log.info $ "login " ++ show email ++ " by " ++ show provider exists <- userExists db email - if exists then authenticate key be au url req resp - else userNotFound au req resp + if exists + then authenticate key be au url req resp + else userNotFound au req resp where param p = do (_, v) <- find ((==) p . fst) $ W.queryString req v - -- XXX: RFC6265: the user agent MUST NOT attach more than one Cookie header field -extractCookie :: ByteString -> Maybe CTime -> ByteString -> W.Request -> Maybe (AuthCookie, Cookies) +extractCookie :: + ByteString + -> Maybe CTime + -> ByteString + -> W.Request + -> Maybe (AuthCookie, Cookies) extractCookie key now name req = do - (_, cookies) <- find ((==) hCookie . fst) $ W.requestHeaders req + (_, cookies) <- find ((==) hCookie . fst) $ W.requestHeaders req (auth, others) <- discriminate cookies case cookieDecode key auth of Left _ -> Nothing - Right cookie -> if maybe True (acExpiry cookie >) now - then Just (cookie, others) else Nothing - where discriminate cs = - case partition ((==) name . fst) $ parseCookies cs of - ((_, x):_, xs) -> Just (x, xs) - _ -> Nothing - + Right cookie -> + if maybe True (acExpiry cookie >) now + then Just (cookie, others) + else Nothing + where + discriminate cs = + case partition ((==) name . fst) $ parseCookies cs of + ((_, x):_, xs) -> Just (x, xs) + _ -> Nothing -authenticate :: ByteString -> BackendConf -> AuthUser -> ByteString -> W.Application +authenticate :: + ByteString -> BackendConf -> AuthUser -> ByteString -> W.Application authenticate key be user url _req resp = do now <- epochTime let domain = pack <$> beCookieDomain be expiry = now + CTime (beCookieMaxAge be) - authCookie = AuthCookie { acUser = user, acExpiry = expiry } - cookie = WC.def { - WC.setCookieName = pack $ beCookieName be - , WC.setCookieHttpOnly = True - , WC.setCookiePath = Just "/" - , WC.setCookieSameSite = Nothing - , WC.setCookieSecure = True - , WC.setCookieValue = cookieEncode key authCookie - , WC.setCookieDomain = domain - , WC.setCookieExpires = Just . posixSecondsToUTCTime . realToFrac $ expiry - } - resp $ W.responseLBS seeOther303 [ - (hLocation, url) - , ("Set-Cookie", toByteString $ WC.renderSetCookie cookie) - ] "" - + authCookie = AuthCookie {acUser = user, acExpiry = expiry} + cookie = + WC.def + { WC.setCookieName = pack $ beCookieName be + , WC.setCookieHttpOnly = True + , WC.setCookiePath = Just "/" + , WC.setCookieSameSite = Nothing + , WC.setCookieSecure = True + , WC.setCookieValue = cookieEncode key authCookie + , WC.setCookieDomain = domain + , WC.setCookieExpires = + Just . posixSecondsToUTCTime . realToFrac $ expiry + } + resp $ + W.responseLBS + seeOther303 + [ (hLocation, url) + , ("Set-Cookie", toByteString $ WC.renderSetCookie cookie) + ] + "" -authorize :: Database -> (AuthCookie, Cookies) -> W.Request -> IO (Maybe W.Request) +authorize :: + Database -> (AuthCookie, Cookies) -> W.Request -> IO (Maybe W.Request) authorize db (authCookie, otherCookies) req = do - let - user = acUser authCookie - domain = decodeUtf8 . fromJust $ requestDomain req - email = getEmail user - emailUtf8 = getEmailUtf8 user - familyUtf8 = getFamilyNameUtf8 user - givenUtf8 = getGivenNameUtf8 user - method = decodeUtf8 $ W.requestMethod req - path = decodeUtf8 $ W.rawPathInfo req + let user = acUser authCookie + domain = decodeUtf8 . fromJust $ requestDomain req + email = getEmail user + emailUtf8 = getEmailUtf8 user + familyUtf8 = getFamilyNameUtf8 user + givenUtf8 = getGivenNameUtf8 user + method = decodeUtf8 $ W.requestMethod req + path = decodeUtf8 $ W.rawPathInfo req grps <- userGroups db email domain path method - if null grps then return Nothing - else do - ip <- pack . fromJust . fst <$> getNameInfo [NI_NUMERICHOST] True False (W.remoteHost req) - return . Just $ req { - W.requestHeaders = toList $ - insert "From" emailUtf8 $ - insert "X-Groups" (BS.intercalate "," $ encodeUtf8 <$> grps) $ - insert "X-Given-Name" givenUtf8 $ - insert "X-Family-Name" familyUtf8 $ - insert "X-Forwarded-Proto" "https" $ - insertWith (flip combine) "X-Forwarded-For" ip $ - setCookies otherCookies $ - fromListWith combine $ W.requestHeaders req - } + if null grps + then return Nothing + else do + ip <- + pack . fromJust . fst <$> + getNameInfo [NI_NUMERICHOST] True False (W.remoteHost req) + return . Just $ + req + { W.requestHeaders = + toList $ + insert "From" emailUtf8 $ + insert "X-Groups" (BS.intercalate "," $ encodeUtf8 <$> grps) $ + insert "X-Given-Name" givenUtf8 $ + insert "X-Family-Name" familyUtf8 $ + insert "X-Forwarded-Proto" "https" $ + insertWith (flip combine) "X-Forwarded-For" ip $ + setCookies otherCookies $ + fromListWith combine $ W.requestHeaders req + } where combine a b = a <> "," <> b setCookies [] = delete hCookie setCookies cs = insert hCookie (toByteString . renderCookies $ cs) - checkAccess :: Database -> AuthCookie -> W.Application checkAccess db authCookie req resp = do let email = getEmail . acUser $ authCookie @@ -217,77 +256,96 @@ checkAccess db authCookie req resp = do Log.debug $ "access <<< " ++ show inq tags <- userAccess db email domain inq Log.debug $ "access >>> " ++ show tags - resp $ W.responseLBS ok200 [(hContentType, "application/json")] (JSON.encode tags) - + resp $ + W.responseLBS + ok200 + [(hContentType, "application/json")] + (JSON.encode tags) -- XXX If something seems strange, think about HTTP/1.1 <-> HTTP/1.0. -- FIXME For HTTP/1.0 backends we might need an option -- FIXME in config file. HTTP Client does HTTP/1.1 by default. forward :: BE.Manager -> W.Application forward mgr req resp = do - let beReq = BE.defaultRequest + let beReq = + BE.defaultRequest { BE.method = W.requestMethod req , BE.path = W.rawPathInfo req , BE.queryString = W.rawQueryString req , BE.requestHeaders = modifyRequestHeaders $ W.requestHeaders req , BE.redirectCount = 0 , BE.decompress = const False - , BE.requestBody = case W.requestBodyLength req of - W.ChunkedBody -> requestBodySourceChunkedIO (sourceRequestBody req) - W.KnownLength l -> requestBodySourceIO (fromIntegral l) (sourceRequestBody req) + , BE.requestBody = + case W.requestBodyLength req of + W.ChunkedBody -> + requestBodySourceChunkedIO (sourceRequestBody req) + W.KnownLength l -> + requestBodySourceIO (fromIntegral l) (sourceRequestBody req) } - msg = unpack (BE.method beReq <> " " <> BE.path beReq <> BE.queryString beReq) + msg = + unpack (BE.method beReq <> " " <> BE.path beReq <> BE.queryString beReq) Log.debug $ "BACKEND <<< " ++ msg ++ " " ++ show (BE.requestHeaders beReq) BE.withResponse beReq mgr $ \res -> do - let status = BE.responseStatus res - headers = BE.responseHeaders res - body = mapOutput (Chunk . fromByteString) . bodyReaderSource $ BE.responseBody res - logging = if statusCode status `elem` [ 400, 500 ] then - Log.warn else Log.debug - logging $ "BACKEND >>> " ++ show (statusCode status) ++ " on " ++ msg ++ " " ++ show headers ++ "\n" - resp $ responseSource status (modifyResponseHeaders headers) body - + let status = BE.responseStatus res + headers = BE.responseHeaders res + body = + mapOutput (Chunk . fromByteString) . bodyReaderSource $ + BE.responseBody res + logging = + if statusCode status `elem` [400, 500] + then Log.warn + else Log.debug + logging $ + "BACKEND >>> " ++ + show (statusCode status) ++ " on " ++ msg ++ " " ++ show headers ++ "\n" + resp $ responseSource status (modifyResponseHeaders headers) body modifyRequestHeaders :: RequestHeaders -> RequestHeaders modifyRequestHeaders = filter (\(n, _) -> n `notElem` ban) where ban = - [ - hConnection - , hContentLength -- XXX This is set automtically before sending request to backend + [ hConnection + , hContentLength -- XXX This is set automtically before sending request to backend , hTransferEncoding -- XXX Likewise ] - modifyResponseHeaders :: ResponseHeaders -> ResponseHeaders modifyResponseHeaders = filter (\(n, _) -> n `notElem` ban) where ban = - [ - hConnection + [ hConnection -- XXX WAI docs say we MUST NOT add (keep) Content-Length, Content-Range, and Transfer-Encoding, -- XXX but we use streaming body, which may add Transfer-Encoding only. -- XXX Thus we keep Content-* headers. , hTransferEncoding ] - -authenticationRequired :: ByteString -> HashMap Text OAuth2Client -> W.Application +authenticationRequired :: + ByteString -> HashMap Text OAuth2Client -> W.Application authenticationRequired key oa2 req resp = do Log.info $ "511 Unauthenticated: " ++ showReq req - resp $ W.responseLBS networkAuthenticationRequired511 [(hContentType, "text/html; charset=utf-8")] page + resp $ + W.responseLBS + networkAuthenticationRequired511 + [(hContentType, "text/html; charset=utf-8")] + page where - path = if W.requestMethod req == methodGet - then W.rawPathInfo req <> W.rawQueryString req - else "/" - state = State.encode key $ "https://" <> fromJust (W.requestHeaderHost req) <> path + path = + if W.requestMethod req == methodGet + then W.rawPathInfo req <> W.rawQueryString req + else "/" + state = + State.encode key $ + "https://" <> fromJust (W.requestHeaderHost req) <> path authLink :: Text -> OAuth2Client -> ByteString -> ByteString - authLink provider oa2c html = + authLink provider oa2c html = let u = oauth2AuthorizeURL oa2c state (redirectURL req provider) d = pack $ oauth2Description oa2c in [qc|{html}<p><a href="{u}">Authenticate with {d}</a></p>|] authHtml = foldrWithKey authLink "" oa2 - page = fromStrict [qc| + page = + fromStrict + [qc| <!DOCTYPE html> <html lang="en"> <head> @@ -301,14 +359,16 @@ authenticationRequired key oa2 req resp = do </html> |] - forbidden :: AuthCookie -> W.Application forbidden ac req resp = do Log.info $ "403 Forbidden: " ++ show email ++ ": " ++ showReq req - resp $ W.responseLBS forbidden403 [(hContentType, "text/html; charset=utf-8")] page + resp $ + W.responseLBS forbidden403 [(hContentType, "text/html; charset=utf-8")] page where email = getEmailUtf8 . acUser $ ac - page = fromStrict [qc| + page = + fromStrict + [qc| <!DOCTYPE html> <html lang="en"> <head> @@ -323,14 +383,16 @@ forbidden ac req resp = do </html> |] - userNotFound :: AuthUser -> W.Application userNotFound au _ resp = do Log.info $ "404 User not found: " ++ show email - resp $ W.responseLBS notFound404 [(hContentType, "text/html; charset=utf-8")] page + resp $ + W.responseLBS notFound404 [(hContentType, "text/html; charset=utf-8")] page where email = getEmailUtf8 au - page = fromStrict [qc| + page = + fromStrict + [qc| <!DOCTYPE html> <html lang="en"> <head> @@ -345,98 +407,102 @@ userNotFound au _ resp = do </html> |] - logout :: ByteString -> ByteString -> Maybe ByteString -> W.Application logout key cookieName cookieDomain req resp = do let host = fromJust $ W.requestHeaderHost req case extractCookie key Nothing cookieName req of - Nothing -> resp $ W.responseLBS found302 [ (hLocation, "https://" <> host) ] "" - Just _ -> do - let cookie = WC.def { - WC.setCookieName = cookieName + Nothing -> + resp $ W.responseLBS found302 [(hLocation, "https://" <> host)] "" + Just _ -> do + let cookie = + WC.def + { WC.setCookieName = cookieName , WC.setCookieHttpOnly = True , WC.setCookiePath = Just "/" , WC.setCookieSameSite = Just WC.sameSiteStrict , WC.setCookieSecure = True , WC.setCookieValue = "goodbye" , WC.setCookieDomain = cookieDomain - , WC.setCookieExpires = Just . posixSecondsToUTCTime . realToFrac $ CTime 0 + , WC.setCookieExpires = + Just . posixSecondsToUTCTime . realToFrac $ CTime 0 } - resp $ W.responseLBS found302 [ - (hLocation, "https://" <> host) - , ("Set-Cookie", toByteString $ WC.renderSetCookie cookie) - ] "" - - -badRequest ::String -> W.Application + resp $ + W.responseLBS + found302 + [ (hLocation, "https://" <> host) + , ("Set-Cookie", toByteString $ WC.renderSetCookie cookie) + ] + "" + +badRequest :: String -> W.Application badRequest msg req resp = do Log.warn $ "400 Bad Request (" ++ msg ++ "): " ++ showReq req resp $ W.responseLBS badRequest400 [] "Bad Request" - -notFound ::String -> W.Application +notFound :: String -> W.Application notFound msg req resp = do Log.warn $ "404 Not Found (" ++ msg ++ "): " ++ showReq req resp $ W.responseLBS notFound404 [] "Not Found" - logException :: W.Middleware logException app req resp = - catches (app req resp) [ - Handler badGateway, - Handler internalError - ] + catches (app req resp) [Handler badGateway, Handler internalError] where internalError :: SomeException -> IO W.ResponseReceived internalError = response internalServerError500 - badGateway :: BE.HttpException -> IO W.ResponseReceived badGateway = response badGateway502 - response :: Exception e => Status -> e -> IO W.ResponseReceived response st e = do - Log.error $ show (statusCode st) ++ " " ++ unpack (statusMessage st) - ++ ": " ++ displayException e ++ " on " ++ showReq req - resp $ W.responseLBS st [(hContentType, "text/plain")] (fromStrict $ statusMessage st) - - + Log.error $ + show (statusCode st) ++ + " " ++ + unpack (statusMessage st) ++ + ": " ++ displayException e ++ " on " ++ showReq req + resp $ + W.responseLBS + st + [(hContentType, "text/plain")] + (fromStrict $ statusMessage st) get :: W.Middleware get app req resp | W.requestMethod req == methodGet = app req resp | otherwise = do Log.warn $ "405 Method Not Allowed: " ++ showReq req - resp $ W.responseLBS methodNotAllowed405 [("Allow", "GET")] "Method Not Allowed" - + resp $ + W.responseLBS methodNotAllowed405 [("Allow", "GET")] "Method Not Allowed" post :: W.Middleware post app req resp | W.requestMethod req == methodPost = app req resp | otherwise = do Log.warn $ "405 Method Not Allowed: " ++ showReq req - resp $ W.responseLBS methodNotAllowed405 [("Allow", "POST")] "Method Not Allowed" - + resp $ + W.responseLBS methodNotAllowed405 [("Allow", "POST")] "Method Not Allowed" redirectURL :: W.Request -> Text -> ByteString redirectURL req provider = - "https://" <> fromJust (W.requestHeaderHost req) - <> "/.sproxy/oauth2/" <> encodeUtf8 provider - + "https://" <> fromJust (W.requestHeaderHost req) <> "/.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 = - unpack ( W.requestMethod req <> " " - <> fromMaybe "<no host>" (W.requestHeaderHost req) - <> W.rawPathInfo req <> W.rawQueryString req <> " " ) - ++ show (W.httpVersion req) ++ " " - ++ show (fromMaybe "-" $ W.requestHeaderReferer req) ++ " " - ++ show (fromMaybe "-" $ W.requestHeaderUserAgent req) - ++ " from " ++ show (W.remoteHost req) - +showReq req = + unpack + (W.requestMethod req <> " " <> + fromMaybe "<no host>" (W.requestHeaderHost req) <> + W.rawPathInfo req <> + W.rawQueryString req <> + " ") ++ + show (W.httpVersion req) ++ + " " ++ + show (fromMaybe "-" $ W.requestHeaderReferer req) ++ + " " ++ + show (fromMaybe "-" $ W.requestHeaderUserAgent req) ++ + " from " ++ show (W.remoteHost req) |