1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
|
{-# LANGUAGE TupleSections, OverloadedStrings #-}
module Handler.Me where
import Import
import UtilEmail (randomKey, sendVerifyEmail)
import Prelude (head)
import Control.Monad (join)
import Data.Maybe (fromJust)
import qualified Data.Text as T
import Data.Time.Clock (getCurrentTime)
getMeR :: Handler RepHtml
getMeR = do
Entity uid u <- requireAuth
(fformWidget, fformEnctype) <- generateFormPost (efwdForm uid u)
(eformWidget, eformEnctype) <- generateFormPost emailForm
let submission = Nothing :: Maybe User
destination = T.empty
defaultLayout $ do
aDomId <- lift newIdent
setTitle "PFIF contractor page"
$(widgetFile "mepage")
postMeR :: Handler RepHtml
postMeR = do
Entity uid u <- requireAuth
((fresult, fformWidget), fformEnctype) <- runFormPost (efwdForm uid u)
(eformWidget, eformEnctype) <- generateFormPost emailForm
let submission = case fresult of
FormSuccess res -> Just res
_ -> Nothing
maybe (return ()) (runDB . replace uid) submission
destination <- runDB $ maybe (return "<None>") (fmap emailEmail . get404) (userPrimaryemail =<< submission)
defaultLayout $ do
aDomId <- lift newIdent
setTitle "PFIF contractor page"
$(widgetFile "mepage")
postNewdestR :: Handler RepHtml
postNewdestR = do
Entity uid u <- requireAuth
((eresult, eformWidget), eformEnctype) <- runFormPost emailForm
submission <- case eresult of
FormSuccess res -> do
lid <- runDB $ insert res
render <- getUrlRender
tm <- getRouteToMaster
let verKey = fromJust $ emailVerkey res
let verUrl = render $ tm $ verify lid [verKey]
sendVerifyEmail (emailEmail res) verKey verUrl
return (Just res)
_ -> return Nothing
defaultLayout $ do
aDomId <- lift newIdent
setTitle "Email addition page"
$(widgetFile "newdestpage")
where
verify :: EmailId -> Texts -> Route App
verify eid verkey = VerifyEmailR eid verkey
efwdForm :: UserId -> User -> Form User
efwdForm uid u = renderDivs $ User
<$> pure (userIdent u)
<*> pure (userPassword u)
<*> pure (userSalt u)
<*> aopt (radioField (emails uid u)) "Verified addresses" (Just (userPrimaryemail u))
where
emails :: UserId -> User -> GHandler App App (OptionList EmailId)
emails uid u = do -- optionsPersist [EmailUser ==. Just uid, EmailVerkey ==. Nothing] [Desc EmailLastverified] emailEmail
es <- runDB $ selectList [EmailUser ==. Just uid, EmailVerkey ==. Nothing] [Desc EmailLastverified]
optionsPairs $ map (\e -> (emailEmail . entityVal $ e, entityKey e)) es
emailForm :: Form Email
emailForm = renderDivs $ Email
<$> areq (check noPFIF emailField) "Target" Nothing
<*> pure Nothing
<*> aformM (liftIO (fmap Just randomKey))
<*> pure Nothing
where
noPFIF :: Text -> Either Text Text
noPFIF e = if T.isSuffixOf "protocolfreedom.org" e then Left "You may not forward to a protocolfreedom.org address." else Right e
getVerifyEmailR :: EmailId -> Texts -> Handler RepHtml
getVerifyEmailR eid ts = do
let key = head ts
Entity uid u <- requireAuth
e <- runDB $ get404 eid
case (emailVerkey e == Just key,T.length key == 10, emailUser e == Nothing) of
(True, True, True) -> liftIO getCurrentTime >>= \now -> runDB $ update eid [EmailVerkey =. Nothing, EmailUser =. Just uid, EmailLastverified =. Just now]
_ -> fail "Oops"
redirect MeR
|
