From 52ac4d79bda2c5f5cc2ff636e79b4bf3b5979868 Mon Sep 17 00:00:00 2001
From: William Carroll <wpcarro@gmail.com>
Date: Tue, 28 Jul 2020 09:10:54 +0100
Subject: [PATCH] Allow API users to create Trip entries

Next up:
- list trips
- update existing trip entries
- delete existing trip entries
---
 src/API.hs   |  3 +++
 src/App.hs   | 12 ++++++++--
 src/Types.hs | 67 +++++++++++++++++++++++++++++++++++++++++++++++++++-
 3 files changed, 79 insertions(+), 3 deletions(-)

diff --git a/src/API.hs b/src/API.hs
index 70da1921d..f858e6d7a 100644
--- a/src/API.hs
+++ b/src/API.hs
@@ -15,3 +15,6 @@ type API = "user"
       :<|> "user"
            :> Capture "name" Text
            :> Get  '[JSON] (Maybe T.Account)
+      :<|> "trip"
+           :> ReqBody '[JSON] T.Trip
+           :> Post '[JSON] Bool
diff --git a/src/App.hs b/src/App.hs
index b80a3ba4f..20d99e385 100644
--- a/src/App.hs
+++ b/src/App.hs
@@ -17,11 +17,13 @@ import qualified Types as T
 --------------------------------------------------------------------------------
 
 server :: FilePath -> Server API
-server dbFile =
-  userAddH :<|> userGetH
+server dbFile = userAddH
+           :<|> userGetH
+           :<|> createTripH
   where
     userAddH newUser = liftIO $ userAdd newUser
     userGetH name    = liftIO $ userGet name
+    createTripH trip = liftIO $ createTrip trip
 
     -- TODO(wpcarro): Handle failed CONSTRAINTs instead of sending 500s
     userAdd :: T.Account -> IO (Maybe T.Session)
@@ -40,6 +42,12 @@ server dbFile =
         [x] -> pure (Just x)
         _   -> pure Nothing
 
+    createTrip :: T.Trip -> IO Bool
+    createTrip trip = withConnection dbFile $ \conn -> do
+      execute conn "INSERT INTO Trips (username,destination,startDate,endDate,comment) VALUES (?,?,?,?,?)"
+        (trip & T.tripFields)
+      pure True
+
 mkApp :: FilePath -> IO Application
 mkApp dbFile = do
   pure $ serve (Proxy @ API) $ server dbFile
diff --git a/src/Types.hs b/src/Types.hs
index d57fa92ed..14536ae8c 100644
--- a/src/Types.hs
+++ b/src/Types.hs
@@ -107,8 +107,9 @@ data Account = Account
   , accountProfilePicture :: ProfilePicture
   } deriving (Eq, Show, Generic)
 
-instance FromJSON Account
+-- TODO(wpcarro): Prefer username to accountUsername for JSON
 instance ToJSON Account
+instance FromJSON Account
 
 -- | Return a tuple with all of the fields for an Account record to use for SQL.
 accountFields :: Account -> (Username, Password, Email, Role, ProfilePicture)
@@ -144,3 +145,67 @@ instance ToJSON Session where
            , "password" .= password
            , "role" .= role
            ]
+
+newtype Comment = Comment Text
+  deriving (Eq, Show, Generic)
+
+instance ToJSON Comment
+instance FromJSON Comment
+
+instance ToField Comment where
+  toField (Comment x) = SQLText x
+
+instance FromField Comment where
+  fromField = forNewtype Comment
+
+-- TODO(wpcarro): Replace this with a different type.
+newtype Date = Date Text
+  deriving (Eq, Show, Generic)
+
+instance ToJSON Date
+instance FromJSON Date
+
+instance ToField Date where
+  toField (Date x) = SQLText x
+
+instance FromField Date where
+  fromField = forNewtype Date
+
+newtype Destination = Destination Text
+  deriving (Eq, Show, Generic)
+
+-- TODO(wpcarro): Prefer username to tripUsername for JSON
+instance ToJSON Destination
+instance FromJSON Destination
+
+instance ToField Destination where
+  toField (Destination x) = SQLText x
+
+instance FromField Destination where
+  fromField = forNewtype Destination
+
+data Trip = Trip
+  { tripUsername :: Username
+  , tripDestination :: Destination
+  , tripStartDate :: Date
+  , tripEndDate :: Date
+  , tripComment :: Comment
+  } deriving (Eq, Show, Generic)
+
+-- | Return the tuple representation of a Trip record for SQL.
+tripFields :: Trip -> (Username, Destination, Date, Date, Comment)
+tripFields (Trip{ tripUsername
+                , tripDestination
+                , tripStartDate
+                , tripEndDate
+                , tripComment
+                })
+  = ( tripUsername
+    , tripDestination
+    , tripStartDate
+    , tripEndDate
+    , tripComment
+    )
+
+instance ToJSON Trip
+instance FromJSON Trip