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:
parent
ab12be7840
commit
fdd51f626c
3 changed files with 117 additions and 60 deletions
|
@ -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
|
||||
|
|
121
src/App.hs
121
src/App.hs
|
@ -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
54
src/Auth.hs
Normal 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 = ""
|
||||
}
|
Loading…
Reference in a new issue