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
## 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

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

@ -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 @@ module Yesod.Auth.Dummy
( 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 :: YesodAuth m => AuthPlugin m
authDummy =
AuthPlugin "dummy" dispatch login
where
dispatch :: Text -> [Text] -> AuthHandler m TypedContent
dispatch "POST" [] = do
(jsonResult :: Result Value) <- parseCheckJsonBody
eIdent <- case jsonResult of

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

@ -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 @@ module Yesod.Auth.Email
, defaultRegisterHelper
) where
import Yesod.Auth
import qualified Yesod.Auth.Message as Msg
import Yesod.Core
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 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 Data.Aeson.Types (Parser, Result(..), parseMaybe, withObject, (.:?))
import Data.Maybe (isJust)
import Data.ByteArray (convert)
import Yesod.Auth
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
loginR = PluginR "email" ["login"]
@ -240,7 +242,7 @@ class ( YesodAuth site
--
-- @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 :: (YesodAuthEmail m) => AuthPlugin m
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 @@ defaultRegisterHelper allowUsername forgotPassword dest = do
_ -> 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 @@ defaultRegisterHelper allowUsername forgotPassword dest = do
let mpass = case (forgotPassword, creds) of
(False, Just (_, mp)) -> mp
_ -> Nothing
_ -> Nothing
case eidentifier of
Left failMsg -> loginErrorMessageI dest failMsg
@ -620,7 +623,7 @@ defaultRegisterHelper allowUsername forgotPassword dest = do
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 @@ postLoginR = do
_ -> 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 @@ getPasswordR = do
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 @@ postPasswordR = do
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 @@ postPasswordR = do
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 @@ postPasswordR = do
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 @@ postPasswordR = do
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 @@ postPasswordR = do
mr <- getMessageRender
selectRep $ do
provideRep $
provideRep $
fmap asHtml $ redirect $ afterPasswordRoute y
provideJsonMessage (mr msgOk)

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

@ -53,55 +53,55 @@ module Yesod.Auth.GoogleEmail2
, 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 @@ authPlugin storeToken clientID clientSecret =
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 @@ authPlugin storeToken clientID clientSecret =
-- 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 @@ data RelationshipStatus = Single -- ^ Person is single
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.

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

@ -131,10 +131,9 @@ module Yesod.Auth.Hardcoded
, 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 :: YesodAuthHardcoded m => AuthPlugin m
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|

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

@ -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