module Controller.Login
( checkPassword
, loginAccount
, viewLogin
, postLogin
, loginHandler
, postLogout
, postLogoutHandler
, postUser
, userHandler
) where
import Control.Applicative ((<|>))
import Control.Monad (when, unless)
import Control.Monad.Trans.Class (lift)
import qualified Crypto.BCrypt as BCrypt
import qualified Data.ByteString as BS
import Data.Function (on)
import Data.Maybe (fromMaybe)
import qualified Network.Wai as Wai
import Network.HTTP.Types.Method (methodGet, methodPost)
import qualified Network.HTTP.Types.Method as HTM
import Ops
import Has
import qualified JSON
import Model.Id.Types
import Model.Party
import Model.Identity
import Model.Permission
import Model.Notification
import Model.Token
import HTTP.Cookie
import HTTP.Form.Deform
import HTTP.Path.Parser
import Action
import Controller.Paths
import Controller.Form
import Controller.Angular
import Controller.Notification
import View.Login
import Controller.Root
import Controller.Party
loginAccount :: API -> SiteAuth -> Bool -> Handler Response
loginAccount api auth su = do
(sess :: Session) <- createSession auth su
let Token (Id tok) ex = (accountToken . sessionAccountToken) sess
cook <- setSignedCookie "session" tok ex
case api of
JSON -> return $ okResponse [cook] $ JSON.recordEncoding $ identityJSON (Identified sess)
HTML -> peeks $ otherRouteResponse [cook] viewParty (HTML, TargetProfile)
loginHandler :: API -> HTM.Method -> [(BS.ByteString, BS.ByteString)] -> Action
loginHandler api method _
| method == methodGet && api == HTML = viewLoginAction
| method == methodPost = postLoginAction api
| otherwise = error "unhandled api/method combo"
viewLogin :: ActionRoute ()
viewLogin = action GET ("user" >/> "login") $ \() -> viewLoginAction
viewLoginAction :: Action
viewLoginAction = withAuth $ do
angular
maybeIdentity
(peeks (blankForm . htmlLogin))
(const (peeks (otherRouteResponse [] viewParty (HTML, TargetProfile))))
checkPassword :: BS.ByteString -> SiteAuth -> Bool
checkPassword p = any (`BCrypt.validatePassword` p) . accountPasswd
postLogin :: ActionRoute API
postLogin = action POST (pathAPI </< "user" </< "login") postLoginAction
data LoginRequest = LoginRequest BS.ByteString BS.ByteString Bool
postLoginAction :: API -> Action
postLoginAction = \api -> withoutAuth $ do
(Just auth, su) <- runForm ((api == HTML) `thenUse` htmlLogin) $ do
email <- "email" .:> emailTextForm
password <- "password" .:> deform
superuser <- "superuser" .:> deform
let _ = LoginRequest email password superuser
(auth :: Maybe SiteAuth) <- lift $ lookupSiteAuthByEmail True email
let p :: Maybe Party
p = view <$> auth
su = superuser && any ((PermissionADMIN ==) . accessMember) auth
attempts <- lift $ maybe (return 0) recentAccountLogins p
let pass = checkPassword password `any` auth
block = attempts > 4
lift $ auditAccountLogin pass (fromMaybe nobodyParty p) email
when block $ "email" .:> deformError "Too many login attempts. Try again later."
unless pass $ "password" .:> deformError "Incorrect email address or password. Both are case-sensitive, and institutional addresses are preferred."
return (auth, su)
loginAccount api auth su
postLogout :: ActionRoute API
postLogout = action POST (pathAPI </< "user" </< "logout") $ \api -> postLogoutHandler api []
postLogoutHandler :: API -> [(BS.ByteString, BS.ByteString)] -> Action
postLogoutHandler = \api _ -> withAuth $ do
_ <- maybeIdentity (return False) removeSession
case api of
JSON -> return $ okResponse [cook] $ JSON.recordEncoding $ identityJSON NotLoggedIn
HTML -> peeks $ otherRouteResponse [cook] viewRoot HTML
where cook = clearCookie "session"
userJSONField :: BS.ByteString -> Maybe BS.ByteString -> Handler (Maybe JSON.Encoding)
userJSONField "notifications" _ = Just . JSON.toEncoding <$> countUserNotifications
userJSONField _ _ = return Nothing
userHandler :: API -> [(BS.ByteString, BS.ByteString)] -> Action
userHandler api _ =
withAuth $ do
method <- peeks Wai.requestMethod
if method == methodGet && api == JSON then viewUserAction
else if method == methodPost then postUserAction api
else error "unhandled api/method combo"
viewUserAction :: Handler Response
viewUserAction = do
ident <- peek
let i = identityJSON ident
q <- JSON.jsonQuery userJSONField =<< peeks Wai.queryString
return $ okResponse [] (i `JSON.foldObjectIntoRec` q)
postUser :: ActionRoute API
postUser = action POST (pathAPI </< "user") $ \api -> withAuth $ postUserAction api
data UpdateUserRequest = UpdateUserRequest () (Maybe BS.ByteString) (Maybe BS.ByteString)
postUserAction :: API -> Handler Response
postUserAction api = do
auth <- peek
let acct = siteAccount auth
auth' <- runForm ((api == HTML) `thenUse` htmlUserForm acct) $ do
csrfForm
"auth" .:> (deformGuard "Incorrect password" . (`checkPassword` auth) =<< deform)
email <- "email" .:> deformNonEmpty emailTextForm
passwd <- "password" .:> deformNonEmpty (passwordForm acct)
let _ = UpdateUserRequest () email passwd
let acct' = acct
{ accountEmail = fromMaybe (accountEmail acct) email
, accountParty = (accountParty acct){ partyAccount = Just acct' }
}
return auth
{ siteAccount = acct'
, accountPasswd = passwd <|> accountPasswd auth
}
changeAccount auth'
when (on (/=) (accountEmail . siteAccount) auth' auth || on (/=) accountPasswd auth' auth) $
createNotification (blankNotification acct NoticeAccountChange)
{ notificationParty = Just $ partyRow $ accountParty acct
, notificationDelivered = DeliveryAsync
}
case api of
JSON -> return $ okResponse [] $ JSON.recordEncoding $ partyJSON $ accountParty $ siteAccount auth'
HTML -> peeks $ otherRouteResponse [] viewParty (api, TargetProfile)