haskell/yesod
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Merge pull request #1737 from geraldus/ghc-9.0.1

Browse Source 
Make yesod-auth buildable with GHC 9.0.1
This commit is contained in:
Michael Snoyman 2021-09-10 14:56:36 +03:00 committed by GitHub
commit dfc270b0b2
No known key found for this signature in database
GPG Key ID: 4AEE18F83AFDEB23
6 changed files with 125 additions and 114 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
yesod-auth/ChangeLog.md
View File

@ -1,5 +1,9 @@
# ChangeLog for yesod-auth # 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 ## 1.6.10.3
* Relax bounds for yesod-form 1.7 * Relax bounds for yesod-form 1.7

20
yesod-auth/Yesod/Auth/Dummy.hs
View File

@ -1,8 +1,9 @@
{-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
-- | Provides a dummy authentication module that simply lets a user specify -- | Provides a dummy authentication module that simply lets a user specify
-- their identifier. This is not intended for real world use, just for -- their identifier. This is not intended for real world use, just for
-- testing. This plugin supports form submissions via JSON (since 1.6.8). -- testing. This plugin supports form submissions via JSON (since 1.6.8).
@ -35,12 +36,12 @@ module Yesod.Auth.Dummy
( authDummy ( authDummy
) where ) where
import Yesod.Auth import Data.Aeson.Types (Parser, Result (..))
import Yesod.Form (runInputPost, textField, ireq)
import Yesod.Core
import Data.Text (Text)
import Data.Aeson.Types (Result(..), Parser)
import qualified Data.Aeson.Types as A (parseEither, withObject) 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 :: Value -> Parser Text
identParser = A.withObject "Ident" (.: "ident") identParser = A.withObject "Ident" (.: "ident")
@ -49,6 +50,7 @@ authDummy :: YesodAuth m => AuthPlugin m
authDummy = authDummy =
AuthPlugin "dummy" dispatch login AuthPlugin "dummy" dispatch login
where where
dispatch :: Text -> [Text] -> AuthHandler m TypedContent
dispatch "POST" [] = do dispatch "POST" [] = do
(jsonResult :: Result Value) <- parseCheckJsonBody (jsonResult :: Result Value) <- parseCheckJsonBody
eIdent <- case jsonResult of eIdent <- case jsonResult of

71
yesod-auth/Yesod/Auth/Email.hs
View File

@ -117,28 +117,30 @@ module Yesod.Auth.Email
, defaultRegisterHelper , defaultRegisterHelper
) where ) where
import Yesod.Auth import Control.Applicative ((<$>), (<*>))
import qualified Yesod.Auth.Message as Msg import qualified Crypto.Hash as H
import Yesod.Core import qualified Crypto.Nonce as Nonce
import Yesod.Form import Data.Aeson.Types (Parser, Result (..), parseMaybe,
import qualified Yesod.Auth.Util.PasswordStore as PS withObject, (.:?))
import Control.Applicative ((<$>), (<*>)) import Data.ByteArray (convert)
import qualified Crypto.Hash as H import Data.ByteString.Base16 as B16
import qualified Crypto.Nonce as Nonce import Data.Maybe (isJust)
import Data.ByteString.Base16 as B16 import Data.Text (Text)
import Data.Text (Text) import qualified Data.Text as T
import qualified Data.Text as TS import qualified Data.Text as TS
import qualified Data.Text as T import Data.Text.Encoding (decodeUtf8With, encodeUtf8)
import Data.Text.Encoding (decodeUtf8With, encodeUtf8) import qualified Data.Text.Encoding as TE
import qualified Data.Text.Encoding as TE import Data.Text.Encoding.Error (lenientDecode)
import Data.Text.Encoding.Error (lenientDecode) import Data.Time (addUTCTime, getCurrentTime)
import Data.Time (addUTCTime, getCurrentTime) import Safe (readMay)
import Safe (readMay) import System.IO.Unsafe (unsafePerformIO)
import System.IO.Unsafe (unsafePerformIO)
import qualified Text.Email.Validate import qualified Text.Email.Validate
import Data.Aeson.Types (Parser, Result(..), parseMaybe, withObject, (.:?)) import Yesod.Auth
import Data.Maybe (isJust) import qualified Yesod.Auth.Message as Msg
import Data.ByteArray (convert) 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 loginR, registerR, forgotPasswordR, setpassR :: AuthRoute
loginR = PluginR "email" ["login"] loginR = PluginR "email" ["login"]
@ -240,7 +242,7 @@ class ( YesodAuth site
-- --
-- @since 1.4.20 -- @since 1.4.20
hashAndSaltPassword :: Text -> AuthHandler site SaltedPass hashAndSaltPassword :: Text -> AuthHandler site SaltedPass
hashAndSaltPassword = liftIO . saltPass hashAndSaltPassword password = liftIO $ saltPass password
-- | Verify a password matches the stored password for the given account. -- | Verify a password matches the stored password for the given account.
-- --
@ -432,13 +434,14 @@ authEmail :: (YesodAuthEmail m) => AuthPlugin m
authEmail = authEmail =
AuthPlugin "email" dispatch emailLoginHandler AuthPlugin "email" dispatch emailLoginHandler
where where
dispatch :: YesodAuthEmail m => Text -> [Text] -> AuthHandler m TypedContent
dispatch "GET" ["register"] = getRegisterR >>= sendResponse dispatch "GET" ["register"] = getRegisterR >>= sendResponse
dispatch "POST" ["register"] = postRegisterR >>= sendResponse dispatch "POST" ["register"] = postRegisterR >>= sendResponse
dispatch "GET" ["forgot-password"] = getForgotPasswordR >>= sendResponse dispatch "GET" ["forgot-password"] = getForgotPasswordR >>= sendResponse
dispatch "POST" ["forgot-password"] = postForgotPasswordR >>= sendResponse dispatch "POST" ["forgot-password"] = postForgotPasswordR >>= sendResponse
dispatch "GET" ["verify", eid, verkey] = dispatch "GET" ["verify", eid, verkey] =
case fromPathPiece eid of case fromPathPiece eid of
Nothing -> notFound Nothing -> notFound
Just eid' -> getVerifyR eid' verkey False >>= sendResponse Just eid' -> getVerifyR eid' verkey False >>= sendResponse
dispatch "GET" ["verify", eid, verkey, hasSetPass] = dispatch "GET" ["verify", eid, verkey, hasSetPass] =
case fromPathPiece eid of case fromPathPiece eid of
@ -576,7 +579,7 @@ defaultRegisterHelper allowUsername forgotPassword dest = do
_ -> do _ -> do
(creds :: Result Value) <- parseCheckJsonBody (creds :: Result Value) <- parseCheckJsonBody
return $ case creds of return $ case creds of
Error _ -> Nothing Error _ -> Nothing
Success val -> parseMaybe parseRegister val Success val -> parseMaybe parseRegister val
let eidentifier = case creds of let eidentifier = case creds of
@ -589,7 +592,7 @@ defaultRegisterHelper allowUsername forgotPassword dest = do
let mpass = case (forgotPassword, creds) of let mpass = case (forgotPassword, creds) of
(False, Just (_, mp)) -> mp (False, Just (_, mp)) -> mp
_ -> Nothing _ -> Nothing
case eidentifier of case eidentifier of
Left failMsg -> loginErrorMessageI dest failMsg Left failMsg -> loginErrorMessageI dest failMsg
@ -620,7 +623,7 @@ defaultRegisterHelper allowUsername forgotPassword dest = do
then sendConfirmationEmail creds then sendConfirmationEmail creds
else case emailPreviouslyRegisteredResponse identifier of else case emailPreviouslyRegisteredResponse identifier of
Just response -> response Just response -> response
Nothing -> sendConfirmationEmail creds Nothing -> sendConfirmationEmail creds
where sendConfirmationEmail (lid, _, verKey, email) = do where sendConfirmationEmail (lid, _, verKey, email) = do
render <- getUrlRender render <- getUrlRender
tp <- getRouteToParent tp <- getRouteToParent
@ -739,7 +742,7 @@ postLoginR = do
_ -> do _ -> do
(creds :: Result Value) <- parseCheckJsonBody (creds :: Result Value) <- parseCheckJsonBody
case creds of case creds of
Error _ -> return Nothing Error _ -> return Nothing
Success val -> return $ parseMaybe parseCreds val Success val -> return $ parseMaybe parseCreds val
case midentifier of case midentifier of
@ -779,8 +782,8 @@ getPasswordR = do
maid <- maybeAuthId maid <- maybeAuthId
case maid of case maid of
Nothing -> loginErrorMessageI LoginR Msg.BadSetPass Nothing -> loginErrorMessageI LoginR Msg.BadSetPass
Just _ -> do Just aid -> do
needOld <- maybe (return True) needOldPassword maid needOld <- needOldPassword aid
setPasswordHandler needOld setPasswordHandler needOld
-- | Default implementation of 'setPasswordHandler'. -- | Default implementation of 'setPasswordHandler'.
@ -870,7 +873,7 @@ postPasswordR = do
maid <- maybeAuthId maid <- maybeAuthId
(creds :: Result Value) <- parseCheckJsonBody (creds :: Result Value) <- parseCheckJsonBody
let jcreds = case creds of let jcreds = case creds of
Error _ -> Nothing Error _ -> Nothing
Success val -> parseMaybe parsePassword val Success val -> parseMaybe parsePassword val
let doJsonParsing = isJust jcreds let doJsonParsing = isJust jcreds
case maid of case maid of
@ -882,7 +885,7 @@ postPasswordR = do
res <- runInputPostResult $ ireq textField "current" res <- runInputPostResult $ ireq textField "current"
let fcurrent = case res of let fcurrent = case res of
FormSuccess currentPass -> Just currentPass FormSuccess currentPass -> Just currentPass
_ -> Nothing _ -> Nothing
let current = if doJsonParsing let current = if doJsonParsing
then getThird jcreds then getThird jcreds
else fcurrent else fcurrent
@ -901,9 +904,9 @@ postPasswordR = do
where where
msgOk = Msg.PassUpdated msgOk = Msg.PassUpdated
getThird (Just (_,_,t)) = t getThird (Just (_,_,t)) = t
getThird Nothing = Nothing getThird Nothing = Nothing
getNewConfirm (Just (a,b,_)) = Just (a,b) getNewConfirm (Just (a,b,_)) = Just (a,b)
getNewConfirm _ = Nothing getNewConfirm _ = Nothing
confirmPassword aid tm jcreds = do confirmPassword aid tm jcreds = do
res <- runInputPostResult $ (,) res <- runInputPostResult $ (,)
<$> ireq textField "new" <$> ireq textField "new"
@ -912,7 +915,7 @@ postPasswordR = do
then getNewConfirm jcreds then getNewConfirm jcreds
else case res of else case res of
FormSuccess res' -> Just res' FormSuccess res' -> Just res'
_ -> Nothing _ -> Nothing
case creds of case creds of
Nothing -> loginErrorMessageI setpassR Msg.PassMismatch Nothing -> loginErrorMessageI setpassR Msg.PassMismatch
Just (new, confirm) -> Just (new, confirm) ->

116
yesod-auth/Yesod/Auth/GoogleEmail2.hs
View File

@ -53,55 +53,55 @@ module Yesod.Auth.GoogleEmail2
, pid , pid
) where ) where
import Yesod.Auth (Auth, AuthPlugin (AuthPlugin), import Yesod.Auth (Auth, AuthHandler,
AuthRoute, Creds (Creds), AuthPlugin (AuthPlugin),
Route (PluginR), YesodAuth, AuthRoute, Creds (Creds),
runHttpRequest, setCredsRedirect, Route (PluginR), YesodAuth,
logoutDest, AuthHandler) logoutDest, runHttpRequest,
import qualified Yesod.Auth.Message as Msg setCredsRedirect)
import Yesod.Core (HandlerSite, MonadHandler, import qualified Yesod.Auth.Message as Msg
TypedContent, getRouteToParent, import Yesod.Core (HandlerSite, MonadHandler,
getUrlRender, invalidArgs, TypedContent, addMessage,
liftIO, lookupGetParam, getRouteToParent, getUrlRender,
lookupSession, notFound, redirect, getYesod, invalidArgs, liftIO,
setSession, whamlet, (.:), liftSubHandler, lookupGetParam,
addMessage, getYesod, lookupSession, notFound, redirect,
toHtml, liftSubHandler) setSession, toHtml, whamlet, (.:))
import Blaze.ByteString.Builder (fromByteString, toByteString) import Blaze.ByteString.Builder (fromByteString, toByteString)
import Control.Applicative ((<$>), (<*>)) import Control.Applicative ((<$>), (<*>))
import Control.Arrow (second) import Control.Arrow (second)
import Control.Monad (unless, when) import Control.Monad (unless, when)
import Control.Monad.IO.Class (MonadIO) import Control.Monad.IO.Class (MonadIO)
import qualified Crypto.Nonce as Nonce import qualified Crypto.Nonce as Nonce
import Data.Aeson ((.:?)) import Data.Aeson ((.:?))
import qualified Data.Aeson as A import qualified Data.Aeson as A
#if MIN_VERSION_aeson(1,0,0) #if MIN_VERSION_aeson(1,0,0)
import qualified Data.Aeson.Text as A import qualified Data.Aeson.Text as A
#else #else
import qualified Data.Aeson.Encode as A import qualified Data.Aeson.Encode as A
#endif #endif
import Data.Aeson.Parser (json') import Data.Aeson.Parser (json')
import Data.Aeson.Types (FromJSON (parseJSON), parseEither, import Data.Aeson.Types (FromJSON (parseJSON), parseEither,
parseMaybe, withObject, withText) parseMaybe, withObject, withText)
import Data.Conduit import Data.Conduit
import Data.Conduit.Attoparsec (sinkParser) import Data.Conduit.Attoparsec (sinkParser)
import qualified Data.HashMap.Strict as M import qualified Data.HashMap.Strict as M
import Data.Maybe (fromMaybe) import Data.Maybe (fromMaybe)
import Data.Monoid (mappend) import Data.Monoid (mappend)
import Data.Text (Text) import Data.Text (Text)
import qualified Data.Text as T import qualified Data.Text as T
import Data.Text.Encoding (decodeUtf8, encodeUtf8) import Data.Text.Encoding (decodeUtf8, encodeUtf8)
import qualified Data.Text.Lazy as TL import qualified Data.Text.Lazy as TL
import qualified Data.Text.Lazy.Builder as TL import qualified Data.Text.Lazy.Builder as TL
import Network.HTTP.Client (Manager, requestHeaders, import Network.HTTP.Client (Manager, requestHeaders,
responseBody, urlEncodedBody) responseBody, urlEncodedBody)
import qualified Network.HTTP.Client as HTTP import qualified Network.HTTP.Client as HTTP
import Network.HTTP.Client.Conduit (Request, bodyReaderSource) import Network.HTTP.Client.Conduit (Request, bodyReaderSource)
import Network.HTTP.Conduit (http) import Network.HTTP.Conduit (http)
import Network.HTTP.Types (renderQueryText) import Network.HTTP.Types (renderQueryText)
import System.IO.Unsafe (unsafePerformIO) import System.IO.Unsafe (unsafePerformIO)
-- | Plugin identifier. This is used to identify the plugin used for -- | Plugin identifier. This is used to identify the plugin used for
@ -239,7 +239,7 @@ authPlugin storeToken clientID clientSecret =
value <- makeHttpRequest req value <- makeHttpRequest req
token@(Token accessToken' tokenType') <- token@(Token accessToken' tokenType') <-
case parseEither parseJSON value of case parseEither parseJSON value of
Left e -> error e Left e -> error e
Right t -> return t Right t -> return t
unless (tokenType' == "Bearer") $ error $ "Unknown token type: " ++ show tokenType' unless (tokenType' == "Bearer") $ error $ "Unknown token type: " ++ show tokenType'
@ -247,16 +247,18 @@ authPlugin storeToken clientID clientSecret =
-- User's access token is saved for further access to API -- User's access token is saved for further access to API
when storeToken $ setSession accessTokenKey accessToken' when storeToken $ setSession accessTokenKey accessToken'
personValue <- makeHttpRequest =<< personValueRequest token personValReq <- personValueRequest token
personValue <- makeHttpRequest personValReq
person <- case parseEither parseJSON personValue of person <- case parseEither parseJSON personValue of
Left e -> error e Left e -> error e
Right x -> return x Right x -> return x
email <- email <-
case map emailValue $ filter (\e -> emailType e == EmailAccount) $ personEmails person of case map emailValue $ filter (\e -> emailType e == EmailAccount) $ personEmails person of
[e] -> return e [e] -> return e
[] -> error "No account email" [] -> error "No account email"
x -> error $ "Too many account emails: " ++ show x x -> error $ "Too many account emails: " ++ show x
setCredsRedirect $ Creds pid email $ allPersonInfo personValue setCredsRedirect $ Creds pid email $ allPersonInfo personValue
dispatch _ _ = notFound dispatch _ _ = notFound
@ -450,16 +452,16 @@ data RelationshipStatus = Single -- ^ Person is single
instance FromJSON RelationshipStatus where instance FromJSON RelationshipStatus where
parseJSON = withText "RelationshipStatus" $ \t -> return $ case t of parseJSON = withText "RelationshipStatus" $ \t -> return $ case t of
"single" -> Single "single" -> Single
"in_a_relationship" -> InRelationship "in_a_relationship" -> InRelationship
"engaged" -> Engaged "engaged" -> Engaged
"married" -> Married "married" -> Married
"its_complicated" -> Complicated "its_complicated" -> Complicated
"open_relationship" -> OpenRelationship "open_relationship" -> OpenRelationship
"widowed" -> Widowed "widowed" -> Widowed
"in_domestic_partnership" -> DomesticPartnership "in_domestic_partnership" -> DomesticPartnership
"in_civil_union" -> CivilUnion "in_civil_union" -> CivilUnion
_ -> RelationshipStatus t _ -> RelationshipStatus t
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- | The URI of the person's profile photo. -- | The URI of the person's profile photo.

8
yesod-auth/Yesod/Auth/Hardcoded.hs
View File

@ -131,10 +131,9 @@ module Yesod.Auth.Hardcoded
, loginR ) , loginR )
where where
import Yesod.Auth (AuthPlugin (..), AuthRoute, import Yesod.Auth (AuthHandler, AuthPlugin (..), AuthRoute,
Creds (..), Route (..), YesodAuth, Creds (..), Route (..), YesodAuth,
loginErrorMessageI, setCredsRedirect, loginErrorMessageI, setCredsRedirect)
AuthHandler)
import qualified Yesod.Auth.Message as Msg import qualified Yesod.Auth.Message as Msg
import Yesod.Core import Yesod.Core
import Yesod.Form (ireq, runInputPost, textField) import Yesod.Form (ireq, runInputPost, textField)
@ -159,8 +158,9 @@ authHardcoded :: YesodAuthHardcoded m => AuthPlugin m
authHardcoded = authHardcoded =
AuthPlugin "hardcoded" dispatch loginWidget AuthPlugin "hardcoded" dispatch loginWidget
where where
dispatch :: YesodAuthHardcoded m => Text -> [Text] -> AuthHandler m TypedContent
dispatch "POST" ["login"] = postLoginR >>= sendResponse dispatch "POST" ["login"] = postLoginR >>= sendResponse
dispatch _ _ = notFound dispatch _ _ = notFound
loginWidget toMaster = do loginWidget toMaster = do
request <- getRequest request <- getRequest
[whamlet| [whamlet|

2
yesod-auth/yesod-auth.cabal
View File

@ -1,6 +1,6 @@
cabal-version: >=1.10 cabal-version: >=1.10
name: yesod-auth name: yesod-auth
version: 1.6.10.3 version: 1.6.10.4
license: MIT license: MIT
license-file: LICENSE license-file: LICENSE
author: Michael Snoyman, Patrick Brisbin author: Michael Snoyman, Patrick Brisbin