summaryrefslogtreecommitdiff
path: root/Handler
diff options
context:
space:
mode:
Diffstat (limited to 'Handler')
-rw-r--r--Handler/Home.hs18
-rw-r--r--Handler/Me.hs93
2 files changed, 111 insertions, 0 deletions
diff --git a/Handler/Home.hs b/Handler/Home.hs
new file mode 100644
index 0000000..6f5237b
--- /dev/null
+++ b/Handler/Home.hs
@@ -0,0 +1,18 @@
+{-# LANGUAGE TupleSections, OverloadedStrings #-}
+module Handler.Home where
+
+import Import
+
+getHomeR :: Handler RepHtml
+getHomeR = do
+ defaultLayout $ do
+ aDomId <- lift newIdent
+ setTitle "PFIF Contractor Portal"
+ $(widgetFile "homepage")
+
+postHomeR :: Handler RepHtml
+postHomeR = do
+ defaultLayout $ do
+ aDomId <- lift newIdent
+ setTitle "PFIF Contractor Portal"
+ $(widgetFile "homepage")
diff --git a/Handler/Me.hs b/Handler/Me.hs
new file mode 100644
index 0000000..289b391
--- /dev/null
+++ b/Handler/Me.hs
@@ -0,0 +1,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