1 {-# LANGUAGE OverloadedStrings #-} 2 module Databrary.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 Databrary.Ops 26 import Databrary.Has 27 import qualified Databrary.JSON as JSON 28 import Databrary.Model.Id.Types 29 import Databrary.Model.Party 30 import Databrary.Model.Identity 31 import Databrary.Model.Permission 32 import Databrary.Model.Notification 33 import Databrary.Model.Token 34 import Databrary.HTTP.Cookie 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.Angular 41 import Databrary.Controller.Notification 42 import Databrary.View.Login 43 44 import {-# SOURCE #-} Databrary.Controller.Root 45 import {-# SOURCE #-} Databrary.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 -- | The action for handling POST for user/login 80 postLoginAction :: API -> Action 81 postLoginAction = \api -> withoutAuth $ do 82 (Just auth, su) <- runForm ((api == HTML) `thenUse` htmlLogin) $ do 83 email <- "email" .:> emailTextForm 84 password <- "password" .:> deform 85 superuser <- "superuser" .:> deform 86 (auth :: Maybe SiteAuth) <- lift $ lookupSiteAuthByEmail True email 87 let p :: Maybe Party 88 p = view <$> auth 89 -- The site auth will contain a member value, indicating the 90 -- user's right to edit group 0 (databrary site). There is no 91 -- inheritance for this value, so this is essentially looking 92 -- at the member value for the direct authorization between the user and 93 -- group 0. See examples of typical superadmins like party 1, party 7 in 0.sql. 94 su = superuser && any ((PermissionADMIN ==) . accessMember) auth 95 attempts <- lift $ maybe (return 0) recentAccountLogins p 96 let pass = checkPassword password `any` auth 97 block = attempts > 4 98 lift $ auditAccountLogin pass (fromMaybe nobodyParty p) email 99 when block $ "email" .:> deformError "Too many login attempts. Try again later." 100 unless pass $ "password" .:> deformError "Incorrect email address or password. Both are case-sensitive, and institutional addresses are preferred." 101 return (auth, su) 102 loginAccount api auth su 103 104 postLogout :: ActionRoute API 105 postLogout = action POST (pathAPI </< "user" </< "logout") $ \api -> postLogoutHandler api [] 106 107 postLogoutHandler :: API -> [(BS.ByteString, BS.ByteString)] -> Action -- TODO: guard against methods besides POST 108 postLogoutHandler = \api _ -> withAuth $ do 109 _ <- maybeIdentity (return False) removeSession 110 case api of 111 JSON -> return $ okResponse [cook] $ JSON.recordEncoding $ identityJSON NotLoggedIn 112 HTML -> peeks $ otherRouteResponse [cook] viewRoot HTML 113 where cook = clearCookie "session" 114 115 userJSONField :: BS.ByteString -> Maybe BS.ByteString -> Handler (Maybe JSON.Encoding) 116 userJSONField "notifications" _ = Just . JSON.toEncoding <$> countUserNotifications 117 userJSONField _ _ = return Nothing 118 119 userHandler :: API -> [(BS.ByteString, BS.ByteString)] -> Action 120 userHandler api _ = 121 withAuth $ do 122 method <- peeks Wai.requestMethod 123 if method == methodGet && api == JSON then viewUserAction 124 else if method == methodPost then postUserAction api 125 else error "unhandled api/method combo" -- TODO: better error 126 127 -- viewUser :: ActionRoute () 128 -- viewUser = action GET (pathJSON </< "user") $ \() -> withAuth $ viewUserAction 129 130 viewUserAction :: Handler Response 131 viewUserAction = do 132 ident <- peek 133 let i = identityJSON ident 134 q <- JSON.jsonQuery userJSONField =<< peeks Wai.queryString 135 return $ okResponse [] (i `JSON.foldObjectIntoRec` q) 136 137 postUser :: ActionRoute API -- TODO: remove when 138 postUser = action POST (pathAPI </< "user") $ \api -> withAuth $ postUserAction api 139 140 postUserAction :: API -> Handler Response 141 postUserAction api = do 142 auth <- peek 143 let acct = siteAccount auth 144 auth' <- runForm ((api == HTML) `thenUse` (htmlUserForm acct)) $ do 145 csrfForm 146 "auth" .:> (deformGuard "Incorrect password" . (`checkPassword` auth) =<< deform) 147 email <- "email" .:> deformNonEmpty emailTextForm 148 passwd <- "password" .:> deformNonEmpty (passwordForm acct) 149 let acct' = acct 150 { accountEmail = fromMaybe (accountEmail acct) email 151 , accountParty = (accountParty acct){ partyAccount = Just acct' } 152 } 153 return auth 154 { siteAccount = acct' 155 , accountPasswd = passwd <|> accountPasswd auth 156 } 157 changeAccount auth' 158 when (on (/=) (accountEmail . siteAccount) auth' auth || on (/=) accountPasswd auth' auth) $ 159 createNotification (blankNotification acct NoticeAccountChange) -- use old acct (email) 160 { notificationParty = Just $ partyRow $ accountParty acct 161 , notificationDelivered = DeliveryAsync -- force immediate delivery 162 } 163 case api of 164 JSON -> return $ okResponse [] $ JSON.recordEncoding $ partyJSON $ accountParty $ siteAccount auth' 165 HTML -> peeks $ otherRouteResponse [] viewParty (api, TargetProfile)