From bb31be8f6072e4dd72c8630c019f7ab5e0bc9fa9 Mon Sep 17 00:00:00 2001 From: Igor Pashev Date: Wed, 26 Jul 2017 21:09:57 +0300 Subject: [WIP] State in OAuth2 callback should be short-lived --- src/Sproxy/Application.hs | 77 +++++++++++++++++++++++++++-------------------- 1 file changed, 45 insertions(+), 32 deletions(-) (limited to 'src/Sproxy/Application.hs') diff --git a/src/Sproxy/Application.hs b/src/Sproxy/Application.hs index 3d6598f..2e273ab 100644 --- a/src/Sproxy/Application.hs +++ b/src/Sproxy/Application.hs @@ -9,6 +9,9 @@ module Sproxy.Application ( import Blaze.ByteString.Builder (toByteString) import Blaze.ByteString.Builder.ByteString (fromByteString) import Control.Exception (Exception, Handler(..), SomeException, catches, displayException) +import Control.Monad (mzero) +import Control.Monad.IO.Class (liftIO) +import Control.Monad.Trans.Maybe (MaybeT(..), runMaybeT) import Data.ByteString (ByteString) import Data.ByteString as BS (break, intercalate) import Data.ByteString.Char8 (pack, unpack) @@ -36,7 +39,6 @@ import Network.HTTP.Types.Status ( Status(..), badGateway502, badRequest400, for import Network.Socket (NameInfoFlag(NI_NUMERICHOST), getNameInfo) import Network.Wai.Conduit (sourceRequestBody, responseSource) import System.FilePath.Glob (Pattern, match) -import System.Posix.Time (epochTime) import Text.InterpolatedString.Perl6 (qc) import Web.Cookie (Cookies, parseCookies, renderCookies) import qualified Data.Aeson as JSON @@ -44,7 +46,7 @@ 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, +import Sproxy.Application.Cookie (AuthUser, cookieDecode, cookieEncode, getEmail, getEmailUtf8, getFamilyNameUtf8, getGivenNameUtf8 ) import Sproxy.Application.OAuth2.Common (OAuth2Client(..)) @@ -90,17 +92,15 @@ sproxy key db oa2 backends = logException $ \req resp -> do Nothing -> notFound "OAuth2 provider" req resp Just oa2c -> get (oauth2callback key db (provider, oa2c) be) req resp - ["access"] -> do - now <- Just <$> epochTime - case extractCookie key now cookieName req of + ["access"] -> + extractCookie key cookieName req >>= \case Nothing -> authenticationRequired key oa2 req resp Just (authCookie, _) -> post (checkAccess db authCookie) req resp _ -> notFound "proxy" req resp - _ -> do - now <- Just <$> epochTime - case extractCookie key now cookieName req of + _ -> + extractCookie key cookieName req >>= \case Nothing -> authenticationRequired key oa2 req resp Just cs@(authCookie, _) -> authorize db cs req >>= \case @@ -122,7 +122,7 @@ oauth2callback key db (provider, oa2c) be req resp = case param "state" of Nothing -> badRequest "missing auth state" req resp Just state -> - case State.decode key state of + State.decode key state >>= \case Left msg -> badRequest ("invalid state: " ++ msg) req resp Right path -> do au <- oauth2Authenticate oa2c code (redirectURL req provider) @@ -138,8 +138,24 @@ oauth2callback key db (provider, oa2c) be req resp = -- XXX: RFC6265: the user agent MUST NOT attach more than one Cookie header field -extractCookie :: ByteString -> Maybe CTime -> ByteString -> W.Request -> Maybe (AuthCookie, Cookies) -extractCookie key now name req = do +extractCookie :: ByteString -> ByteString -> W.Request -> IO (Maybe (AuthUser, Cookies)) +extractCookie key name req = runMaybeT $ do + (_, cookies) <- findCookieHeader + (auth, others) <- discriminate cookies + liftIO $ cookieDecode key auth >>= \case + Left err -> do + Log.debug ("extract cookie: " ++ show err) + mzero + Right user -> return (user, others) + + where + findCookieHeader = + MaybeT . return $ find ((==) hCookie . fst) (W.requestHeaders req) + discriminate cs = + case partition ((==) name . fst) $ parseCookies cs of + ((_, x):_, xs) -> return (x, xs) + _ -> mzero +{- (_, cookies) <- find ((==) hCookie . fst) $ W.requestHeaders req (auth, others) <- discriminate cookies case cookieDecode key auth of @@ -150,21 +166,19 @@ extractCookie key now name req = do case partition ((==) name . fst) $ parseCookies cs of ((_, x):_, xs) -> Just (x, xs) _ -> Nothing - +-} authenticate :: ByteString -> BackendConf -> AuthUser -> ByteString -> W.Application authenticate key be user path req resp = do - now <- epochTime + (authCookie, expiry) <- cookieEncode key (beCookieMaxAge be) user let domain = pack <$> beCookieDomain be - expiry = now + CTime (beCookieMaxAge be) - authCookie = AuthCookie { acUser = user, acExpiry = expiry } cookie = WC.def { WC.setCookieName = pack $ beCookieName be , WC.setCookieHttpOnly = True , WC.setCookiePath = Just "/" , WC.setCookieSameSite = Nothing , WC.setCookieSecure = True - , WC.setCookieValue = cookieEncode key authCookie + , WC.setCookieValue = authCookie , WC.setCookieDomain = domain , WC.setCookieExpires = Just . posixSecondsToUTCTime . realToFrac $ expiry } @@ -174,10 +188,9 @@ authenticate key be user path req resp = do ] "" -authorize :: Database -> (AuthCookie, Cookies) -> W.Request -> IO (Maybe W.Request) -authorize db (authCookie, otherCookies) req = do +authorize :: Database -> (AuthUser, Cookies) -> W.Request -> IO (Maybe W.Request) +authorize db (user, otherCookies) req = do let - user = acUser authCookie domain = decodeUtf8 . fromJust $ requestDomain req email = getEmail user emailUtf8 = getEmailUtf8 user @@ -206,9 +219,9 @@ authorize db (authCookie, otherCookies) req = do setCookies cs = insert hCookie (toByteString . renderCookies $ cs) -checkAccess :: Database -> AuthCookie -> W.Application -checkAccess db authCookie req resp = do - let email = getEmail . acUser $ authCookie +checkAccess :: Database -> AuthUser -> W.Application +checkAccess db user req resp = do + let email = getEmail user domain = decodeUtf8 . fromJust $ requestDomain req body <- W.strictRequestBody req case JSON.eitherDecode' body of @@ -275,12 +288,11 @@ modifyResponseHeaders = filter (\(n, _) -> n `notElem` ban) authenticationRequired :: ByteString -> HashMap Text OAuth2Client -> W.Application authenticationRequired key oa2 req resp = do Log.info $ "511 Unauthenticated: " ++ showReq req - resp $ W.responseLBS networkAuthenticationRequired511 [(hContentType, "text/html; charset=utf-8")] page - where - path = if W.requestMethod req == methodGet - then W.rawPathInfo req <> W.rawQueryString req - else "/" - state = State.encode key path + (state, _) <- State.encode key 60 + (if W.requestMethod req == methodGet + then W.rawPathInfo req <> W.rawQueryString req + else "/") + let authLink :: Text -> OAuth2Client -> ByteString -> ByteString authLink provider oa2c html = let u = oauth2AuthorizeURL oa2c state (redirectURL req provider) @@ -300,14 +312,15 @@ authenticationRequired key oa2 req resp = do |] + resp $ W.responseLBS networkAuthenticationRequired511 [(hContentType, "text/html; charset=utf-8")] page -forbidden :: AuthCookie -> W.Application -forbidden ac req resp = do +forbidden :: AuthUser -> W.Application +forbidden user req resp = do Log.info $ "403 Forbidden: " ++ show email ++ ": " ++ showReq req resp $ W.responseLBS forbidden403 [(hContentType, "text/html; charset=utf-8")] page where - email = getEmailUtf8 . acUser $ ac + email = getEmailUtf8 user page = fromStrict [qc| @@ -349,7 +362,7 @@ userNotFound au _ resp = do logout :: ByteString -> ByteString -> Maybe ByteString -> W.Application logout key cookieName cookieDomain req resp = do let host = fromJust $ W.requestHeaderHost req - case extractCookie key Nothing cookieName req of + extractCookie key cookieName req >>= \case Nothing -> resp $ W.responseLBS found302 [ (hLocation, "https://" <> host) ] "" Just _ -> do let cookie = WC.def { -- cgit v1.2.3