diff options
| -rw-r--r-- | src/API.hs | 29 | ||||
| -rw-r--r-- | src/App.hs | 41 | ||||
| -rw-r--r-- | src/Types.hs | 19 |
3 files changed, 63 insertions, 26 deletions
diff --git a/src/API.hs b/src/API.hs index 545aa25be777..95b9f14a399c 100644 --- a/src/API.hs +++ b/src/API.hs @@ -9,20 +9,31 @@ import Servant.API import qualified Types as T -------------------------------------------------------------------------------- -type API = "user" +type API = + -- accounts: Create + "accounts" :> ReqBody '[JSON] T.Account :> Post '[JSON] (Maybe T.Session) - :<|> "user" - :> Capture "name" Text - :> Get '[JSON] (Maybe T.Account) - -- Create + -- accounts: Read + -- accounts: Update + -- accounts: Delete + :<|> "accounts" + :> QueryParam' '[Required] "username" Text + :> Delete '[JSON] NoContent + -- accounts: List + :<|> "accounts" + :> Get '[JSON] [T.User] + + -- trips: Create :<|> "trips" :> ReqBody '[JSON] T.Trip :> Post '[JSON] NoContent - -- Read - :<|> "trips" - :> Get '[JSON] [T.Trip] - -- Delete + -- trips: Read + -- trips: Update + -- trips: Delete :<|> "trips" :> ReqBody '[JSON] T.TripPK :> Delete '[JSON] NoContent + -- trips: List + :<|> "trips" + :> Get '[JSON] [T.Trip] diff --git a/src/App.hs b/src/App.hs index 7747951922fa..8e169f9f8d26 100644 --- a/src/App.hs +++ b/src/App.hs @@ -17,21 +17,24 @@ import qualified Types as T -------------------------------------------------------------------------------- server :: FilePath -> Server API -server dbFile = userAddH - :<|> userGetH +server dbFile = createAccountH + :<|> deleteAccountH + :<|> listAccountsH :<|> createTripH - :<|> listTripsH :<|> deleteTripH + :<|> listTripsH where - userAddH newUser = liftIO $ userAdd newUser - userGetH name = liftIO $ userGet name - createTripH trip = liftIO $ createTrip trip - listTripsH = liftIO $ listTrips - deleteTripH tripPK = liftIO $ deleteTrip tripPK + 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 -- TODO(wpcarro): Handle failed CONSTRAINTs instead of sending 500s - userAdd :: T.Account -> IO (Maybe T.Session) - userAdd account = withConnection dbFile $ \conn -> do + createAccount :: T.Account -> IO (Maybe T.Session) + createAccount account = withConnection dbFile $ \conn -> do execute conn "INSERT INTO Accounts (username,password,email,role,profilePicture) VALUES (?,?,?,?,?)" (account & T.accountFields) T.Session{ T.username = T.accountUsername account @@ -39,12 +42,16 @@ server dbFile = userAddH , T.role = T.accountRole account } & Just & pure - userGet :: Text -> IO (Maybe T.Account) - userGet name = withConnection dbFile $ \conn -> do - res <- query conn "SELECT * FROM Accounts WHERE username = ?" (Only name) - case res of - [x] -> pure (Just x) - _ -> pure Nothing + deleteAccount :: Text -> IO NoContent + deleteAccount username = withConnection dbFile $ \conn -> do + execute conn "DELETE FROM Accounts WHERE username = ?" + (Only (T.Username username)) + pure NoContent + + listAccounts :: IO [T.User] + listAccounts = withConnection dbFile $ \conn -> do + accounts <- query_ conn "SELECT * FROM Accounts" + pure $ T.userFromAccount <$> accounts createTrip :: T.Trip -> IO NoContent createTrip trip = withConnection dbFile $ \conn -> do @@ -53,7 +60,7 @@ server dbFile = userAddH pure NoContent listTrips :: IO [T.Trip] - listTrips = withConnection dbFile $ \conn -> do + listTrips = withConnection dbFile $ \conn -> query_ conn "SELECT * FROM Trips" -- TODO(wpcarro): Validate incoming data like startDate. diff --git a/src/Types.hs b/src/Types.hs index 6d6b83347931..2f78ddb9a112 100644 --- a/src/Types.hs +++ b/src/Types.hs @@ -234,3 +234,22 @@ tripFields (Trip{ tripUsername instance ToJSON Trip instance FromJSON Trip + +-- | Users and Accounts both refer to the same underlying entities; however, +-- Users model the user-facing Account details, hiding sensitive details like +-- passwords and emails. +data User = User + { userUsername :: Username + , userProfilePicture :: ProfilePicture + , userRole :: Role + } deriving (Eq, Show, Generic) + +instance ToJSON User +instance FromJSON User + +userFromAccount :: Account -> User +userFromAccount account = + User { userUsername = accountUsername account + , userProfilePicture = accountProfilePicture account + , userRole = accountRole account + } |