randomKey in Auth uses randomString from Mail
This commit is contained in:
parent
53c2a2f49a
commit
21becc6bda
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
Loading…
Reference in New Issue
Block a user