diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,5 +1,12 @@ # ChangeLog for yesod-auth +## 1.6.12.0 + +* Add `afterPasswordRouteHandler` [#1863](https://github.com/yesodweb/yesod/pull/1863) +* Use crypton instead of cryptonite [#1838](https://github.com/yesodweb/yesod/pull/1838) +* Set `base >= 4.11` for less CPP and imports [#1876](https://github.com/yesodweb/yesod/pull/1876) + + ## 1.6.11.3 * Add Romanian translation [#1809](https://github.com/yesodweb/yesod/pull/1809) diff --git a/Yesod/Auth.hs b/Yesod/Auth.hs --- a/Yesod/Auth.hs +++ b/Yesod/Auth.hs @@ -1,15 +1,18 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE ViewPatterns #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DefaultSignatures #-} -{-# LANGUAGE QuasiQuotes, TypeFamilies, TemplateHaskell #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE RankNTypes #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE ViewPatterns #-} {-# OPTIONS_GHC -fno-warn-orphans #-} + module Yesod.Auth ( -- * Subsite Auth @@ -49,7 +52,6 @@ import Control.Monad (when) import Control.Monad.Trans.Maybe -import UnliftIO (withRunInIO, MonadUnliftIO) import Yesod.Auth.Routes import Data.Text.Encoding (decodeUtf8With) diff --git a/Yesod/Auth/BrowserId.hs b/Yesod/Auth/BrowserId.hs --- a/Yesod/Auth/BrowserId.hs +++ b/Yesod/Auth/BrowserId.hs @@ -1,7 +1,8 @@ -{-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TemplateHaskell #-} + -- | NOTE: Mozilla Persona will be shut down by the end of 2016, therefore this -- module is no longer recommended for use. module Yesod.Auth.BrowserId diff --git a/Yesod/Auth/Dummy.hs b/Yesod/Auth/Dummy.hs --- a/Yesod/Auth/Dummy.hs +++ b/Yesod/Auth/Dummy.hs @@ -1,9 +1,10 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeFamilies #-} + -- | Provides a dummy authentication module that simply lets a user specify -- their identifier. This is not intended for real world use, just for -- testing. This plugin supports form submissions via JSON (since 1.6.8). diff --git a/Yesod/Auth/Email.hs b/Yesod/Auth/Email.hs --- a/Yesod/Auth/Email.hs +++ b/Yesod/Auth/Email.hs @@ -1,11 +1,12 @@ {-# LANGUAGE ConstrainedClassMethods #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE PatternGuards #-} -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE Rank2Types #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PatternGuards #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE Rank2Types #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} + -- | A Yesod plugin for Authentication via e-mail -- -- This plugin works out of the box by only setting a few methods on @@ -117,7 +118,6 @@ , defaultRegisterHelper ) where -import Control.Applicative ((<$>), (<*>)) import qualified Crypto.Hash as H import qualified Crypto.Nonce as Nonce import Data.Aeson.Types (Parser, Result (..), parseMaybe, @@ -139,7 +139,6 @@ import qualified Yesod.Auth.Message as Msg import qualified Yesod.Auth.Util.PasswordStore as PS import Yesod.Core -import Yesod.Core.Types (TypedContent (TypedContent)) import Yesod.Form loginR, registerR, forgotPasswordR, setpassR :: AuthRoute @@ -295,6 +294,14 @@ -- @since 1.2.0 afterPasswordRoute :: site -> Route site + -- | Same as @afterPasswordRoute@ but allows you to run Handler code + -- + -- If this function is overridden then @afterPasswordRoute@ is ignored. + -- + -- @since 1.6.12.0 + afterPasswordRouteHandler :: AuthHandler site (Route site) + afterPasswordRouteHandler = getYesod >>= pure . afterPasswordRoute + -- | Route to send user to after verification with a password -- -- @since 1.6.4 @@ -485,8 +492,7 @@ passwordMsg <- renderMessage' Msg.Password (passwordRes, passwordView) <- mreq passwordField (passwordSettings passwordMsg) Nothing - let userRes = UserLoginForm Control.Applicative.<$> emailRes - Control.Applicative.<*> passwordRes + let userRes = UserLoginForm <$> emailRes <*> passwordRes let widget = do [whamlet| #{extra} @@ -617,13 +623,13 @@ return $ Just (lid, False, key, identifier) case registerCreds of Nothing -> loginErrorMessageI dest (Msg.IdentifierNotFound identifier) - Just creds@(_, False, _, _) -> sendConfirmationEmail creds - Just creds@(_, True, _, _) -> do + Just regCreds@(_, False, _, _) -> sendConfirmationEmail regCreds + Just regCreds@(_, True, _, _) -> do if forgotPassword - then sendConfirmationEmail creds + then sendConfirmationEmail regCreds else case emailPreviouslyRegisteredResponse identifier of Just response -> response - Nothing -> sendConfirmationEmail creds + Nothing -> sendConfirmationEmail regCreds where sendConfirmationEmail (lid, _, verKey, email) = do render <- getUrlRender tp <- getRouteToParent @@ -927,16 +933,16 @@ Left e -> loginErrorMessage (tm setpassR) e Right () -> do salted <- hashAndSaltPassword new - y <- do - setPassword aid salted - deleteSession loginLinkKey - addMessageI "success" msgOk - getYesod + setPassword aid salted + deleteSession loginLinkKey + addMessageI "success" msgOk + _ <- getYesod mr <- getMessageRender selectRep $ do - provideRep $ - fmap asHtml $ redirect $ afterPasswordRoute y + provideRep $ do + route <- afterPasswordRouteHandler + fmap asHtml $ redirect route provideJsonMessage (mr msgOk) saltLength :: Int diff --git a/Yesod/Auth/GoogleEmail2.hs b/Yesod/Auth/GoogleEmail2.hs --- a/Yesod/Auth/GoogleEmail2.hs +++ b/Yesod/Auth/GoogleEmail2.hs @@ -1,9 +1,10 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TypeFamilies #-} + -- | Use an email address as an identifier via Google's login system. -- -- Note that this is a replacement for "Yesod.Auth.GoogleEmail", which depends @@ -70,7 +71,6 @@ import Blaze.ByteString.Builder (fromByteString, toByteString) -import Control.Applicative ((<$>), (<*>)) import Control.Arrow (second) import Control.Monad (unless, when) import Control.Monad.IO.Class (MonadIO) @@ -88,7 +88,6 @@ import Data.Conduit import Data.Conduit.Attoparsec (sinkParser) import Data.Maybe (fromMaybe) -import Data.Monoid (mappend) import Data.Text (Text) import qualified Data.Text as T import Data.Text.Encoding (decodeUtf8, encodeUtf8) @@ -188,7 +187,7 @@ return $ decodeUtf8 $ toByteString $ fromByteString "https://accounts.google.com/o/oauth2/auth" - `Data.Monoid.mappend` renderQueryText True qs + `mappend` renderQueryText True qs login tm = do [whamlet|_{Msg.LoginGoogle}|] @@ -308,9 +307,10 @@ } deriving (Show, Eq) instance FromJSON Token where - parseJSON = withObject "Tokens" $ \o -> Token - Control.Applicative.<$> o .: "access_token" - Control.Applicative.<*> o .: "token_type" + parseJSON = withObject "Tokens" $ \o -> + Token + <$> o .: "access_token" + <*> o .: "token_type" -------------------------------------------------------------------------------- -- | Gender of the person diff --git a/Yesod/Auth/Hardcoded.hs b/Yesod/Auth/Hardcoded.hs --- a/Yesod/Auth/Hardcoded.hs +++ b/Yesod/Auth/Hardcoded.hs @@ -1,10 +1,11 @@ -{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} + {-| Module : Yesod.Auth.Hardcoded Description : Very simple auth plugin for hardcoded auth pairs. @@ -137,8 +138,6 @@ import qualified Yesod.Auth.Message as Msg import Yesod.Core import Yesod.Form (ireq, runInputPost, textField) - -import Control.Applicative ((<$>), (<*>)) import Data.Text (Text) @@ -187,8 +186,8 @@ => AuthHandler site TypedContent postLoginR = do (username, password) <- runInputPost - ((,) Control.Applicative.<$> ireq textField "username" - Control.Applicative.<*> ireq textField "password") + ((,) <$> ireq textField "username" + <*> ireq textField "password") isValid <- validatePassword username password if isValid then setCredsRedirect (Creds "hardcoded" username []) diff --git a/Yesod/Auth/Message.hs b/Yesod/Auth/Message.hs --- a/Yesod/Auth/Message.hs +++ b/Yesod/Auth/Message.hs @@ -1,4 +1,5 @@ {-# LANGUAGE OverloadedStrings #-} + module Yesod.Auth.Message ( AuthMessage (..) , defaultMessage @@ -23,8 +24,7 @@ , romanianMessage ) where -import Data.Monoid (mappend, (<>)) -import Data.Text (Text) +import Data.Text (Text) data AuthMessage = NoOpenID @@ -92,9 +92,7 @@ englishMessage EnterEmail = "Enter your e-mail address below, and a confirmation e-mail will be sent to you." englishMessage ConfirmationEmailSentTitle = "Confirmation e-mail sent" englishMessage (ConfirmationEmailSent email) = - "A confirmation e-mail has been sent to " `Data.Monoid.mappend` - email `mappend` - "." + "A confirmation e-mail has been sent to " `mappend` email `mappend` "." englishMessage AddressVerified = "Email address verified, please set a new password" englishMessage EmailVerifiedChangePass = "Email address verified, please set a new password" englishMessage EmailVerified = "Email address verified" @@ -885,7 +883,7 @@ romanianMessage EnterEmail = "Introduceți adresa dvs. de e-mail pentru a primi un e-mail de confirmare." romanianMessage ConfirmationEmailSentTitle = "Un mesaj de confirmare a fost trimis la adresa dvs. de e-mail" romanianMessage (ConfirmationEmailSent email) = - "Un mesaj de confirmare a fost trimis la " `Data.Monoid.mappend` email `mappend` "." + "Un mesaj de confirmare a fost trimis la " `mappend` email `mappend` "." romanianMessage AddressVerified = "Adresa de e-mail a fost verificată, vă rugăm să setați o parolă nouă" romanianMessage EmailVerifiedChangePass = "Adresa de e-mail a fost verificată, vă rugăm să setați o parolă nouă" romanianMessage EmailVerified = "Adresa de e-mail a fost verificată" diff --git a/Yesod/Auth/OpenId.hs b/Yesod/Auth/OpenId.hs --- a/Yesod/Auth/OpenId.hs +++ b/Yesod/Auth/OpenId.hs @@ -1,9 +1,9 @@ {-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE GADTs #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE CPP #-} +{-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE RankNTypes #-} -{-# LANGUAGE GADTs #-} + module Yesod.Auth.OpenId ( authOpenId , forwardUrl diff --git a/Yesod/Auth/Routes.hs b/Yesod/Auth/Routes.hs --- a/Yesod/Auth/Routes.hs +++ b/Yesod/Auth/Routes.hs @@ -1,10 +1,13 @@ -{-# LANGUAGE QuasiQuotes, TypeFamilies, TemplateHaskell #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE RankNTypes #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE ViewPatterns #-} + module Yesod.Auth.Routes where import Yesod.Core diff --git a/Yesod/Auth/Rpxnow.hs b/Yesod/Auth/Rpxnow.hs --- a/Yesod/Auth/Rpxnow.hs +++ b/Yesod/Auth/Rpxnow.hs @@ -1,8 +1,9 @@ -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RankNTypes #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GADTs #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE RankNTypes #-} + module Yesod.Auth.Rpxnow ( authRpxnow ) where diff --git a/Yesod/Auth/Util/PasswordStore.hs b/Yesod/Auth/Util/PasswordStore.hs --- a/Yesod/Auth/Util/PasswordStore.hs +++ b/Yesod/Auth/Util/PasswordStore.hs @@ -1,5 +1,6 @@ -{-# LANGUAGE OverloadedStrings, BangPatterns #-} -{-# LANGUAGE CPP #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE OverloadedStrings #-} + -- | -- This is a fork of pwstore-fast, originally copyright (c) Peter Scott, 2011, -- and released under a BSD-style licence. @@ -169,7 +170,7 @@ let hLen = 32 dkLen = hLen in go hLen dkLen where - go hLen dkLen | dkLen > (2^(32 :: Int) - 1) * hLen = error "Derived key too long." + go hLen dkLen | dkLen > (2 ^ (32 :: Int) - 1) * hLen = error "Derived key too long." | otherwise = let !l = ceiling ((fromIntegral dkLen / fromIntegral hLen) :: Double) !r = dkLen - (l - 1) * hLen @@ -233,15 +234,16 @@ -- | Try to parse a password hash. readPwHash :: ByteString -> Maybe (Int, Salt, ByteString) -readPwHash pw | length broken /= 4 - || algorithm /= "sha256" - || B.length hash /= 44 = Nothing - | otherwise = case B.readInt strBS of - Just (strength, _) -> Just (strength, SaltBS salt, hash) - Nothing -> Nothing - where broken = B.split '|' pw - [algorithm, strBS, salt, hash] = broken +readPwHash pw + | ["sha256", strBS, salt, hash] <- broken + , B.length hash == 44 = + (\(strength, _) -> (strength, SaltBS salt, hash)) + <$> B.readInt strBS + | otherwise = Nothing + where + broken = B.split '|' pw + -- | Encode a password hash, from a @(strength, salt, hash)@ tuple, where -- strength is an 'Int', and both @salt@ and @hash@ are base64-encoded -- 'ByteString's. @@ -280,7 +282,7 @@ -> IO ByteString makePasswordWith algorithm password strength = do salt <- genSaltIO - return $ makePasswordSaltWith algorithm (2^) password salt strength + return $ makePasswordSaltWith algorithm (2 ^) password salt strength -- | A generic version of 'makePasswordSalt', meant to give the user -- the maximum control over the generation parameters. @@ -314,7 +316,7 @@ -- @since 1.4.18 -- makePasswordSalt :: ByteString -> Salt -> Int -> ByteString -makePasswordSalt = makePasswordSaltWith pbkdf1 (2^) +makePasswordSalt = makePasswordSaltWith pbkdf1 (2 ^) -- | 'verifyPasswordWith' @algorithm userInput pwHash@ verifies -- the password @userInput@ given by the user against the stored password @@ -351,7 +353,7 @@ -- @since 1.4.18 -- verifyPassword :: ByteString -> ByteString -> Bool -verifyPassword = verifyPasswordWith pbkdf1 (2^) +verifyPassword = verifyPasswordWith pbkdf1 (2 ^) -- | Try to strengthen a password hash, by hashing it some more -- times. @'strengthenPassword' pwHash new_strength@ will return a new password @@ -376,7 +378,7 @@ else pwHash where newHash = encode $ hashRounds hash extraRounds - extraRounds = (2^newstr) - (2^oldstr) + extraRounds = (2 ^ newstr) - (2 ^ oldstr) hash = decodeLenient hashB64 -- | Return the strength of a password hash. @@ -453,12 +455,3 @@ where (a, g') = randomR ('\NUL', '\255') g salt = makeSalt $ B.pack $ map fst (rands gen 16) newgen = snd $ last (rands gen 16) - -#if !MIN_VERSION_base(4, 6, 0) --- | Strict version of 'modifySTRef' -modifySTRef' :: STRef s a -> (a -> a) -> ST s () -modifySTRef' ref f = do - x <- readSTRef ref - let x' = f x - x' `seq` writeSTRef ref x' -#endif diff --git a/yesod-auth.cabal b/yesod-auth.cabal --- a/yesod-auth.cabal +++ b/yesod-auth.cabal @@ -1,6 +1,6 @@ cabal-version: >=1.10 name: yesod-auth -version: 1.6.11.3 +version: 1.6.12.0 license: MIT license-file: LICENSE author: Michael Snoyman, Patrick Brisbin @@ -21,7 +21,7 @@ library default-language: Haskell2010 - build-depends: base >= 4.10 && < 5 + build-depends: base >= 4.11 && < 5 , aeson >= 0.7 , attoparsec-aeson >= 2.1 , authenticate >= 1.3.4 @@ -35,7 +35,7 @@ , conduit >= 1.3 , conduit-extra , containers - , cryptonite + , crypton , data-default , email-validate >= 1.0 , file-embed