diff --git a/Happstack/Authenticate/Core.hs b/Happstack/Authenticate/Core.hs --- a/Happstack/Authenticate/Core.hs +++ b/Happstack/Authenticate/Core.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE DataKinds, DeriveDataTypeable, DeriveGeneric, FlexibleContexts, FlexibleInstances, GeneralizedNewtypeDeriving, MultiParamTypeClasses, RecordWildCards, ScopedTypeVariables, StandaloneDeriving, TemplateHaskell, TypeOperators, TypeFamilies, TypeSynonymInstances, UndecidableInstances, OverloadedStrings #-} +{-# LANGUAGE CPP, DataKinds, DeriveDataTypeable, DeriveGeneric, FlexibleContexts, FlexibleInstances, GeneralizedNewtypeDeriving, MultiParamTypeClasses, RecordWildCards, ScopedTypeVariables, StandaloneDeriving, TemplateHaskell, TypeOperators, TypeFamilies, TypeSynonymInstances, UndecidableInstances, OverloadedStrings #-} {- A user is uniquely identified by their 'UserId'. A user can have one @@ -135,7 +135,7 @@ import Data.Map (Map) import qualified Data.Map as Map import Data.Maybe (fromMaybe, maybeToList) -import Data.Monoid ((<>), mconcat) +import Data.Monoid ((<>), mconcat, mempty) import Data.SafeCopy (SafeCopy, base, deriveSafeCopy) import Data.IxSet.Typed import qualified Data.IxSet.Typed as IxSet @@ -156,12 +156,24 @@ import System.Random (randomRIO) import Text.Boomerang.TH (makeBoomerangs) import Text.Shakespeare.I18N (RenderMessage(renderMessage), mkMessageFor) -import Web.JWT (Algorithm(HS256), JWT, VerifiedJWT, JWTClaimsSet(..), encodeSigned, claims, decode, decodeAndVerifySignature, secondsSinceEpoch, intDate, secret, verify) +import Web.JWT (Algorithm(HS256), JWT, VerifiedJWT, JWTClaimsSet(..), encodeSigned, claims, decode, decodeAndVerifySignature, secondsSinceEpoch, intDate, verify) +#if MIN_VERSION_jwt(0,8,0) +import Web.JWT (ClaimsMap(..), hmacSecret) +#else +import Web.JWT (secret) +#endif + import Web.Routes (RouteT, PathInfo(..), nestURL) import Web.Routes.Boomerang import Web.Routes.Happstack () import Web.Routes.TH (derivePathInfo) +#if MIN_VERSION_jwt(0,8,0) +#else +unClaimsMap = id +#endif + + -- | when creating JSON field names, drop the first character. Since -- we are using lens, the leading character should always be _. jsonOptions :: Options @@ -626,13 +638,29 @@ do ssecret <- getOrGenSharedSecret authenticateState (user ^. userId) admin <- liftIO $ (authenticateConfig ^. isAuthAdmin) (user ^. userId) now <- liftIO getCurrentTime - let claims = def { exp = intDate $ utcTimeToPOSIXSeconds (addUTCTime (60*60*24*30) now) - , unregisteredClaims = + let claims = JWTClaimsSet + { iss = Nothing + , sub = Nothing + , aud = Nothing + , exp = intDate $ utcTimeToPOSIXSeconds (addUTCTime (60*60*24*30) now) + , nbf = Nothing + , iat = Nothing + , jti = Nothing + , unregisteredClaims = +#if MIN_VERSION_jwt(0,8,0) + ClaimsMap $ +#endif Map.fromList [ ("user" , toJSON user) , ("authAdmin", toJSON admin) ] - } + } +#if MIN_VERSION_jwt(0,10,0) + return $ encodeSigned (hmacSecret $ _unSharedSecret ssecret) mempty claims +#elif MIN_VERSION_jwt(0,9,0) + return $ encodeSigned (hmacSecret $ _unSharedSecret ssecret) claims +#else return $ encodeSigned HS256 (secret $ _unSharedSecret ssecret) claims +#endif -- | decode and verify the `TokenText`. If successful, return the -- `Token` otherwise `Nothing`. @@ -648,7 +676,7 @@ Nothing -> return Nothing (Just unverified) -> -- check that token has user claim - case Map.lookup "user" (unregisteredClaims (claims unverified)) of + case Map.lookup "user" (unClaimsMap (unregisteredClaims (claims unverified))) of Nothing -> return Nothing (Just uv) -> -- decode user json value @@ -661,7 +689,11 @@ Nothing -> return Nothing (Just ssecret) -> -- finally we can verify all the claims +#if MIN_VERSION_jwt(0,8,0) + case verify (hmacSecret (_unSharedSecret ssecret)) unverified of +#else case verify (secret (_unSharedSecret ssecret)) unverified of +#endif Nothing -> return Nothing (Just verified) -> -- check expiration case exp (claims verified) of @@ -670,7 +702,7 @@ (Just exp') -> if (utcTimeToPOSIXSeconds now) > (secondsSinceEpoch exp') then return Nothing - else case Map.lookup "authAdmin" (unregisteredClaims (claims verified)) of + else case Map.lookup "authAdmin" (unClaimsMap (unregisteredClaims (claims verified))) of Nothing -> return (Just (Token u False, verified)) (Just a) -> case fromJSON a of diff --git a/Happstack/Authenticate/Password/Core.hs b/Happstack/Authenticate/Password/Core.hs --- a/Happstack/Authenticate/Password/Core.hs +++ b/Happstack/Authenticate/Password/Core.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE DataKinds, DeriveDataTypeable, DeriveGeneric, FlexibleInstances, MultiParamTypeClasses, RecordWildCards, TemplateHaskell, TypeFamilies, TypeSynonymInstances, OverloadedStrings #-} +{-# LANGUAGE CPP, DataKinds, DeriveDataTypeable, DeriveGeneric, FlexibleInstances, MultiParamTypeClasses, RecordWildCards, TemplateHaskell, TypeFamilies, TypeSynonymInstances, OverloadedStrings #-} module Happstack.Authenticate.Password.Core where import Control.Applicative ((<$>), optional) @@ -20,7 +20,7 @@ import Data.Map (Map) import qualified Data.Map as Map import Data.Maybe (fromMaybe, fromJust) -import Data.Monoid ((<>)) +import Data.Monoid ((<>), mempty) import Data.SafeCopy (SafeCopy, base, deriveSafeCopy) import Data.Text (Text) import qualified Data.Text as Text @@ -41,10 +41,20 @@ import qualified Text.Email.Validate as Email import Text.Shakespeare.I18N (RenderMessage(..), Lang, mkMessageFor) import qualified Web.JWT as JWT -import Web.JWT (Algorithm(HS256), JWT, VerifiedJWT, JWTClaimsSet(..), encodeSigned, claims, decode, decodeAndVerifySignature, intDate, secret, secondsSinceEpoch, verify) +import Web.JWT (Algorithm(HS256), JWT, VerifiedJWT, JWTClaimsSet(..), encodeSigned, claims, decode, decodeAndVerifySignature, intDate, secondsSinceEpoch, verify) +#if MIN_VERSION_jwt(0,8,0) +import Web.JWT (ClaimsMap(..), hmacSecret) +#else +import Web.JWT (secret) +#endif import Web.Routes import Web.Routes.TH +#if MIN_VERSION_jwt(0,8,0) +#else +unClaimsMap = id +#endif + ------------------------------------------------------------------------------ -- PasswordConfig ------------------------------------------------------------------------------ @@ -246,7 +256,7 @@ -> PasswordConfig -> Maybe (UserId, AccountURL) -> m (Either PasswordError UserId) --- handle new account creation via POST to /account +-- handle new account creation via POST to \/account -- FIXME: check that password and password confirmation match account authenticateState passwordState authenticateConfig passwordConfig Nothing = do method POST @@ -281,7 +291,7 @@ (False, Nothing) -> Nothing (_, Just email) -> if Email.isValid (Text.encodeUtf8 (email ^. unEmail)) then Nothing else Just $ CoreError InvalidEmail --- handle updates to /account//* +-- handle updates to '/account//*' account authenticateState passwordState authenticateConfig passwordConfig (Just (uid, url)) = case url of Password -> @@ -358,7 +368,7 @@ issueResetToken :: (MonadIO m) => AcidState AuthenticateState -> User - -> m (Either PasswordError JWT.JSON) + -> m (Either PasswordError Text) issueResetToken authenticateState user = case user ^. email of Nothing -> return (Left NoEmailAddress) @@ -366,10 +376,27 @@ do ssecret <- getOrGenSharedSecret authenticateState (user ^. userId) -- FIXME: add expiration time now <- liftIO getPOSIXTime - let claims = JWT.def { unregisteredClaims = Map.singleton "reset-password" (toJSON user) - , JWT.exp = intDate $ now + 60 - } + let claims = JWT.JWTClaimsSet + { JWT.iss = Nothing + , JWT.sub = Nothing + , JWT.aud = Nothing + , JWT.exp = intDate $ now + 60 + , JWT.nbf = Nothing + , JWT.iat = Nothing + , JWT.jti = Nothing + , JWT.unregisteredClaims = +#if MIN_VERSION_jwt(0,8,0) + JWT.ClaimsMap $ +#endif + Map.singleton "reset-password" (toJSON user) + } +#if MIN_VERSION_jwt(0,10,0) + return $ Right $ encodeSigned (hmacSecret $ _unSharedSecret ssecret) mempty claims +#elif MIN_VERSION_jwt(0,9,0) + return $ Right $ encodeSigned (hmacSecret $ _unSharedSecret ssecret) claims +#else return $ Right $ encodeSigned HS256 (secret $ _unSharedSecret ssecret) claims +#endif -- FIXME: I18N -- FIXME: call renderSendMail @@ -450,7 +477,7 @@ case mUnverified of Nothing -> return Nothing (Just unverified) -> - case Map.lookup "reset-password" (unregisteredClaims (claims unverified)) of + case Map.lookup "reset-password" (unClaimsMap (unregisteredClaims (claims unverified))) of Nothing -> return Nothing (Just uv) -> case fromJSON uv of @@ -460,7 +487,11 @@ case mssecret of Nothing -> return Nothing (Just ssecret) -> +#if MIN_VERSION_jwt(0,8,0) + case verify (hmacSecret (_unSharedSecret ssecret)) unverified of +#else case verify (secret (_unSharedSecret ssecret)) unverified of +#endif Nothing -> return Nothing (Just verified) -> do now <- liftIO getPOSIXTime diff --git a/happstack-authenticate.cabal b/happstack-authenticate.cabal --- a/happstack-authenticate.cabal +++ b/happstack-authenticate.cabal @@ -1,5 +1,5 @@ Name: happstack-authenticate -Version: 2.3.4.15 +Version: 2.3.4.16 Synopsis: Happstack Authentication Library Description: A themeable authentication library with support for username+password and OpenId. Homepage: http://www.happstack.com/ @@ -54,7 +54,7 @@ filepath >= 1.3 && < 1.5, hsx2hs >= 0.13 && < 0.15, jmacro >= 0.6.11 && < 0.7, - jwt >= 0.3 && < 0.8, + jwt >= 0.3 && < 0.11, ixset-typed >= 0.3 && < 0.5, happstack-jmacro >= 7.0 && < 7.1, happstack-server >= 6.0 && < 7.6, @@ -64,7 +64,7 @@ hsp >= 0.10 && < 0.11, hsx-jmacro >= 7.3 && < 7.4, safecopy >= 0.8 && < 0.10, - mime-mail >= 0.4 && < 0.5, + mime-mail >= 0.4 && < 0.6, mtl >= 2.0 && < 2.3, lens >= 4.2 && < 4.18, pwstore-purehaskell == 2.1.*,