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