1 {-# LANGUAGE CPP, OverloadedStrings #-} 2 module Databrary.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 Databrary.Ops 16 import Databrary.Has 17 import qualified Databrary.JSON as JSON 18 import Databrary.Model.Id 19 import Databrary.Model.Token 20 import Databrary.Model.Party 21 #if !defined(DEVEL) && !defined(SANDBOX) 22 import Databrary.Model.Permission 23 #endif 24 import Databrary.Model.Notification.Types 25 import Databrary.HTTP.Path.Parser 26 import Databrary.Action.Run 27 import Databrary.Action 28 import Databrary.Controller.Paths 29 import Databrary.Controller.Form 30 import Databrary.Controller.Login 31 import Databrary.Controller.Angular 32 import Databrary.Controller.Notification 33 import Databrary.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