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 =