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

Add 'yesod-auth/' from commit 'fe498e3dac01bfc999cad33b90a2b1b397785178'

Browse Source 
git-subtree-dir: yesod-auth
git-subtree-mainline: a7df7531dc
git-subtree-split: fe498e3dac
This commit is contained in:
Michael Snoyman 2011-07-22 08:59:54 +03:00
commit cd5ee0fb12
19 changed files with 1536 additions and 0 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
yesod-auth/.gitignore vendored Normal file
View File

@ -0,0 +1,4 @@
dist
*.swp
auth2.db3
client_session_key.aes

25
yesod-auth/LICENSE Normal file
View File

@ -0,0 +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.

0
yesod-auth/README Normal file
View File

8
yesod-auth/Setup.lhs Executable file
View File

@ -0,0 +1,8 @@
#!/usr/bin/env runhaskell
> module Main where
> import Distribution.Simple
> import System.Cmd (system)
> main :: IO ()
> main = defaultMain

211
yesod-auth/Yesod/Auth.hs Normal file
View File

@ -0,0 +1,211 @@
{-# LANGUAGE QuasiQuotes, TypeFamilies, TemplateHaskell #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE OverloadedStrings #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Yesod.Auth
( -- * Subsite
Auth
, AuthPlugin (..)
, AuthRoute (..)
, getAuth
, YesodAuth (..)
-- * Plugin interface
, Creds (..)
, setCreds
-- * User functions
, maybeAuthId
, maybeAuth
, requireAuthId
, requireAuth
) where
#include "qq.h"
import Control.Monad (when)
import Control.Monad.Trans.Class (lift)
import Control.Monad.Trans.Maybe
import Data.Aeson
import Data.Text.Encoding (decodeUtf8With)
import Data.Text.Encoding.Error (lenientDecode)
import Data.Text (Text)
import qualified Data.Text as T
import qualified Data.Map as Map
import Language.Haskell.TH.Syntax hiding (lift)
import qualified Network.Wai as W
import Text.Hamlet (html)
import Yesod.Core
import Yesod.Persist
import Yesod.Json
import Yesod.Auth.Message (AuthMessage, defaultMessage)
import qualified Yesod.Auth.Message as Msg
import Yesod.Form (FormMessage)
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), RenderMessage m FormMessage) => 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
setTitleI Msg.LoginTitle
tm <- lift getRouteToMaster
mapM_ (flip apLogin tm) authPlugins
renderAuthMessage :: m
-> [Text] -- ^ languages
-> AuthMessage -> Text
renderAuthMessage _ _ = defaultMessage
mkYesodSub "Auth"
[ ClassP ''YesodAuth [VarT $ mkName "master"]
]
#define STRINGS *Texts
[QQ(parseRoutes)|
/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 ->
when doRedirects $ do
case authRoute y of
Nothing -> do rh <- defaultLayout $ addHtml [QQ(html)| <h1>Invalid login |]
sendResponse rh
Just ar -> do setMessageI Msg.InvalidLogin
redirect RedirectTemporary ar
Just aid -> do
setSession credsKey $ toSinglePiece aid
when doRedirects $ do
setMessageI Msg.NowLoggedIn
redirectUltDest RedirectTemporary $ loginDest y
getCheckR :: YesodAuth m => GHandler Auth m RepHtmlJson
getCheckR = do
creds <- maybeAuthId
defaultLayoutJson (do
setTitle "Authentication Status"
addHtml $ html' creds) (json' creds)
where
html' creds =
[QQ(html)|
<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 = setUltDestReferer >> loginHandler
getLogoutR :: YesodAuth m => GHandler Auth m ()
getLogoutR = setUltDestReferer >> 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 = runMaybeT $ do
aid <- MaybeT $ maybeAuthId
a <- MaybeT $ runDB $ get aid
return (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"
instance YesodAuth m => RenderMessage m AuthMessage where
renderMessage = renderAuthMessage

48
yesod-auth/Yesod/Auth/BrowserId.hs Normal file
View File

@ -0,0 +1,48 @@
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE OverloadedStrings #-}
module Yesod.Auth.BrowserId
( authBrowserId
) where
import Yesod.Auth
import Web.Authenticate.BrowserId
import Data.Text (Text)
import Yesod.Core
import Text.Hamlet (hamlet)
import Control.Monad.IO.Class (liftIO)
#include "qq.h"
pid :: Text
pid = "browserid"
complete :: AuthRoute
complete = PluginR pid []
authBrowserId :: YesodAuth m
=> Text -- ^ audience
-> AuthPlugin m
authBrowserId audience = AuthPlugin
{ apName = pid
, apDispatch = \m ps ->
case (m, ps) of
("GET", [assertion]) -> do
memail <- liftIO $ checkAssertion audience assertion
case memail of
Nothing -> error "Invalid assertion"
Just email -> setCreds True Creds
{ credsPlugin = pid
, credsIdent = email
, credsExtra = []
}
(_, []) -> badMethod
_ -> notFound
, apLogin = \toMaster -> do
addScriptRemote browserIdJs
addHamlet [QQ(hamlet)|
<p>
<a href="javascript:navigator.id.getVerifiedEmail(function(a){if(a)document.location='@{toMaster complete}/'+a});">
<img src="https://browserid.org/i/sign_in_green.png">
|]
}

34
yesod-auth/Yesod/Auth/Dummy.hs Normal file
View File

@ -0,0 +1,34 @@
{-# 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.Auth.Dummy
( authDummy
) where
#include "qq.h"
import Yesod.Auth
import Yesod.Form (runInputPost, textField, ireq)
import Yesod.Handler (notFound)
import Text.Hamlet (hamlet)
import Yesod.Widget (addHamlet)
authDummy :: YesodAuth m => AuthPlugin m
authDummy =
AuthPlugin "dummy" dispatch login
where
dispatch "POST" [] = do
ident <- runInputPost $ ireq textField "ident"
setCreds True $ Creds "dummy" ident []
dispatch _ _ = notFound
url = PluginR "dummy" []
login authToMaster =
addHamlet [QQ(hamlet)|
<form method="post" action="@{authToMaster url}">
\Your new identifier is:
<input type="text" name="ident">
<input type="submit" value="Dummy Login">
|]

276
yesod-auth/Yesod/Auth/Email.hs Normal file
View File

@ -0,0 +1,276 @@
{-# LANGUAGE QuasiQuotes, TypeFamilies #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE FlexibleContexts #-}
module Yesod.Auth.Email
( -- * Plugin
authEmail
, YesodAuthEmail (..)
, EmailCreds (..)
, saltPass
-- * Routes
, loginR
, registerR
, setpassR
) where
#include "qq.h"
import Network.Mail.Mime (randomString)
import Yesod.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 qualified Crypto.PasswordStore as PS
import qualified Data.Text.Encoding as DTE
import Yesod.Form
import Yesod.Handler
import Yesod.Content
import Yesod.Widget
import Yesod.Core
import Control.Monad.IO.Class (liftIO)
import qualified Yesod.Auth.Message as Msg
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 ->
[QQ(whamlet)|
<form method="post" action="@{tm loginR}">
<table>
<tr>
<th>_{Msg.Email}
<td>
<input type="email" name="email">
<tr>
<th>_{Msg.Password}
<td>
<input type="password" name="password">
<tr>
<td colspan="2">
<input type="submit" value=_{Msg.LoginViaEmail}>
<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
toMaster <- getRouteToMaster
defaultLayout $ do
setTitleI Msg.RegisterLong
addWidget
[QQ(whamlet)|
<p>_{Msg.EnterEmail}
<form method="post" action="@{toMaster registerR}">
<label for="email">_{Msg.Email}
<input type="email" name="email" width="150">
<input type="submit" value=_{Msg.Register}>
|]
postRegisterR :: YesodAuthEmail master => GHandler Auth master RepHtml
postRegisterR = do
y <- getYesod
email <- runInputPost $ ireq emailField "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
setTitleI Msg.ConfirmationEmailSentTitle
addWidget
[QQ(whamlet)| <p>_{Msg.ConfirmationEmailSent email} |]
getVerifyR :: YesodAuthEmail m
=> AuthEmailId m -> Text -> GHandler Auth m RepHtml
getVerifyR lid key = do
realKey <- getVerifyKey lid
memail <- getEmail lid
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
setMessageI Msg.AddressVerified
redirect RedirectTemporary $ toMaster setpassR
_ -> return ()
defaultLayout $ do
setTitleI Msg.InvalidKey
addWidget
[QQ(whamlet)| <p>_{Msg.InvalidKey} |]
postLoginR :: YesodAuthEmail master => GHandler Auth master ()
postLoginR = do
(email, pass) <- runInputPost $ (,)
<$> ireq emailField "email"
<*> ireq textField "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
setMessageI Msg.InvalidEmailPass
toMaster <- getRouteToMaster
redirect RedirectTemporary $ toMaster LoginR
getPasswordR :: YesodAuthEmail master => GHandler Auth master RepHtml
getPasswordR = do
toMaster <- getRouteToMaster
maid <- maybeAuthId
case maid of
Just _ -> return ()
Nothing -> do
setMessageI Msg.BadSetPass
redirect RedirectTemporary $ toMaster loginR
defaultLayout $ do
setTitleI Msg.SetPassTitle
addWidget
[QQ(whamlet)|
<h3>_{Msg.SetPass}
<form method="post" action="@{toMaster setpassR}">
<table>
<tr>
<th>_{Msg.NewPass}
<td>
<input type="password" name="new">
<tr>
<th>_{Msg.ConfirmPass}
<td>
<input type="password" name="confirm">
<tr>
<td colspan="2">
<input type="submit" value="_{Msg.SetPassTitle}">
|]
postPasswordR :: YesodAuthEmail master => GHandler Auth master ()
postPasswordR = do
(new, confirm) <- runInputPost $ (,)
<$> ireq textField "new"
<*> ireq textField "confirm"
toMaster <- getRouteToMaster
y <- getYesod
when (new /= confirm) $ do
setMessageI Msg.PassMismatch
redirect RedirectTemporary $ toMaster setpassR
maid <- maybeAuthId
aid <- case maid of
Nothing -> do
setMessageI Msg.BadSetPass
redirect RedirectTemporary $ toMaster loginR
Just aid -> return aid
salted <- liftIO $ saltPass new
setPassword aid salted
setMessageI Msg.PassUpdated
redirect RedirectTemporary $ loginDest y
saltLength :: Int
saltLength = 5
-- | Salt a password with a randomly generated salt.
saltPass :: Text -> IO Text
saltPass = fmap DTE.decodeUtf8
. flip PS.makePassword 12
. DTE.encodeUtf8
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 ct salted =
PS.verifyPassword (DTE.encodeUtf8 ct) (DTE.encodeUtf8 salted) || isValidPass' ct salted
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'

78
yesod-auth/Yesod/Auth/Facebook.hs Normal file
View File

@ -0,0 +1,78 @@
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE OverloadedStrings #-}
module Yesod.Auth.Facebook
( authFacebook
, facebookUrl
) where
#include "qq.h"
import Yesod.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 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
import qualified Yesod.Auth.Message as Msg
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 <- runInputGet $ ireq textField "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
[QQ(whamlet)|
<p>
<a href="#{furl}">_{Msg.Facebook}
|]
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

256
yesod-auth/Yesod/Auth/HashDB.hs Normal file
View File

@ -0,0 +1,256 @@
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE GADTs #-}
-------------------------------------------------------------------------------
-- |
-- Module : Yesod.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 salted SHA1 hash of their password is stored.
--
-- Example usage:
--
-- > -- import the function
-- > import 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 (Just . UniqueUser)
-- > authPlugins = [authHashDB (Just . UniqueUser)]
-- >
-- >
-- > -- 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
--
-- Note that function which converts username to unique identifier must be same.
--
-- Your app must be an instance of YesodPersist. and the username,
-- salt and hashed-passwords should be added to the database.
--
-- > echo -n 'MySaltMyPassword' | sha1sum
--
-- can be used to get the hash from the commandline.
--
-------------------------------------------------------------------------------
module Yesod.Auth.HashDB
( HashDBUser(..)
, setPassword
-- * Authentification
, validateUser
, authHashDB
, getAuthIdHashDB
-- * Predefined data type
, User(..)
, UserId
, migrateUsers
) where
#include "qq.h"
import Yesod.Persist
import Yesod.Handler
import Yesod.Form
import Yesod.Auth
import Yesod.Widget (addHamlet)
import Text.Hamlet (hamlet, html)
import Control.Applicative ((<$>), (<*>))
import Control.Monad (replicateM,liftM)
import Control.Monad.IO.Class (MonadIO, liftIO)
import qualified Data.ByteString.Lazy.Char8 as BS (pack)
import Data.Digest.Pure.SHA (sha1, showDigest)
import Data.Text (Text, pack, unpack, append)
import Data.Maybe (fromMaybe)
import System.Random (randomRIO)
-- | Interface for data type which holds user info. It's just a
-- collection of getters and setters
class HashDBUser user where
-- | Retrieve password hash from user data
userPasswordHash :: user -> Maybe Text
-- | Retrieve salt for password
userPasswordSalt :: user -> Maybe Text
-- | Set hash and password
setUserHashAndSalt :: Text -- ^ Salt
-> Text -- ^ Password hash
-> user -> user
-- | Generate random salt. Length of 8 is chosen arbitrarily
randomSalt :: MonadIO m => m Text
randomSalt = pack `liftM` liftIO (replicateM 8 (randomRIO ('0','z')))
-- | Calculate salted hash using SHA1.
saltedHash :: Text -- ^ Salt
-> Text -- ^ Password
-> Text
saltedHash salt =
pack . showDigest . sha1 . BS.pack . unpack . append salt
-- | Set password for user. This function should be used for setting
-- passwords. It generates random salt and calculates proper hashes.
setPassword :: (MonadIO m, HashDBUser user) => Text -> user -> m user
setPassword pwd u = do salt <- randomSalt
return $ setUserHashAndSalt salt (saltedHash salt pwd) u
----------------------------------------------------------------
-- Authentification
----------------------------------------------------------------
-- | Given a user ID and password in plaintext, validate them against
-- the database values.
validateUser :: ( YesodPersist yesod
, PersistBackend (YesodDB yesod (GGHandler sub yesod IO))
, PersistEntity user
, HashDBUser user
) =>
Unique user -- ^ User unique identifier
-> Text -- ^ Password in plaint-text
-> GHandler sub yesod Bool
validateUser userID passwd = do
-- Checks that hash and password match
let validate u = do hash <- userPasswordHash u
salt <- userPasswordSalt u
return $ hash == saltedHash salt passwd
-- Get user data
user <- runDB $ getBy userID
return $ fromMaybe False $ validate . snd =<< user
login :: AuthRoute
login = PluginR "hashdb" ["login"]
-- | Handle the login form. First parameter is function which maps
-- username (whatever it might be) to unique user ID.
postLoginR :: ( YesodAuth y, YesodPersist y
, HashDBUser user, PersistEntity user
, PersistBackend (YesodDB y (GGHandler Auth y IO)))
=> (Text -> Maybe (Unique user))
-> GHandler Auth y ()
postLoginR uniq = do
(mu,mp) <- runInputPost $ (,)
<$> iopt textField "username"
<*> iopt textField "password"
isValid <- fromMaybe (return False)
(validateUser <$> (uniq =<< mu) <*> mp)
if isValid
then setCreds True $ Creds "hashdb" (fromMaybe "" mu) []
else do setMessage [QQ(html)| 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 :: ( YesodAuth master, YesodPersist master
, HashDBUser user, PersistEntity user
, Key user ~ AuthId master
, PersistBackend (YesodDB master (GGHandler sub master IO)))
=> (AuthRoute -> Route master) -- ^ your site's Auth Route
-> (Text -> Maybe (Unique user)) -- ^ gets user ID
-> Creds master -- ^ the creds argument
-> GHandler sub master (Maybe (AuthId master))
getAuthIdHashDB authR uniq creds = do
muid <- maybeAuth
case muid of
-- user already authenticated
Just (uid, _) -> return $ Just uid
Nothing -> do
x <- case uniq (credsIdent creds) of
Nothing -> return Nothing
Just u -> runDB (getBy u)
case x of
-- user exists
Just (uid, _) -> return $ Just uid
Nothing -> do
setMessage [QQ(html)| 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 m, YesodPersist m
, HashDBUser user
, PersistEntity user
, PersistBackend (YesodDB m (GGHandler Auth m IO)))
=> (Text -> Maybe (Unique user)) -> AuthPlugin m
authHashDB uniq = AuthPlugin "hashdb" dispatch $ \tm -> addHamlet
[QQ(hamlet)|
<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>&nbsp;
<td>
<input type="submit" value="Login">
<script>
if (!("autofocus" in document.createElement("input"))) {
document.getElementById("x").focus();
}
|]
where
dispatch "POST" ["login"] = postLoginR uniq >>= sendResponse
dispatch _ _ = notFound
----------------------------------------------------------------
-- Predefined datatype
----------------------------------------------------------------
-- | Generate data base instances for a valid user
share2 mkPersist (mkMigrate "migrateUsers")
[QQ(persist)|
User
username Text Eq
password Text
salt Text
UniqueUser username
|]
instance HashDBUser User where
userPasswordHash = Just . userPassword
userPasswordSalt = Just . userSalt
setUserHashAndSalt s h u = u { userSalt = s
, userPassword = h
}

65
yesod-auth/Yesod/Auth/Message.hs Normal file
View File

@ -0,0 +1,65 @@
{-# LANGUAGE OverloadedStrings #-}
module Yesod.Auth.Message
( AuthMessage (..)
, defaultMessage
) where
import Data.Monoid (mappend)
import Data.Text (Text)
data AuthMessage =
NoOpenID
| LoginOpenID
| Email
| Password
| Register
| RegisterLong
| EnterEmail
| ConfirmationEmailSentTitle
| ConfirmationEmailSent Text
| AddressVerified
| InvalidKeyTitle
| InvalidKey
| InvalidEmailPass
| BadSetPass
| SetPassTitle
| SetPass
| NewPass
| ConfirmPass
| PassMismatch
| PassUpdated
| Facebook
| LoginViaEmail
| InvalidLogin
| NowLoggedIn
| LoginTitle
defaultMessage :: AuthMessage -> Text
defaultMessage NoOpenID = "No OpenID identifier found"
defaultMessage LoginOpenID = "Login via OpenID"
defaultMessage Email = "Email"
defaultMessage Password = "Password"
defaultMessage Register = "Register"
defaultMessage RegisterLong = "Register a new account"
defaultMessage EnterEmail = "Enter your e-mail address below, and a confirmation e-mail will be sent to you."
defaultMessage ConfirmationEmailSentTitle = "Confirmation e-mail sent"
defaultMessage (ConfirmationEmailSent email) =
"A confirmation e-mail has been sent to " `mappend`
email `mappend`
"."
defaultMessage AddressVerified = "Address verified, please set a new password"
defaultMessage InvalidKeyTitle = "Invalid verification key"
defaultMessage InvalidKey = "I'm sorry, but that was an invalid verification key."
defaultMessage InvalidEmailPass = "Invalid email/password combination"
defaultMessage BadSetPass = "You must be logged in to set a password"
defaultMessage SetPassTitle = "Set password"
defaultMessage SetPass = "Set a new password"
defaultMessage NewPass = "New password"
defaultMessage ConfirmPass = "Confirm"
defaultMessage PassMismatch = "Passwords did not match, please try again"
defaultMessage PassUpdated = "Password updated"
defaultMessage Facebook = "Login with Facebook"
defaultMessage LoginViaEmail = "Login via email"
defaultMessage InvalidLogin = "Invalid login"
defaultMessage NowLoggedIn = "You are now logged in"
defaultMessage LoginTitle = "Login"

88
yesod-auth/Yesod/Auth/OAuth.hs Normal file
View File

@ -0,0 +1,88 @@
{-# LANGUAGE CPP, QuasiQuotes, OverloadedStrings #-}
{-# OPTIONS_GHC -fwarn-unused-imports #-}
module Yesod.Auth.OAuth
( authOAuth
, oauthUrl
, authTwitter
, twitterUrl
) where
#include "qq.h"
import Yesod.Auth
import Yesod.Form
import Yesod.Handler
import Yesod.Widget
import Text.Hamlet (html)
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)
import Control.Applicative ((<$>), (<*>))
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, oaTok) <- runInputGet $ (,)
<$> ireq textField "oauth_verifier"
<*> ireq textField "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
[QQ(html)| <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

88
yesod-auth/Yesod/Auth/OpenId.hs Normal file
View File

@ -0,0 +1,88 @@
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE OverloadedStrings #-}
module Yesod.Auth.OpenId
( authOpenId
, forwardUrl
) where
#include "qq.h"
import Yesod.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)
import qualified Yesod.Auth.Message as Msg
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
[QQ(cassius)|##{ident}
background: #fff url(http://www.myopenid.com/static/openid-icon-small.gif) no-repeat scroll 0pt 50%;
padding-left: 18px;
|]
l <- lift languages
[QQ(whamlet)|
<form method="get" action="@{tm forwardUrl}">
<label for="#{ident}">OpenID: #
<input id="#{ident}" type="text" name="#{name}" value="http://">
<input type="submit" value="_{Msg.LoginOpenID}">
|]
dispatch "GET" ["forward"] = do
roid <- runInputGet $ iopt textField name
case roid of
Just 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
Nothing -> do
toMaster <- getRouteToMaster
setMessageI Msg.NoOpenID
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

57
yesod-auth/Yesod/Auth/Rpxnow.hs Normal file
View File

@ -0,0 +1,57 @@
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE OverloadedStrings #-}
module Yesod.Auth.Rpxnow
( authRpxnow
) where
#include "qq.h"
import Yesod.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
[QQ(hamlet)|
<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"]

125
yesod-auth/auth2.hs Normal file
View File

@ -0,0 +1,125 @@
{-# LANGUAGE QuasiQuotes, TypeFamilies, TemplateHaskell #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
import Yesod
import Yesod.Mail
import Yesod.Helpers.Auth2
import Yesod.Helpers.Auth2.OpenId
import Yesod.Helpers.Auth2.Rpxnow
import Yesod.Helpers.Auth2.Facebook
import Yesod.Helpers.Auth2.Email
import Control.Monad (join)
import Database.Persist.Sqlite
import Safe (readMay)
mkPersist [$persist|
Email
email String Eq
status Bool update
verkey String null update
password String null update
UniqueEmail email
|]
data A2 = A2 { connPool :: ConnectionPool }
mkYesod "A2" [$parseRoutes|
/auth AuthR Auth getAuth
|]
instance Yesod A2 where approot _ = "http://localhost:3000"
instance YesodAuth A2 where
type AuthId A2 = String
loginDest _ = AuthR CheckR
logoutDest _ = AuthR CheckR
getAuthId = return . Just . credsIdent
showAuthId = const id
readAuthId = const Just
authPlugins =
[ authDummy
, authOpenId
, authRpxnow "yesod-test" "c8043882f14387d7ad8dfc99a1a8dab2e028f690"
, authFacebook
"d790dfc0203e31c0209ed32f90782c31"
"a7685e10c8977f5435e599aaf1d232eb"
[]
, authEmail
]
main :: IO ()
main = withConnectionPool $ \p -> do
flip runConnectionPool p $ runMigration $ migrate (undefined :: Email)
basicHandler 3000 $ A2 p
instance YesodAuthEmail A2 where
type AuthEmailId A2 = EmailId
showAuthEmailId _ = show
readAuthEmailId _ = readMay
addUnverified email verkey = runDB $ insert $ Email email False (Just verkey) Nothing
sendVerifyEmail email verkey verurl = do
render <- getUrlRenderParams
tm <- getRouteToMaster
let lbs = renderHamlet render [$hamlet|
%p
%a!href=$verurl$ Verify your email address.
|]
liftIO $ renderSendMail Mail
{ mailHeaders =
[ ("To", email)
, ("From", "reply@orangeroster.com")
, ("Subject", "OrangeRoster: Verify your email address")
]
, mailPlain = verurl
, mailParts =
[ Part
{ partType = "text/html; charset=utf-8"
, partEncoding = None
, partDisposition = Inline
, partContent = lbs
}
]
}
getVerifyKey emailid = runDB $ do
x <- get $ fromIntegral emailid
return $ maybe Nothing emailVerkey x
setVerifyKey emailid verkey = runDB $
update (fromIntegral emailid) [EmailVerkey $ Just verkey]
verifyAccount emailid' = runDB $ do
let emailid = fromIntegral emailid'
x <- get emailid
uid <-
case x of
Nothing -> return Nothing
Just email -> do
update emailid [EmailStatus True]
return $ Just $ emailEmail email
return uid
getPassword email = runDB $ do
x <- getBy $ UniqueEmail email
return $ x >>= emailPassword . snd
setPassword email password = runDB $
updateWhere [EmailEmailEq email] [EmailPassword $ Just password]
getEmailCreds email = runDB $ do
x <- getBy $ UniqueEmail email
case x of
Nothing -> return Nothing
Just (eid, e) ->
return $ Just EmailCreds
{ emailCredsId = fromIntegral eid
, emailCredsAuthId = Just $ emailEmail e
, emailCredsStatus = emailStatus e
, emailCredsVerkey = emailVerkey e
}
getEmail emailid = runDB $ do
x <- get $ fromIntegral emailid
return $ fmap emailEmail x
instance YesodPersist A2 where
type YesodDB A2 = SqlPersist
runDB db = fmap connPool getYesod >>= runConnectionPool db
withConnectionPool :: MonadCatchIO m => (ConnectionPool -> m a) -> m a
withConnectionPool = withSqlitePool "auth2.db3" 10
runConnectionPool :: MonadCatchIO m => SqlPersist m a -> ConnectionPool -> m a
runConnectionPool = runSqlPool

48
yesod-auth/browserid.hs Normal file
View File

@ -0,0 +1,48 @@
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE MultiParamTypeClasses #-}
import Yesod.Core
import Yesod.Auth
import Yesod.Auth.BrowserId
import Data.Text (Text)
import Text.Hamlet (hamlet)
import Control.Monad.IO.Class (liftIO)
import Yesod.Form
import Network.Wai.Handler.Warp (run)
data BID = BID
type Handler = GHandler BID BID
mkYesod "BID" [parseRoutes|
/ RootR GET
/after AfterLoginR GET
/auth AuthR Auth getAuth
|]
getRootR :: Handler ()
getRootR = redirect RedirectTemporary $ AuthR LoginR
getAfterLoginR :: Handler RepHtml
getAfterLoginR = do
mauth <- maybeAuthId
defaultLayout $ addHamlet [hamlet|
<p>Auth: #{show mauth}
|]
instance Yesod BID where
approot _ = "http://localhost:3000"
instance YesodAuth BID where
type AuthId BID = Text
loginDest _ = AfterLoginR
logoutDest _ = AuthR LoginR
getAuthId = return . Just . credsIdent
authPlugins = [authBrowserId "localhost:3000"]
instance RenderMessage BID FormMessage where
renderMessage _ _ = defaultFormMessage
main :: IO ()
main = toWaiApp BID >>= run 3000

53
yesod-auth/facebook.hs Normal file
View File

@ -0,0 +1,53 @@
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE MultiParamTypeClasses #-}
import Yesod
import Yesod.Auth
import Yesod.Auth.Facebook
import Web.Authenticate.Facebook
import Yesod.Form
data FB = FB Facebook
type Handler = GHandler FB FB
fb :: FB
fb = FB Facebook
{ facebookClientId = "154414801293567"
, facebookClientSecret = "f901e124bee0d162c9188f92b939b370"
, facebookRedirectUri = "http://localhost:3000/facebook"
}
mkYesod "FB" [parseRoutes|
/ RootR GET
/after AfterLoginR GET
/auth AuthR Auth getAuth
|]
getRootR :: Handler ()
getRootR = redirect RedirectTemporary $ AuthR LoginR
getAfterLoginR :: Handler RepHtml
getAfterLoginR = defaultLayout $ return ()
instance Yesod FB where
approot _ = "http://localhost:3000"
instance YesodAuth FB where
type AuthId FB = String
loginDest _ = AfterLoginR
logoutDest _ = AuthR LoginR
getAuthId _ = do
liftIO $ putStrLn "getAuthId"
return $ Just "foo"
authPlugins = return $ authFacebook
"154414801293567"
"f901e124bee0d162c9188f92b939b370"
[]
instance RenderMessage FB FormMessage where
renderMessage _ _ = defaultFormMessage
main :: IO ()
main = warpDebug 3000 fb

10
yesod-auth/include/qq.h Normal file
View File

@ -0,0 +1,10 @@
-- CPP macro which choses which quasyquotes syntax to use depending
-- on GHC version.
--
-- QQ stands for quasyquote.
#if GHC7
# define QQ(x) x
#else
# define QQ(x) $x
#endif

62
yesod-auth/yesod-auth.cabal Normal file
View File

@ -0,0 +1,62 @@
name: yesod-auth
version: 0.7.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://www.yesodweb.com/
extra-source-files: include/qq.h
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.2 && < 0.10
, bytestring >= 0.9.1.4 && < 0.10
, yesod-core >= 0.9 && < 0.10
, 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.2 && < 0.3
, hamlet >= 0.9 && < 0.10
, yesod-json >= 0.2 && < 0.3
, containers >= 0.2 && < 0.5
, yesod-form >= 0.3 && < 0.4
, transformers >= 0.2 && < 0.3
, persistent >= 0.6 && < 0.7
, persistent-template >= 0.6 && < 0.7
, SHA >= 1.4.1.3 && < 1.5
, http-enumerator >= 0.6 && < 0.7
, aeson >= 0.3.2.2 && < 0.4
, pwstore-fast >= 2.1 && < 2.2
exposed-modules: Yesod.Auth
Yesod.Auth.BrowserId
Yesod.Auth.Dummy
Yesod.Auth.Email
Yesod.Auth.Facebook
Yesod.Auth.OpenId
Yesod.Auth.OAuth
Yesod.Auth.Rpxnow
Yesod.Auth.HashDB
Yesod.Auth.Message
ghc-options: -Wall
include-dirs: include
source-repository head
type: git
location: git://github.com/snoyberg/yesod-auth.git