yesod-auth 0.4.0 → 0.4.0.1
raw patch · 11 files changed
+1228/−1225 lines, 11 filesdep +web-routes-quasisetup-changed
Dependencies added: web-routes-quasi
Files
- LICENSE +25/−25
- Setup.lhs +8/−8
- Yesod/Helpers/Auth.hs +270/−269
- Yesod/Helpers/Auth/Dummy.hs +35/−35
- Yesod/Helpers/Auth/Email.hs +298/−297
- Yesod/Helpers/Auth/Facebook.hs +82/−82
- Yesod/Helpers/Auth/HashDB.hs +210/−210
- Yesod/Helpers/Auth/OAuth.hs +89/−89
- Yesod/Helpers/Auth/OpenId.hs +94/−94
- Yesod/Helpers/Auth/Rpxnow.hs +59/−59
- yesod-auth.cabal +58/−57
LICENSE view
@@ -1,25 +1,25 @@-The following license covers this documentation, and the source code, except-where otherwise indicated.--Copyright 2010, Michael Snoyman. All rights reserved.--Redistribution and use in source and binary forms, with or without-modification, are permitted provided that the following conditions are met:--* Redistributions of source code must retain the above copyright notice, this- list of conditions and the following disclaimer.--* Redistributions in binary form must reproduce the above copyright notice,- this list of conditions and the following disclaimer in the documentation- and/or other materials provided with the distribution.--THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS "AS IS" AND ANY EXPRESS OR-IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF-MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO-EVENT SHALL THE COPYRIGHT HOLDERS BE LIABLE FOR ANY DIRECT, INDIRECT,-INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT-NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA,-OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF-LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE-OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF-ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.+The following license covers this documentation, and the source code, except +where otherwise indicated. + +Copyright 2010, Michael Snoyman. All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + +* Redistributions of source code must retain the above copyright notice, this + list of conditions and the following disclaimer. + +* Redistributions in binary form must reproduce the above copyright notice, + this list of conditions and the following disclaimer in the documentation + and/or other materials provided with the distribution. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS "AS IS" AND ANY EXPRESS OR +IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF +MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO +EVENT SHALL THE COPYRIGHT HOLDERS BE LIABLE FOR ANY DIRECT, INDIRECT, +INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT +NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, +OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF +LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE +OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF +ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
Setup.lhs view
@@ -1,8 +1,8 @@-#!/usr/bin/env runhaskell--> module Main where-> import Distribution.Simple-> import System.Cmd (system)--> main :: IO ()-> main = defaultMain+#!/usr/bin/env runhaskell + +> module Main where +> import Distribution.Simple +> import System.Cmd (system) + +> main :: IO () +> main = defaultMain
Yesod/Helpers/Auth.hs view
@@ -1,269 +1,270 @@-{-# LANGUAGE QuasiQuotes, TypeFamilies, TemplateHaskell #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE CPP #-}-{-# LANGUAGE OverloadedStrings #-}-module Yesod.Helpers.Auth- ( -- * Subsite- Auth- , AuthPlugin (..)- , AuthRoute (..)- , getAuth- , YesodAuth (..)- -- * Plugin interface- , Creds (..)- , setCreds- -- * User functions- , maybeAuthId- , maybeAuth- , requireAuthId- , requireAuth- ) where--import Yesod.Core-import Yesod.Persist-import Yesod.Json-import Text.Blaze-import Language.Haskell.TH.Syntax hiding (lift)-import qualified Network.Wai as W-import Text.Hamlet (hamlet)-import qualified Data.Map as Map-import Control.Monad.Trans.Class (lift)-import Data.Aeson-import Data.Text (Text)-import qualified Data.Text as T-import Data.Text.Encoding (decodeUtf8With)-import Data.Text.Encoding.Error (lenientDecode)-import Data.Monoid (mconcat)--data Auth = Auth--type Method = Text-type Piece = Text--data AuthPlugin m = AuthPlugin- { apName :: Text- , apDispatch :: Method -> [Piece] -> GHandler Auth m ()- , apLogin :: forall s. (Route Auth -> Route m) -> GWidget s m ()- }--getAuth :: a -> Auth-getAuth = const Auth---- | User credentials-data Creds m = Creds- { credsPlugin :: Text -- ^ How the user was authenticated- , credsIdent :: Text -- ^ Identifier. Exact meaning depends on plugin.- , credsExtra :: [(Text, Text)]- }--class (Yesod m, SinglePiece (AuthId m)) => YesodAuth m where- type AuthId m-- -- | Default destination on successful login, if no other- -- destination exists.- loginDest :: m -> Route m-- -- | Default destination on successful logout, if no other- -- destination exists.- logoutDest :: m -> Route m-- getAuthId :: Creds m -> GHandler s m (Maybe (AuthId m))-- authPlugins :: [AuthPlugin m]-- -- | What to show on the login page.- loginHandler :: GHandler Auth m RepHtml- loginHandler = defaultLayout $ do- setTitle "Login"- tm <- lift getRouteToMaster- mapM_ (flip apLogin tm) authPlugins-- ----- Message strings. In theory in the future make this localizable- ----- See gist: https://gist.github.com/778712- messageNoOpenID :: m -> Html- messageNoOpenID _ = "No OpenID identifier found"- messageLoginOpenID :: m -> Html- messageLoginOpenID _ = "Login via OpenID"-- messageEmail :: m -> Html- messageEmail _ = "Email"- messagePassword :: m -> Html- messagePassword _ = "Password"- messageRegister :: m -> Html- messageRegister _ = "Register"- messageRegisterLong :: m -> Html- messageRegisterLong _ = "Register a new account"- messageEnterEmail :: m -> Html- messageEnterEmail _ = "Enter your e-mail address below, and a confirmation e-mail will be sent to you."- messageConfirmationEmailSentTitle :: m -> Html- messageConfirmationEmailSentTitle _ = "Confirmation e-mail sent"- messageConfirmationEmailSent :: m -> Text -> Html- messageConfirmationEmailSent _ email = toHtml $ mconcat- ["A confirmation e-mail has been sent to ", email, "."]- messageAddressVerified :: m -> Html- messageAddressVerified _ = "Address verified, please set a new password"- messageInvalidKeyTitle :: m -> Html- messageInvalidKeyTitle _ = "Invalid verification key"- messageInvalidKey :: m -> Html- messageInvalidKey _ = "I'm sorry, but that was an invalid verification key."- messageInvalidEmailPass :: m -> Html- messageInvalidEmailPass _ = "Invalid email/password combination"- messageBadSetPass :: m -> Html- messageBadSetPass _ = "You must be logged in to set a password"- messageSetPassTitle :: m -> Html- messageSetPassTitle _ = "Set password"- messageSetPass :: m -> Html- messageSetPass _ = "Set a new password"- messageNewPass :: m -> Html- messageNewPass _ = "New password"- messageConfirmPass :: m -> Html- messageConfirmPass _ = "Confirm"- messagePassMismatch :: m -> Html- messagePassMismatch _ = "Passwords did not match, please try again"- messagePassUpdated :: m -> Html- messagePassUpdated _ = "Password updated"-- messageFacebook :: m -> Html- messageFacebook _ = "Login with Facebook"--type Texts = [Text]--mkYesodSub "Auth"- [ ClassP ''YesodAuth [VarT $ mkName "master"]- ]-#define STRINGS *Texts-#if GHC7- [parseRoutes|-#else- [$parseRoutes|-#endif-/check CheckR GET-/login LoginR GET-/logout LogoutR GET POST-/page/#Text/STRINGS PluginR-|]--credsKey :: Text-credsKey = "_ID"---- | FIXME: won't show up till redirect-setCreds :: YesodAuth m => Bool -> Creds m -> GHandler s m ()-setCreds doRedirects creds = do- y <- getYesod- maid <- getAuthId creds- case maid of- Nothing ->- if doRedirects- then do- case authRoute y of- Nothing -> do- rh <- defaultLayout-#if GHC7- [hamlet|-#else- [$hamlet|-#endif- <h1>Invalid login-|]- sendResponse rh- Just ar -> do- setMessage "Invalid login"- redirect RedirectTemporary ar- else return ()- Just aid -> do- setSession credsKey $ toSinglePiece aid- if doRedirects- then do- setMessage "You are now logged in"- redirectUltDest RedirectTemporary $ loginDest y- else return ()--getCheckR :: YesodAuth m => GHandler Auth m RepHtmlJson-getCheckR = do- creds <- maybeAuthId- defaultLayoutJson (do- setTitle "Authentication Status"- addHtml $ html creds) (json' creds)- where- html creds =-#if GHC7- [hamlet|-#else- [$hamlet|-#endif-<h1>Authentication Status-$maybe _ <- creds- <p>Logged in.-$nothing- <p>Not logged in.-|]- json' creds =- Object $ Map.fromList- [ (T.pack "logged_in", Bool $ maybe False (const True) creds)- ]--getLoginR :: YesodAuth m => GHandler Auth m RepHtml-getLoginR = loginHandler--getLogoutR :: YesodAuth m => GHandler Auth m ()-getLogoutR = postLogoutR -- FIXME redirect to post--postLogoutR :: YesodAuth m => GHandler Auth m ()-postLogoutR = do- y <- getYesod- deleteSession credsKey- redirectUltDest RedirectTemporary $ logoutDest y--handlePluginR :: YesodAuth m => Text -> [Text] -> GHandler Auth m ()-handlePluginR plugin pieces = do- env <- waiRequest- let method = decodeUtf8With lenientDecode $ W.requestMethod env- case filter (\x -> apName x == plugin) authPlugins of- [] -> notFound- ap:_ -> apDispatch ap method pieces---- | Retrieves user credentials, if user is authenticated.-maybeAuthId :: YesodAuth m => GHandler s m (Maybe (AuthId m))-maybeAuthId = do- ms <- lookupSession credsKey- case ms of- Nothing -> return Nothing- Just s -> return $ fromSinglePiece s--maybeAuth :: ( YesodAuth m- , Key val ~ AuthId m- , PersistBackend (YesodDB m (GGHandler s m IO))- , PersistEntity val- , YesodPersist m- ) => GHandler s m (Maybe (Key val, val))-maybeAuth = do- maid <- maybeAuthId- case maid of- Nothing -> return Nothing- Just aid -> do- ma <- runDB $ get aid- case ma of- Nothing -> return Nothing- Just a -> return $ Just (aid, a)--requireAuthId :: YesodAuth m => GHandler s m (AuthId m)-requireAuthId = maybeAuthId >>= maybe redirectLogin return--requireAuth :: ( YesodAuth m- , Key val ~ AuthId m- , PersistBackend (YesodDB m (GGHandler s m IO))- , PersistEntity val- , YesodPersist m- ) => GHandler s m (Key val, val)-requireAuth = maybeAuth >>= maybe redirectLogin return--redirectLogin :: Yesod m => GHandler s m a-redirectLogin = do- y <- getYesod- setUltDest'- case authRoute y of- Just z -> redirect RedirectTemporary z- Nothing -> permissionDenied "Please configure authRoute"+{-# LANGUAGE QuasiQuotes, TypeFamilies, TemplateHaskell #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE OverloadedStrings #-} +module Yesod.Helpers.Auth + ( -- * Subsite + Auth + , AuthPlugin (..) + , AuthRoute (..) + , getAuth + , YesodAuth (..) + -- * Plugin interface + , Creds (..) + , setCreds + -- * User functions + , maybeAuthId + , maybeAuth + , requireAuthId + , requireAuth + ) where + +import Yesod.Core +import Yesod.Persist +import Yesod.Json +import Text.Blaze +import Language.Haskell.TH.Syntax hiding (lift) +import qualified Network.Wai as W +import Text.Hamlet (hamlet) +import qualified Data.Map as Map +import Control.Monad.Trans.Class (lift) +import Data.Aeson +import Data.Text (Text) +import qualified Data.Text as T +import Data.Text.Encoding (decodeUtf8With) +import Data.Text.Encoding.Error (lenientDecode) +import Data.Monoid (mconcat) +import Web.Routes.Quasi (toSinglePiece, fromSinglePiece) + +data Auth = Auth + +type Method = Text +type Piece = Text + +data AuthPlugin m = AuthPlugin + { apName :: Text + , apDispatch :: Method -> [Piece] -> GHandler Auth m () + , apLogin :: forall s. (Route Auth -> Route m) -> GWidget s m () + } + +getAuth :: a -> Auth +getAuth = const Auth + +-- | User credentials +data Creds m = Creds + { credsPlugin :: Text -- ^ How the user was authenticated + , credsIdent :: Text -- ^ Identifier. Exact meaning depends on plugin. + , credsExtra :: [(Text, Text)] + } + +class (Yesod m, SinglePiece (AuthId m)) => YesodAuth m where + type AuthId m + + -- | Default destination on successful login, if no other + -- destination exists. + loginDest :: m -> Route m + + -- | Default destination on successful logout, if no other + -- destination exists. + logoutDest :: m -> Route m + + getAuthId :: Creds m -> GHandler s m (Maybe (AuthId m)) + + authPlugins :: [AuthPlugin m] + + -- | What to show on the login page. + loginHandler :: GHandler Auth m RepHtml + loginHandler = defaultLayout $ do + setTitle "Login" + tm <- lift getRouteToMaster + mapM_ (flip apLogin tm) authPlugins + + ----- Message strings. In theory in the future make this localizable + ----- See gist: https://gist.github.com/778712 + messageNoOpenID :: m -> Html + messageNoOpenID _ = "No OpenID identifier found" + messageLoginOpenID :: m -> Html + messageLoginOpenID _ = "Login via OpenID" + + messageEmail :: m -> Html + messageEmail _ = "Email" + messagePassword :: m -> Html + messagePassword _ = "Password" + messageRegister :: m -> Html + messageRegister _ = "Register" + messageRegisterLong :: m -> Html + messageRegisterLong _ = "Register a new account" + messageEnterEmail :: m -> Html + messageEnterEmail _ = "Enter your e-mail address below, and a confirmation e-mail will be sent to you." + messageConfirmationEmailSentTitle :: m -> Html + messageConfirmationEmailSentTitle _ = "Confirmation e-mail sent" + messageConfirmationEmailSent :: m -> Text -> Html + messageConfirmationEmailSent _ email = toHtml $ mconcat + ["A confirmation e-mail has been sent to ", email, "."] + messageAddressVerified :: m -> Html + messageAddressVerified _ = "Address verified, please set a new password" + messageInvalidKeyTitle :: m -> Html + messageInvalidKeyTitle _ = "Invalid verification key" + messageInvalidKey :: m -> Html + messageInvalidKey _ = "I'm sorry, but that was an invalid verification key." + messageInvalidEmailPass :: m -> Html + messageInvalidEmailPass _ = "Invalid email/password combination" + messageBadSetPass :: m -> Html + messageBadSetPass _ = "You must be logged in to set a password" + messageSetPassTitle :: m -> Html + messageSetPassTitle _ = "Set password" + messageSetPass :: m -> Html + messageSetPass _ = "Set a new password" + messageNewPass :: m -> Html + messageNewPass _ = "New password" + messageConfirmPass :: m -> Html + messageConfirmPass _ = "Confirm" + messagePassMismatch :: m -> Html + messagePassMismatch _ = "Passwords did not match, please try again" + messagePassUpdated :: m -> Html + messagePassUpdated _ = "Password updated" + + messageFacebook :: m -> Html + messageFacebook _ = "Login with Facebook" + +type Texts = [Text] + +mkYesodSub "Auth" + [ ClassP ''YesodAuth [VarT $ mkName "master"] + ] +#define STRINGS *Texts +#if GHC7 + [parseRoutes| +#else + [$parseRoutes| +#endif +/check CheckR GET +/login LoginR GET +/logout LogoutR GET POST +/page/#Text/STRINGS PluginR +|] + +credsKey :: Text +credsKey = "_ID" + +-- | FIXME: won't show up till redirect +setCreds :: YesodAuth m => Bool -> Creds m -> GHandler s m () +setCreds doRedirects creds = do + y <- getYesod + maid <- getAuthId creds + case maid of + Nothing -> + if doRedirects + then do + case authRoute y of + Nothing -> do + rh <- defaultLayout +#if GHC7 + [hamlet| +#else + [$hamlet| +#endif + <h1>Invalid login +|] + sendResponse rh + Just ar -> do + setMessage "Invalid login" + redirect RedirectTemporary ar + else return () + Just aid -> do + setSession credsKey $ toSinglePiece aid + if doRedirects + then do + setMessage "You are now logged in" + redirectUltDest RedirectTemporary $ loginDest y + else return () + +getCheckR :: YesodAuth m => GHandler Auth m RepHtmlJson +getCheckR = do + creds <- maybeAuthId + defaultLayoutJson (do + setTitle "Authentication Status" + addHtml $ html creds) (json' creds) + where + html creds = +#if GHC7 + [hamlet| +#else + [$hamlet| +#endif +<h1>Authentication Status +$maybe _ <- creds + <p>Logged in. +$nothing + <p>Not logged in. +|] + json' creds = + Object $ Map.fromList + [ (T.pack "logged_in", Bool $ maybe False (const True) creds) + ] + +getLoginR :: YesodAuth m => GHandler Auth m RepHtml +getLoginR = loginHandler + +getLogoutR :: YesodAuth m => GHandler Auth m () +getLogoutR = postLogoutR -- FIXME redirect to post + +postLogoutR :: YesodAuth m => GHandler Auth m () +postLogoutR = do + y <- getYesod + deleteSession credsKey + redirectUltDest RedirectTemporary $ logoutDest y + +handlePluginR :: YesodAuth m => Text -> [Text] -> GHandler Auth m () +handlePluginR plugin pieces = do + env <- waiRequest + let method = decodeUtf8With lenientDecode $ W.requestMethod env + case filter (\x -> apName x == plugin) authPlugins of + [] -> notFound + ap:_ -> apDispatch ap method pieces + +-- | Retrieves user credentials, if user is authenticated. +maybeAuthId :: YesodAuth m => GHandler s m (Maybe (AuthId m)) +maybeAuthId = do + ms <- lookupSession credsKey + case ms of + Nothing -> return Nothing + Just s -> return $ fromSinglePiece s + +maybeAuth :: ( YesodAuth m + , Key val ~ AuthId m + , PersistBackend (YesodDB m (GGHandler s m IO)) + , PersistEntity val + , YesodPersist m + ) => GHandler s m (Maybe (Key val, val)) +maybeAuth = do + maid <- maybeAuthId + case maid of + Nothing -> return Nothing + Just aid -> do + ma <- runDB $ get aid + case ma of + Nothing -> return Nothing + Just a -> return $ Just (aid, a) + +requireAuthId :: YesodAuth m => GHandler s m (AuthId m) +requireAuthId = maybeAuthId >>= maybe redirectLogin return + +requireAuth :: ( YesodAuth m + , Key val ~ AuthId m + , PersistBackend (YesodDB m (GGHandler s m IO)) + , PersistEntity val + , YesodPersist m + ) => GHandler s m (Key val, val) +requireAuth = maybeAuth >>= maybe redirectLogin return + +redirectLogin :: Yesod m => GHandler s m a +redirectLogin = do + y <- getYesod + setUltDest' + case authRoute y of + Just z -> redirect RedirectTemporary z + Nothing -> permissionDenied "Please configure authRoute"
Yesod/Helpers/Auth/Dummy.hs view
@@ -1,35 +1,35 @@-{-# LANGUAGE QuasiQuotes #-}-{-# LANGUAGE CPP #-}-{-# LANGUAGE OverloadedStrings #-}--- | Provides a dummy authentication module that simply lets a user specify--- his/her identifier. This is not intended for real world use, just for--- testing.-module Yesod.Helpers.Auth.Dummy- ( authDummy- ) where--import Yesod.Helpers.Auth-import Yesod.Form (runFormPost', stringInput)-import Yesod.Handler (notFound)-import Text.Hamlet (hamlet)--authDummy :: YesodAuth m => AuthPlugin m-authDummy =- AuthPlugin "dummy" dispatch login- where- dispatch "POST" [] = do- ident <- runFormPost' $ stringInput "ident"- setCreds True $ Creds "dummy" ident []- dispatch _ _ = notFound- url = PluginR "dummy" []- login authToMaster =-#if GHC7- [hamlet|-#else- [$hamlet|-#endif-<form method="post" action="@{authToMaster url}">- \Your new identifier is: - <input type="text" name="ident">- <input type="submit" value="Dummy Login">-|]+{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE OverloadedStrings #-} +-- | Provides a dummy authentication module that simply lets a user specify +-- his/her identifier. This is not intended for real world use, just for +-- testing. +module Yesod.Helpers.Auth.Dummy + ( authDummy + ) where + +import Yesod.Helpers.Auth +import Yesod.Form (runFormPost', stringInput) +import Yesod.Handler (notFound) +import Text.Hamlet (hamlet) + +authDummy :: YesodAuth m => AuthPlugin m +authDummy = + AuthPlugin "dummy" dispatch login + where + dispatch "POST" [] = do + ident <- runFormPost' $ stringInput "ident" + setCreds True $ Creds "dummy" ident [] + dispatch _ _ = notFound + url = PluginR "dummy" [] + login authToMaster = +#if GHC7 + [hamlet| +#else + [$hamlet| +#endif +<form method="post" action="@{authToMaster url}"> + \Your new identifier is: + <input type="text" name="ident"> + <input type="submit" value="Dummy Login"> +|]
Yesod/Helpers/Auth/Email.hs view
@@ -1,297 +1,298 @@-{-# LANGUAGE QuasiQuotes, TypeFamilies #-}-{-# LANGUAGE CPP #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE FlexibleContexts #-}-module Yesod.Helpers.Auth.Email- ( -- * Plugin- authEmail- , YesodAuthEmail (..)- , EmailCreds (..)- , saltPass- -- * Routes- , loginR- , registerR- , setpassR- ) where--import Network.Mail.Mime (randomString)-import Yesod.Helpers.Auth-import System.Random-import Control.Monad (when)-import Control.Applicative ((<$>), (<*>))-import Data.Digest.Pure.MD5-import qualified Data.Text.Lazy as T-import qualified Data.Text as TS-import Data.Text.Lazy.Encoding (encodeUtf8)-import Data.Text (Text)--import Yesod.Form-import Yesod.Handler-import Yesod.Content-import Yesod.Widget-import Yesod.Core-import Text.Hamlet (hamlet)-import Control.Monad.IO.Class (liftIO)-import Control.Monad.Trans.Class (lift)--loginR, registerR, setpassR :: AuthRoute-loginR = PluginR "email" ["login"]-registerR = PluginR "email" ["register"]-setpassR = PluginR "email" ["set-password"]--verify :: Text -> Text -> AuthRoute -- FIXME-verify eid verkey = PluginR "email" ["verify", eid, verkey]--type Email = Text-type VerKey = Text-type VerUrl = Text-type SaltedPass = Text-type VerStatus = Bool---- | Data stored in a database for each e-mail address.-data EmailCreds m = EmailCreds- { emailCredsId :: AuthEmailId m- , emailCredsAuthId :: Maybe (AuthId m)- , emailCredsStatus :: VerStatus- , emailCredsVerkey :: Maybe VerKey- }--class (YesodAuth m, SinglePiece (AuthEmailId m)) => YesodAuthEmail m where- type AuthEmailId m-- addUnverified :: Email -> VerKey -> GHandler Auth m (AuthEmailId m)- sendVerifyEmail :: Email -> VerKey -> VerUrl -> GHandler Auth m ()- getVerifyKey :: AuthEmailId m -> GHandler Auth m (Maybe VerKey)- setVerifyKey :: AuthEmailId m -> VerKey -> GHandler Auth m ()- verifyAccount :: AuthEmailId m -> GHandler Auth m (Maybe (AuthId m))- getPassword :: AuthId m -> GHandler Auth m (Maybe SaltedPass)- setPassword :: AuthId m -> SaltedPass -> GHandler Auth m ()- getEmailCreds :: Email -> GHandler Auth m (Maybe (EmailCreds m))- getEmail :: AuthEmailId m -> GHandler Auth m (Maybe Email)-- -- | Generate a random alphanumeric string.- randomKey :: m -> IO Text- randomKey _ = do- stdgen <- newStdGen- return $ TS.pack $ fst $ randomString 10 stdgen--authEmail :: YesodAuthEmail m => AuthPlugin m-authEmail =- AuthPlugin "email" dispatch $ \tm -> do- y <- lift getYesod-#if GHC7- [hamlet|-#else- [$hamlet|-#endif-<form method="post" action="@{tm loginR}">- <table>- <tr>- <th>#{messageEmail y}- <td>- <input type="email" name="email">- <tr>- <th>#{messagePassword y}- <td>- <input type="password" name="password">- <tr>- <td colspan="2">- <input type="submit" value="Login via email">- <a href="@{tm registerR}">I don't have an account-|]- where- dispatch "GET" ["register"] = getRegisterR >>= sendResponse- dispatch "POST" ["register"] = postRegisterR >>= sendResponse- dispatch "GET" ["verify", eid, verkey] =- case fromSinglePiece eid of- Nothing -> notFound- Just eid' -> getVerifyR eid' verkey >>= sendResponse- dispatch "POST" ["login"] = postLoginR >>= sendResponse- dispatch "GET" ["set-password"] = getPasswordR >>= sendResponse- dispatch "POST" ["set-password"] = postPasswordR >>= sendResponse- dispatch _ _ = notFound--getRegisterR :: YesodAuthEmail master => GHandler Auth master RepHtml-getRegisterR = do- y <- getYesod- toMaster <- getRouteToMaster- defaultLayout $ do- setTitle $ messageRegisterLong y- addHamlet-#if GHC7- [hamlet|-#else- [$hamlet|-#endif-<p>#{messageEnterEmail y}-<form method="post" action="@{toMaster registerR}">- <label for="email">#{messageEmail y}- <input type="email" name="email" width="150">- <input type="submit" value="#{messageRegister y}">-|]--postRegisterR :: YesodAuthEmail master => GHandler Auth master RepHtml-postRegisterR = do- y <- getYesod- email <- runFormPost' $ emailInput "email"- mecreds <- getEmailCreds email- (lid, verKey) <-- case mecreds of- Just (EmailCreds lid _ _ (Just key)) -> return (lid, key)- Just (EmailCreds lid _ _ Nothing) -> do- key <- liftIO $ randomKey y- setVerifyKey lid key- return (lid, key)- Nothing -> do- key <- liftIO $ randomKey y- lid <- addUnverified email key- return (lid, key)- render <- getUrlRender- tm <- getRouteToMaster- let verUrl = render $ tm $ verify (toSinglePiece lid) verKey- sendVerifyEmail email verKey verUrl- defaultLayout $ do- setTitle $ messageConfirmationEmailSentTitle y- addWidget-#if GHC7- [hamlet|-#else- [$hamlet|-#endif-<p>#{messageConfirmationEmailSent y email}-|]--getVerifyR :: YesodAuthEmail m- => AuthEmailId m -> Text -> GHandler Auth m RepHtml-getVerifyR lid key = do- realKey <- getVerifyKey lid- memail <- getEmail lid- y <- getYesod- case (realKey == Just key, memail) of- (True, Just email) -> do- muid <- verifyAccount lid- case muid of- Nothing -> return ()- Just _uid -> do- setCreds False $ Creds "email" email [("verifiedEmail", email)] -- FIXME uid?- toMaster <- getRouteToMaster- setMessage $ messageAddressVerified y- redirect RedirectTemporary $ toMaster setpassR- _ -> return ()- defaultLayout $ do- setTitle $ messageInvalidKey y- addHtml-#if GHC7- [hamlet|-#else- [$hamlet|-#endif-<p>#{messageInvalidKey y}-|]--postLoginR :: YesodAuthEmail master => GHandler Auth master ()-postLoginR = do- (email, pass) <- runFormPost' $ (,)- <$> emailInput "email"- <*> stringInput "password"- mecreds <- getEmailCreds email- maid <-- case (mecreds >>= emailCredsAuthId, fmap emailCredsStatus mecreds) of- (Just aid, Just True) -> do- mrealpass <- getPassword aid- case mrealpass of- Nothing -> return Nothing- Just realpass -> return $- if isValidPass pass realpass- then Just aid- else Nothing- _ -> return Nothing- case maid of- Just _aid ->- setCreds True $ Creds "email" email [("verifiedEmail", email)] -- FIXME aid?- Nothing -> do- y <- getYesod- setMessage $ messageInvalidEmailPass y- toMaster <- getRouteToMaster- redirect RedirectTemporary $ toMaster LoginR--getPasswordR :: YesodAuthEmail master => GHandler Auth master RepHtml-getPasswordR = do- toMaster <- getRouteToMaster- maid <- maybeAuthId- y <- getYesod- case maid of- Just _ -> return ()- Nothing -> do- setMessage $ messageBadSetPass y- redirect RedirectTemporary $ toMaster loginR- defaultLayout $ do- setTitle $ messageSetPassTitle y- addHamlet-#if GHC7- [hamlet|-#else- [$hamlet|-#endif-<h3>#{messageSetPass y}-<form method="post" action="@{toMaster setpassR}">- <table>- <tr>- <th>#{messageNewPass y}- <td>- <input type="password" name="new">- <tr>- <th>#{messageConfirmPass y}- <td>- <input type="password" name="confirm">- <tr>- <td colspan="2">- <input type="submit" value="#{messageSetPassTitle y}">-|]--postPasswordR :: YesodAuthEmail master => GHandler Auth master ()-postPasswordR = do- (new, confirm) <- runFormPost' $ (,)- <$> stringInput "new"- <*> stringInput "confirm"- toMaster <- getRouteToMaster- y <- getYesod- when (new /= confirm) $ do- setMessage $ messagePassMismatch y- redirect RedirectTemporary $ toMaster setpassR- maid <- maybeAuthId- aid <- case maid of- Nothing -> do- setMessage $ messageBadSetPass y- redirect RedirectTemporary $ toMaster loginR- Just aid -> return aid- salted <- liftIO $ saltPass new- setPassword aid salted- setMessage $ messagePassUpdated y- redirect RedirectTemporary $ loginDest y--saltLength :: Int-saltLength = 5---- | Salt a password with a randomly generated salt.-saltPass :: Text -> IO Text-saltPass pass = do- stdgen <- newStdGen- let salt = take saltLength $ randomRs ('A', 'Z') stdgen- return $ TS.pack $ saltPass' salt $ TS.unpack pass--saltPass' :: String -> String -> String-saltPass' salt pass =- salt ++ show (md5 $ fromString $ salt ++ pass)- where- fromString = encodeUtf8 . T.pack--isValidPass :: Text -- ^ cleartext password- -> SaltedPass -- ^ salted password- -> Bool-isValidPass clear' salted' =- let salt = take saltLength salted- in salted == saltPass' salt clear- where- clear = TS.unpack clear'- salted = TS.unpack salted'+{-# LANGUAGE QuasiQuotes, TypeFamilies #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE FlexibleContexts #-} +module Yesod.Helpers.Auth.Email + ( -- * Plugin + authEmail + , YesodAuthEmail (..) + , EmailCreds (..) + , saltPass + -- * Routes + , loginR + , registerR + , setpassR + ) where + +import Network.Mail.Mime (randomString) +import Yesod.Helpers.Auth +import System.Random +import Control.Monad (when) +import Control.Applicative ((<$>), (<*>)) +import Data.Digest.Pure.MD5 +import qualified Data.Text.Lazy as T +import qualified Data.Text as TS +import Data.Text.Lazy.Encoding (encodeUtf8) +import Data.Text (Text) + +import Yesod.Form +import Yesod.Handler +import Yesod.Content +import Yesod.Widget +import Yesod.Core +import Text.Hamlet (hamlet) +import Control.Monad.IO.Class (liftIO) +import Control.Monad.Trans.Class (lift) +import Web.Routes.Quasi (toSinglePiece, fromSinglePiece) + +loginR, registerR, setpassR :: AuthRoute +loginR = PluginR "email" ["login"] +registerR = PluginR "email" ["register"] +setpassR = PluginR "email" ["set-password"] + +verify :: Text -> Text -> AuthRoute -- FIXME +verify eid verkey = PluginR "email" ["verify", eid, verkey] + +type Email = Text +type VerKey = Text +type VerUrl = Text +type SaltedPass = Text +type VerStatus = Bool + +-- | Data stored in a database for each e-mail address. +data EmailCreds m = EmailCreds + { emailCredsId :: AuthEmailId m + , emailCredsAuthId :: Maybe (AuthId m) + , emailCredsStatus :: VerStatus + , emailCredsVerkey :: Maybe VerKey + } + +class (YesodAuth m, SinglePiece (AuthEmailId m)) => YesodAuthEmail m where + type AuthEmailId m + + addUnverified :: Email -> VerKey -> GHandler Auth m (AuthEmailId m) + sendVerifyEmail :: Email -> VerKey -> VerUrl -> GHandler Auth m () + getVerifyKey :: AuthEmailId m -> GHandler Auth m (Maybe VerKey) + setVerifyKey :: AuthEmailId m -> VerKey -> GHandler Auth m () + verifyAccount :: AuthEmailId m -> GHandler Auth m (Maybe (AuthId m)) + getPassword :: AuthId m -> GHandler Auth m (Maybe SaltedPass) + setPassword :: AuthId m -> SaltedPass -> GHandler Auth m () + getEmailCreds :: Email -> GHandler Auth m (Maybe (EmailCreds m)) + getEmail :: AuthEmailId m -> GHandler Auth m (Maybe Email) + + -- | Generate a random alphanumeric string. + randomKey :: m -> IO Text + randomKey _ = do + stdgen <- newStdGen + return $ TS.pack $ fst $ randomString 10 stdgen + +authEmail :: YesodAuthEmail m => AuthPlugin m +authEmail = + AuthPlugin "email" dispatch $ \tm -> do + y <- lift getYesod +#if GHC7 + [hamlet| +#else + [$hamlet| +#endif +<form method="post" action="@{tm loginR}"> + <table> + <tr> + <th>#{messageEmail y} + <td> + <input type="email" name="email"> + <tr> + <th>#{messagePassword y} + <td> + <input type="password" name="password"> + <tr> + <td colspan="2"> + <input type="submit" value="Login via email"> + <a href="@{tm registerR}">I don't have an account +|] + where + dispatch "GET" ["register"] = getRegisterR >>= sendResponse + dispatch "POST" ["register"] = postRegisterR >>= sendResponse + dispatch "GET" ["verify", eid, verkey] = + case fromSinglePiece eid of + Nothing -> notFound + Just eid' -> getVerifyR eid' verkey >>= sendResponse + dispatch "POST" ["login"] = postLoginR >>= sendResponse + dispatch "GET" ["set-password"] = getPasswordR >>= sendResponse + dispatch "POST" ["set-password"] = postPasswordR >>= sendResponse + dispatch _ _ = notFound + +getRegisterR :: YesodAuthEmail master => GHandler Auth master RepHtml +getRegisterR = do + y <- getYesod + toMaster <- getRouteToMaster + defaultLayout $ do + setTitle $ messageRegisterLong y + addHamlet +#if GHC7 + [hamlet| +#else + [$hamlet| +#endif +<p>#{messageEnterEmail y} +<form method="post" action="@{toMaster registerR}"> + <label for="email">#{messageEmail y} + <input type="email" name="email" width="150"> + <input type="submit" value="#{messageRegister y}"> +|] + +postRegisterR :: YesodAuthEmail master => GHandler Auth master RepHtml +postRegisterR = do + y <- getYesod + email <- runFormPost' $ emailInput "email" + mecreds <- getEmailCreds email + (lid, verKey) <- + case mecreds of + Just (EmailCreds lid _ _ (Just key)) -> return (lid, key) + Just (EmailCreds lid _ _ Nothing) -> do + key <- liftIO $ randomKey y + setVerifyKey lid key + return (lid, key) + Nothing -> do + key <- liftIO $ randomKey y + lid <- addUnverified email key + return (lid, key) + render <- getUrlRender + tm <- getRouteToMaster + let verUrl = render $ tm $ verify (toSinglePiece lid) verKey + sendVerifyEmail email verKey verUrl + defaultLayout $ do + setTitle $ messageConfirmationEmailSentTitle y + addWidget +#if GHC7 + [hamlet| +#else + [$hamlet| +#endif +<p>#{messageConfirmationEmailSent y email} +|] + +getVerifyR :: YesodAuthEmail m + => AuthEmailId m -> Text -> GHandler Auth m RepHtml +getVerifyR lid key = do + realKey <- getVerifyKey lid + memail <- getEmail lid + y <- getYesod + case (realKey == Just key, memail) of + (True, Just email) -> do + muid <- verifyAccount lid + case muid of + Nothing -> return () + Just _uid -> do + setCreds False $ Creds "email" email [("verifiedEmail", email)] -- FIXME uid? + toMaster <- getRouteToMaster + setMessage $ messageAddressVerified y + redirect RedirectTemporary $ toMaster setpassR + _ -> return () + defaultLayout $ do + setTitle $ messageInvalidKey y + addHtml +#if GHC7 + [hamlet| +#else + [$hamlet| +#endif +<p>#{messageInvalidKey y} +|] + +postLoginR :: YesodAuthEmail master => GHandler Auth master () +postLoginR = do + (email, pass) <- runFormPost' $ (,) + <$> emailInput "email" + <*> stringInput "password" + mecreds <- getEmailCreds email + maid <- + case (mecreds >>= emailCredsAuthId, fmap emailCredsStatus mecreds) of + (Just aid, Just True) -> do + mrealpass <- getPassword aid + case mrealpass of + Nothing -> return Nothing + Just realpass -> return $ + if isValidPass pass realpass + then Just aid + else Nothing + _ -> return Nothing + case maid of + Just _aid -> + setCreds True $ Creds "email" email [("verifiedEmail", email)] -- FIXME aid? + Nothing -> do + y <- getYesod + setMessage $ messageInvalidEmailPass y + toMaster <- getRouteToMaster + redirect RedirectTemporary $ toMaster LoginR + +getPasswordR :: YesodAuthEmail master => GHandler Auth master RepHtml +getPasswordR = do + toMaster <- getRouteToMaster + maid <- maybeAuthId + y <- getYesod + case maid of + Just _ -> return () + Nothing -> do + setMessage $ messageBadSetPass y + redirect RedirectTemporary $ toMaster loginR + defaultLayout $ do + setTitle $ messageSetPassTitle y + addHamlet +#if GHC7 + [hamlet| +#else + [$hamlet| +#endif +<h3>#{messageSetPass y} +<form method="post" action="@{toMaster setpassR}"> + <table> + <tr> + <th>#{messageNewPass y} + <td> + <input type="password" name="new"> + <tr> + <th>#{messageConfirmPass y} + <td> + <input type="password" name="confirm"> + <tr> + <td colspan="2"> + <input type="submit" value="#{messageSetPassTitle y}"> +|] + +postPasswordR :: YesodAuthEmail master => GHandler Auth master () +postPasswordR = do + (new, confirm) <- runFormPost' $ (,) + <$> stringInput "new" + <*> stringInput "confirm" + toMaster <- getRouteToMaster + y <- getYesod + when (new /= confirm) $ do + setMessage $ messagePassMismatch y + redirect RedirectTemporary $ toMaster setpassR + maid <- maybeAuthId + aid <- case maid of + Nothing -> do + setMessage $ messageBadSetPass y + redirect RedirectTemporary $ toMaster loginR + Just aid -> return aid + salted <- liftIO $ saltPass new + setPassword aid salted + setMessage $ messagePassUpdated y + redirect RedirectTemporary $ loginDest y + +saltLength :: Int +saltLength = 5 + +-- | Salt a password with a randomly generated salt. +saltPass :: Text -> IO Text +saltPass pass = do + stdgen <- newStdGen + let salt = take saltLength $ randomRs ('A', 'Z') stdgen + return $ TS.pack $ saltPass' salt $ TS.unpack pass + +saltPass' :: String -> String -> String +saltPass' salt pass = + salt ++ show (md5 $ fromString $ salt ++ pass) + where + fromString = encodeUtf8 . T.pack + +isValidPass :: Text -- ^ cleartext password + -> SaltedPass -- ^ salted password + -> Bool +isValidPass clear' salted' = + let salt = take saltLength salted + in salted == saltPass' salt clear + where + clear = TS.unpack clear' + salted = TS.unpack salted'
Yesod/Helpers/Auth/Facebook.hs view
@@ -1,82 +1,82 @@-{-# LANGUAGE QuasiQuotes #-}-{-# LANGUAGE CPP #-}-{-# LANGUAGE OverloadedStrings #-}-module Yesod.Helpers.Auth.Facebook- ( authFacebook- , facebookUrl- ) where--import Yesod.Helpers.Auth-import qualified Web.Authenticate.Facebook as Facebook-import Data.Aeson-import Data.Aeson.Types (parseMaybe)-import Data.Maybe (fromMaybe)--import Yesod.Form-import Yesod.Handler-import Yesod.Widget-import Text.Hamlet (hamlet)-import Control.Monad.IO.Class (liftIO)-import Control.Monad.Trans.Class (lift)-import Data.Text (Text)-import Control.Monad (mzero)-import Data.Monoid (mappend)-import qualified Data.Aeson.Types--facebookUrl :: AuthRoute-facebookUrl = PluginR "facebook" ["forward"]--authFacebook :: YesodAuth m- => Text -- ^ Application ID- -> Text -- ^ Application secret- -> [Text] -- ^ Requested permissions- -> AuthPlugin m-authFacebook cid secret perms =- AuthPlugin "facebook" dispatch login- where- url = PluginR "facebook" []- dispatch "GET" ["forward"] = do- tm <- getRouteToMaster- render <- getUrlRender- let fb = Facebook.Facebook cid secret $ render $ tm url- redirectText RedirectTemporary $ Facebook.getForwardUrl fb perms- dispatch "GET" [] = do- render <- getUrlRender- tm <- getRouteToMaster- let fb = Facebook.Facebook cid secret $ render $ tm url- code <- runFormGet' $ stringInput "code"- at <- liftIO $ Facebook.getAccessToken fb code- let Facebook.AccessToken at' = at- so <- liftIO $ Facebook.getGraphData at "me"- let c = fromMaybe (error "Invalid response from Facebook")- $ parseMaybe (parseCreds at') $ either error id so- setCreds True c- dispatch _ _ = notFound- login tm = do- render <- lift getUrlRender- let fb = Facebook.Facebook cid secret $ render $ tm url- let furl = Facebook.getForwardUrl fb $ perms- y <- lift getYesod- addHtml-#if GHC7- [hamlet|-#else- [$hamlet|-#endif-<p>- <a href="#{furl}">#{messageFacebook y}-|]--parseCreds :: Text -> Value -> Data.Aeson.Types.Parser (Creds m)-parseCreds at' (Object m) = do- id' <- m .: "id"- let id'' = "http://graph.facebook.com/" `mappend` id'- name <- m .: "name"- email <- m .: "email"- return- $ Creds "facebook" id''- $ maybe id (\x -> (:) ("verifiedEmail", x)) email- $ maybe id (\x -> (:) ("displayName ", x)) name- [ ("accessToken", at')- ]-parseCreds _ _ = mzero+{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE OverloadedStrings #-} +module Yesod.Helpers.Auth.Facebook + ( authFacebook + , facebookUrl + ) where + +import Yesod.Helpers.Auth +import qualified Web.Authenticate.Facebook as Facebook +import Data.Aeson +import Data.Aeson.Types (parseMaybe) +import Data.Maybe (fromMaybe) + +import Yesod.Form +import Yesod.Handler +import Yesod.Widget +import Text.Hamlet (hamlet) +import Control.Monad.IO.Class (liftIO) +import Control.Monad.Trans.Class (lift) +import Data.Text (Text) +import Control.Monad (mzero) +import Data.Monoid (mappend) +import qualified Data.Aeson.Types + +facebookUrl :: AuthRoute +facebookUrl = PluginR "facebook" ["forward"] + +authFacebook :: YesodAuth m + => Text -- ^ Application ID + -> Text -- ^ Application secret + -> [Text] -- ^ Requested permissions + -> AuthPlugin m +authFacebook cid secret perms = + AuthPlugin "facebook" dispatch login + where + url = PluginR "facebook" [] + dispatch "GET" ["forward"] = do + tm <- getRouteToMaster + render <- getUrlRender + let fb = Facebook.Facebook cid secret $ render $ tm url + redirectText RedirectTemporary $ Facebook.getForwardUrl fb perms + dispatch "GET" [] = do + render <- getUrlRender + tm <- getRouteToMaster + let fb = Facebook.Facebook cid secret $ render $ tm url + code <- runFormGet' $ stringInput "code" + at <- liftIO $ Facebook.getAccessToken fb code + let Facebook.AccessToken at' = at + so <- liftIO $ Facebook.getGraphData at "me" + let c = fromMaybe (error "Invalid response from Facebook") + $ parseMaybe (parseCreds at') $ either error id so + setCreds True c + dispatch _ _ = notFound + login tm = do + render <- lift getUrlRender + let fb = Facebook.Facebook cid secret $ render $ tm url + let furl = Facebook.getForwardUrl fb $ perms + y <- lift getYesod + addHtml +#if GHC7 + [hamlet| +#else + [$hamlet| +#endif +<p> + <a href="#{furl}">#{messageFacebook y} +|] + +parseCreds :: Text -> Value -> Data.Aeson.Types.Parser (Creds m) +parseCreds at' (Object m) = do + id' <- m .: "id" + let id'' = "http://graph.facebook.com/" `mappend` id' + name <- m .: "name" + email <- m .: "email" + return + $ Creds "facebook" id'' + $ maybe id (\x -> (:) ("verifiedEmail", x)) email + $ maybe id (\x -> (:) ("displayName ", x)) name + [ ("accessToken", at') + ] +parseCreds _ _ = mzero
Yesod/Helpers/Auth/HashDB.hs view
@@ -1,210 +1,210 @@-{-# LANGUAGE QuasiQuotes #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE CPP #-}-{-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE OverloadedStrings #-}----------------------------------------------------------------------------------- |--- Module : Yesod.Helpers.Auth.HashDB--- Copyright : (c) Patrick Brisbin 2010 --- License : as-is------ Maintainer : pbrisbin@gmail.com--- Stability : Stable--- Portability : Portable------ A yesod-auth AuthPlugin designed to look users up in Persist where--- their user id's and a sha1 hash of their password will already be--- stored.------ Example usage:------ > -- import the function--- > import Helpers.Auth.HashDB--- >--- > -- make sure you have an auth route--- > mkYesodData "MyApp" [$parseRoutes|--- > / RootR GET--- > /auth AuthR Auth getAuth--- > |]--- >--- >--- > -- make your app an instance of YesodAuth using this plugin--- > instance YesodAuth MyApp where--- > type AuthId MyApp = UserId--- >--- > loginDest _ = RootR--- > logoutDest _ = RootR--- > getAuthId = getAuthIdHashDB AuthR --- > showAuthId _ = showIntegral--- > readAuthId _ = readIntegral--- > authPlugins = [authHashDB]--- >--- >--- > -- include the migration function in site startup--- > withServer :: (Application -> IO a) -> IO a--- > withServer f = withConnectionPool $ \p -> do--- > runSqlPool (runMigration migrateUsers) p--- > let h = DevSite p------ Your app must be an instance of YesodPersist and the username and--- hashed-passwords must be added manually to the database.------ > echo -n 'MyPassword' | sha1sum------ can be used to get the hash from the commandline.------------------------------------------------------------------------------------module Yesod.Helpers.Auth.HashDB- ( authHashDB- , getAuthIdHashDB- , UserId- , migrateUsers- ) where--import Yesod.Persist-import Yesod.Handler-import Yesod.Form-import Yesod.Helpers.Auth-import Text.Hamlet (hamlet)--import Control.Applicative ((<$>), (<*>))-import Data.ByteString.Lazy.Char8 (pack)-import Data.Digest.Pure.SHA (sha1, showDigest)-import Data.Text (Text, unpack)-import Data.Maybe (fromMaybe)---- | Computer the sha1 of a string and return it as a string-sha1String :: String -> String-sha1String = showDigest . sha1 . pack---- | Generate data base instances for a valid user-share2 mkPersist (mkMigrate "migrateUsers")-#if GHC7- [persist|-#else- [$persist|-#endif-User- username Text Eq- password Text- UniqueUser username-|]---- | Given a (user,password) in plaintext, validate them against the--- database values-validateUser :: (YesodPersist y, - PersistBackend (YesodDB y (GGHandler sub y IO))) - => (Text, Text) - -> GHandler sub y Bool-validateUser (user,password) = runDB (getBy $ UniqueUser user) >>= \dbUser ->- case dbUser of- -- user not found- Nothing -> return False- -- validate password- Just (_, sqlUser) -> return $ sha1String (unpack password) == unpack (userPassword sqlUser)--login :: AuthRoute-login = PluginR "hashdb" ["login"]---- | Handle the login form-postLoginR :: (YesodAuth y,- YesodPersist y, - PersistBackend (YesodDB y (GGHandler Auth y IO)))- => GHandler Auth y ()-postLoginR = do- (mu,mp) <- runFormPost' $ (,)- <$> maybeStringInput "username"- <*> maybeStringInput "password"-- isValid <- case (mu,mp) of- (Nothing, _ ) -> return False- (_ , Nothing) -> return False- (Just u , Just p ) -> validateUser (u,p)-- if isValid- then setCreds True $ Creds "hashdb" (fromMaybe "" mu) []- else do- setMessage-#if GHC7- [hamlet|-#else- [$hamlet|-#endif- Invalid username/password-|]- toMaster <- getRouteToMaster- redirect RedirectTemporary $ toMaster LoginR---- | A drop in for the getAuthId method of your YesodAuth instance which--- can be used if authHashDB is the only plugin in use.-getAuthIdHashDB :: (Key User ~ AuthId master,- PersistBackend (YesodDB master (GGHandler sub master IO)),- YesodPersist master,- YesodAuth master)- => (AuthRoute -> Route master) -- ^ your site's Auth Route- -> Creds m -- ^ the creds argument- -> GHandler sub master (Maybe UserId)-getAuthIdHashDB authR creds = do- muid <- maybeAuth- case muid of- -- user already authenticated- Just (uid, _) -> return $ Just uid- Nothing -> do- x <- runDB $ getBy $ UniqueUser (credsIdent creds)- case x of- -- user exists- Just (uid, _) -> return $ Just uid- Nothing -> do- setMessage-#if GHC7- [hamlet|-#else- [$hamlet|-#endif- User not found-|]- redirect RedirectTemporary $ authR LoginR---- | Prompt for username and password, validate that against a database--- which holds the username and a hash of the password-authHashDB :: (YesodAuth y,- YesodPersist y, - PersistBackend (YesodDB y (GGHandler Auth y IO)))- => AuthPlugin y-authHashDB = AuthPlugin "hashdb" dispatch $ \tm ->-#if GHC7- [hamlet|-#else- [$hamlet|-#endif- <div id="header">- <h1>Login-- <div id="login">- <form method="post" action="@{tm login}">- <table>- <tr>- <th>Username:- <td>- <input id="x" name="username" autofocus="" required>- <tr>- <th>Password:- <td>- <input type="password" name="password" required>- <tr>- <td> - <td>- <input type="submit" value="Login">-- <script>- if (!("autofocus" in document.createElement("input"))) {- document.getElementById("x").focus();- }--|]- where- dispatch "POST" ["login"] = postLoginR >>= sendResponse- dispatch _ _ = notFound+{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE OverloadedStrings #-} +------------------------------------------------------------------------------- +-- | +-- Module : Yesod.Helpers.Auth.HashDB +-- Copyright : (c) Patrick Brisbin 2010 +-- License : as-is +-- +-- Maintainer : pbrisbin@gmail.com +-- Stability : Stable +-- Portability : Portable +-- +-- A yesod-auth AuthPlugin designed to look users up in Persist where +-- their user id's and a sha1 hash of their password will already be +-- stored. +-- +-- Example usage: +-- +-- > -- import the function +-- > import Helpers.Auth.HashDB +-- > +-- > -- make sure you have an auth route +-- > mkYesodData "MyApp" [$parseRoutes| +-- > / RootR GET +-- > /auth AuthR Auth getAuth +-- > |] +-- > +-- > +-- > -- make your app an instance of YesodAuth using this plugin +-- > instance YesodAuth MyApp where +-- > type AuthId MyApp = UserId +-- > +-- > loginDest _ = RootR +-- > logoutDest _ = RootR +-- > getAuthId = getAuthIdHashDB AuthR +-- > showAuthId _ = showIntegral +-- > readAuthId _ = readIntegral +-- > authPlugins = [authHashDB] +-- > +-- > +-- > -- include the migration function in site startup +-- > withServer :: (Application -> IO a) -> IO a +-- > withServer f = withConnectionPool $ \p -> do +-- > runSqlPool (runMigration migrateUsers) p +-- > let h = DevSite p +-- +-- Your app must be an instance of YesodPersist and the username and +-- hashed-passwords must be added manually to the database. +-- +-- > echo -n 'MyPassword' | sha1sum +-- +-- can be used to get the hash from the commandline. +-- +------------------------------------------------------------------------------- +module Yesod.Helpers.Auth.HashDB + ( authHashDB + , getAuthIdHashDB + , UserId + , migrateUsers + ) where + +import Yesod.Persist +import Yesod.Handler +import Yesod.Form +import Yesod.Helpers.Auth +import Text.Hamlet (hamlet) + +import Control.Applicative ((<$>), (<*>)) +import Data.ByteString.Lazy.Char8 (pack) +import Data.Digest.Pure.SHA (sha1, showDigest) +import Data.Text (Text, unpack) +import Data.Maybe (fromMaybe) + +-- | Computer the sha1 of a string and return it as a string +sha1String :: String -> String +sha1String = showDigest . sha1 . pack + +-- | Generate data base instances for a valid user +share2 mkPersist (mkMigrate "migrateUsers") +#if GHC7 + [persist| +#else + [$persist| +#endif +User + username Text Eq + password Text + UniqueUser username +|] + +-- | Given a (user,password) in plaintext, validate them against the +-- database values +validateUser :: (YesodPersist y, + PersistBackend (YesodDB y (GGHandler sub y IO))) + => (Text, Text) + -> GHandler sub y Bool +validateUser (user,password) = runDB (getBy $ UniqueUser user) >>= \dbUser -> + case dbUser of + -- user not found + Nothing -> return False + -- validate password + Just (_, sqlUser) -> return $ sha1String (unpack password) == unpack (userPassword sqlUser) + +login :: AuthRoute +login = PluginR "hashdb" ["login"] + +-- | Handle the login form +postLoginR :: (YesodAuth y, + YesodPersist y, + PersistBackend (YesodDB y (GGHandler Auth y IO))) + => GHandler Auth y () +postLoginR = do + (mu,mp) <- runFormPost' $ (,) + <$> maybeStringInput "username" + <*> maybeStringInput "password" + + isValid <- case (mu,mp) of + (Nothing, _ ) -> return False + (_ , Nothing) -> return False + (Just u , Just p ) -> validateUser (u,p) + + if isValid + then setCreds True $ Creds "hashdb" (fromMaybe "" mu) [] + else do + setMessage +#if GHC7 + [hamlet| +#else + [$hamlet| +#endif + Invalid username/password +|] + toMaster <- getRouteToMaster + redirect RedirectTemporary $ toMaster LoginR + +-- | A drop in for the getAuthId method of your YesodAuth instance which +-- can be used if authHashDB is the only plugin in use. +getAuthIdHashDB :: (Key User ~ AuthId master, + PersistBackend (YesodDB master (GGHandler sub master IO)), + YesodPersist master, + YesodAuth master) + => (AuthRoute -> Route master) -- ^ your site's Auth Route + -> Creds m -- ^ the creds argument + -> GHandler sub master (Maybe UserId) +getAuthIdHashDB authR creds = do + muid <- maybeAuth + case muid of + -- user already authenticated + Just (uid, _) -> return $ Just uid + Nothing -> do + x <- runDB $ getBy $ UniqueUser (credsIdent creds) + case x of + -- user exists + Just (uid, _) -> return $ Just uid + Nothing -> do + setMessage +#if GHC7 + [hamlet| +#else + [$hamlet| +#endif + User not found +|] + redirect RedirectTemporary $ authR LoginR + +-- | Prompt for username and password, validate that against a database +-- which holds the username and a hash of the password +authHashDB :: (YesodAuth y, + YesodPersist y, + PersistBackend (YesodDB y (GGHandler Auth y IO))) + => AuthPlugin y +authHashDB = AuthPlugin "hashdb" dispatch $ \tm -> +#if GHC7 + [hamlet| +#else + [$hamlet| +#endif + <div id="header"> + <h1>Login + + <div id="login"> + <form method="post" action="@{tm login}"> + <table> + <tr> + <th>Username: + <td> + <input id="x" name="username" autofocus="" required> + <tr> + <th>Password: + <td> + <input type="password" name="password" required> + <tr> + <td> + <td> + <input type="submit" value="Login"> + + <script> + if (!("autofocus" in document.createElement("input"))) { + document.getElementById("x").focus(); + } + +|] + where + dispatch "POST" ["login"] = postLoginR >>= sendResponse + dispatch _ _ = notFound
Yesod/Helpers/Auth/OAuth.hs view
@@ -1,89 +1,89 @@-{-# LANGUAGE CPP, QuasiQuotes, OverloadedStrings #-}-{-# OPTIONS_GHC -fwarn-unused-imports #-}-module Yesod.Helpers.Auth.OAuth- ( authOAuth- , oauthUrl- , authTwitter- , twitterUrl- ) where-import Yesod.Helpers.Auth-import Yesod.Form-import Yesod.Handler-import Yesod.Widget-import Text.Hamlet (hamlet)-import Web.Authenticate.OAuth-import Data.Maybe-import Data.String-import Data.ByteString.Char8 (pack)-import Control.Arrow ((***))-import Control.Monad.IO.Class (liftIO)-import Control.Monad.Trans.Class (lift)-import Data.Text (Text, unpack)-import Data.Text.Encoding (encodeUtf8, decodeUtf8With)-import Data.Text.Encoding.Error (lenientDecode)-import Data.ByteString (ByteString)--oauthUrl :: Text -> AuthRoute-oauthUrl name = PluginR name ["forward"]--authOAuth :: YesodAuth m =>- Text -- ^ Service Name- -> String -- ^ OAuth Parameter Name to use for identify- -> String -- ^ Request URL- -> String -- ^ Access Token URL- -> String -- ^ Authorize URL- -> String -- ^ Consumer Key- -> String -- ^ Consumer Secret- -> AuthPlugin m-authOAuth name ident reqUrl accUrl authUrl key sec = AuthPlugin name dispatch login- where- url = PluginR name []- oauth = OAuth { oauthServerName = unpack name, oauthRequestUri = reqUrl- , oauthAccessTokenUri = accUrl, oauthAuthorizeUri = authUrl- , oauthSignatureMethod = HMACSHA1- , oauthConsumerKey = fromString key, oauthConsumerSecret = fromString sec- , oauthCallback = Nothing- }- dispatch "GET" ["forward"] = do- render <- getUrlRender- tm <- getRouteToMaster- let oauth' = oauth { oauthCallback = Just $ encodeUtf8 $ render $ tm url }- tok <- liftIO $ getTemporaryCredential oauth'- redirectText RedirectTemporary (fromString $ authorizeUrl oauth' tok)- dispatch "GET" [] = do- verifier <- runFormGet' $ stringInput "oauth_verifier"- oaTok <- runFormGet' $ stringInput "oauth_token"- let reqTok = Credential [ ("oauth_verifier", encodeUtf8 verifier), ("oauth_token", encodeUtf8 oaTok)- ] - accTok <- liftIO $ getAccessToken oauth reqTok- let crId = decodeUtf8With lenientDecode $ fromJust $ lookup (pack ident) $ unCredential accTok- creds = Creds name crId $ map (bsToText *** bsToText ) $ unCredential accTok- setCreds True creds- dispatch _ _ = notFound- login tm = do- render <- lift getUrlRender- let oaUrl = render $ tm $ oauthUrl name- addHtml-#if GHC7- [hamlet|-#else- [$hamlet|-#endif- <a href=#{oaUrl}>Login with #{name}- |]--authTwitter :: YesodAuth m =>- String -- ^ Consumer Key- -> String -- ^ Consumer Secret- -> AuthPlugin m-authTwitter = authOAuth "twitter"- "screen_name"- "http://twitter.com/oauth/request_token"- "http://twitter.com/oauth/access_token"- "http://twitter.com/oauth/authorize"--twitterUrl :: AuthRoute-twitterUrl = oauthUrl "twitter"--bsToText :: ByteString -> Text-bsToText = decodeUtf8With lenientDecode+{-# LANGUAGE CPP, QuasiQuotes, OverloadedStrings #-} +{-# OPTIONS_GHC -fwarn-unused-imports #-} +module Yesod.Helpers.Auth.OAuth + ( authOAuth + , oauthUrl + , authTwitter + , twitterUrl + ) where +import Yesod.Helpers.Auth +import Yesod.Form +import Yesod.Handler +import Yesod.Widget +import Text.Hamlet (hamlet) +import Web.Authenticate.OAuth +import Data.Maybe +import Data.String +import Data.ByteString.Char8 (pack) +import Control.Arrow ((***)) +import Control.Monad.IO.Class (liftIO) +import Control.Monad.Trans.Class (lift) +import Data.Text (Text, unpack) +import Data.Text.Encoding (encodeUtf8, decodeUtf8With) +import Data.Text.Encoding.Error (lenientDecode) +import Data.ByteString (ByteString) + +oauthUrl :: Text -> AuthRoute +oauthUrl name = PluginR name ["forward"] + +authOAuth :: YesodAuth m => + Text -- ^ Service Name + -> String -- ^ OAuth Parameter Name to use for identify + -> String -- ^ Request URL + -> String -- ^ Access Token URL + -> String -- ^ Authorize URL + -> String -- ^ Consumer Key + -> String -- ^ Consumer Secret + -> AuthPlugin m +authOAuth name ident reqUrl accUrl authUrl key sec = AuthPlugin name dispatch login + where + url = PluginR name [] + oauth = OAuth { oauthServerName = unpack name, oauthRequestUri = reqUrl + , oauthAccessTokenUri = accUrl, oauthAuthorizeUri = authUrl + , oauthSignatureMethod = HMACSHA1 + , oauthConsumerKey = fromString key, oauthConsumerSecret = fromString sec + , oauthCallback = Nothing + } + dispatch "GET" ["forward"] = do + render <- getUrlRender + tm <- getRouteToMaster + let oauth' = oauth { oauthCallback = Just $ encodeUtf8 $ render $ tm url } + tok <- liftIO $ getTemporaryCredential oauth' + redirectText RedirectTemporary (fromString $ authorizeUrl oauth' tok) + dispatch "GET" [] = do + verifier <- runFormGet' $ stringInput "oauth_verifier" + oaTok <- runFormGet' $ stringInput "oauth_token" + let reqTok = Credential [ ("oauth_verifier", encodeUtf8 verifier), ("oauth_token", encodeUtf8 oaTok) + ] + accTok <- liftIO $ getAccessToken oauth reqTok + let crId = decodeUtf8With lenientDecode $ fromJust $ lookup (pack ident) $ unCredential accTok + creds = Creds name crId $ map (bsToText *** bsToText ) $ unCredential accTok + setCreds True creds + dispatch _ _ = notFound + login tm = do + render <- lift getUrlRender + let oaUrl = render $ tm $ oauthUrl name + addHtml +#if GHC7 + [hamlet| +#else + [$hamlet| +#endif + <a href=#{oaUrl}>Login with #{name} + |] + +authTwitter :: YesodAuth m => + String -- ^ Consumer Key + -> String -- ^ Consumer Secret + -> AuthPlugin m +authTwitter = authOAuth "twitter" + "screen_name" + "http://twitter.com/oauth/request_token" + "http://twitter.com/oauth/access_token" + "http://twitter.com/oauth/authorize" + +twitterUrl :: AuthRoute +twitterUrl = oauthUrl "twitter" + +bsToText :: ByteString -> Text +bsToText = decodeUtf8With lenientDecode
Yesod/Helpers/Auth/OpenId.hs view
@@ -1,94 +1,94 @@-{-# LANGUAGE QuasiQuotes #-}-{-# LANGUAGE CPP #-}-{-# LANGUAGE OverloadedStrings #-}-module Yesod.Helpers.Auth.OpenId- ( authOpenId- , forwardUrl- ) where--import Yesod.Helpers.Auth-import qualified Web.Authenticate.OpenId as OpenId-import Control.Monad.Attempt--import Yesod.Form-import Yesod.Handler-import Yesod.Widget-import Yesod.Request-import Text.Hamlet (hamlet)-import Text.Cassius (cassius)-import Text.Blaze (toHtml)-import Control.Monad.Trans.Class (lift)-import Data.Text (Text)--forwardUrl :: AuthRoute-forwardUrl = PluginR "openid" ["forward"]--authOpenId :: YesodAuth m => AuthPlugin m-authOpenId =- AuthPlugin "openid" dispatch login- where- complete = PluginR "openid" ["complete"]- name = "openid_identifier"- login tm = do- ident <- lift newIdent- y <- lift getYesod- addCassius-#if GHC7- [cassius|##{ident}-#else- [$cassius|##{ident}-#endif- background: #fff url(http://www.myopenid.com/static/openid-icon-small.gif) no-repeat scroll 0pt 50%;- padding-left: 18px;-|]- addHamlet-#if GHC7- [hamlet|-#else- [$hamlet|-#endif-<form method="get" action="@{tm forwardUrl}">- <label for="#{ident}">OpenID: - <input id="#{ident}" type="text" name="#{name}" value="http://">- <input type="submit" value="#{messageLoginOpenID y}">-|]- dispatch "GET" ["forward"] = do- (roid, _, _) <- runFormGet $ stringInput name- y <- getYesod- case roid of- FormSuccess oid -> do- render <- getUrlRender- toMaster <- getRouteToMaster- let complete' = render $ toMaster complete- res <- runAttemptT $ OpenId.getForwardUrl oid complete' Nothing []- attempt- (\err -> do- setMessage $ toHtml $ show err- redirect RedirectTemporary $ toMaster LoginR- )- (redirectText RedirectTemporary)- res- _ -> do- toMaster <- getRouteToMaster- setMessage $ messageNoOpenID y- redirect RedirectTemporary $ toMaster LoginR- dispatch "GET" ["complete", ""] = dispatch "GET" ["complete"] -- compatibility issues- dispatch "GET" ["complete"] = do- rr <- getRequest- completeHelper $ reqGetParams rr- dispatch "POST" ["complete", ""] = dispatch "POST" ["complete"] -- compatibility issues- dispatch "POST" ["complete"] = do- (posts, _) <- runRequestBody- completeHelper posts- dispatch _ _ = notFound--completeHelper :: YesodAuth m => [(Text, Text)] -> GHandler Auth m ()-completeHelper gets' = do- res <- runAttemptT $ OpenId.authenticate gets'- toMaster <- getRouteToMaster- let onFailure err = do- setMessage $ toHtml $ show err- redirect RedirectTemporary $ toMaster LoginR- let onSuccess (OpenId.Identifier ident, _) =- setCreds True $ Creds "openid" ident []- attempt onFailure onSuccess res+{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE OverloadedStrings #-} +module Yesod.Helpers.Auth.OpenId + ( authOpenId + , forwardUrl + ) where + +import Yesod.Helpers.Auth +import qualified Web.Authenticate.OpenId as OpenId +import Control.Monad.Attempt + +import Yesod.Form +import Yesod.Handler +import Yesod.Widget +import Yesod.Request +import Text.Hamlet (hamlet) +import Text.Cassius (cassius) +import Text.Blaze (toHtml) +import Control.Monad.Trans.Class (lift) +import Data.Text (Text) + +forwardUrl :: AuthRoute +forwardUrl = PluginR "openid" ["forward"] + +authOpenId :: YesodAuth m => AuthPlugin m +authOpenId = + AuthPlugin "openid" dispatch login + where + complete = PluginR "openid" ["complete"] + name = "openid_identifier" + login tm = do + ident <- lift newIdent + y <- lift getYesod + addCassius +#if GHC7 + [cassius|##{ident} +#else + [$cassius|##{ident} +#endif + background: #fff url(http://www.myopenid.com/static/openid-icon-small.gif) no-repeat scroll 0pt 50%; + padding-left: 18px; +|] + addHamlet +#if GHC7 + [hamlet| +#else + [$hamlet| +#endif +<form method="get" action="@{tm forwardUrl}"> + <label for="#{ident}">OpenID: + <input id="#{ident}" type="text" name="#{name}" value="http://"> + <input type="submit" value="#{messageLoginOpenID y}"> +|] + dispatch "GET" ["forward"] = do + (roid, _, _) <- runFormGet $ stringInput name + y <- getYesod + case roid of + FormSuccess oid -> do + render <- getUrlRender + toMaster <- getRouteToMaster + let complete' = render $ toMaster complete + res <- runAttemptT $ OpenId.getForwardUrl oid complete' Nothing [] + attempt + (\err -> do + setMessage $ toHtml $ show err + redirect RedirectTemporary $ toMaster LoginR + ) + (redirectText RedirectTemporary) + res + _ -> do + toMaster <- getRouteToMaster + setMessage $ messageNoOpenID y + redirect RedirectTemporary $ toMaster LoginR + dispatch "GET" ["complete", ""] = dispatch "GET" ["complete"] -- compatibility issues + dispatch "GET" ["complete"] = do + rr <- getRequest + completeHelper $ reqGetParams rr + dispatch "POST" ["complete", ""] = dispatch "POST" ["complete"] -- compatibility issues + dispatch "POST" ["complete"] = do + (posts, _) <- runRequestBody + completeHelper posts + dispatch _ _ = notFound + +completeHelper :: YesodAuth m => [(Text, Text)] -> GHandler Auth m () +completeHelper gets' = do + res <- runAttemptT $ OpenId.authenticate gets' + toMaster <- getRouteToMaster + let onFailure err = do + setMessage $ toHtml $ show err + redirect RedirectTemporary $ toMaster LoginR + let onSuccess (OpenId.Identifier ident, _) = + setCreds True $ Creds "openid" ident [] + attempt onFailure onSuccess res
Yesod/Helpers/Auth/Rpxnow.hs view
@@ -1,59 +1,59 @@-{-# LANGUAGE QuasiQuotes #-}-{-# LANGUAGE CPP #-}-{-# LANGUAGE OverloadedStrings #-}-module Yesod.Helpers.Auth.Rpxnow- ( authRpxnow- ) where--import Yesod.Helpers.Auth-import qualified Web.Authenticate.Rpxnow as Rpxnow-import Control.Monad (mplus)--import Yesod.Handler-import Yesod.Widget-import Yesod.Request-import Text.Hamlet (hamlet)-import Control.Monad.IO.Class (liftIO)-import Data.Text (pack, unpack)-import Control.Arrow ((***))--authRpxnow :: YesodAuth m- => String -- ^ app name- -> String -- ^ key- -> AuthPlugin m-authRpxnow app apiKey =- AuthPlugin "rpxnow" dispatch login- where- login tm = do- let url = {- FIXME urlEncode $ -} tm $ PluginR "rpxnow" []- addHamlet-#if GHC7- [hamlet|-#else- [$hamlet|-#endif-<iframe src="http://#{app}.rpxnow.com/openid/embed?token_url=@{url}" scrolling="no" frameBorder="no" allowtransparency="true" style="width:400px;height:240px">-|]- dispatch _ [] = do- token1 <- lookupGetParams "token"- token2 <- lookupPostParams "token"- token <- case token1 ++ token2 of- [] -> invalidArgs ["token: Value not supplied"]- x:_ -> return $ unpack x- Rpxnow.Identifier ident extra <- liftIO $ Rpxnow.authenticate apiKey token- let creds =- Creds "rpxnow" ident- $ maybe id (\x -> (:) ("verifiedEmail", x))- (lookup "verifiedEmail" extra)- $ maybe id (\x -> (:) ("displayName", x))- (fmap pack $ getDisplayName $ map (unpack *** unpack) extra)- []- setCreds True creds- dispatch _ _ = notFound---- | Get some form of a display name.-getDisplayName :: [(String, String)] -> Maybe String-getDisplayName extra =- foldr (\x -> mplus (lookup x extra)) Nothing choices- where- choices = ["verifiedEmail", "email", "displayName", "preferredUsername"]+{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE OverloadedStrings #-} +module Yesod.Helpers.Auth.Rpxnow + ( authRpxnow + ) where + +import Yesod.Helpers.Auth +import qualified Web.Authenticate.Rpxnow as Rpxnow +import Control.Monad (mplus) + +import Yesod.Handler +import Yesod.Widget +import Yesod.Request +import Text.Hamlet (hamlet) +import Control.Monad.IO.Class (liftIO) +import Data.Text (pack, unpack) +import Control.Arrow ((***)) + +authRpxnow :: YesodAuth m + => String -- ^ app name + -> String -- ^ key + -> AuthPlugin m +authRpxnow app apiKey = + AuthPlugin "rpxnow" dispatch login + where + login tm = do + let url = {- FIXME urlEncode $ -} tm $ PluginR "rpxnow" [] + addHamlet +#if GHC7 + [hamlet| +#else + [$hamlet| +#endif +<iframe src="http://#{app}.rpxnow.com/openid/embed?token_url=@{url}" scrolling="no" frameBorder="no" allowtransparency="true" style="width:400px;height:240px"> +|] + dispatch _ [] = do + token1 <- lookupGetParams "token" + token2 <- lookupPostParams "token" + token <- case token1 ++ token2 of + [] -> invalidArgs ["token: Value not supplied"] + x:_ -> return $ unpack x + Rpxnow.Identifier ident extra <- liftIO $ Rpxnow.authenticate apiKey token + let creds = + Creds "rpxnow" ident + $ maybe id (\x -> (:) ("verifiedEmail", x)) + (lookup "verifiedEmail" extra) + $ maybe id (\x -> (:) ("displayName", x)) + (fmap pack $ getDisplayName $ map (unpack *** unpack) extra) + [] + setCreds True creds + dispatch _ _ = notFound + +-- | Get some form of a display name. +getDisplayName :: [(String, String)] -> Maybe String +getDisplayName extra = + foldr (\x -> mplus (lookup x extra)) Nothing choices + where + choices = ["verifiedEmail", "email", "displayName", "preferredUsername"]
yesod-auth.cabal view
@@ -1,57 +1,58 @@-name: yesod-auth-version: 0.4.0-license: BSD3-license-file: LICENSE-author: Michael Snoyman, Patrick Brisbin-maintainer: Michael Snoyman <michael@snoyman.com>-synopsis: Authentication for Yesod.-category: Web, Yesod-stability: Stable-cabal-version: >= 1.6.0-build-type: Simple-homepage: http://docs.yesodweb.com/--flag ghc7--library- if flag(ghc7)- build-depends: base >= 4.3 && < 5- cpp-options: -DGHC7- else- build-depends: base >= 4 && < 4.3- build-depends: authenticate >= 0.9 && < 0.10- , bytestring >= 0.9.1.4 && < 0.10- , yesod-core >= 0.8 && < 0.9- , wai >= 0.4 && < 0.5- , template-haskell- , pureMD5 >= 1.1 && < 2.2- , random >= 1.0 && < 1.1- , control-monad-attempt >= 0.3.0 && < 0.4- , text >= 0.7 && < 0.12- , mime-mail >= 0.3 && < 0.4- , blaze-html >= 0.4 && < 0.5- , yesod-persistent >= 0.1 && < 0.2- , hamlet >= 0.8 && < 0.9- , yesod-json >= 0.1 && < 0.2- , containers >= 0.2 && < 0.5- , yesod-form >= 0.1 && < 0.2- , transformers >= 0.2 && < 0.3- , persistent >= 0.5 && < 0.6- , persistent-template >= 0.5 && < 0.6- , SHA >= 1.4.1.3 && < 1.5- , http-enumerator >= 0.6 && < 0.7- , aeson >= 0.3.2.2 && < 0.4-- exposed-modules: Yesod.Helpers.Auth- Yesod.Helpers.Auth.Dummy- Yesod.Helpers.Auth.Email- Yesod.Helpers.Auth.Facebook- Yesod.Helpers.Auth.OpenId- Yesod.Helpers.Auth.OAuth- Yesod.Helpers.Auth.Rpxnow- Yesod.Helpers.Auth.HashDB- ghc-options: -Wall--source-repository head- type: git- location: git://github.com/snoyberg/yesod-auth.git+name: yesod-auth +version: 0.4.0.1 +license: BSD3 +license-file: LICENSE +author: Michael Snoyman, Patrick Brisbin +maintainer: Michael Snoyman <michael@snoyman.com> +synopsis: Authentication for Yesod. +category: Web, Yesod +stability: Stable +cabal-version: >= 1.6.0 +build-type: Simple +homepage: http://www.yesodweb.com/ + +flag ghc7 + +library + if flag(ghc7) + build-depends: base >= 4.3 && < 5 + cpp-options: -DGHC7 + else + build-depends: base >= 4 && < 4.3 + build-depends: authenticate >= 0.9 && < 0.10 + , bytestring >= 0.9.1.4 && < 0.10 + , yesod-core >= 0.8 && < 0.9 + , wai >= 0.4 && < 0.5 + , template-haskell + , pureMD5 >= 1.1 && < 2.2 + , random >= 1.0 && < 1.1 + , control-monad-attempt >= 0.3.0 && < 0.4 + , text >= 0.7 && < 0.12 + , mime-mail >= 0.3 && < 0.4 + , blaze-html >= 0.4 && < 0.5 + , yesod-persistent >= 0.1 && < 0.2 + , hamlet >= 0.8 && < 0.9 + , yesod-json >= 0.1 && < 0.2 + , containers >= 0.2 && < 0.5 + , yesod-form >= 0.1 && < 0.2 + , transformers >= 0.2 && < 0.3 + , persistent >= 0.5 && < 0.6 + , persistent-template >= 0.5 && < 0.6 + , SHA >= 1.4.1.3 && < 1.5 + , http-enumerator >= 0.6 && < 0.7 + , aeson >= 0.3.2.2 && < 0.4 + , web-routes-quasi >= 0.7 && < 0.8 + + exposed-modules: Yesod.Helpers.Auth + Yesod.Helpers.Auth.Dummy + Yesod.Helpers.Auth.Email + Yesod.Helpers.Auth.Facebook + Yesod.Helpers.Auth.OpenId + Yesod.Helpers.Auth.OAuth + Yesod.Helpers.Auth.Rpxnow + Yesod.Helpers.Auth.HashDB + ghc-options: -Wall + +source-repository head + type: git + location: git://github.com/snoyberg/yesod-auth.git