From 385164c6afea7995b797cf8ddddefa187c26f646 Mon Sep 17 00:00:00 2001
From: William Carroll <wpcarro@gmail.com>
Date: Thu, 30 Jul 2020 10:23:55 +0100
Subject: [PATCH] Authorize endpoints

If I ever fully learn `servant-auth`, I'll probably recognize how naive this
hand-rolled solution is. But it works! And the code is pretty declarative, which
I like.
---
 src/App.hs  | 36 +++++++++++++++++++-----------------
 src/Auth.hs | 24 ++++++++++++++++++++----
 2 files changed, 39 insertions(+), 21 deletions(-)

diff --git a/src/App.hs b/src/App.hs
index 4d9bf22db..708dd896f 100644
--- a/src/App.hs
+++ b/src/App.hs
@@ -47,6 +47,11 @@ server dbFile = createAccount
            :<|> login
            :<|> logout
   where
+    -- Admit Admins + whatever the predicate `p` passes.
+    adminsAnd cookie p = Auth.assert dbFile cookie (\acct@T.Account{..} -> accountRole == T.Admin || p acct)
+    -- Admit Admins only.
+    adminsOnly cookie = adminsAnd cookie (const True)
+
     -- TODO(wpcarro): Handle failed CONSTRAINTs instead of sending 500s
     createAccount :: T.CreateAccountRequest -> Handler NoContent
     createAccount request = do
@@ -58,26 +63,23 @@ server dbFile = createAccount
       pure NoContent
 
     deleteAccount :: T.SessionCookie -> Text -> Handler NoContent
-    deleteAccount cookie username = do
-      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 -> Handler [T.User]
-    listAccounts (T.SessionCookie cookie) = liftIO $ Accounts.list dbFile
-
-    createTrip :: T.SessionCookie -> T.Trip -> Handler NoContent
-    createTrip cookie trip = do
-      liftIO $ Trips.create dbFile trip
+    deleteAccount cookie username = adminsOnly cookie $ do
+      liftIO $ Accounts.delete dbFile (T.Username username)
       pure NoContent
 
-    -- TODO(wpcarro): Validate incoming data like startDate.
+    listAccounts :: T.SessionCookie -> Handler [T.User]
+    listAccounts cookie = adminsOnly cookie $ do
+      liftIO $ Accounts.list dbFile
+
+    createTrip :: T.SessionCookie -> T.Trip -> Handler NoContent
+    createTrip cookie trip@T.Trip{..} =
+      adminsAnd cookie (\T.Account{..} -> accountUsername == tripUsername) $ do
+        liftIO $ Trips.create dbFile trip
+        pure NoContent
+
     deleteTrip :: T.SessionCookie -> T.TripPK -> Handler NoContent
-    deleteTrip cookie tripPK = do
+    deleteTrip cookie tripPK@T.TripPK{..} =
+      adminsAnd cookie (\T.Account{..} -> accountUsername == tripPKUsername) $ do
       liftIO $ Trips.delete dbFile tripPK
       pure NoContent
 
diff --git a/src/Auth.hs b/src/Auth.hs
index 6a2436058..4962ce50a 100644
--- a/src/Auth.hs
+++ b/src/Auth.hs
@@ -3,9 +3,13 @@
 --------------------------------------------------------------------------------
 module Auth where
 --------------------------------------------------------------------------------
+import Control.Monad.IO.Class (liftIO)
+import Data.String.Conversions (cs)
 import Database.SQLite.Simple
 import Utils
 import Web.Cookie
+import Servant
+import Servant.Server.Internal.ServerError
 
 import qualified Data.UUID as UUID
 import qualified Web.Cookie as WC
@@ -22,9 +26,9 @@ uuidFromCookie (T.SessionCookie cookies) = do
   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
+-- | Attempt to return the account associated with `cookie`.
+accountFromCookie :: FilePath -> T.SessionCookie -> IO (Maybe T.Account)
+accountFromCookie dbFile cookie = withConnection dbFile $ \conn -> do
   case uuidFromCookie cookie of
     Nothing -> pure Nothing
     Just uuid -> do
@@ -35,7 +39,7 @@ roleFromCookie dbFile cookie = withConnection dbFile $ \conn -> do
           mAccount <- Accounts.lookup dbFile storedSessionUsername
           case mAccount of
             Nothing -> pure Nothing
-            Just T.Account{..} -> pure (Just accountRole)
+            Just x -> pure (Just x)
 
 -- | Create a new session cookie.
 mkCookie :: T.SessionUUID -> SetCookie
@@ -52,3 +56,15 @@ emptyCookie =
     { setCookieName = "auth"
     , setCookieValue = ""
     }
+
+-- | Throw a 401 error if the `predicate` fails.
+assert :: FilePath -> T.SessionCookie -> (T.Account -> Bool) -> Handler a -> Handler a
+assert dbFile cookie predicate handler = do
+  mRole <- liftIO $ accountFromCookie dbFile cookie
+  case mRole of
+    Nothing -> throwError err401 { errBody = "Missing valid session cookie" }
+    Just account ->
+      if predicate account then
+        handler
+      else
+        throwError err401 { errBody = "You are not authorized to access this resource" }