1 {-# LANGUAGE OverloadedStrings #-} 2 module Controller.Register 3 ( passwordResetHandler 4 , viewPasswordReset 5 , postPasswordReset 6 , registerHandler 7 , viewRegister 8 , postRegister 9 , resendInvestigatorHandler 10 , resendInvestigator 11 ) where 12 13 import Control.Applicative ((<$>)) 14 import qualified Data.ByteString as BS 15 import qualified Data.ByteString.Builder as BSB 16 import qualified Data.ByteString.Char8 as BSC 17 import Data.Monoid ((<>)) 18 import qualified Data.Text as T 19 import qualified Data.Text.Encoding as TE 20 import qualified Data.Text.Lazy as TL 21 import qualified Data.Text.Lazy.Encoding as TLE 22 import Network.HTTP.Types.Method (methodGet, methodPost) 23 import qualified Network.HTTP.Types.Method as HTM 24 import Servant (FromHttpApiData(..)) 25 26 import Ops 27 import Has 28 import Service.Mail 29 import Static.Fillin 30 import Model.Permission 31 import Model.Id 32 import Model.Party 33 import Model.Identity 34 import Model.Token 35 import HTTP.Form.Deform 36 import HTTP.Path.Parser 37 import Action 38 import Controller.Paths 39 import Controller.Form 40 import Controller.Permission 41 import Controller.Party 42 import Controller.Token 43 import Controller.Angular 44 import View.Register 45 46 resetPasswordMail :: Either BS.ByteString SiteAuth -> T.Text -> (Maybe TL.Text -> TL.Text) -> Handler () 47 resetPasswordMail (Left email) subj body = 48 sendMail [Left email] [] subj (body Nothing) 49 resetPasswordMail (Right auth) subj body = do 50 tok <- loginTokenId =<< createLoginToken auth True 51 req <- peek 52 sendMail [Right $ view auth] [] subj 53 (body $ Just $ TLE.decodeLatin1 $ BSB.toLazyByteString $ actionURL (Just req) viewLoginToken (HTML, tok) []) 54 55 registerHandler :: API -> HTM.Method -> [(BS.ByteString, BS.ByteString)] -> Action 56 registerHandler api method _ 57 | method == methodGet && api == HTML = viewRegisterAction 58 | method == methodPost = postRegisterAction api 59 | otherwise = error "unhandled api/method combo" -- TODO: better error 60 61 viewRegister :: ActionRoute () 62 viewRegister = action GET (pathHTML </< "user" </< "register") $ \() -> viewRegisterAction 63 64 viewRegisterAction :: Action 65 viewRegisterAction = withAuth $ do 66 angular 67 maybeIdentity 68 (peeks $ blankForm . htmlRegister) 69 (\_ -> peeks $ otherRouteResponse [] viewParty (HTML, TargetProfile)) 70 71 postRegister :: ActionRoute API 72 postRegister = action POST (pathAPI </< "user" </< "register") postRegisterAction 73 74 data RegisterRequest = RegisterRequest T.Text (Maybe T.Text) BSC.ByteString (Maybe T.Text) Bool 75 76 postRegisterAction :: API -> Action 77 postRegisterAction = \api -> withoutAuth $ do 78 reg <- runForm ((api == HTML) `thenUse` htmlRegister) $ do 79 name <- "sortname" .:> (deformRequired =<< deform) 80 prename <- "prename" .:> deformNonEmpty deform 81 email <- "email" .:> emailTextForm 82 affiliation <- "affiliation" .:> deformNonEmpty deform 83 agreement <- "agreement" .:> (deformCheck "You must consent to the user agreement." id =<< deform) 84 let _ = RegisterRequest name prename email affiliation agreement 85 let p = blankParty 86 { partyRow = (partyRow blankParty) 87 { partySortName = name 88 , partyPreName = prename 89 , partyAffiliation = affiliation 90 } 91 , partyAccount = Just a 92 } 93 a = Account 94 { accountParty = p 95 , accountEmail = email 96 } 97 return a 98 auth <- maybe (SiteAuth <$> addAccount reg <*> pure Nothing <*> pure mempty) return =<< lookupSiteAuthByEmail False (accountEmail reg) 99 resetPasswordMail (Right auth) 100 "Databrary account created" 101 $ \(Just url) -> 102 "Thank you for registering with Please use this link to complete your registration:\n\n" 103 <> url <> "\n\n\ 104 \By clicking the above link, you also indicate that you have read and understand the Databrary Access agreement, which you can download here: http://databrary.org/policies/agreement.pdf\n\n\ 105 \Once you've validated your e-mail, you will be able to request authorization to be granted full access to \n" 106 focusIO $ staticSendInvestigator (view auth) 107 return $ okResponse [] $ "Your confirmation email has been sent to '" <> accountEmail reg <> "'." 108 109 resendInvestigator :: ActionRoute (Id Party) 110 resendInvestigator = action POST (pathHTML >/> pathId </< "investigator") $ 111 \i -> resendInvestigatorHandler [("partyId", (BSC.pack . show) i)] 112 113 resendInvestigatorHandler :: [(BS.ByteString, BS.ByteString)] -> Action 114 resendInvestigatorHandler params = withAuth $ do -- TODO: handle POST only 115 let paramId = maybe (error "partyId missing") TE.decodeUtf8 (lookup "partyId" params) 116 let i = either (error . show) Id (parseUrlPiece paramId) 117 checkMemberADMIN 118 p <- getParty (Just PermissionREAD) (TargetParty i) 119 focusIO $ staticSendInvestigator p 120 return $ okResponse [] ("sent" :: String) 121 122 passwordResetHandler :: API -> HTM.Method -> [(BS.ByteString, BS.ByteString)] -> Action 123 passwordResetHandler api method _ 124 | method == methodGet && api == HTML = viewPasswordResetAction 125 | method == methodPost = postPasswordResetAction api 126 | otherwise = error "unhandled api/method combo" -- TODO: better error 127 128 viewPasswordReset :: ActionRoute () 129 viewPasswordReset = action GET (pathHTML </< "user" </< "password") $ \() -> viewPasswordResetAction 130 131 viewPasswordResetAction :: Action 132 viewPasswordResetAction = withoutAuth $ do 133 angular 134 peeks $ blankForm . htmlPasswordReset 135 136 postPasswordReset :: ActionRoute API 137 postPasswordReset = action POST (pathAPI </< "user" </< "password") postPasswordResetAction 138 139 data PasswordResetRequest = PasswordResetRequest BSC.ByteString 140 141 postPasswordResetAction :: API -> Action 142 postPasswordResetAction = \api -> withoutAuth $ do 143 PasswordResetRequest email <- runForm ((api == HTML) `thenUse` htmlPasswordReset) $ 144 PasswordResetRequest <$> ("email" .:> emailTextForm) 145 auth <- lookupPasswordResetAccount email 146 resetPasswordMail (maybe (Left email) Right auth) 147 "Databrary password reset" $ 148 ("Someone (hopefully you) has requested to reset the password for the Databrary account associated with this email address. If you did not request this, let us know (by replying to this message) or simply ignore it.\n\n" <>) 149 . maybe 150 "Unfortunately, no Databrary account was found for this email address. You can try again with a different email address, or reply to this email for assistance.\n" 151 ("Otherwise, you may use this link to reset your Databrary password:\n\n" <>) 152 return $ okResponse [] $ "Your password reset information has been sent to '" <> email <> "'." 153