yesod-auth 1.6.10.3 → 1.6.10.4
raw patch · 6 files changed
+123/−112 lines, 6 filesPVP ok
version bump matches the API change (PVP)
API changes (from Hackage documentation)
Files
- ChangeLog.md +4/−0
- Yesod/Auth/Dummy.hs +11/−9
- Yesod/Auth/Email.hs +44/−41
- Yesod/Auth/GoogleEmail2.hs +59/−57
- Yesod/Auth/Hardcoded.hs +4/−4
- yesod-auth.cabal +1/−1
ChangeLog.md view
@@ -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
Yesod/Auth/Dummy.hs view
@@ -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
Yesod/Auth/Email.hs view
@@ -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)
Yesod/Auth/GoogleEmail2.hs view
@@ -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.
Yesod/Auth/Hardcoded.hs view
@@ -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|
yesod-auth.cabal view
@@ -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