Finally put pfifcontractors into gitHEADmaster

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