diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,6 +1,20 @@ For differences with the original Sproxy scroll down. +1.90.2 +====== + + * Make sure all Sproxy-specific HTTP headers are UTF8-encoded. + + * `/.sproxy/logout` just redirects if no cookie. Previously + it was returning HTTP 404 to unauthenticated users, and redirecting + authenticated users with removal of the cookie. The point is not to + reveal cookie name. + + * Made Warp stop printing exceptions, mostly "client closed connection", + which happens outside of our traps. + + 1.90.1 ====== diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -126,9 +126,12 @@ HTTP headers passed to the back-end server ------------------------------------------ +All Sproxy headers are UTF8-encoded. + + header | value -------------------- | ----- -`From:` | visitor's email address +`From:` | visitor's email address, lower case `X-Groups:` | all groups that granted access to this resource, separated by commas (see the note below) `X-Given-Name:` | the visitor's given (first) name `X-Family-Name:` | the visitor's family (last) name diff --git a/sproxy2.cabal b/sproxy2.cabal --- a/sproxy2.cabal +++ b/sproxy2.cabal @@ -1,5 +1,5 @@ name: sproxy2 -version: 1.90.1 +version: 1.90.2 synopsis: Secure HTTP proxy for authenticating users via OAuth2 description: Sproxy is secure by default. No requests makes it to the backend diff --git a/src/Sproxy/Application.hs b/src/Sproxy/Application.hs --- a/src/Sproxy/Application.hs +++ b/src/Sproxy/Application.hs @@ -8,10 +8,9 @@ import Blaze.ByteString.Builder (toByteString) import Blaze.ByteString.Builder.ByteString (fromByteString) -import Control.Exception (SomeException, catch) +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.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) @@ -81,10 +82,7 @@ ["robots.txt"] -> get robots req resp (".sproxy":proxy) -> case proxy of - ["logout"] -> - case extractCookie key Nothing cookieName req of - Nothing -> notFound "logout without the cookie" req resp - Just _ -> get (logout cookieName cookieDomain) req resp + ["logout"] -> get (logout key cookieName cookieDomain) req resp ["oauth2", provider] -> case HM.lookup provider oa2 of Nothing -> notFound "OAuth2 provider" req resp @@ -118,11 +116,11 @@ 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 @@ -169,34 +167,39 @@ 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) +-- 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 @@ -232,15 +235,20 @@ , hTransferEncoding -- XXX Likewise ] + modifyResponseHeaders :: ResponseHeaders -> ResponseHeaders modifyResponseHeaders = filter (\(n, _) -> n `notElem` ban) where ban = [ hConnection - , hTransferEncoding -- XXX This is set automtically when sending respond from sproxy + -- 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 key oa2 req resp = do Log.info $ "511 Unauthenticated: " ++ showReq req @@ -273,10 +281,10 @@ 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| @@ -293,11 +301,12 @@ |] -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| @@ -314,23 +323,26 @@ |] -logout :: ByteString -> Maybe ByteString -> W.Application -logout name domain req resp = do +logout :: ByteString -> ByteString -> Maybe ByteString -> W.Application +logout key cookieName cookieDomain req resp = do let host = fromJust $ W.requestHeaderHost req - cookie = WC.def { - WC.setCookieName = name - , WC.setCookieHttpOnly = True - , WC.setCookiePath = Just "/" - , WC.setCookieSameSite = Just WC.sameSiteStrict - , WC.setCookieSecure = True - , WC.setCookieValue = "goodbye" - , WC.setCookieDomain = domain - , WC.setCookieExpires = Just . posixSecondsToUTCTime . realToFrac $ CTime 0 - } - resp $ W.responseLBS found302 [ - (hLocation, "https://" <> host) - , ("Set-Cookie", toByteString $ WC.renderSetCookie cookie) - ] "" + case extractCookie key Nothing cookieName req of + 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 + } + resp $ W.responseLBS found302 [ + (hLocation, "https://" <> host) + , ("Set-Cookie", toByteString $ WC.renderSetCookie cookie) + ] "" badRequest ::String -> W.Application @@ -346,9 +358,20 @@ logException :: W.Middleware -logException app req resp = catch (app req resp) $ \e -> do - Log.error $ "500 Internal Error: " ++ show (e :: SomeException) ++ " on " ++ showReq req - resp $ W.responseLBS internalServerError500 [] "Internal Error" +logException app req resp = + catches (app req resp) [ + Handler internalError + ] + where + internalError :: SomeException -> IO W.ResponseReceived + internalError = response internalServerError500 + + 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) + get :: W.Middleware diff --git a/src/Sproxy/Application/Cookie.hs b/src/Sproxy/Application/Cookie.hs --- 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 @@ 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 --- a/src/Sproxy/Application/OAuth2/Common.hs +++ b/src/Sproxy/Application/OAuth2/Common.hs @@ -8,6 +8,7 @@ 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 @@ -- 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 --- a/src/Sproxy/Application/OAuth2/Google.hs +++ b/src/Sproxy/Application/OAuth2/Google.hs @@ -9,12 +9,13 @@ 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 @@ 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 @@ 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 --- a/src/Sproxy/Application/OAuth2/LinkedIn.hs +++ b/src/Sproxy/Application/OAuth2/LinkedIn.hs @@ -7,15 +7,16 @@ 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 @@ 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 @@ 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.hs b/src/Sproxy/Server.hs --- a/src/Sproxy/Server.hs +++ b/src/Sproxy/Server.hs @@ -18,7 +18,8 @@ SocketOption(ReuseAddr), SocketType(Stream), bind, close, connect, inet_addr, listen, maxListenQueue, setSocketOption, socket ) import Network.Wai.Handler.WarpTLS (tlsSettingsChain, runTLSSocket) -import Network.Wai.Handler.Warp (defaultSettings, setHTTP2Disabled, runSettingsSocket) +import Network.Wai.Handler.Warp ( defaultSettings, runSettingsSocket, + setHTTP2Disabled, setOnException ) import System.Entropy (getEntropy) import System.Environment (setEnv) import System.Exit (exitFailure) @@ -96,7 +97,8 @@ let settings = - (if cfHTTP2 cf then id else setHTTP2Disabled) + (if cfHTTP2 cf then id else setHTTP2Disabled) $ + setOnException (\_ _ -> return ()) defaultSettings -- XXX 2048 is from bindPortTCP from streaming-commons used internally by runTLS. diff --git a/src/Sproxy/Server/DB.hs b/src/Sproxy/Server/DB.hs --- a/src/Sproxy/Server/DB.hs +++ b/src/Sproxy/Server/DB.hs @@ -11,11 +11,9 @@ 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 @@ 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 @@ 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