[WIP] State in OAuth2 callback should be short-livedstate

4 files changed, 78 insertions, 65 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 {
diff --git a/src/Sproxy/Application/Cookie.hs b/src/Sproxy/Application/Cookie.hs
index a86f42a..5bd15ef 100644
--- a/src/Sproxy/Application/Cookie.hs
+++ b/src/Sproxy/Application/Cookie.hs
@@ -1,7 +1,6 @@
 {-# LANGUAGE OverloadedStrings #-}
 module Sproxy.Application.Cookie (
-  AuthCookie(..)
-, AuthUser
+  AuthUser
 , cookieDecode
 , cookieEncode
 , getEmail
@@ -16,7 +15,7 @@ module Sproxy.Application.Cookie (
 import Data.ByteString (ByteString)
 import Data.Text (Text, toLower, strip)
 import Data.Text.Encoding (decodeUtf8, encodeUtf8)
-import Foreign.C.Types (CTime(..))
+import Foreign.C.Types (CTime)
 import qualified Data.Serialize as DS
 
 import qualified Sproxy.Application.State as State
@@ -27,28 +26,20 @@ data AuthUser = AuthUser {
 , auFamilyName :: ByteString
 }
 
-data AuthCookie = AuthCookie {
-  acUser   :: AuthUser
-, acExpiry :: CTime
-}
-
-instance DS.Serialize AuthCookie where
-  put c = DS.put (auEmail u, auGivenName u, auFamilyName u, x)
-          where u = acUser c
-                x = (\(CTime i) -> i) $ acExpiry c
+instance DS.Serialize AuthUser where
+  put u = DS.put (auEmail u, auGivenName u, auFamilyName u)
   get = do
-    (e, n, f, x) <- DS.get
-    return AuthCookie {
-        acUser = AuthUser { auEmail = e, auGivenName = n, auFamilyName = f }
-      , acExpiry = CTime x
-      }
+    (e, n, f) <- DS.get
+    return AuthUser { auEmail = e, auGivenName = n, auFamilyName = f }
 
 
-cookieDecode :: ByteString -> ByteString -> Either String AuthCookie
-cookieDecode key d = State.decode key d >>= DS.decode
+cookieDecode :: ByteString -> ByteString -> IO (Either String AuthUser)
+cookieDecode key d = do
+  c <- State.decode key d
+  return $ c >>= DS.decode
 
-cookieEncode :: ByteString -> AuthCookie -> ByteString
-cookieEncode key = State.encode key . DS.encode
+cookieEncode :: ByteString -> Int -> AuthUser -> IO (ByteString, CTime)
+cookieEncode key shelflife = State.encode key (fromIntegral shelflife) . DS.encode
 
 
 getEmail :: AuthUser -> Text
diff --git a/src/Sproxy/Application/State.hs b/src/Sproxy/Application/State.hs
index 29d9252..8ddbedf 100644
--- a/src/Sproxy/Application/State.hs
+++ b/src/Sproxy/Application/State.hs
@@ -6,6 +6,8 @@ module Sproxy.Application.State (
 import Data.ByteString (ByteString)
 import Data.ByteString.Lazy (fromStrict, toStrict)
 import Data.Digest.Pure.SHA (hmacSha1, bytestringDigest)
+import Foreign.C.Types (CTime(..))
+import System.Posix.Time (epochTime)
 import qualified Data.ByteString.Base64 as Base64
 import qualified Data.Serialize as DS
 
@@ -13,16 +15,24 @@ import qualified Data.Serialize as DS
 -- FIXME: Compress / decompress ?
 
 
-encode :: ByteString -> ByteString -> ByteString
-encode key payload = Base64.encode . DS.encode $ (payload, digest key payload)
-
-
-decode :: ByteString -> ByteString -> Either String ByteString
-decode key d = do
-  (payload, dgst) <- DS.decode =<< Base64.decode d
-  if dgst /= digest key payload
-  then Left "junk"
-  else Right payload
+encode :: ByteString -> Int -> ByteString -> IO (ByteString, CTime)
+encode key shelflife payload = do
+  now <- epochTime
+  let expiry = now + (CTime . fromIntegral $ shelflife)
+      d = DS.encode (payload, (\(CTime i64) -> i64) expiry)
+  return (Base64.encode . DS.encode $ (d, digest key d), expiry)
+
+
+decode :: ByteString -> ByteString -> IO (Either String ByteString)
+decode key raw = do
+  (CTime now) <- epochTime
+  return $ do
+      (d, dgst) <- DS.decode =<< Base64.decode raw
+      if dgst /= digest key d then Left "junk"
+      else do
+        (payload, expiry) <- DS.decode d
+        if expiry < now then Left "expired"
+                        else Right payload
   
 
 digest :: ByteString -> ByteString -> ByteString
diff --git a/src/Sproxy/Config.hs b/src/Sproxy/Config.hs
index e0f35a3..b011680 100644
--- a/src/Sproxy/Config.hs
+++ b/src/Sproxy/Config.hs
@@ -8,7 +8,6 @@ module Sproxy.Config (
 import Control.Applicative (empty)
 import Data.Aeson (FromJSON, parseJSON)
 import Data.HashMap.Strict (HashMap)
-import Data.Int (Int64)
 import Data.Text (Text)
 import Data.Word (Word16)
 import Data.Yaml (Value(Object), (.:), (.:?), (.!=))
@@ -64,7 +63,7 @@ data BackendConf = BackendConf {
 , beSocket       :: Maybe FilePath
 , beCookieName   :: String
 , beCookieDomain :: Maybe String
-, beCookieMaxAge :: Int64
+, beCookieMaxAge :: Int
 , beConnCount    :: Int
 } deriving (Show)