diff --git a/Yesod/Helpers/Auth.hs b/Yesod/Helpers/Auth.hs index d4f58290..6dff278e 100644 --- a/Yesod/Helpers/Auth.hs +++ b/Yesod/Helpers/Auth.hs @@ -40,6 +40,7 @@ import qualified Web.Authenticate.OpenId as OpenId import qualified Web.Authenticate.Facebook as Facebook import Yesod +import Yesod.Mail (randomString) import Data.Maybe import Control.Monad @@ -72,10 +73,10 @@ class Yesod master => YesodAuth master where -- | Generate a random alphanumeric string. -- -- This is used for verify string in email authentication. - randomKey :: master -> GHandler (Auth master) master String - randomKey _ = liftIO $ do + randomKey :: master -> IO String + randomKey _ = do stdgen <- newStdGen - return $ take 10 $ randomRs ('A', 'Z') stdgen + return $ fst $ randomString 10 stdgen -- | Each authentication subsystem (OpenId, Rpxnow, Email, Facebook) has its -- own settings. If those settings are not present, then relevant handlers will @@ -314,17 +315,18 @@ postEmailRegisterR :: YesodAuth master => GHandler (Auth master) master RepHtml postEmailRegisterR = do ae <- getAuthEmailSettings email <- runFormPost' $ emailInput "email" - y <- getYesod mecreds <- getEmailCreds ae email (lid, verKey) <- case mecreds of Just (EmailCreds lid _ _ (Just key)) -> return (lid, key) Just (EmailCreds lid _ _ Nothing) -> do - key <- randomKey y + y <- getYesod + key <- liftIO $ randomKey y setVerifyKey ae lid key return (lid, key) Nothing -> do - key <- randomKey y + y <- getYesod + key <- liftIO $ randomKey y lid <- addUnverified ae email key return (lid, key) render <- getUrlRender diff --git a/Yesod/Mail.hs b/Yesod/Mail.hs index 7411110c..256b43b5 100644 --- a/Yesod/Mail.hs +++ b/Yesod/Mail.hs @@ -9,6 +9,7 @@ module Yesod.Mail , sendmail , Disposition (..) , renderSendMail + , randomString ) where import qualified Data.ByteString.Lazy as L @@ -23,21 +24,24 @@ import System.Exit import Codec.Binary.Base64 (encode) import Control.Monad ((<=<)) +randomString :: RandomGen d => Int -> d -> (String, d) +randomString len = + first (map toChar) . sequence' (replicate len (randomR (0, 61))) + where + sequence' [] g = ([], g) + sequence' (f:fs) g = + let (f', g') = f g + (fs', g'') = sequence' fs g' + in (f' : fs', g'') + toChar i + | i < 26 = toEnum $ i + fromEnum 'A' + | i < 52 = toEnum $ i + fromEnum 'a' - 26 + | otherwise = toEnum $ i + fromEnum '0' - 52 + newtype Boundary = Boundary { unBoundary :: String } instance Random Boundary where randomR = const random - random = - first (Boundary . map toChar) . sequence' (replicate 10 (randomR (0, 61))) - where - sequence' [] g = ([], g) - sequence' (f:fs) g = - let (f', g') = f g - (fs', g'') = sequence' fs g' - in (f' : fs', g'') - toChar i - | i < 26 = toEnum $ i + fromEnum 'A' - | i < 52 = toEnum $ i + fromEnum 'a' - 26 - | otherwise = toEnum $ i + fromEnum '0' - 52 + random = first Boundary . randomString 10 data Mail = Mail { mailHeaders :: [(String, String)] @@ -93,7 +97,7 @@ renderMail (Boundary b) (Mail headers plain parts) = toLazyByteString $ mconcat , fromByteString "\n" , case encoding of None -> writeList writeByteString $ L.toChunks content - Base64 -> fromString $ encode $ L.unpack content + Base64 -> writeList writeByte $ map (toEnum . fromEnum) $ encode $ L.unpack content ] renderMail' :: Mail -> IO L.ByteString