From 2b957655c6e362ec5492687d1ba54143646b99ea Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Thu, 7 Apr 2011 23:16:49 +0300 Subject: [PATCH] yesod-core 0.8 --- Yesod/Helpers/Auth.hs | 47 +++++++++++++++++++--------------- Yesod/Helpers/Auth/Dummy.hs | 1 + Yesod/Helpers/Auth/Email.hs | 34 ++++++++++++++---------- Yesod/Helpers/Auth/Facebook.hs | 42 ++++++++++++++++++------------ Yesod/Helpers/Auth/HashDB.hs | 13 +++++----- Yesod/Helpers/Auth/OAuth.hs | 21 +++++++++------ Yesod/Helpers/Auth/OpenId.hs | 6 +++-- Yesod/Helpers/Auth/Rpxnow.hs | 15 ++++++----- yesod-auth.cabal | 26 +++++++++---------- 9 files changed, 119 insertions(+), 86 deletions(-) diff --git a/Yesod/Helpers/Auth.hs b/Yesod/Helpers/Auth.hs index abc07621..cd88835d 100644 --- a/Yesod/Helpers/Auth.hs +++ b/Yesod/Helpers/Auth.hs @@ -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

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 diff --git a/Yesod/Helpers/Auth/Dummy.hs b/Yesod/Helpers/Auth/Dummy.hs index 62694026..e5125932 100644 --- a/Yesod/Helpers/Auth/Dummy.hs +++ b/Yesod/Helpers/Auth/Dummy.hs @@ -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. diff --git a/Yesod/Helpers/Auth/Email.hs b/Yesod/Helpers/Auth/Email.hs index 23dbdcf7..dd8508d1 100644 --- a/Yesod/Helpers/Auth/Email.hs +++ b/Yesod/Helpers/Auth/Email.hs @@ -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' diff --git a/Yesod/Helpers/Auth/Facebook.hs b/Yesod/Helpers/Auth/Facebook.hs index 5c049e49..5517928e 100644 --- a/Yesod/Helpers/Auth/Facebook.hs +++ b/Yesod/Helpers/Auth/Facebook.hs @@ -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 =

#{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 diff --git a/Yesod/Helpers/Auth/HashDB.hs b/Yesod/Helpers/Auth/HashDB.hs index 458738c6..e0fe5391 100644 --- a/Yesod/Helpers/Auth/HashDB.hs +++ b/Yesod/Helpers/Auth/HashDB.hs @@ -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"] diff --git a/Yesod/Helpers/Auth/OAuth.hs b/Yesod/Helpers/Auth/OAuth.hs index a2c6c438..cabf51e7 100644 --- a/Yesod/Helpers/Auth/OAuth.hs +++ b/Yesod/Helpers/Auth/OAuth.hs @@ -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 diff --git a/Yesod/Helpers/Auth/OpenId.hs b/Yesod/Helpers/Auth/OpenId.hs index 776fa3bd..cd7d6b47 100644 --- a/Yesod/Helpers/Auth/OpenId.hs +++ b/Yesod/Helpers/Auth/OpenId.hs @@ -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 diff --git a/Yesod/Helpers/Auth/Rpxnow.hs b/Yesod/Helpers/Auth/Rpxnow.hs index 3790be30..03391799 100644 --- a/Yesod/Helpers/Auth/Rpxnow.hs +++ b/Yesod/Helpers/Auth/Rpxnow.hs @@ -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 =