1 {-# LANGUAGE CPP, OverloadedStrings #-} 2 module Controller.Token 3 ( lookupPasswordResetAccount 4 , viewLoginToken 5 , postPasswordToken 6 ) where 7 8 #if !defined(DEVEL) && !defined(SANDBOX) 9 import Control.Monad (mfilter) 10 #endif 11 import Control.Monad (when, unless) 12 import qualified Data.ByteString as BS 13 import Data.Maybe (isNothing, isJust) 14 15 import Ops 16 import Has 17 import qualified JSON 18 import Model.Id 19 import Model.Token 20 import Model.Party 21 #if !defined(DEVEL) && !defined(SANDBOX) 22 import Model.Permission 23 #endif 24 import Model.Notification.Types 25 import HTTP.Path.Parser 26 import Action.Run 27 import Action 28 import Controller.Paths 29 import Controller.Form 30 import Controller.Login 31 import Controller.Angular 32 import Controller.Notification 33 import View.Token 34 35 lookupPasswordResetAccount :: BS.ByteString -> Handler (Maybe SiteAuth) 36 lookupPasswordResetAccount email = 37 #if !defined(DEVEL) && !defined(SANDBOX) 38 mfilter ((PermissionADMIN >) . accessMember) <$> 39 #endif 40 lookupSiteAuthByEmail True email 41 42 viewLoginToken :: ActionRoute (API, Id LoginToken) 43 viewLoginToken = action GET (pathAPI </> pathId) $ \(api, ti) -> withoutAuth $ do 44 when (api == HTML) angular 45 tok <- maybeAction =<< lookupLoginToken ti 46 if loginPasswordToken tok 47 then case api of 48 JSON -> return $ okResponse [] $ JSON.recordEncoding $ JSON.Record ti $ 49 "reset" JSON..= isJust (accountPasswd (view tok)) 50 HTML -> peeks $ blankForm . htmlPasswordToken ti 51 else do 52 _ <- removeLoginToken tok 53 loginAccount api (view tok) False 54 55 postPasswordToken :: ActionRoute (API, Id LoginToken) 56 postPasswordToken = action POST (pathAPI </> pathId) $ \(api, ti) -> withoutAuth $ do 57 tok <- maybeAction =<< lookupLoginToken ti 58 unless (loginPasswordToken tok) $ result =<< peeks notFoundResponse 59 let auth :: SiteAuth 60 auth = view tok 61 pw <- runForm ((api == HTML) `thenUse` htmlPasswordToken ti) $ 62 passwordForm (siteAccount auth) 63 changeAccount auth{ accountPasswd = Just pw } -- or should this be withAuth? 64 _ <- removeLoginToken tok 65 unless (isNothing $ accountPasswd auth) $ 66 createNotification (blankNotification (siteAccount auth) NoticeAccountChange) 67 { notificationParty = Just $ partyRow $ accountParty $ siteAccount auth } 68 loginAccount api (view tok) False