aboutsummaryrefslogtreecommitdiff
path: root/src/Sproxy/Application.hs
diff options
context:
space:
mode:
Diffstat (limited to 'src/Sproxy/Application.hs')
-rw-r--r--src/Sproxy/Application.hs77
1 files changed, 45 insertions, 32 deletions
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
</body>
</html>
|]
+ 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|
<!DOCTYPE html>
<html lang="en">
@@ -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 {
generated by cgit v1.2.3 (git 2.39.1) at 2024-04-27 02:20:53 +0000