diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,10 @@ +# 0.2.0.0 +======== + +* Drop compatiblity with hoauth2 versions <= 1.0.0. +* Add a function for getting the oauth2 token from an authenticated request. +* Modify encoding of oauth2 session cookies. As a consequence existing cookies will be invalid. + 0.1.2.1 ======= diff --git a/src/Network/Wai/Auth/ClientSession.hs b/src/Network/Wai/Auth/ClientSession.hs --- a/src/Network/Wai/Auth/ClientSession.hs +++ b/src/Network/Wai/Auth/ClientSession.hs @@ -3,6 +3,7 @@ module Network.Wai.Auth.ClientSession ( loadCookieValue , saveCookieValue + , deleteCookieValue , Key , getDefaultKey ) where @@ -15,6 +16,8 @@ import qualified Data.ByteString.Lazy as L import Data.Int (Int64) import Data.Maybe (listToMaybe) +import Data.Time.Clock (UTCTime(UTCTime)) +import Data.Time.Calendar (fromGregorian) import Foreign.C.Types (CTime (..)) import GHC.Generics (Generic) import Network.HTTP.Types (Header) @@ -23,9 +26,9 @@ import Web.ClientSession (Key, decrypt, encryptIO, getDefaultKey) import Web.Cookie (def, parseCookies, renderSetCookie, - setCookieHttpOnly, setCookieMaxAge, - setCookieName, setCookiePath, - setCookieValue) + setCookieExpires, setCookieHttpOnly, + setCookieMaxAge, setCookieName, + setCookiePath, setCookieValue) data Wrapper value = Wrapper { contained :: value @@ -78,4 +81,19 @@ , setCookiePath = Just "/" , setCookieHttpOnly = True , setCookieMaxAge = Just $ fromIntegral age + }) + +deleteCookieValue + :: S.ByteString -- ^ cookie name + -> Header +deleteCookieValue name = + ( "Set-Cookie" + , toByteString $ + renderSetCookie + def + { setCookieName = name + , setCookieValue = "" + , setCookiePath = Just "/" + , setCookieHttpOnly = True + , setCookieExpires = Just $ UTCTime (fromGregorian 1970 01 01) 0 }) diff --git a/src/Network/Wai/Auth/Internal.hs b/src/Network/Wai/Auth/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Network/Wai/Auth/Internal.hs @@ -0,0 +1,26 @@ +module Network.Wai.Auth.Internal + ( OAuth2TokenBinary(..) + ) where + +import Data.Binary (Binary(get, put)) +import qualified Network.OAuth.OAuth2 as OA2 + +newtype OAuth2TokenBinary = + OAuth2TokenBinary { unOAuth2TokenBinary :: OA2.OAuth2Token } + deriving (Show) + +instance Binary OAuth2TokenBinary where + put (OAuth2TokenBinary token) = do + put $ OA2.atoken $ OA2.accessToken token + put $ OA2.rtoken <$> OA2.refreshToken token + put $ OA2.expiresIn token + put $ OA2.tokenType token + put $ OA2.idtoken <$> OA2.idToken token + get = do + accessToken <- OA2.AccessToken <$> get + refreshToken <- fmap OA2.RefreshToken <$> get + expiresIn <- get + tokenType <- get + idToken <- fmap OA2.IdToken <$> get + pure $ OAuth2TokenBinary $ + OA2.OAuth2Token accessToken refreshToken expiresIn tokenType idToken diff --git a/src/Network/Wai/Middleware/Auth.hs b/src/Network/Wai/Middleware/Auth.hs --- a/src/Network/Wai/Middleware/Auth.hs +++ b/src/Network/Wai/Middleware/Auth.hs @@ -21,6 +21,7 @@ , smartAppRoot , waiMiddlewareAuthVersion , getAuthUser + , getDeleteSessionHeader ) where import Blaze.ByteString.Builder (fromByteString) @@ -37,8 +38,9 @@ import Data.Version (Version) import Foreign.C.Types (CTime (..)) import GHC.Generics (Generic) -import Network.HTTP.Types (status200, status303, - status404, status501) +import Network.HTTP.Types (Header, status200, + status303, status404, + status501) import Network.Wai (Middleware, Request, pathInfo, rawPathInfo, rawQueryString, @@ -221,13 +223,13 @@ onFailure status501 "Empty user identity is not allowed" - onSuccess userIdentity = do + onSuccess authLoginState = do CTime now <- epochTime cookie <- saveAuthState $ AuthLoggedIn $ AuthUser - { authUserIdentity = userIdentity + { authLoginState = authLoginState , authProviderName = encodeUtf8 $ getProviderName provider , authLoginTime = fromIntegral now @@ -252,6 +254,7 @@ providerUrlRenderer onSuccess onFailure + ["health"] -> respond $ responseLBS status200 [] "OK" _ -> respond $ responseLBS status404 [] "Unknown URL" -- Workaround for Chrome asking for favicon.ico, causing a wrong -- redirect url to be stored in a cookie. @@ -296,3 +299,8 @@ waiMiddlewareAuthVersion :: Version waiMiddlewareAuthVersion = Paths.version +-- | Get a response header to delete the users current session. +-- +-- @since 0.2.0 +getDeleteSessionHeader :: AuthSettings -> Header +getDeleteSessionHeader = deleteCookieValue . asStateKey diff --git a/src/Network/Wai/Middleware/Auth/OAuth2.hs b/src/Network/Wai/Middleware/Auth/OAuth2.hs --- a/src/Network/Wai/Middleware/Auth/OAuth2.hs +++ b/src/Network/Wai/Middleware/Auth/OAuth2.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TemplateHaskell #-} @@ -8,8 +7,10 @@ , oAuth2Parser , URIParseException(..) , parseAbsoluteURI + , getAccessToken ) where +import Data.Binary (encode, decode) import Control.Monad.Catch import Data.Aeson.TH (defaultOptions, deriveJSON, @@ -20,23 +21,21 @@ import Data.Monoid ((<>)) import Data.Proxy (Proxy (..)) import qualified Data.Text as T -import Data.Text.Encoding (encodeUtf8) +import Data.Text.Encoding (encodeUtf8, + decodeUtf8With) +import Data.Text.Encoding.Error (lenientDecode) import Network.HTTP.Client.TLS (getGlobalManager) import Network.HTTP.Types (status303, status403, status404, status501) import qualified Network.OAuth.OAuth2 as OA2 -import Network.Wai (queryString, responseLBS) +import Network.Wai (Request, queryString, + responseLBS) +import Network.Wai.Auth.Internal (OAuth2TokenBinary(..)) import Network.Wai.Auth.Tools (toLowerUnderscore) +import qualified Network.Wai.Middleware.Auth as MA import Network.Wai.Middleware.Auth.Provider import qualified URI.ByteString as U - -#if MIN_VERSION_hoauth2(1,0,0) -import Data.Text.Encoding (decodeUtf8With) -import Data.Text.Encoding.Error (lenientDecode) import URI.ByteString (URI) -#else -type URI = OA2.URI -#endif -- | General OAuth2 authentication `Provider`. data OAuth2 = OAuth2 @@ -66,9 +65,6 @@ Left err -> throwM $ URIParseException err Right url -> return url - -#if MIN_VERSION_hoauth2(1,0,0) - parseAbsoluteURI' :: MonadThrow m => T.Text -> m U.URI parseAbsoluteURI' = parseAbsoluteURI @@ -88,34 +84,10 @@ getRedirectURI :: U.URIRef a -> S.ByteString getRedirectURI = U.serializeURIRef' -getAccessToken :: OA2.OAuth2Token -> S.ByteString -getAccessToken = encodeUtf8 . OA2.atoken . OA2.accessToken +encodeAccessToken :: OA2.OAuth2Token -> S.ByteString +encodeAccessToken = SL.toStrict . encode . OAuth2TokenBinary -#else -parseAbsoluteURI' :: MonadThrow m => T.Text -> m URI -parseAbsoluteURI' urlTxt = U.serializeURIRef' <$> parseAbsoluteURI urlTxt - -getExchangeToken :: S.ByteString -> S.ByteString -getExchangeToken = id - -appendQueryParams :: URI -> [(S.ByteString, S.ByteString)] -> URI -appendQueryParams uri params = OA2.appendQueryParam uri params - -getClientId :: T.Text -> S.ByteString -getClientId = encodeUtf8 - -getClientSecret :: T.Text -> S.ByteString -getClientSecret = encodeUtf8 - -getRedirectURI :: URI -> S.ByteString -getRedirectURI = id - -getAccessToken :: OA2.AccessToken -> S.ByteString -getAccessToken = OA2.accessToken - -#endif - -- | Aeson parser for `OAuth2` provider. -- -- @since 0.1.0 @@ -159,7 +131,7 @@ eRes <- OA2.fetchAccessToken man oauth2 $ getExchangeToken code case eRes of Left err -> onFailure status501 $ S8.pack $ show err - Right token -> onSuccess $ getAccessToken token + Right token -> onSuccess $ encodeAccessToken token _ -> case lookup "error" params of (Just (Just "access_denied")) -> @@ -180,3 +152,14 @@ $(deriveJSON defaultOptions { fieldLabelModifier = toLowerUnderscore . drop 3} ''OAuth2) + +-- | Get the @AccessToken@ for the current user. +-- +-- If called on a @Request@ behind the middleware, should always return a +-- @Just@ value. +-- +-- @since 0.2.0.0 +getAccessToken :: Request -> Maybe OA2.OAuth2Token +getAccessToken req = do + user <- MA.getAuthUser req + unOAuth2TokenBinary <$> decode (SL.fromStrict (authLoginState user)) diff --git a/src/Network/Wai/Middleware/Auth/Provider.hs b/src/Network/Wai/Middleware/Auth/Provider.hs --- a/src/Network/Wai/Middleware/Auth/Provider.hs +++ b/src/Network/Wai/Middleware/Auth/Provider.hs @@ -17,7 +17,9 @@ , parseProviders -- * User , AuthUser(..) + , AuthLoginState , UserIdentity + , authUserIdentity -- * Template , mkRouteRender , providersTemplate @@ -71,7 +73,7 @@ -- \@?{(ProviderUrl ["login", "complete"], [("user", "Hamlet")])} -- @ -- --- * @(`UserIdentity` -> `IO` `Response`)@ - Action to call on a successfull login. +-- * @(`AuthLoginState` -> `IO` `Response`)@ - Action to call on a successfull login. -- * @(`Status` -> `S.ByteString` -> `IO` `Response`)@ - Should be called in case of -- a failure with login process by supplying a -- status and a short error message. @@ -100,7 +102,7 @@ -> Request -> [T.Text] -> Render ProviderUrl - -> (UserIdentity -> IO Response) + -> (AuthLoginState -> IO Response) -> (Status -> S.ByteString -> IO Response) -> IO Response @@ -137,12 +139,19 @@ } deriving (Show) --- | An arbitrary user identifer, eg. a username or an email address. +-- | An arbitrary state that comes with logged in user, eg. a username, token or an email address. +type AuthLoginState = S.ByteString + type UserIdentity = S.ByteString +{-# DEPRECATED UserIdentity "In favor of `AuthLoginState`" #-} +authUserIdentity :: AuthUser -> UserIdentity +authUserIdentity = authLoginState +{-# DEPRECATED authUserIdentity "In favor of `authLoginState`" #-} + -- | Representation of a user for a particular `Provider`. data AuthUser = AuthUser - { authUserIdentity :: !UserIdentity + { authLoginState :: !UserIdentity , authProviderName :: !S.ByteString , authLoginTime :: !Int64 } deriving (Generic, Show) diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 --- /dev/null +++ b/test/Main.hs @@ -0,0 +1,49 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE OverloadedStrings #-} + +module Main (main) where + +import Data.Binary (encode, decode) +import qualified Data.Text as T +import Hedgehog +import Hedgehog.Gen as Gen +import Hedgehog.Range as Range +import Network.Wai.Auth.Internal (OAuth2TokenBinary(..)) +import qualified Network.OAuth.OAuth2.Internal as OA2 + +main :: IO Bool +main = + checkParallel $ Group "Main" [ + ("oAuth2TokenBinaryDuality", oAuth2TokenBinaryDuality) + ] + +oAuth2TokenBinaryDuality :: Property +oAuth2TokenBinaryDuality = property $ do + token <- forAll oauth2TokenBinary + tripping token encode (Just . decode) + +oauth2TokenBinary :: Gen OAuth2TokenBinary +oauth2TokenBinary = do + accessToken <- OA2.AccessToken <$> anyText + refreshToken <- Gen.maybe $ OA2.RefreshToken <$> anyText + expiresIn <- Gen.maybe $ Gen.int (Range.linear 0 1000) + tokenType <- Gen.maybe $ anyText + idToken <- Gen.maybe $ OA2.IdToken <$> anyText + pure $ OAuth2TokenBinary $ + OA2.OAuth2Token accessToken refreshToken expiresIn tokenType idToken + +anyText :: Gen T.Text +anyText = Gen.text (Range.linear 0 100) Gen.unicodeAll + +-- The `OAuth2Token` type from the `hoauth2` library does not have a `Eq` +-- instance, and it's constituent parts don't have a `Generic` instance. Hence +-- this orphan instance here. +instance Eq OAuth2TokenBinary where + (OAuth2TokenBinary t1) == (OAuth2TokenBinary t2) = + all id + [ OA2.atoken (OA2.accessToken t1) == OA2.atoken (OA2.accessToken t2) + , (OA2.rtoken <$> OA2.refreshToken t1) == (OA2.rtoken <$> OA2.refreshToken t2) + , OA2.expiresIn t1 == OA2.expiresIn t2 + , OA2.tokenType t1 == OA2.tokenType t2 + , (OA2.idtoken <$> OA2.idToken t1) == (OA2.idtoken <$> OA2.idToken t2) + ] diff --git a/wai-middleware-auth.cabal b/wai-middleware-auth.cabal --- a/wai-middleware-auth.cabal +++ b/wai-middleware-auth.cabal @@ -1,7 +1,8 @@ +cabal-version: 1.18 name: wai-middleware-auth -version: 0.1.2.1 +version: 0.2.0.0 synopsis: Authentication middleware that secures WAI application -description: See README +description: Please see the README and Haddocks at license: MIT license-file: LICENSE author: Alexey Kuleshevich @@ -9,7 +10,6 @@ category: Web build-type: Simple extra-doc-files: README.md CHANGELOG.md -cabal-version: >=1.10 library exposed-modules: Network.Wai.Middleware.Auth @@ -18,6 +18,7 @@ Network.Wai.Middleware.Auth.OAuth2.Google Network.Wai.Middleware.Auth.Provider Network.Wai.Auth.Executable + Network.Wai.Auth.Internal other-modules: Paths_wai_middleware_auth Network.Wai.Auth.AppRoot Network.Wai.Auth.Config @@ -35,7 +36,7 @@ , clientsession , cookie , exceptions - , hoauth2 >= 0.5.0 + , hoauth2 >= 1.0 , http-client , http-client-tls , http-conduit @@ -45,6 +46,7 @@ , safe-exceptions , shakespeare , text + , time , unix-compat , unordered-containers , uri-bytestring @@ -68,6 +70,19 @@ , optparse-simple , wai-middleware-auth , warp + ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N + +test-suite spec + default-language: Haskell2010 + type: exitcode-stdio-1.0 + main-is: Main.hs + hs-source-dirs: test + build-depends: base + , binary + , hedgehog + , hoauth2 + , text + , wai-middleware-auth ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N source-repository head