diff options
| -rw-r--r-- | src/API.hs | 13 | ||||
| -rw-r--r-- | src/App.hs | 62 | ||||
| -rw-r--r-- | src/Types.hs | 10 |
3 files changed, 58 insertions, 27 deletions
diff --git a/src/API.hs b/src/API.hs index c84da5aef917..50263bb3e69c 100644 --- a/src/API.hs +++ b/src/API.hs @@ -5,10 +5,14 @@ module API where -------------------------------------------------------------------------------- import Data.Text import Servant.API +import Web.Cookie import qualified Types as T -------------------------------------------------------------------------------- +-- | Once authenticated, users receive a SessionCookie. +type SessionCookie = Header' '[Required] "Set-Cookie" T.SessionCookie + type API = -- accounts: Create "accounts" @@ -18,20 +22,24 @@ type API = -- accounts: Update -- accounts: Delete :<|> "accounts" + :> SessionCookie :> QueryParam' '[Required] "username" Text :> Delete '[JSON] NoContent -- accounts: List :<|> "accounts" + :> SessionCookie :> Get '[JSON] [T.User] -- trips: Create :<|> "trips" + :> SessionCookie :> ReqBody '[JSON] T.Trip :> Post '[JSON] NoContent -- trips: Read -- trips: Update -- trips: Delete :<|> "trips" + :> SessionCookie :> ReqBody '[JSON] T.TripPK :> Delete '[JSON] NoContent -- trips: List @@ -41,4 +49,7 @@ type API = -- Miscellaneous :<|> "login" :> ReqBody '[JSON] T.AccountCredentials - :> Post '[JSON] NoContent + :> Post '[JSON] (Headers '[Header "Set-Cookie" SetCookie] NoContent) + :<|> "logout" + :> SessionCookie + :> Get '[JSON] (Headers '[Header "Set-Cookie" SetCookie] NoContent) diff --git a/src/App.hs b/src/App.hs index 209e2f209231..783b4402f078 100644 --- a/src/App.hs +++ b/src/App.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE DataKinds #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE NamedFieldPuns #-} @@ -14,6 +15,7 @@ import Network.Wai.Handler.Warp as Warp import Servant import API import Utils +import Web.Cookie import qualified Crypto.KDF.BCrypt as BC import qualified Data.Text.Encoding as TE @@ -32,14 +34,16 @@ server dbFile = createAccountH :<|> deleteTripH :<|> listTripsH :<|> loginH + :<|> logoutH where - createAccountH newUser = liftIO $ createAccount newUser - deleteAccountH username = liftIO $ deleteAccount username - listAccountsH = liftIO $ listAccounts - createTripH trip = liftIO $ createTrip trip - deleteTripH tripPK = liftIO $ deleteTrip tripPK - listTripsH = liftIO $ listTrips - loginH creds = liftIO $ login creds + 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 -- TODO(wpcarro): Handle failed CONSTRAINTs instead of sending 500s createAccount :: T.CreateAccountRequest -> IO NoContent @@ -51,30 +55,30 @@ server dbFile = createAccountH (T.createAccountRequestRole request) pure NoContent - deleteAccount :: Text -> IO NoContent - deleteAccount username = do + deleteAccount :: T.SessionCookie -> Text -> IO NoContent + deleteAccount cookie username = do Accounts.delete dbFile (T.Username username) pure NoContent - listAccounts :: IO [T.User] - listAccounts = Accounts.list dbFile + listAccounts :: T.SessionCookie -> IO [T.User] + listAccounts cookie = Accounts.list dbFile - createTrip :: T.Trip -> IO NoContent - createTrip trip = do + createTrip :: T.SessionCookie -> T.Trip -> IO NoContent + createTrip cookie trip = do Trips.create dbFile trip pure NoContent - listTrips :: IO [T.Trip] - listTrips = Trips.list dbFile - -- TODO(wpcarro): Validate incoming data like startDate. - deleteTrip :: T.TripPK -> IO NoContent - deleteTrip tripPK = do + deleteTrip :: T.SessionCookie -> T.TripPK -> IO NoContent + deleteTrip cookie tripPK = do Trips.delete dbFile tripPK pure NoContent - -- TODO(wpcarro): Create and store a session token - login :: T.AccountCredentials -> IO NoContent + listTrips :: IO [T.Trip] + listTrips = Trips.list dbFile + + login :: T.AccountCredentials + -> IO (Headers '[Header "Set-Cookie" SetCookie] NoContent) login (T.AccountCredentials username password) = do mAccount <- Accounts.lookup dbFile username case mAccount of @@ -85,25 +89,31 @@ server dbFile = createAccountH if T.passwordsMatch password accountPassword then do session <- Sessions.findOrCreate dbFile account -- set cookie - pure NoContent + undefined else do LoginAttempts.increment dbFile username - throwIO $ err401 { errBody = "Your credentials are invalid" } + throwIO 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" } + throwIO err401 { errBody = "Too many failed login attempts" } else if T.passwordsMatch password accountPassword then do session <- Sessions.findOrCreate dbFile account -- set cookie - pure NoContent + undefined else do LoginAttempts.increment dbFile username -- TODO(wpcarro): Catch and return errors over HTTP - throwIO $ err401 { errBody = "Your credentials are invalid" } + throwIO 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 -> throwIO 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 diff --git a/src/Types.hs b/src/Types.hs index d33ea6870f13..eed9bf8c1696 100644 --- a/src/Types.hs +++ b/src/Types.hs @@ -14,6 +14,8 @@ import Database.SQLite.Simple.Ok import Database.SQLite.Simple.FromField import Database.SQLite.Simple.ToField import GHC.Generics +import Web.Cookie +import Servant.API import Crypto.Random.Types (MonadRandom) import qualified Crypto.KDF.BCrypt as BC @@ -382,3 +384,11 @@ data LoginAttempt = LoginAttempt instance FromRow LoginAttempt where fromRow = LoginAttempt <$> field <*> field + +newtype SessionCookie = SessionCookie Cookies + +instance FromHttpApiData SessionCookie where + parseHeader x = + x |> parseCookies |> SessionCookie |> pure + parseQueryParam x = + x |> TE.encodeUtf8 |> parseCookies |> SessionCookie |> pure |