Fully support login, logout

Refactor my handlers to use the `Handler a` type instead of `IO a`; this allows
me to throwError inside of handlers that Servant properly handles. Previously I
was creating 500 errors unnecessarily.
This commit is contained in:
William Carroll 2020-07-29 20:26:23 +01:00
parent ab12be7840
commit fdd51f626c
3 changed files with 117 additions and 60 deletions

View file

@ -11,7 +11,7 @@ import qualified Types as T
--------------------------------------------------------------------------------
-- | Once authenticated, users receive a SessionCookie.
type SessionCookie = Header' '[Required] "Set-Cookie" T.SessionCookie
type SessionCookie = Header' '[Required] "Cookie" T.SessionCookie
type API =
-- accounts: Create

View file

@ -7,118 +7,121 @@
--------------------------------------------------------------------------------
module App where
--------------------------------------------------------------------------------
import Control.Exception (throwIO)
import Control.Monad.IO.Class (liftIO)
import Data.String.Conversions (cs)
import Data.Text (Text)
import Network.Wai.Handler.Warp as Warp
import Servant
import Servant.Server.Internal.ServerError
import API
import Utils
import Web.Cookie
import qualified Crypto.KDF.BCrypt as BC
import qualified Data.Text.Encoding as TE
import qualified Data.UUID as UUID
import qualified Data.UUID.V4 as UUID
import qualified Types as T
import qualified Accounts as Accounts
import qualified Auth as Auth
import qualified Trips as Trips
import qualified Sessions as Sessions
import qualified LoginAttempts as LoginAttempts
--------------------------------------------------------------------------------
server :: FilePath -> Server API
server dbFile = createAccountH
:<|> deleteAccountH
:<|> listAccountsH
:<|> createTripH
:<|> deleteTripH
:<|> listTripsH
:<|> loginH
:<|> logoutH
where
createAccountH newUser = liftIO $ createAccount newUser
deleteAccountH cookie username = liftIO $ deleteAccount cookie username
listAccountsH cookie = liftIO $ listAccounts cookie
createTripH cookie trip = liftIO $ createTrip cookie trip
deleteTripH cookie tripPK = liftIO $ deleteTrip cookie tripPK
listTripsH = liftIO $ listTrips
loginH creds = liftIO $ login creds
logoutH cookie = liftIO $ logout cookie
err429 :: ServerError
err429 = ServerError
{ errHTTPCode = 429
, errReasonPhrase = "Too many requests"
, errBody = ""
, errHeaders = []
}
server :: FilePath -> Server API
server dbFile = createAccount
:<|> deleteAccount
:<|> listAccounts
:<|> createTrip
:<|> deleteTrip
:<|> listTrips
:<|> login
:<|> logout
where
-- TODO(wpcarro): Handle failed CONSTRAINTs instead of sending 500s
createAccount :: T.CreateAccountRequest -> IO NoContent
createAccount :: T.CreateAccountRequest -> Handler NoContent
createAccount request = do
Accounts.create dbFile
liftIO $ Accounts.create dbFile
(T.createAccountRequestUsername request)
(T.createAccountRequestPassword request)
(T.createAccountRequestEmail request)
(T.createAccountRequestRole request)
pure NoContent
deleteAccount :: T.SessionCookie -> Text -> IO NoContent
deleteAccount :: T.SessionCookie -> Text -> Handler NoContent
deleteAccount cookie username = do
Accounts.delete dbFile (T.Username username)
pure NoContent
mRole <- liftIO $ Auth.roleFromCookie dbFile cookie
case mRole of
Just T.Admin -> do
liftIO $ Accounts.delete dbFile (T.Username username)
pure NoContent
-- cannot delete an account if you're not an Admin
_ -> throwError err401 { errBody = "Only admins can delete accounts." }
listAccounts :: T.SessionCookie -> IO [T.User]
listAccounts cookie = Accounts.list dbFile
listAccounts :: T.SessionCookie -> Handler [T.User]
listAccounts (T.SessionCookie cookie) = liftIO $ Accounts.list dbFile
createTrip :: T.SessionCookie -> T.Trip -> IO NoContent
createTrip :: T.SessionCookie -> T.Trip -> Handler NoContent
createTrip cookie trip = do
Trips.create dbFile trip
liftIO $ Trips.create dbFile trip
pure NoContent
-- TODO(wpcarro): Validate incoming data like startDate.
deleteTrip :: T.SessionCookie -> T.TripPK -> IO NoContent
deleteTrip :: T.SessionCookie -> T.TripPK -> Handler NoContent
deleteTrip cookie tripPK = do
Trips.delete dbFile tripPK
liftIO $ Trips.delete dbFile tripPK
pure NoContent
listTrips :: IO [T.Trip]
listTrips = Trips.list dbFile
listTrips :: Handler [T.Trip]
listTrips = liftIO $ Trips.list dbFile
login :: T.AccountCredentials
-> IO (Headers '[Header "Set-Cookie" SetCookie] NoContent)
-> Handler (Headers '[Header "Set-Cookie" SetCookie] NoContent)
login (T.AccountCredentials username password) = do
mAccount <- Accounts.lookup dbFile username
mAccount <- liftIO $ Accounts.lookup dbFile username
case mAccount of
Just account@T.Account{..} -> do
mAttempts <- LoginAttempts.forUsername dbFile accountUsername
mAttempts <- liftIO $ LoginAttempts.forUsername dbFile accountUsername
case mAttempts of
Nothing ->
if T.passwordsMatch password accountPassword then do
session <- Sessions.findOrCreate dbFile account
-- set cookie
undefined
uuid <- liftIO $ Sessions.findOrCreate dbFile account
pure $ addHeader (Auth.mkCookie uuid) NoContent
else do
LoginAttempts.increment dbFile username
throwIO err401 { errBody = "Your credentials are invalid" }
liftIO $ LoginAttempts.increment dbFile username
throwError err401 { errBody = "Your credentials are invalid" }
Just attempts ->
if attempts > 3 then
-- TODO(wpcarro): Prefer 429 error code
throwIO err401 { errBody = "Too many failed login attempts" }
throwError err429
else if T.passwordsMatch password accountPassword then do
session <- Sessions.findOrCreate dbFile account
-- set cookie
undefined
uuid <- liftIO $ Sessions.findOrCreate dbFile account
pure $ addHeader (Auth.mkCookie uuid) NoContent
else do
LoginAttempts.increment dbFile username
-- TODO(wpcarro): Catch and return errors over HTTP
throwIO err401 { errBody = "Your credentials are invalid" }
liftIO $ LoginAttempts.increment dbFile username
throwError err401 { errBody = "Your credentials are invalid" }
-- In this branch, the user didn't supply a known username.
Nothing -> throwIO err401 { errBody = "Your credentials are invalid" }
Nothing -> throwError err401 { errBody = "Your credentials are invalid" }
logout :: T.SessionCookie
-> IO (Headers '[Header "Set-Cookie" SetCookie] NoContent)
logout cookie = undefined
-- pull off SessionUUID from the request headers
-- delete the SessionUUID from the Sessions table.
mkApp :: FilePath -> IO Application
mkApp dbFile = do
pure $ serve (Proxy @ API) $ server dbFile
-> Handler (Headers '[Header "Set-Cookie" SetCookie] NoContent)
logout cookie = do
case Auth.uuidFromCookie cookie of
Nothing ->
pure $ addHeader Auth.emptyCookie NoContent
Just uuid -> do
liftIO $ Sessions.delete dbFile uuid
pure $ addHeader Auth.emptyCookie NoContent
run :: FilePath -> IO ()
run sqliteFile =
Warp.run 3000 =<< mkApp sqliteFile
run dbFile =
Warp.run 3000 (serve (Proxy @ API) $ server dbFile)

54
src/Auth.hs Normal file
View file

@ -0,0 +1,54 @@
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
--------------------------------------------------------------------------------
module Auth where
--------------------------------------------------------------------------------
import Database.SQLite.Simple
import Utils
import Web.Cookie
import qualified Data.UUID as UUID
import qualified Web.Cookie as WC
import qualified Sessions as Sessions
import qualified Accounts as Accounts
import qualified Types as T
import qualified Data.ByteString.Lazy as LBS
--------------------------------------------------------------------------------
-- | Return the UUID from a Session cookie.
uuidFromCookie :: T.SessionCookie -> Maybe T.SessionUUID
uuidFromCookie (T.SessionCookie cookies) = do
auth <- lookup "auth" cookies
uuid <- UUID.fromASCIIBytes auth
pure $ T.SessionUUID uuid
-- | Attempt to return the user role associated with the `cookie`.
roleFromCookie :: FilePath -> T.SessionCookie -> IO (Maybe T.Role)
roleFromCookie dbFile cookie = withConnection dbFile $ \conn -> do
case uuidFromCookie cookie of
Nothing -> pure Nothing
Just uuid -> do
mSession <- Sessions.get dbFile uuid
case mSession of
Nothing -> pure Nothing
Just T.StoredSession{..} -> do
mAccount <- Accounts.lookup dbFile storedSessionUsername
case mAccount of
Nothing -> pure Nothing
Just T.Account{..} -> pure (Just accountRole)
-- | Create a new session cookie.
mkCookie :: T.SessionUUID -> SetCookie
mkCookie (T.SessionUUID uuid) =
defaultSetCookie
{ setCookieName = "auth"
, setCookieValue = UUID.toASCIIBytes uuid
}
-- | Use this to clear out the session cookie.
emptyCookie :: SetCookie
emptyCookie =
defaultSetCookie
{ setCookieName = "auth"
, setCookieValue = ""
}