From ea17e9c2a3350ba670f95a6fa0ce7716adfa4176 Mon Sep 17 00:00:00 2001
From: Igor Pashev <pashev.igor@gmail.com>
Date: Fri, 25 Nov 2016 23:40:29 +0300
Subject: 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.
---
 src/Sproxy/Application.hs | 48 +++++++++++++++++++++++++----------------------
 1 file changed, 26 insertions(+), 22 deletions(-)

(limited to 'src/Sproxy/Application.hs')

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">
-- 
cgit v1.2.3