Allow API users to create Trip entries

Next up:
- list trips
- update existing trip entries
- delete existing trip entries
This commit is contained in:
William Carroll 2020-07-28 09:10:54 +01:00
parent 475f62fb16
commit 52ac4d79bd
3 changed files with 79 additions and 3 deletions

View file

@ -15,3 +15,6 @@ type API = "user"
:<|> "user" :<|> "user"
:> Capture "name" Text :> Capture "name" Text
:> Get '[JSON] (Maybe T.Account) :> Get '[JSON] (Maybe T.Account)
:<|> "trip"
:> ReqBody '[JSON] T.Trip
:> Post '[JSON] Bool

View file

@ -17,11 +17,13 @@ import qualified Types as T
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
server :: FilePath -> Server API server :: FilePath -> Server API
server dbFile = server dbFile = userAddH
userAddH :<|> userGetH :<|> userGetH
:<|> createTripH
where where
userAddH newUser = liftIO $ userAdd newUser userAddH newUser = liftIO $ userAdd newUser
userGetH name = liftIO $ userGet name userGetH name = liftIO $ userGet name
createTripH trip = liftIO $ createTrip trip
-- TODO(wpcarro): Handle failed CONSTRAINTs instead of sending 500s -- TODO(wpcarro): Handle failed CONSTRAINTs instead of sending 500s
userAdd :: T.Account -> IO (Maybe T.Session) userAdd :: T.Account -> IO (Maybe T.Session)
@ -40,6 +42,12 @@ server dbFile =
[x] -> pure (Just x) [x] -> pure (Just x)
_ -> pure Nothing _ -> 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 :: FilePath -> IO Application
mkApp dbFile = do mkApp dbFile = do
pure $ serve (Proxy @ API) $ server dbFile pure $ serve (Proxy @ API) $ server dbFile

View file

@ -107,8 +107,9 @@ data Account = Account
, accountProfilePicture :: ProfilePicture , accountProfilePicture :: ProfilePicture
} deriving (Eq, Show, Generic) } deriving (Eq, Show, Generic)
instance FromJSON Account -- TODO(wpcarro): Prefer username to accountUsername for JSON
instance ToJSON Account instance ToJSON Account
instance FromJSON Account
-- | Return a tuple with all of the fields for an Account record to use for SQL. -- | Return a tuple with all of the fields for an Account record to use for SQL.
accountFields :: Account -> (Username, Password, Email, Role, ProfilePicture) accountFields :: Account -> (Username, Password, Email, Role, ProfilePicture)
@ -144,3 +145,67 @@ instance ToJSON Session where
, "password" .= password , "password" .= password
, "role" .= role , "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