randomKey in Auth uses randomString from Mail

This commit is contained in:
Michael Snoyman 2010-08-20 10:37:27 +03:00
parent 53c2a2f49a
commit 21becc6bda
2 changed files with 25 additions and 19 deletions

View File

@ -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

View File

@ -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