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