1 {-# LANGUAGE OverloadedStrings #-} 2 module Controller.Login 3 ( checkPassword 4 , loginAccount 5 , viewLogin 6 , postLogin 7 , loginHandler 8 , postLogout 9 , postLogoutHandler 10 , postUser 11 , userHandler 12 ) where 13 14 import Control.Applicative ((<|>)) 15 import Control.Monad (when, unless) 16 import Control.Monad.Trans.Class (lift) 17 import qualified Crypto.BCrypt as BCrypt 18 import qualified Data.ByteString as BS 19 import Data.Function (on) 20 import Data.Maybe (fromMaybe) 21 import qualified Network.Wai as Wai 22 import Network.HTTP.Types.Method (methodGet, methodPost) 23 import qualified Network.HTTP.Types.Method as HTM 24 25 import Ops 26 import Has 27 import qualified JSON 28 import Model.Id.Types 29 import Model.Party 30 import Model.Identity 31 import Model.Permission 32 import Model.Notification 33 import Model.Token 34 import HTTP.Cookie 35 import HTTP.Form.Deform 36 import HTTP.Path.Parser 37 import Action 38 import Controller.Paths 39 import Controller.Form 40 import Controller.Angular 41 import Controller.Notification 42 import View.Login 43 44 import {-# SOURCE #-} Controller.Root 45 import {-# SOURCE #-} Controller.Party 46 47 loginAccount :: API -> SiteAuth -> Bool -> Handler Response 48 loginAccount api auth su = do 49 (sess :: Session) <- createSession auth su 50 let Token (Id tok) ex = (accountToken . sessionAccountToken) sess 51 cook <- setSignedCookie "session" tok ex 52 case api of 53 JSON -> return $ okResponse [cook] $ JSON.recordEncoding $ identityJSON (Identified sess) 54 HTML -> peeks $ otherRouteResponse [cook] viewParty (HTML, TargetProfile) 55 56 loginHandler :: API -> HTM.Method -> [(BS.ByteString, BS.ByteString)] -> Action 57 loginHandler api method _ 58 | method == methodGet && api == HTML = viewLoginAction 59 | method == methodPost = postLoginAction api 60 | otherwise = error "unhandled api/method combo" -- TODO: better error 61 62 viewLogin :: ActionRoute () 63 viewLogin = action GET ("user" >/> "login") $ \() -> viewLoginAction 64 65 -- | The action for handling GET for user/login 66 viewLoginAction :: Action 67 viewLoginAction = withAuth $ do 68 angular 69 maybeIdentity 70 (peeks (blankForm . htmlLogin)) 71 (const (peeks (otherRouteResponse [] viewParty (HTML, TargetProfile)))) 72 73 checkPassword :: BS.ByteString -> SiteAuth -> Bool 74 checkPassword p = any (`BCrypt.validatePassword` p) . accountPasswd 75 76 postLogin :: ActionRoute API 77 postLogin = action POST (pathAPI </< "user" </< "login") postLoginAction 78 79 data LoginRequest = LoginRequest BS.ByteString BS.ByteString Bool 80 81 -- | The action for handling POST for user/login 82 postLoginAction :: API -> Action 83 postLoginAction = \api -> withoutAuth $ do 84 (Just auth, su) <- runForm ((api == HTML) `thenUse` htmlLogin) $ do 85 email <- "email" .:> emailTextForm 86 password <- "password" .:> deform 87 superuser <- "superuser" .:> deform 88 let _ = LoginRequest email password superuser 89 (auth :: Maybe SiteAuth) <- lift $ lookupSiteAuthByEmail True email 90 let p :: Maybe Party 91 p = view <$> auth 92 -- The site auth will contain a member value, indicating the 93 -- user's right to edit group 0 (databrary site). There is no 94 -- inheritance for this value, so this is essentially looking 95 -- at the member value for the direct authorization between the user and 96 -- group 0. See examples of typical superadmins like party 1, party 7 in 0.sql. 97 su = superuser && any ((PermissionADMIN ==) . accessMember) auth 98 attempts <- lift $ maybe (return 0) recentAccountLogins p 99 let pass = checkPassword password `any` auth 100 block = attempts > 4 101 lift $ auditAccountLogin pass (fromMaybe nobodyParty p) email 102 when block $ "email" .:> deformError "Too many login attempts. Try again later." 103 unless pass $ "password" .:> deformError "Incorrect email address or password. Both are case-sensitive, and institutional addresses are preferred." 104 return (auth, su) 105 loginAccount api auth su 106 107 postLogout :: ActionRoute API 108 postLogout = action POST (pathAPI </< "user" </< "logout") $ \api -> postLogoutHandler api [] 109 110 postLogoutHandler :: API -> [(BS.ByteString, BS.ByteString)] -> Action -- TODO: guard against methods besides POST 111 postLogoutHandler = \api _ -> withAuth $ do 112 _ <- maybeIdentity (return False) removeSession 113 case api of 114 JSON -> return $ okResponse [cook] $ JSON.recordEncoding $ identityJSON NotLoggedIn 115 HTML -> peeks $ otherRouteResponse [cook] viewRoot HTML 116 where cook = clearCookie "session" 117 118 userJSONField :: BS.ByteString -> Maybe BS.ByteString -> Handler (Maybe JSON.Encoding) 119 userJSONField "notifications" _ = Just . JSON.toEncoding <$> countUserNotifications 120 userJSONField _ _ = return Nothing 121 122 userHandler :: API -> [(BS.ByteString, BS.ByteString)] -> Action 123 userHandler api _ = 124 withAuth $ do 125 method <- peeks Wai.requestMethod 126 if method == methodGet && api == JSON then viewUserAction 127 else if method == methodPost then postUserAction api 128 else error "unhandled api/method combo" -- TODO: better error 129 130 -- viewUser :: ActionRoute () 131 -- viewUser = action GET (pathJSON </< "user") $ \() -> withAuth $ viewUserAction 132 133 viewUserAction :: Handler Response 134 viewUserAction = do 135 ident <- peek 136 let i = identityJSON ident 137 q <- JSON.jsonQuery userJSONField =<< peeks Wai.queryString 138 return $ okResponse [] (i `JSON.foldObjectIntoRec` q) 139 140 postUser :: ActionRoute API -- TODO: remove when 141 postUser = action POST (pathAPI </< "user") $ \api -> withAuth $ postUserAction api 142 143 data UpdateUserRequest = UpdateUserRequest () (Maybe BS.ByteString) (Maybe BS.ByteString) 144 145 postUserAction :: API -> Handler Response 146 postUserAction api = do 147 auth <- peek 148 let acct = siteAccount auth 149 auth' <- runForm ((api == HTML) `thenUse` htmlUserForm acct) $ do 150 csrfForm 151 -- TODO: pass old password into UpdateUserRequest 152 "auth" .:> (deformGuard "Incorrect password" . (`checkPassword` auth) =<< deform) 153 email <- "email" .:> deformNonEmpty emailTextForm 154 passwd <- "password" .:> deformNonEmpty (passwordForm acct) 155 let _ = UpdateUserRequest () email passwd 156 let acct' = acct 157 { accountEmail = fromMaybe (accountEmail acct) email 158 , accountParty = (accountParty acct){ partyAccount = Just acct' } 159 } 160 return auth 161 { siteAccount = acct' 162 , accountPasswd = passwd <|> accountPasswd auth 163 } 164 changeAccount auth' 165 when (on (/=) (accountEmail . siteAccount) auth' auth || on (/=) accountPasswd auth' auth) $ 166 createNotification (blankNotification acct NoticeAccountChange) -- use old acct (email) 167 { notificationParty = Just $ partyRow $ accountParty acct 168 , notificationDelivered = DeliveryAsync -- force immediate delivery 169 } 170 case api of 171 JSON -> return $ okResponse [] $ JSON.recordEncoding $ partyJSON $ accountParty $ siteAccount auth' 172 HTML -> peeks $ otherRouteResponse [] viewParty (api, TargetProfile)