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.

1 files changed, 61 insertions, 58 deletions

diff --git a/src/App.hs b/src/App.hs
index 783b4402f078..4d9bf22db879 100644
--- a/src/App.hs
+++ b/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
 --------------------------------------------------------------------------------
 
+err429 :: ServerError
+err429 = ServerError
+  { errHTTPCode = 429
+  , errReasonPhrase = "Too many requests"
+  , errBody = ""
+  , errHeaders = []
+  }
+
 server :: FilePath -> Server API
-server dbFile = createAccountH
-           :<|> deleteAccountH
-           :<|> listAccountsH
-           :<|> createTripH
-           :<|> deleteTripH
-           :<|> listTripsH
-           :<|> loginH
-           :<|> logoutH
+server dbFile = createAccount
+           :<|> deleteAccount
+           :<|> listAccounts
+           :<|> createTrip
+           :<|> deleteTrip
+           :<|> listTrips
+           :<|> login
+           :<|> logout
   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
-
     -- 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)