diff options
author | Igor Pashev <pashev.igor@gmail.com> | 2016-11-25 23:40:29 +0300 |
---|---|---|
committer | Igor Pashev <pashev.igor@gmail.com> | 2016-11-25 23:51:25 +0300 |
commit | ea17e9c2a3350ba670f95a6fa0ce7716adfa4176 (patch) | |
tree | 1cde3e92d68a816a54ea7b0cca8af0b97e7c291e /src/Sproxy/Application.hs | |
parent | 7ba0b2158124bbf10fbdeeec70fb7e631a32a364 (diff) | |
download | sproxy2-ea17e9c2a3350ba670f95a6fa0ce7716adfa4176.tar.gz |
Make sure all HTTP headers are UTF8-encoded
Especially X-Family-Name, X-Given-Name.
Since we get all the data from JSON and JSON is in UTF8
by default RFC 7159, we are safe.
Refactored to make it less error-prone and to get
as small number of encoding/decoding as possible.
Diffstat (limited to 'src/Sproxy/Application.hs')
-rw-r--r-- | src/Sproxy/Application.hs | 48 |
1 files changed, 26 insertions, 22 deletions
diff --git a/src/Sproxy/Application.hs b/src/Sproxy/Application.hs index 83c4b70..ad3bec7 100644 --- a/src/Sproxy/Application.hs +++ b/src/Sproxy/Application.hs @@ -11,7 +11,6 @@ import Blaze.ByteString.Builder.ByteString (fromByteString) import Control.Exception (Exception, Handler(..), SomeException, catches, displayException) import Data.ByteString (ByteString) import Data.ByteString as BS (break, intercalate) -import Data.Char (toLower) import Data.ByteString.Char8 (pack, unpack) import Data.ByteString.Lazy (fromStrict) import Data.Conduit (Flush(Chunk), mapOutput) @@ -44,7 +43,9 @@ 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) +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, userExists, userGroups) @@ -115,11 +116,11 @@ oauth2callback key db (provider, oa2c) be req resp = Left msg -> badRequest ("invalid state: " ++ msg) req resp Right path -> do au <- oauth2Authenticate oa2c code (redirectURL req provider) - let email = map toLower $ auEmail au - Log.info $ "login `" ++ email ++ "' by " ++ show provider + let email = getEmail au + Log.info $ "login " ++ show email ++ " by " ++ show provider exists <- userExists db email - if exists then authenticate key be au{auEmail = email} path req resp - else userNotFound email req resp + if exists then authenticate key be au path req resp + else userNotFound au req resp where param p = do (_, v) <- find ((==) p . fst) $ W.queryString req @@ -166,29 +167,31 @@ authenticate key be user path req resp = do authorize :: Database -> (AuthCookie, Cookies) -> W.Request -> IO (Maybe W.Request) authorize db (authCookie, otherCookies) req = do + let + user = acUser authCookie + domain = decodeUtf8 . fromJust $ W.requestHeaderHost 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" (pack email) $ - insert "X-Groups" (BS.intercalate "," grps) $ - insert "X-Given-Name" given $ - insert "X-Family-Name" family $ + 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 - user = acUser authCookie - email = auEmail user - given = pack $ auGivenName user - family = pack $ auFamilyName user - domain = decodeUtf8 . fromJust $ W.requestHeaderHost req - path = decodeUtf8 $ W.rawPathInfo req - method = decodeUtf8 $ W.requestMethod req combine a b = a <> "," <> b setCookies [] = delete hCookie setCookies cs = insert hCookie (toByteString . renderCookies $ cs) @@ -278,10 +281,10 @@ authenticationRequired key oa2 req resp = do forbidden :: AuthCookie -> W.Application forbidden ac req resp = do - Log.info $ "403 Forbidden (" ++ email ++ "): " ++ showReq req + Log.info $ "403 Forbidden: " ++ show email ++ ": " ++ showReq req resp $ W.responseLBS forbidden403 [(hContentType, "text/html; charset=utf-8")] page where - email = auEmail . acUser $ ac + email = getEmailUtf8 . acUser $ ac page = fromStrict [qc| <!DOCTYPE html> <html lang="en"> @@ -298,11 +301,12 @@ forbidden ac req resp = do |] -userNotFound :: String -> W.Application -userNotFound email _ resp = do - Log.info $ "404 User not found (" ++ email ++ ")" +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 where + email = getEmailUtf8 au page = fromStrict [qc| <!DOCTYPE html> <html lang="en"> |