From 6d9e76313d1f89dcf4c1adb7bfabd811a65bd83a Mon Sep 17 00:00:00 2001
From: William Carroll <wpcarro@gmail.com>
Date: Tue, 28 Jul 2020 10:14:33 +0100
Subject: [PATCH] Partially support DELETE /trips

Allow a user to delete a trip entry from the Trips table using the Primary
Key. While this type-checks and compiles, it doesn't appear to be working as
intended. Perhaps I should use an auto-incrementing integer as the Primary
Key. I'm not sure how I want to handle this, so I'm punting for now.
---
 src/API.hs   |  9 +++++++--
 src/App.hs   | 17 ++++++++++++++---
 src/Types.hs | 18 ++++++++++++++++++
 3 files changed, 39 insertions(+), 5 deletions(-)

diff --git a/src/API.hs b/src/API.hs
index a42bf804b..545aa25be 100644
--- a/src/API.hs
+++ b/src/API.hs
@@ -14,10 +14,15 @@ type API = "user"
            :> Post '[JSON] (Maybe T.Session)
       :<|> "user"
            :> Capture "name" Text
-           :> Get  '[JSON] (Maybe T.Account)
-      :<|> "trip"
+           :> Get '[JSON] (Maybe T.Account)
+      -- Create
+      :<|> "trips"
            :> ReqBody '[JSON] T.Trip
            :> Post '[JSON] NoContent
       -- Read
       :<|> "trips"
            :> Get '[JSON] [T.Trip]
+      -- Delete
+      :<|> "trips"
+           :> ReqBody '[JSON] T.TripPK
+           :> Delete '[JSON] NoContent
diff --git a/src/App.hs b/src/App.hs
index c4203137a..774795192 100644
--- a/src/App.hs
+++ b/src/App.hs
@@ -21,11 +21,13 @@ server dbFile = userAddH
            :<|> userGetH
            :<|> createTripH
            :<|> listTripsH
+           :<|> deleteTripH
   where
-    userAddH newUser = liftIO $ userAdd newUser
-    userGetH name    = liftIO $ userGet name
-    createTripH trip = liftIO $ createTrip trip
+    userAddH newUser   = liftIO $ userAdd newUser
+    userGetH name      = liftIO $ userGet name
+    createTripH trip   = liftIO $ createTrip trip
     listTripsH         = liftIO $ listTrips
+    deleteTripH tripPK = liftIO $ deleteTrip tripPK
 
     -- TODO(wpcarro): Handle failed CONSTRAINTs instead of sending 500s
     userAdd :: T.Account -> IO (Maybe T.Session)
@@ -53,6 +55,15 @@ server dbFile = userAddH
     listTrips :: IO [T.Trip]
     listTrips = withConnection dbFile $ \conn -> do
       query_ conn "SELECT * FROM Trips"
+
+    -- TODO(wpcarro): Validate incoming data like startDate.
+    deleteTrip :: T.TripPK -> IO NoContent
+    deleteTrip tripPK =
+      withConnection dbFile $ \conn -> do
+        execute conn "DELETE FROM Trips WHERE username = ? AND destination = ? and startDate = ?"
+          (tripPK & T.tripPKFields)
+        pure NoContent
+
 mkApp :: FilePath -> IO Application
 mkApp dbFile = do
   pure $ serve (Proxy @ API) $ server dbFile
diff --git a/src/Types.hs b/src/Types.hs
index 112b17c53..6d6b83347 100644
--- a/src/Types.hs
+++ b/src/Types.hs
@@ -199,6 +199,24 @@ instance FromRow Trip where
                  <*> field
                  <*> field
 
+-- | The fields used as the Primary Key for a Trip entry.
+data TripPK = TripPK
+  { tripPKUsername :: Username
+  , tripPKDestination :: Destination
+  , tripPKStartDate :: Date
+  } deriving (Eq, Show, Generic)
+
+tripPKFields :: TripPK -> (Username, Destination, Date)
+tripPKFields (TripPK{ tripPKUsername
+                    , tripPKDestination
+                    , tripPKStartDate
+                    })
+  = (tripPKUsername, tripPKDestination, tripPKStartDate)
+
+-- TODO(wpcarro): Prefer shorter JSON fields like username instead of
+-- tripPKUsername.
+instance FromJSON TripPK
+
 -- | Return the tuple representation of a Trip record for SQL.
 tripFields :: Trip -> (Username, Destination, Date, Date, Comment)
 tripFields (Trip{ tripUsername