sproxy2 1.90.1 → 1.90.2
raw patch · 10 files changed
+157/−77 lines, 10 files
Files
- ChangeLog.md +14/−0
- README.md +4/−1
- sproxy2.cabal +1/−1
- src/Sproxy/Application.hs +70/−47
- src/Sproxy/Application/Cookie.hs +40/−5
- src/Sproxy/Application/OAuth2/Common.hs +2/−1
- src/Sproxy/Application/OAuth2/Google.hs +9/−6
- src/Sproxy/Application/OAuth2/LinkedIn.hs +10/−9
- src/Sproxy/Server.hs +4/−2
- src/Sproxy/Server/DB.hs +3/−5
ChangeLog.md view
@@ -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 ======
README.md view
@@ -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
sproxy2.cabal view
@@ -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
src/Sproxy/Application.hs view
@@ -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| <!DOCTYPE html> <html lang="en">@@ -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| <!DOCTYPE html> <html lang="en">@@ -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
src/Sproxy/Application/Cookie.hs view
@@ -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 }
src/Sproxy/Application/OAuth2/Common.hs view
@@ -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
src/Sproxy/Application/OAuth2/Google.hs view
@@ -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
src/Sproxy/Application/OAuth2/LinkedIn.hs view
@@ -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
src/Sproxy/Server.hs view
@@ -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.
src/Sproxy/Server/DB.hs view
@@ -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