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

yesod-core 0.8

Browse Source
This commit is contained in:
Michael Snoyman 2011-04-07 23:16:49 +03:00
parent ef635dc07d
commit 2b957655c6
9 changed files with 119 additions and 86 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

47
Yesod/Helpers/Auth.hs
View File

@ -4,6 +4,7 @@
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE OverloadedStrings #-}
module Yesod.Helpers.Auth
( -- * Subsite
Auth
@ -35,17 +36,22 @@ import qualified Data.ByteString.Char8 as S8
import qualified Network.Wai as W
import Text.Hamlet (hamlet)
import Data.Text.Lazy (pack)
import Data.JSON.Types (Value (..), Atom (AtomBoolean))
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 = String
type Piece = String
type Method = Text
type Piece = Text
data AuthPlugin m = AuthPlugin
{ apName :: String
{ apName :: Text
, apDispatch :: Method -> [Piece] -> GHandler Auth m ()
, apLogin :: forall s. (Route Auth -> Route m) -> GWidget s m ()
}
@ -55,9 +61,9 @@ getAuth = const Auth
-- | User credentials
data Creds m = Creds
{ credsPlugin :: String -- ^ How the user was authenticated
, credsIdent :: String -- ^ Identifier. Exact meaning depends on plugin.
, credsExtra :: [(String, String)]
{ credsPlugin :: Text -- ^ How the user was authenticated
, credsIdent :: Text -- ^ Identifier. Exact meaning depends on plugin.
, credsExtra :: [(Text, Text)]
}
class Yesod m => YesodAuth m where
@ -73,8 +79,8 @@ class Yesod m => YesodAuth m where
getAuthId :: Creds m -> GHandler s m (Maybe (AuthId m))
showAuthId :: m -> AuthId m -> String
readAuthId :: m -> String -> Maybe (AuthId m)
showAuthId :: m -> AuthId m -> Text
readAuthId :: m -> Text -> Maybe (AuthId m)
authPlugins :: [AuthPlugin m]
@ -104,8 +110,9 @@ class Yesod m => YesodAuth m where
messageEnterEmail _ = string "Enter your e-mail address below, and a confirmation e-mail will be sent to you."
messageConfirmationEmailSentTitle :: m -> Html
messageConfirmationEmailSentTitle _ = string "Confirmation e-mail sent"
messageConfirmationEmailSent :: m -> String -> Html
messageConfirmationEmailSent _ email = string $ "A confirmation e-mail has been sent to " ++ email ++ "."
messageConfirmationEmailSent :: m -> Text -> Html
messageConfirmationEmailSent _ email = toHtml $ mconcat
["A confirmation e-mail has been sent to ", email, "."]
messageAddressVerified :: m -> Html
messageAddressVerified _ = string "Address verified, please set a new password"
messageInvalidKeyTitle :: m -> Html
@ -132,10 +139,12 @@ class Yesod m => YesodAuth m where
messageFacebook :: m -> Html
messageFacebook _ = string "Login with Facebook"
type Texts = [Text]
mkYesodSub "Auth"
[ ClassP ''YesodAuth [VarT $ mkName "master"]
]
#define STRINGS *Strings
#define STRINGS *Texts
#if GHC7
[parseRoutes|
#else
@ -144,10 +153,10 @@ mkYesodSub "Auth"
/check CheckR GET
/login LoginR GET
/logout LogoutR GET POST
/page/#String/STRINGS PluginR
/page/#Text/STRINGS PluginR
|]
credsKey :: String
credsKey :: Text
credsKey = "_ID"
-- | FIXME: won't show up till redirect
@ -202,10 +211,8 @@ $nothing
<p>Not logged in.
|]
json creds =
ValueObject $ Map.fromList
[ (pack "logged_in"
, ValueAtom $ AtomBoolean
$ maybe False (const True) creds)
Object $ Map.fromList
[ (T.pack "logged_in", Bool $ maybe False (const True) creds)
]
getLoginR :: YesodAuth m => GHandler Auth m RepHtml
@ -220,10 +227,10 @@ postLogoutR = do
deleteSession credsKey
redirectUltDest RedirectTemporary $ logoutDest y
handlePluginR :: YesodAuth m => String -> [String] -> GHandler Auth m ()
handlePluginR :: YesodAuth m => Text -> [Text] -> GHandler Auth m ()
handlePluginR plugin pieces = do
env <- waiRequest
let method = S8.unpack $ W.requestMethod env
let method = decodeUtf8With lenientDecode $ W.requestMethod env
case filter (\x -> apName x == plugin) authPlugins of
[] -> notFound
ap:_ -> apDispatch ap method pieces

1
Yesod/Helpers/Auth/Dummy.hs
View File

@ -1,5 +1,6 @@
{-# 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.

34
Yesod/Helpers/Auth/Email.hs
View File

@ -1,5 +1,6 @@
{-# LANGUAGE QuasiQuotes, TypeFamilies #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE OverloadedStrings #-}
module Yesod.Helpers.Auth.Email
( -- * Plugin
authEmail
@ -19,7 +20,9 @@ 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
@ -35,13 +38,13 @@ loginR = PluginR "email" ["login"]
registerR = PluginR "email" ["register"]
setpassR = PluginR "email" ["set-password"]
verify :: String -> String -> AuthRoute -- FIXME
verify :: Text -> Text -> AuthRoute -- FIXME
verify eid verkey = PluginR "email" ["verify", eid, verkey]
type Email = String
type VerKey = String
type VerUrl = String
type SaltedPass = String
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.
@ -55,8 +58,8 @@ data EmailCreds m = EmailCreds
class YesodAuth m => YesodAuthEmail m where
type AuthEmailId m
showAuthEmailId :: m -> AuthEmailId m -> String
readAuthEmailId :: m -> String -> Maybe (AuthEmailId m)
showAuthEmailId :: m -> AuthEmailId m -> Text
readAuthEmailId :: m -> Text -> Maybe (AuthEmailId m)
addUnverified :: Email -> VerKey -> GHandler Auth m (AuthEmailId m)
sendVerifyEmail :: Email -> VerKey -> VerUrl -> GHandler Auth m ()
@ -69,10 +72,10 @@ class YesodAuth m => YesodAuthEmail m where
getEmail :: AuthEmailId m -> GHandler Auth m (Maybe Email)
-- | Generate a random alphanumeric string.
randomKey :: m -> IO String
randomKey :: m -> IO Text
randomKey _ = do
stdgen <- newStdGen
return $ fst $ randomString 10 stdgen
return $ TS.pack $ fst $ randomString 10 stdgen
authEmail :: YesodAuthEmail m => AuthPlugin m
authEmail =
@ -162,7 +165,7 @@ postRegisterR = do
|]
getVerifyR :: YesodAuthEmail m
=> AuthEmailId m -> String -> GHandler Auth m RepHtml
=> AuthEmailId m -> Text -> GHandler Auth m RepHtml
getVerifyR lid key = do
realKey <- getVerifyKey lid
memail <- getEmail lid
@ -274,11 +277,11 @@ saltLength :: Int
saltLength = 5
-- | Salt a password with a randomly generated salt.
saltPass :: String -> IO String
saltPass :: Text -> IO Text
saltPass pass = do
stdgen <- newStdGen
let salt = take saltLength $ randomRs ('A', 'Z') stdgen
return $ saltPass' salt pass
return $ TS.pack $ saltPass' salt $ TS.unpack pass
saltPass' :: String -> String -> String
saltPass' salt pass =
@ -286,9 +289,12 @@ saltPass' salt pass =
where
fromString = encodeUtf8 . T.pack
isValidPass :: String -- ^ cleartext password
isValidPass :: Text -- ^ cleartext password
-> SaltedPass -- ^ salted password
-> Bool
isValidPass clear salted =
isValidPass clear' salted' =
let salt = take saltLength salted
in salted == saltPass' salt clear
where
clear = TS.unpack clear'
salted = TS.unpack salted'

42
Yesod/Helpers/Auth/Facebook.hs
View File

@ -1,5 +1,6 @@
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE OverloadedStrings #-}
module Yesod.Helpers.Auth.Facebook
( authFacebook
, facebookUrl
@ -7,7 +8,8 @@ module Yesod.Helpers.Auth.Facebook
import Yesod.Helpers.Auth
import qualified Web.Authenticate.Facebook as Facebook
import Data.Object (fromMapping, lookupScalar)
import Data.Aeson
import Data.Aeson.Types (parseMaybe)
import Data.Maybe (fromMaybe)
import Yesod.Form
@ -17,14 +19,17 @@ import Text.Hamlet (hamlet)
import Control.Monad.IO.Class (liftIO)
import qualified Data.ByteString.Char8 as S8
import Control.Monad.Trans.Class (lift)
import Data.Text (Text)
import Control.Monad (mzero)
import Data.Monoid (mappend)
facebookUrl :: AuthRoute
facebookUrl = PluginR "facebook" ["forward"]
authFacebook :: YesodAuth m
=> String -- ^ Application ID
-> String -- ^ Application secret
-> [String] -- ^ Requested permissions
=> Text -- ^ Application ID
-> Text -- ^ Application secret
-> [Text] -- ^ Requested permissions
-> AuthPlugin m
authFacebook cid secret perms =
AuthPlugin "facebook" dispatch login
@ -34,7 +39,7 @@ authFacebook cid secret perms =
tm <- getRouteToMaster
render <- getUrlRender
let fb = Facebook.Facebook cid secret $ render $ tm url
redirectString RedirectTemporary $ S8.pack $ Facebook.getForwardUrl fb perms
redirectString RedirectTemporary $ Facebook.getForwardUrl fb perms
dispatch "GET" [] = do
render <- getUrlRender
tm <- getRouteToMaster
@ -43,18 +48,8 @@ authFacebook cid secret perms =
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") $ do
m <- fromMapping so
id' <- lookupScalar "id" m
let name = lookupScalar "name" m
let email = lookupScalar "email" m
let id'' = "http://graph.facebook.com/" ++ id'
return
$ Creds "facebook" id''
$ maybe id (\x -> (:) ("verifiedEmail", x)) email
$ maybe id (\x -> (:) ("displayName ", x)) name
[ ("accessToken", at')
]
let c = fromMaybe (error "Invalid response from Facebook")
$ parseMaybe (parseCreds at') $ either error id so
setCreds True c
dispatch _ _ = notFound
login tm = do
@ -71,3 +66,16 @@ authFacebook cid secret perms =
<p>
<a href="#{furl}">#{messageFacebook y}
|]
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

13
Yesod/Helpers/Auth/HashDB.hs
View File

@ -4,6 +4,7 @@
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE OverloadedStrings #-}
-------------------------------------------------------------------------------
-- |
-- Module : Yesod.Helpers.Auth.HashDB
@ -72,8 +73,8 @@ import Text.Hamlet (hamlet)
import Control.Applicative ((<$>), (<*>))
import Data.ByteString.Lazy.Char8 (pack)
import Data.Digest.Pure.SHA (sha1, showDigest)
import Database.Persist.TH (share2)
import Database.Persist.GenericSql (mkMigrate)
import Database.Persist.TH (share2, mkMigrate, persist, mkPersist)
import Data.Text (Text, unpack)
-- | Computer the sha1 of a string and return it as a string
sha1String :: String -> String
@ -87,8 +88,8 @@ share2 mkPersist (mkMigrate "migrateUsers")
[$persist|
#endif
User
username String Eq
password String
username Text Eq
password Text
UniqueUser username
|]
@ -96,14 +97,14 @@ User
-- database values
validateUser :: (YesodPersist y,
PersistBackend (YesodDB y (GGHandler sub y IO)))
=> (String, String)
=> (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 password == userPassword sqlUser
Just (_, sqlUser) -> return $ sha1String (unpack password) == unpack (userPassword sqlUser)
login :: AuthRoute
login = PluginR "hashdb" ["login"]

21
Yesod/Helpers/Auth/OAuth.hs
View File

@ -15,17 +15,20 @@ import Web.Authenticate.OAuth
import Data.Maybe
import Data.String
import Network.HTTP.Enumerator
import Data.ByteString.Char8 (unpack, pack)
import Data.ByteString.Char8 (pack)
import Control.Arrow ((***))
import Control.Monad
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)
oauthUrl :: String -> AuthRoute
oauthUrl :: Text -> AuthRoute
oauthUrl name = PluginR name ["forward"]
authOAuth :: YesodAuth m =>
String -- ^ Service Name
Text -- ^ Service Name
-> String -- ^ OAuth Parameter Name to use for identify
-> String -- ^ Request URL
-> String -- ^ Access Token URL
@ -36,7 +39,7 @@ authOAuth :: YesodAuth m =>
authOAuth name ident reqUrl accUrl authUrl key sec = AuthPlugin name dispatch login
where
url = PluginR name []
oauth = OAuth { oauthServerName = name, oauthRequestUri = reqUrl
oauth = OAuth { oauthServerName = unpack name, oauthRequestUri = reqUrl
, oauthAccessTokenUri = accUrl, oauthAuthorizeUri = authUrl
, oauthSignatureMethod = HMACSHA1
, oauthConsumerKey = fromString key, oauthConsumerSecret = fromString sec
@ -45,7 +48,7 @@ authOAuth name ident reqUrl accUrl authUrl key sec = AuthPlugin name dispatch lo
dispatch "GET" ["forward"] = do
render <- getUrlRender
tm <- getRouteToMaster
let oauth' = oauth { oauthCallback = Just $ fromString $ render $ tm url }
let oauth' = oauth { oauthCallback = Just $ encodeUtf8 $ render $ tm url }
tok <- liftIO $ getTemporaryCredential oauth'
redirectString RedirectTemporary (fromString $ authorizeUrl oauth' tok)
dispatch "GET" [] = do
@ -54,11 +57,11 @@ authOAuth name ident reqUrl accUrl authUrl key sec = AuthPlugin name dispatch lo
let callback = render $ tm url
verifier <- runFormGet' $ stringInput "oauth_verifier"
oaTok <- runFormGet' $ stringInput "oauth_token"
let reqTok = Credential [ ("oauth_verifier", pack verifier), ("oauth_token", pack oaTok)
let reqTok = Credential [ ("oauth_verifier", encodeUtf8 verifier), ("oauth_token", encodeUtf8 oaTok)
]
accTok <- liftIO $ getAccessToken oauth reqTok
let crId = unpack $ fromJust $ lookup (pack ident) $ unCredential accTok
creds = Creds name crId $ map (unpack *** unpack) $ unCredential accTok
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
@ -85,3 +88,5 @@ authTwitter = authOAuth "twitter"
twitterUrl :: AuthRoute
twitterUrl = oauthUrl "twitter"
bsToText = decodeUtf8With lenientDecode

6
Yesod/Helpers/Auth/OpenId.hs
View File

@ -1,5 +1,6 @@
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE OverloadedStrings #-}
module Yesod.Helpers.Auth.OpenId
( authOpenId
, forwardUrl
@ -18,6 +19,7 @@ import Text.Cassius (cassius)
import Text.Blaze (string)
import Control.Monad.Trans.Class (lift)
import qualified Data.ByteString.Char8 as S8
import Data.Text (Text)
forwardUrl :: AuthRoute
forwardUrl = PluginR "openid" ["forward"]
@ -65,7 +67,7 @@ authOpenId =
setMessage $ string $ show err
redirect RedirectTemporary $ toMaster LoginR
)
(redirectString RedirectTemporary . S8.pack)
(redirectString RedirectTemporary)
res
_ -> do
toMaster <- getRouteToMaster
@ -81,7 +83,7 @@ authOpenId =
completeHelper posts
dispatch _ _ = notFound
completeHelper :: YesodAuth m => [(String, String)] -> GHandler Auth m ()
completeHelper :: YesodAuth m => [(Text, Text)] -> GHandler Auth m ()
completeHelper gets' = do
res <- runAttemptT $ OpenId.authenticate gets'
toMaster <- getRouteToMaster

15
Yesod/Helpers/Auth/Rpxnow.hs
View File

@ -1,5 +1,6 @@
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE OverloadedStrings #-}
module Yesod.Helpers.Auth.Rpxnow
( authRpxnow
) where
@ -13,6 +14,8 @@ import Yesod.Widget
import Yesod.Request
import Text.Hamlet (hamlet)
import Control.Monad.IO.Class (liftIO)
import Data.Text (Text, pack, unpack)
import Control.Arrow ((***))
authRpxnow :: YesodAuth m
=> String -- ^ app name
@ -32,18 +35,18 @@ authRpxnow app apiKey =
<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 <- lookupGetParam "token"
token2 <- lookupPostParam "token"
let token = case token1 `mplus` token2 of
Nothing -> invalidArgs ["token: Value not supplied"]
Just x -> x
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))
(getDisplayName extra)
(fmap pack $ getDisplayName $ map (unpack *** unpack) extra)
[]
setCreds True creds
dispatch _ _ = notFound

26
yesod-auth.cabal
View File

@ -1,5 +1,5 @@
name: yesod-auth
version: 0.3.2
version: 0.4.0
license: BSD3
license-file: LICENSE
author: Michael Snoyman, Patrick Brisbin
@ -19,28 +19,28 @@ library
cpp-options: -DGHC7
else
build-depends: base >= 4 && < 4.3
build-depends: authenticate >= 0.8.1 && < 0.9
build-depends: authenticate >= 0.9 && < 0.10
, bytestring >= 0.9.1.4 && < 0.10
, yesod-core >= 0.7 && < 0.8
, wai >= 0.3 && < 0.4
, yesod-core >= 0.8 && < 0.9
, wai >= 0.4 && < 0.5
, template-haskell
, pureMD5 >= 1.1 && < 2.2
, random >= 1.0 && < 1.1
, data-object >= 0.3.1.3 && < 0.4
, control-monad-attempt >= 0.3.0 && < 0.4
, text >= 0.7 && < 0.12
, mime-mail >= 0.1 && < 0.2
, mime-mail >= 0.3 && < 0.4
, blaze-html >= 0.4 && < 0.5
, yesod-persistent >= 0.0 && < 0.1
, hamlet >= 0.7 && < 0.8
, yesod-json >= 0.0 && < 0.1
, yesod-persistent >= 0.1 && < 0.2
, hamlet >= 0.8 && < 0.9
, yesod-json >= 0.1 && < 0.2
, containers >= 0.2 && < 0.5
, json-types >= 0.1 && < 0.2
, yesod-form >= 0.0 && < 0.1
, yesod-form >= 0.1 && < 0.2
, transformers >= 0.2 && < 0.3
, persistent >= 0.4 && < 0.5
, persistent >= 0.5 && < 0.6
, persistent-template >= 0.5 && < 0.6
, SHA >= 1.4.1.3 && < 1.5
, http-enumerator >= 0.3.1 && < 0.4
, http-enumerator >= 0.6 && < 0.7
, aeson >= 0.3.2.2 && < 0.4
exposed-modules: Yesod.Helpers.Auth
Yesod.Helpers.Auth.Dummy