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.

6 files changed, 90 insertions, 48 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">
diff --git a/src/Sproxy/Application/Cookie.hs b/src/Sproxy/Application/Cookie.hs
index 07cc162..a86f42a 100644
--- a/src/Sproxy/Application/Cookie.hs
+++ b/src/Sproxy/Application/Cookie.hs
@@ -1,20 +1,30 @@
+{-# LANGUAGE OverloadedStrings #-}
 module Sproxy.Application.Cookie (
   AuthCookie(..)
-, AuthUser(..)
+, AuthUser
 , cookieDecode
 , cookieEncode
+, getEmail
+, getEmailUtf8
+, getFamilyNameUtf8
+, getGivenNameUtf8
+, newUser
+, setFamilyName
+, setGivenName
 ) where
 
 import Data.ByteString (ByteString)
+import Data.Text (Text, toLower, strip)
+import Data.Text.Encoding (decodeUtf8, encodeUtf8)
 import Foreign.C.Types (CTime(..))
 import qualified Data.Serialize as DS
 
 import qualified Sproxy.Application.State as State
 
 data AuthUser = AuthUser {
-  auEmail      :: String
-, auGivenName  :: String
-, auFamilyName :: String
+  auEmail      :: ByteString
+, auGivenName  :: ByteString
+, auFamilyName :: ByteString
 }
 
 data AuthCookie = AuthCookie {
@@ -37,8 +47,33 @@ instance DS.Serialize AuthCookie where
 cookieDecode :: ByteString -> ByteString -> Either String AuthCookie
 cookieDecode key d = State.decode key d >>= DS.decode
 
-
 cookieEncode :: ByteString -> AuthCookie -> ByteString
 cookieEncode key = State.encode key . DS.encode
 
 
+getEmail :: AuthUser -> Text
+getEmail = decodeUtf8 . auEmail
+
+getEmailUtf8 :: AuthUser -> ByteString
+getEmailUtf8 = auEmail
+
+getGivenNameUtf8 :: AuthUser -> ByteString
+getGivenNameUtf8 = auGivenName
+
+getFamilyNameUtf8 :: AuthUser -> ByteString
+getFamilyNameUtf8 = auFamilyName
+
+
+newUser :: Text -> AuthUser
+newUser email = AuthUser {
+    auEmail = encodeUtf8 . toLower . strip $ email
+  , auGivenName = ""
+  , auFamilyName = ""
+  }
+
+setGivenName :: Text -> AuthUser -> AuthUser
+setGivenName given au = au{ auGivenName = encodeUtf8 . strip $ given }
+
+setFamilyName :: Text -> AuthUser -> AuthUser
+setFamilyName family au = au{ auFamilyName = encodeUtf8 . strip $ family }
+
diff --git a/src/Sproxy/Application/OAuth2/Common.hs b/src/Sproxy/Application/OAuth2/Common.hs
index 07fb759..0324e62 100644
--- a/src/Sproxy/Application/OAuth2/Common.hs
+++ b/src/Sproxy/Application/OAuth2/Common.hs
@@ -8,6 +8,7 @@ module Sproxy.Application.OAuth2.Common (
 import Control.Applicative (empty)
 import Data.Aeson (FromJSON, parseJSON, Value(Object), (.:))
 import Data.ByteString(ByteString)
+import Data.Text (Text)
 
 import Sproxy.Application.Cookie (AuthUser)
 
@@ -29,7 +30,7 @@ type OAuth2Provider = (ByteString, ByteString) -> OAuth2Client
 --   and expires_in because we don't use them, *and* expires_in creates troubles:
 --   it's an integer from Google and string from LinkedIn (sic!)
 data AccessTokenBody = AccessTokenBody {
-  accessToken :: String
+  accessToken :: Text
 } deriving (Eq, Show)
 
 instance FromJSON AccessTokenBody where
diff --git a/src/Sproxy/Application/OAuth2/Google.hs b/src/Sproxy/Application/OAuth2/Google.hs
index 6b68f44..5a1834c 100644
--- a/src/Sproxy/Application/OAuth2/Google.hs
+++ b/src/Sproxy/Application/OAuth2/Google.hs
@@ -9,12 +9,13 @@ import Control.Exception (Exception, throwIO)
 import Data.Aeson (FromJSON, decode, parseJSON, Value(Object), (.:))
 import Data.ByteString.Lazy (ByteString)
 import Data.Monoid ((<>))
+import Data.Text (Text, unpack)
 import Data.Typeable (Typeable)
 import Network.HTTP.Types (hContentType)
 import Network.HTTP.Types.URI (urlEncode)
 import qualified Network.HTTP.Conduit as H
 
-import Sproxy.Application.Cookie (AuthUser(..))
+import Sproxy.Application.Cookie (newUser, setFamilyName, setGivenName)
 import Sproxy.Application.OAuth2.Common (AccessTokenBody(accessToken), OAuth2Client(..), OAuth2Provider)
 
 
@@ -48,11 +49,13 @@ provider (client_id, client_secret) =
       case decode $ H.responseBody tresp of
         Nothing -> throwIO $ GoogleException tresp
         Just atResp -> do
-          ureq  <- H.parseRequest $ "https://www.googleapis.com/oauth2/v1/userinfo?access_token=" ++ accessToken atResp
+          ureq  <- H.parseRequest $ unpack ("https://www.googleapis.com/oauth2/v1/userinfo?access_token=" <> accessToken atResp)
           uresp <- H.httpLbs ureq mgr
           case decode $ H.responseBody uresp of
             Nothing -> throwIO $ GoogleException uresp
-            Just u -> return AuthUser { auEmail = email u, auGivenName = givenName u, auFamilyName = familyName u }
+            Just u -> return $ setFamilyName (familyName u) $
+                               setGivenName (givenName u) $
+                               newUser (email u)
   }
 
 
@@ -64,9 +67,9 @@ instance Exception GoogleException
 
 
 data GoogleUserInfo = GoogleUserInfo {
-  email :: String
-, givenName :: String
-, familyName :: String
+  email :: Text
+, givenName :: Text
+, familyName :: Text
 } deriving (Eq, Show)
 
 instance FromJSON GoogleUserInfo where
diff --git a/src/Sproxy/Application/OAuth2/LinkedIn.hs b/src/Sproxy/Application/OAuth2/LinkedIn.hs
index b60afde..b35c566 100644
--- a/src/Sproxy/Application/OAuth2/LinkedIn.hs
+++ b/src/Sproxy/Application/OAuth2/LinkedIn.hs
@@ -7,15 +7,16 @@ module Sproxy.Application.OAuth2.LinkedIn (
 import Control.Applicative (empty)
 import Control.Exception (Exception, throwIO)
 import Data.Aeson (FromJSON, decode, parseJSON, Value(Object), (.:))
-import Data.ByteString.Char8 (pack)
 import Data.ByteString.Lazy (ByteString)
 import Data.Monoid ((<>))
+import Data.Text (Text)
+import Data.Text.Encoding (encodeUtf8)
 import Data.Typeable (Typeable)
 import Network.HTTP.Types (hContentType)
 import Network.HTTP.Types.URI (urlEncode)
 import qualified Network.HTTP.Conduit as H
 
-import Sproxy.Application.Cookie (AuthUser(..))
+import Sproxy.Application.Cookie (newUser, setFamilyName, setGivenName)
 import Sproxy.Application.OAuth2.Common (AccessTokenBody(accessToken), OAuth2Client(..), OAuth2Provider)
 
 
@@ -50,14 +51,14 @@ provider (client_id, client_secret) =
         Just atResp -> do
           let ureq = (H.parseRequest_ "https://api.linkedin.com/v1/people/\
                 \~:(email-address,first-name,last-name)?format=json") {
-                  H.requestHeaders = [ ("Authorization", "Bearer " <> pack (accessToken atResp)) ]
+                  H.requestHeaders = [ ("Authorization", "Bearer " <> encodeUtf8 (accessToken atResp)) ]
                 }
           uresp <- H.httpLbs ureq mgr
           case decode $ H.responseBody uresp of
             Nothing -> throwIO $ LinkedInException uresp
-            Just u -> return AuthUser { auEmail = emailAddress u
-                                      , auGivenName = firstName u
-                                      , auFamilyName = lastName u }
+            Just u -> return $ setFamilyName (lastName u) $
+                               setGivenName (firstName u) $
+                               newUser (emailAddress u)
   }
 
 
@@ -69,9 +70,9 @@ instance Exception LinkedInException
 
 
 data LinkedInUserInfo = LinkedInUserInfo {
-  emailAddress :: String
-, firstName :: String
-, lastName :: String
+  emailAddress :: Text
+, firstName :: Text
+, lastName :: Text
 } deriving (Eq, Show)
 
 instance FromJSON LinkedInUserInfo where
diff --git a/src/Sproxy/Server/DB.hs b/src/Sproxy/Server/DB.hs
index b760afc..90e2abd 100644
--- a/src/Sproxy/Server/DB.hs
+++ b/src/Sproxy/Server/DB.hs
@@ -11,11 +11,9 @@ module Sproxy.Server.DB (
 import Control.Concurrent (forkIO, threadDelay)
 import Control.Exception (SomeException, bracket, catch, finally)
 import Control.Monad (forever, void)
-import Data.ByteString (ByteString)
 import Data.ByteString.Char8 (pack)
 import Data.Pool (Pool, createPool, withResource)
 import Data.Text (Text, toLower, unpack)
-import Data.Text.Encoding (encodeUtf8)
 import Database.SQLite.Simple (NamedParam((:=)))
 import Text.InterpolatedString.Perl6 (q, qc)
 import qualified Database.PostgreSQL.Simple as PG
@@ -52,7 +50,7 @@ start home ds = do
   return db
 
 
-userExists :: Database -> String -> IO Bool
+userExists :: Database -> Text -> IO Bool
 userExists db email = do
   r <- withResource db $ \c -> fmap SQLite.fromOnly <$> SQLite.queryNamed c
     "SELECT EXISTS (SELECT 1 FROM group_member WHERE :email LIKE email LIMIT 1)"
@@ -60,9 +58,9 @@ userExists db email = do
   return $ head r
 
 
-userGroups :: Database -> String -> Text -> Text -> Text -> IO [ByteString]
+userGroups :: Database -> Text -> Text -> Text -> Text -> IO [Text]
 userGroups db email domain path method =
-  withResource db $ \c -> fmap (encodeUtf8 . SQLite.fromOnly) <$> SQLite.queryNamed c [q|
+  withResource db $ \c -> fmap SQLite.fromOnly <$> SQLite.queryNamed c [q|
       SELECT gm."group" FROM group_privilege gp JOIN group_member gm ON gm."group"  = gp."group"
       WHERE :email LIKE gm.email
       AND :domain LIKE gp.domain