diff --git a/Yesod/Helpers/Auth.hs b/Yesod/Helpers/Auth.hs
--- 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
@@ -21,31 +22,29 @@
, requireAuth
) where
-import Yesod.Handler
import Yesod.Core
-import Yesod.Widget
-import Yesod.Content
-import Yesod.Dispatch
import Yesod.Persist
-import Yesod.Request
import Yesod.Json
import Text.Blaze
import Language.Haskell.TH.Syntax hiding (lift)
-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,12 +54,12 @@
-- | 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
+class (Yesod m, SinglePiece (AuthId m)) => YesodAuth m where
type AuthId m
-- | Default destination on successful login, if no other
@@ -73,69 +72,69 @@
getAuthId :: Creds m -> GHandler s m (Maybe (AuthId m))
- showAuthId :: m -> AuthId m -> String
- readAuthId :: m -> String -> Maybe (AuthId m)
-
authPlugins :: [AuthPlugin m]
-- | What to show on the login page.
loginHandler :: GHandler Auth m RepHtml
loginHandler = defaultLayout $ do
- setTitle $ string "Login"
+ setTitle "Login"
tm <- lift getRouteToMaster
mapM_ (flip apLogin tm) authPlugins
----- Message strings. In theory in the future make this localizable
----- See gist: https://gist.github.com/778712
messageNoOpenID :: m -> Html
- messageNoOpenID _ = string "No OpenID identifier found"
+ messageNoOpenID _ = "No OpenID identifier found"
messageLoginOpenID :: m -> Html
- messageLoginOpenID _ = string "Login via OpenID"
+ messageLoginOpenID _ = "Login via OpenID"
messageEmail :: m -> Html
- messageEmail _ = string "Email"
+ messageEmail _ = "Email"
messagePassword :: m -> Html
- messagePassword _ = string "Password"
+ messagePassword _ = "Password"
messageRegister :: m -> Html
- messageRegister _ = string "Register"
+ messageRegister _ = "Register"
messageRegisterLong :: m -> Html
- messageRegisterLong _ = string "Register a new account"
+ messageRegisterLong _ = "Register a new account"
messageEnterEmail :: m -> Html
- messageEnterEmail _ = string "Enter your e-mail address below, and a confirmation e-mail will be sent to you."
+ messageEnterEmail _ = "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 ++ "."
+ messageConfirmationEmailSentTitle _ = "Confirmation e-mail sent"
+ messageConfirmationEmailSent :: m -> Text -> Html
+ messageConfirmationEmailSent _ email = toHtml $ mconcat
+ ["A confirmation e-mail has been sent to ", email, "."]
messageAddressVerified :: m -> Html
- messageAddressVerified _ = string "Address verified, please set a new password"
+ messageAddressVerified _ = "Address verified, please set a new password"
messageInvalidKeyTitle :: m -> Html
- messageInvalidKeyTitle _ = string "Invalid verification key"
+ messageInvalidKeyTitle _ = "Invalid verification key"
messageInvalidKey :: m -> Html
- messageInvalidKey _ = string "I'm sorry, but that was an invalid verification key."
+ messageInvalidKey _ = "I'm sorry, but that was an invalid verification key."
messageInvalidEmailPass :: m -> Html
- messageInvalidEmailPass _ = string "Invalid email/password combination"
+ messageInvalidEmailPass _ = "Invalid email/password combination"
messageBadSetPass :: m -> Html
- messageBadSetPass _ = string "You must be logged in to set a password"
+ messageBadSetPass _ = "You must be logged in to set a password"
messageSetPassTitle :: m -> Html
- messageSetPassTitle _ = string "Set password"
+ messageSetPassTitle _ = "Set password"
messageSetPass :: m -> Html
- messageSetPass _ = string "Set a new password"
+ messageSetPass _ = "Set a new password"
messageNewPass :: m -> Html
- messageNewPass _ = string "New password"
+ messageNewPass _ = "New password"
messageConfirmPass :: m -> Html
- messageConfirmPass _ = string "Confirm"
+ messageConfirmPass _ = "Confirm"
messagePassMismatch :: m -> Html
- messagePassMismatch _ = string "Passwords did not match, please try again"
+ messagePassMismatch _ = "Passwords did not match, please try again"
messagePassUpdated :: m -> Html
- messagePassUpdated _ = string "Password updated"
+ messagePassUpdated _ = "Password updated"
messageFacebook :: m -> Html
- messageFacebook _ = string "Login with Facebook"
+ messageFacebook _ = "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 +143,10 @@
/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
@@ -171,14 +170,14 @@
|]
sendResponse rh
Just ar -> do
- setMessage $ string "Invalid login"
+ setMessage "Invalid login"
redirect RedirectTemporary ar
else return ()
Just aid -> do
- setSession credsKey $ showAuthId y aid
+ setSession credsKey $ toSinglePiece aid
if doRedirects
then do
- setMessage $ string "You are now logged in"
+ setMessage "You are now logged in"
redirectUltDest RedirectTemporary $ loginDest y
else return ()
@@ -186,8 +185,8 @@
getCheckR = do
creds <- maybeAuthId
defaultLayoutJson (do
- setTitle $ string "Authentication Status"
- addHtml $ html creds) (json creds)
+ setTitle "Authentication Status"
+ addHtml $ html creds) (json' creds)
where
html creds =
#if GHC7
@@ -201,11 +200,9 @@
$nothing
Not logged in.
|]
- json creds =
- ValueObject $ Map.fromList
- [ (pack "logged_in"
- , ValueAtom $ AtomBoolean
- $ maybe False (const True) creds)
+ json' creds =
+ Object $ Map.fromList
+ [ (T.pack "logged_in", Bool $ maybe False (const True) creds)
]
getLoginR :: YesodAuth m => GHandler Auth m RepHtml
@@ -220,10 +217,10 @@
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
@@ -232,10 +229,9 @@
maybeAuthId :: YesodAuth m => GHandler s m (Maybe (AuthId m))
maybeAuthId = do
ms <- lookupSession credsKey
- y <- getYesod
case ms of
Nothing -> return Nothing
- Just s -> return $ readAuthId y s
+ Just s -> return $ fromSinglePiece s
maybeAuth :: ( YesodAuth m
, Key val ~ AuthId m
diff --git a/Yesod/Helpers/Auth/Dummy.hs b/Yesod/Helpers/Auth/Dummy.hs
--- 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
--- a/Yesod/Helpers/Auth/Email.hs
+++ b/Yesod/Helpers/Auth/Email.hs
@@ -1,5 +1,7 @@
{-# LANGUAGE QuasiQuotes, TypeFamilies #-}
{-# LANGUAGE CPP #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE FlexibleContexts #-}
module Yesod.Helpers.Auth.Email
( -- * Plugin
authEmail
@@ -19,7 +21,9 @@
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 +39,13 @@
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.
@@ -52,12 +56,9 @@
, emailCredsVerkey :: Maybe VerKey
}
-class YesodAuth m => YesodAuthEmail m where
+class (YesodAuth m, SinglePiece (AuthEmailId m)) => YesodAuthEmail m where
type AuthEmailId m
- showAuthEmailId :: m -> AuthEmailId m -> String
- readAuthEmailId :: m -> String -> Maybe (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)
@@ -69,10 +70,10 @@
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 =
@@ -101,9 +102,8 @@
where
dispatch "GET" ["register"] = getRegisterR >>= sendResponse
dispatch "POST" ["register"] = postRegisterR >>= sendResponse
- dispatch "GET" ["verify", eid, verkey] = do
- y <- getYesod
- case readAuthEmailId y eid of
+ dispatch "GET" ["verify", eid, verkey] =
+ case fromSinglePiece eid of
Nothing -> notFound
Just eid' -> getVerifyR eid' verkey >>= sendResponse
dispatch "POST" ["login"] = postLoginR >>= sendResponse
@@ -148,7 +148,7 @@
return (lid, key)
render <- getUrlRender
tm <- getRouteToMaster
- let verUrl = render $ tm $ verify (showAuthEmailId y lid) verKey
+ let verUrl = render $ tm $ verify (toSinglePiece lid) verKey
sendVerifyEmail email verKey verUrl
defaultLayout $ do
setTitle $ messageConfirmationEmailSentTitle y
@@ -162,7 +162,7 @@
|]
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 +274,11 @@
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 +286,12 @@
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
--- 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 @@
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
@@ -15,16 +17,19 @@
import Yesod.Widget
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)
+import qualified Data.Aeson.Types
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 @@
tm <- getRouteToMaster
render <- getUrlRender
let fb = Facebook.Facebook cid secret $ render $ tm url
- redirectString RedirectTemporary $ S8.pack $ Facebook.getForwardUrl fb perms
+ redirectText RedirectTemporary $ Facebook.getForwardUrl fb perms
dispatch "GET" [] = do
render <- getUrlRender
tm <- getRouteToMaster
@@ -43,18 +48,8 @@
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,17 @@
#{messageFacebook y}
|]
+
+parseCreds :: Text -> Value -> Data.Aeson.Types.Parser (Creds m)
+parseCreds at' (Object m) = do
+ id' <- m .: "id"
+ let id'' = "http://graph.facebook.com/" `mappend` id'
+ name <- m .: "name"
+ email <- m .: "email"
+ return
+ $ Creds "facebook" id''
+ $ maybe id (\x -> (:) ("verifiedEmail", x)) email
+ $ maybe id (\x -> (:) ("displayName ", x)) name
+ [ ("accessToken", at')
+ ]
+parseCreds _ _ = mzero
diff --git a/Yesod/Helpers/Auth/HashDB.hs b/Yesod/Helpers/Auth/HashDB.hs
--- 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 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 Data.Text (Text, unpack)
+import Data.Maybe (fromMaybe)
-- | Computer the sha1 of a string and return it as a string
sha1String :: String -> String
@@ -87,8 +88,8 @@
[$persist|
#endif
User
- username String Eq
- password String
+ username Text Eq
+ password Text
UniqueUser username
|]
@@ -96,14 +97,14 @@
-- 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"]
@@ -114,14 +115,17 @@
PersistBackend (YesodDB y (GGHandler Auth y IO)))
=> GHandler Auth y ()
postLoginR = do
- (user, password) <- runFormPost' $ (,)
- <$> stringInput "username"
- <*> stringInput "password"
+ (mu,mp) <- runFormPost' $ (,)
+ <$> maybeStringInput "username"
+ <*> maybeStringInput "password"
- isValid <- validateUser (user,password)
+ isValid <- case (mu,mp) of
+ (Nothing, _ ) -> return False
+ (_ , Nothing) -> return False
+ (Just u , Just p ) -> validateUser (u,p)
if isValid
- then setCreds True $ Creds "hashdb" user []
+ then setCreds True $ Creds "hashdb" (fromMaybe "" mu) []
else do
setMessage
#if GHC7
@@ -129,7 +133,7 @@
#else
[$hamlet|
#endif
- invalid username/password
+ Invalid username/password
|]
toMaster <- getRouteToMaster
redirect RedirectTemporary $ toMaster LoginR
@@ -160,7 +164,7 @@
#else
[$hamlet|
#endif
- user not found
+ User not found
|]
redirect RedirectTemporary $ authR LoginR
@@ -178,28 +182,28 @@
#endif