1 {-# LANGUAGE OverloadedStrings #-} 2 module Databrary.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 Databrary.Ops 27 import Databrary.Has 28 import Databrary.Service.Mail 29 import Databrary.Static.Fillin 30 import Databrary.Model.Permission 31 import Databrary.Model.Id 32 import Databrary.Model.Party 33 import Databrary.Model.Identity 34 import Databrary.Model.Token 35 import Databrary.HTTP.Form.Deform 36 import Databrary.HTTP.Path.Parser 37 import Databrary.Action 38 import Databrary.Controller.Paths 39 import Databrary.Controller.Form 40 import Databrary.Controller.Permission 41 import Databrary.Controller.Party 42 import Databrary.Controller.Token 43 import Databrary.Controller.Angular 44 import Databrary.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 postRegisterAction :: API -> Action 75 postRegisterAction = \api -> withoutAuth $ do 76 reg <- runForm ((api == HTML) `thenUse` htmlRegister) $ do 77 name <- "sortname" .:> (deformRequired =<< deform) 78 prename <- "prename" .:> deformNonEmpty deform 79 email <- "email" .:> emailTextForm 80 affiliation <- "affiliation" .:> deformNonEmpty deform 81 _ <- "agreement" .:> (deformCheck "You must consent to the user agreement." id =<< deform) 82 let p = blankParty 83 { partyRow = (partyRow blankParty) 84 { partySortName = name 85 , partyPreName = prename 86 , partyAffiliation = affiliation 87 } 88 , partyAccount = Just a 89 } 90 a = Account 91 { accountParty = p 92 , accountEmail = email 93 } 94 return a 95 auth <- maybe (SiteAuth <$> addAccount reg <*> pure Nothing <*> pure mempty) return =<< lookupSiteAuthByEmail False (accountEmail reg) 96 resetPasswordMail (Right auth) 97 "Databrary account created" 98 $ \(Just url) -> 99 "Thank you for registering with Databrary. Please use this link to complete your registration:\n\n" 100 <> url <> "\n\n\ 101 \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\ 102 \Once you've validated your e-mail, you will be able to request authorization to be granted full access to Databrary.\n" 103 focusIO $ staticSendInvestigator (view auth) 104 return $ okResponse [] $ "Your confirmation email has been sent to '" <> accountEmail reg <> "'." 105 106 resendInvestigator :: ActionRoute (Id Party) 107 resendInvestigator = action POST (pathHTML >/> pathId </< "investigator") $ 108 \i -> resendInvestigatorHandler [("partyId", (BSC.pack . show) i)] 109 110 resendInvestigatorHandler :: [(BS.ByteString, BS.ByteString)] -> Action 111 resendInvestigatorHandler params = withAuth $ do -- TODO: handle POST only 112 let paramId = maybe (error "partyId missing") TE.decodeUtf8 (lookup "partyId" params) 113 let i = either (error . show) Id (parseUrlPiece paramId) 114 checkMemberADMIN 115 p <- getParty (Just PermissionREAD) (TargetParty i) 116 focusIO $ staticSendInvestigator p 117 return $ okResponse [] ("sent" :: String) 118 119 passwordResetHandler :: API -> HTM.Method -> [(BS.ByteString, BS.ByteString)] -> Action 120 passwordResetHandler api method _ 121 | method == methodGet && api == HTML = viewPasswordResetAction 122 | method == methodPost = postPasswordResetAction api 123 | otherwise = error "unhandled api/method combo" -- TODO: better error 124 125 viewPasswordReset :: ActionRoute () 126 viewPasswordReset = action GET (pathHTML </< "user" </< "password") $ \() -> viewPasswordResetAction 127 128 viewPasswordResetAction :: Action 129 viewPasswordResetAction = withoutAuth $ do 130 angular 131 peeks $ blankForm . htmlPasswordReset 132 133 postPasswordReset :: ActionRoute API 134 postPasswordReset = action POST (pathAPI </< "user" </< "password") $ postPasswordResetAction 135 136 postPasswordResetAction :: API -> Action 137 postPasswordResetAction = \api -> withoutAuth $ do 138 email <- runForm ((api == HTML) `thenUse` htmlPasswordReset) $ do 139 "email" .:> emailTextForm 140 auth <- lookupPasswordResetAccount email 141 resetPasswordMail (maybe (Left email) Right auth) 142 "Databrary password reset" $ 143 ("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" <>) 144 . maybe 145 "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" 146 ("Otherwise, you may use this link to reset your Databrary password:\n\n" <>) 147 return $ okResponse [] $ "Your password reset information has been sent to '" <> email <> "'." 148