diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,5 +1,9 @@ # ChangeLog for yesod-auth +## 1.6.10.4 + +* Add support for GHC 9 [#1737](https://github.com/yesodweb/yesod/pull/1737) + ## 1.6.10.3 * Relax bounds for yesod-form 1.7 diff --git a/Yesod/Auth/Dummy.hs b/Yesod/Auth/Dummy.hs --- a/Yesod/Auth/Dummy.hs +++ b/Yesod/Auth/Dummy.hs @@ -1,8 +1,9 @@ -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# 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). @@ -35,12 +36,12 @@ ( authDummy ) where -import Yesod.Auth -import Yesod.Form (runInputPost, textField, ireq) -import Yesod.Core -import Data.Text (Text) -import Data.Aeson.Types (Result(..), Parser) +import Data.Aeson.Types (Parser, Result (..)) import qualified Data.Aeson.Types as A (parseEither, withObject) +import Data.Text (Text) +import Yesod.Auth +import Yesod.Core +import Yesod.Form (ireq, runInputPost, textField) identParser :: Value -> Parser Text identParser = A.withObject "Ident" (.: "ident") @@ -49,6 +50,7 @@ authDummy = AuthPlugin "dummy" dispatch login where + dispatch :: Text -> [Text] -> AuthHandler m TypedContent dispatch "POST" [] = do (jsonResult :: Result Value) <- parseCheckJsonBody eIdent <- case jsonResult of diff --git a/Yesod/Auth/Email.hs b/Yesod/Auth/Email.hs --- a/Yesod/Auth/Email.hs +++ b/Yesod/Auth/Email.hs @@ -31,16 +31,16 @@ -- = Using JSON Endpoints -- -- We are assuming that you have declared auth route as follows --- +-- -- @ -- /auth AuthR Auth getAuth -- @ --- +-- -- If you are using a different route, then you have to adjust the -- endpoints accordingly. -- -- * Registration --- +-- -- @ -- Endpoint: \/auth\/page\/email\/register -- Method: POST @@ -49,9 +49,9 @@ -- "password": "myStrongPassword" (optional) -- } -- @ --- +-- -- * Forgot password --- +-- -- @ -- Endpoint: \/auth\/page\/email\/forgot-password -- Method: POST @@ -59,16 +59,16 @@ -- @ -- -- * Login --- +-- -- @ -- Endpoint: \/auth\/page\/email\/login -- Method: POST --- JSON Data: { +-- JSON Data: { -- "email": "myemail@domain.com", -- "password": "myStrongPassword" -- } -- @ --- +-- -- * Set new password -- -- @ @@ -117,28 +117,30 @@ , defaultRegisterHelper ) where +import Control.Applicative ((<$>), (<*>)) +import qualified Crypto.Hash as H +import qualified Crypto.Nonce as Nonce +import Data.Aeson.Types (Parser, Result (..), parseMaybe, + withObject, (.:?)) +import Data.ByteArray (convert) +import Data.ByteString.Base16 as B16 +import Data.Maybe (isJust) +import Data.Text (Text) +import qualified Data.Text as T +import qualified Data.Text as TS +import Data.Text.Encoding (decodeUtf8With, encodeUtf8) +import qualified Data.Text.Encoding as TE +import Data.Text.Encoding.Error (lenientDecode) +import Data.Time (addUTCTime, getCurrentTime) +import Safe (readMay) +import System.IO.Unsafe (unsafePerformIO) +import qualified Text.Email.Validate import Yesod.Auth -import qualified Yesod.Auth.Message as Msg +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 -import qualified Yesod.Auth.Util.PasswordStore as PS -import Control.Applicative ((<$>), (<*>)) -import qualified Crypto.Hash as H -import qualified Crypto.Nonce as Nonce -import Data.ByteString.Base16 as B16 -import Data.Text (Text) -import qualified Data.Text as TS -import qualified Data.Text as T -import Data.Text.Encoding (decodeUtf8With, encodeUtf8) -import qualified Data.Text.Encoding as TE -import Data.Text.Encoding.Error (lenientDecode) -import Data.Time (addUTCTime, getCurrentTime) -import Safe (readMay) -import System.IO.Unsafe (unsafePerformIO) -import qualified Text.Email.Validate -import Data.Aeson.Types (Parser, Result(..), parseMaybe, withObject, (.:?)) -import Data.Maybe (isJust) -import Data.ByteArray (convert) loginR, registerR, forgotPasswordR, setpassR :: AuthRoute loginR = PluginR "email" ["login"] @@ -240,7 +242,7 @@ -- -- @since 1.4.20 hashAndSaltPassword :: Text -> AuthHandler site SaltedPass - hashAndSaltPassword = liftIO . saltPass + hashAndSaltPassword password = liftIO $ saltPass password -- | Verify a password matches the stored password for the given account. -- @@ -432,13 +434,14 @@ authEmail = AuthPlugin "email" dispatch emailLoginHandler where + dispatch :: YesodAuthEmail m => Text -> [Text] -> AuthHandler m TypedContent dispatch "GET" ["register"] = getRegisterR >>= sendResponse dispatch "POST" ["register"] = postRegisterR >>= sendResponse dispatch "GET" ["forgot-password"] = getForgotPasswordR >>= sendResponse dispatch "POST" ["forgot-password"] = postForgotPasswordR >>= sendResponse dispatch "GET" ["verify", eid, verkey] = case fromPathPiece eid of - Nothing -> notFound + Nothing -> notFound Just eid' -> getVerifyR eid' verkey False >>= sendResponse dispatch "GET" ["verify", eid, verkey, hasSetPass] = case fromPathPiece eid of @@ -576,7 +579,7 @@ _ -> do (creds :: Result Value) <- parseCheckJsonBody return $ case creds of - Error _ -> Nothing + Error _ -> Nothing Success val -> parseMaybe parseRegister val let eidentifier = case creds of @@ -589,7 +592,7 @@ let mpass = case (forgotPassword, creds) of (False, Just (_, mp)) -> mp - _ -> Nothing + _ -> Nothing case eidentifier of Left failMsg -> loginErrorMessageI dest failMsg @@ -620,7 +623,7 @@ then sendConfirmationEmail creds else case emailPreviouslyRegisteredResponse identifier of Just response -> response - Nothing -> sendConfirmationEmail creds + Nothing -> sendConfirmationEmail creds where sendConfirmationEmail (lid, _, verKey, email) = do render <- getUrlRender tp <- getRouteToParent @@ -739,7 +742,7 @@ _ -> do (creds :: Result Value) <- parseCheckJsonBody case creds of - Error _ -> return Nothing + Error _ -> return Nothing Success val -> return $ parseMaybe parseCreds val case midentifier of @@ -779,8 +782,8 @@ maid <- maybeAuthId case maid of Nothing -> loginErrorMessageI LoginR Msg.BadSetPass - Just _ -> do - needOld <- maybe (return True) needOldPassword maid + Just aid -> do + needOld <- needOldPassword aid setPasswordHandler needOld -- | Default implementation of 'setPasswordHandler'. @@ -870,7 +873,7 @@ maid <- maybeAuthId (creds :: Result Value) <- parseCheckJsonBody let jcreds = case creds of - Error _ -> Nothing + Error _ -> Nothing Success val -> parseMaybe parsePassword val let doJsonParsing = isJust jcreds case maid of @@ -882,7 +885,7 @@ res <- runInputPostResult $ ireq textField "current" let fcurrent = case res of FormSuccess currentPass -> Just currentPass - _ -> Nothing + _ -> Nothing let current = if doJsonParsing then getThird jcreds else fcurrent @@ -901,9 +904,9 @@ where msgOk = Msg.PassUpdated getThird (Just (_,_,t)) = t - getThird Nothing = Nothing + getThird Nothing = Nothing getNewConfirm (Just (a,b,_)) = Just (a,b) - getNewConfirm _ = Nothing + getNewConfirm _ = Nothing confirmPassword aid tm jcreds = do res <- runInputPostResult $ (,) <$> ireq textField "new" @@ -912,7 +915,7 @@ then getNewConfirm jcreds else case res of FormSuccess res' -> Just res' - _ -> Nothing + _ -> Nothing case creds of Nothing -> loginErrorMessageI setpassR Msg.PassMismatch Just (new, confirm) -> @@ -932,7 +935,7 @@ mr <- getMessageRender selectRep $ do - provideRep $ + provideRep $ fmap asHtml $ redirect $ afterPasswordRoute y provideJsonMessage (mr msgOk) diff --git a/Yesod/Auth/GoogleEmail2.hs b/Yesod/Auth/GoogleEmail2.hs --- a/Yesod/Auth/GoogleEmail2.hs +++ b/Yesod/Auth/GoogleEmail2.hs @@ -53,55 +53,55 @@ , pid ) where -import Yesod.Auth (Auth, AuthPlugin (AuthPlugin), - AuthRoute, Creds (Creds), - Route (PluginR), YesodAuth, - runHttpRequest, setCredsRedirect, - logoutDest, AuthHandler) -import qualified Yesod.Auth.Message as Msg -import Yesod.Core (HandlerSite, MonadHandler, - TypedContent, getRouteToParent, - getUrlRender, invalidArgs, - liftIO, lookupGetParam, - lookupSession, notFound, redirect, - setSession, whamlet, (.:), - addMessage, getYesod, - toHtml, liftSubHandler) +import Yesod.Auth (Auth, AuthHandler, + AuthPlugin (AuthPlugin), + AuthRoute, Creds (Creds), + Route (PluginR), YesodAuth, + logoutDest, runHttpRequest, + setCredsRedirect) +import qualified Yesod.Auth.Message as Msg +import Yesod.Core (HandlerSite, MonadHandler, + TypedContent, addMessage, + getRouteToParent, getUrlRender, + getYesod, invalidArgs, liftIO, + liftSubHandler, lookupGetParam, + lookupSession, notFound, redirect, + setSession, toHtml, whamlet, (.:)) -import Blaze.ByteString.Builder (fromByteString, toByteString) -import Control.Applicative ((<$>), (<*>)) -import Control.Arrow (second) -import Control.Monad (unless, when) -import Control.Monad.IO.Class (MonadIO) -import qualified Crypto.Nonce as Nonce -import Data.Aeson ((.:?)) -import qualified Data.Aeson as A +import Blaze.ByteString.Builder (fromByteString, toByteString) +import Control.Applicative ((<$>), (<*>)) +import Control.Arrow (second) +import Control.Monad (unless, when) +import Control.Monad.IO.Class (MonadIO) +import qualified Crypto.Nonce as Nonce +import Data.Aeson ((.:?)) +import qualified Data.Aeson as A #if MIN_VERSION_aeson(1,0,0) -import qualified Data.Aeson.Text as A +import qualified Data.Aeson.Text as A #else -import qualified Data.Aeson.Encode as A +import qualified Data.Aeson.Encode as A #endif -import Data.Aeson.Parser (json') -import Data.Aeson.Types (FromJSON (parseJSON), parseEither, - parseMaybe, withObject, withText) +import Data.Aeson.Parser (json') +import Data.Aeson.Types (FromJSON (parseJSON), parseEither, + parseMaybe, withObject, withText) import Data.Conduit -import Data.Conduit.Attoparsec (sinkParser) -import qualified Data.HashMap.Strict as M -import Data.Maybe (fromMaybe) -import Data.Monoid (mappend) -import Data.Text (Text) -import qualified Data.Text as T -import Data.Text.Encoding (decodeUtf8, encodeUtf8) -import qualified Data.Text.Lazy as TL -import qualified Data.Text.Lazy.Builder as TL -import Network.HTTP.Client (Manager, requestHeaders, - responseBody, urlEncodedBody) -import qualified Network.HTTP.Client as HTTP +import Data.Conduit.Attoparsec (sinkParser) +import qualified Data.HashMap.Strict as M +import Data.Maybe (fromMaybe) +import Data.Monoid (mappend) +import Data.Text (Text) +import qualified Data.Text as T +import Data.Text.Encoding (decodeUtf8, encodeUtf8) +import qualified Data.Text.Lazy as TL +import qualified Data.Text.Lazy.Builder as TL +import Network.HTTP.Client (Manager, requestHeaders, + responseBody, urlEncodedBody) +import qualified Network.HTTP.Client as HTTP import Network.HTTP.Client.Conduit (Request, bodyReaderSource) -import Network.HTTP.Conduit (http) -import Network.HTTP.Types (renderQueryText) -import System.IO.Unsafe (unsafePerformIO) +import Network.HTTP.Conduit (http) +import Network.HTTP.Types (renderQueryText) +import System.IO.Unsafe (unsafePerformIO) -- | Plugin identifier. This is used to identify the plugin used for @@ -239,7 +239,7 @@ value <- makeHttpRequest req token@(Token accessToken' tokenType') <- case parseEither parseJSON value of - Left e -> error e + Left e -> error e Right t -> return t unless (tokenType' == "Bearer") $ error $ "Unknown token type: " ++ show tokenType' @@ -247,16 +247,18 @@ -- User's access token is saved for further access to API when storeToken $ setSession accessTokenKey accessToken' - personValue <- makeHttpRequest =<< personValueRequest token + personValReq <- personValueRequest token + personValue <- makeHttpRequest personValReq + person <- case parseEither parseJSON personValue of - Left e -> error e + Left e -> error e Right x -> return x email <- case map emailValue $ filter (\e -> emailType e == EmailAccount) $ personEmails person of [e] -> return e - [] -> error "No account email" - x -> error $ "Too many account emails: " ++ show x + [] -> error "No account email" + x -> error $ "Too many account emails: " ++ show x setCredsRedirect $ Creds pid email $ allPersonInfo personValue dispatch _ _ = notFound @@ -450,16 +452,16 @@ instance FromJSON RelationshipStatus where parseJSON = withText "RelationshipStatus" $ \t -> return $ case t of - "single" -> Single - "in_a_relationship" -> InRelationship - "engaged" -> Engaged - "married" -> Married - "its_complicated" -> Complicated - "open_relationship" -> OpenRelationship - "widowed" -> Widowed - "in_domestic_partnership" -> DomesticPartnership - "in_civil_union" -> CivilUnion - _ -> RelationshipStatus t + "single" -> Single + "in_a_relationship" -> InRelationship + "engaged" -> Engaged + "married" -> Married + "its_complicated" -> Complicated + "open_relationship" -> OpenRelationship + "widowed" -> Widowed + "in_domestic_partnership" -> DomesticPartnership + "in_civil_union" -> CivilUnion + _ -> RelationshipStatus t -------------------------------------------------------------------------------- -- | The URI of the person's profile photo. diff --git a/Yesod/Auth/Hardcoded.hs b/Yesod/Auth/Hardcoded.hs --- a/Yesod/Auth/Hardcoded.hs +++ b/Yesod/Auth/Hardcoded.hs @@ -131,10 +131,9 @@ , loginR ) where -import Yesod.Auth (AuthPlugin (..), AuthRoute, +import Yesod.Auth (AuthHandler, AuthPlugin (..), AuthRoute, Creds (..), Route (..), YesodAuth, - loginErrorMessageI, setCredsRedirect, - AuthHandler) + loginErrorMessageI, setCredsRedirect) import qualified Yesod.Auth.Message as Msg import Yesod.Core import Yesod.Form (ireq, runInputPost, textField) @@ -159,8 +158,9 @@ authHardcoded = AuthPlugin "hardcoded" dispatch loginWidget where + dispatch :: YesodAuthHardcoded m => Text -> [Text] -> AuthHandler m TypedContent dispatch "POST" ["login"] = postLoginR >>= sendResponse - dispatch _ _ = notFound + dispatch _ _ = notFound loginWidget toMaster = do request <- getRequest [whamlet| 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.10.3 +version: 1.6.10.4 license: MIT license-file: LICENSE author: Michael Snoyman, Patrick Brisbin