Create a gist now

Instantly share code, notes, and snippets.

@ploeh /ApiModel.hs
Last active Aug 9, 2017

What would you like to do?
Handling a reservation request in Haskell. Proof of concept
module ApiModel where
import Data.Time (ZonedTime(..), parseTimeM, defaultTimeLocale, iso8601DateFormat)
data ReservationRendition = ReservationRendition
{ rDate :: String
, rName :: String
, rEmail :: String
, rQuantity :: Int }
deriving (Eq, Show, Read)
data Reservation = Reservation
{ date :: ZonedTime
, name :: String
, email :: String
, quantity :: Int }
deriving (Show, Read)
data Caravan = Caravan
{ caravanCapacity :: Int } -- Imagine that this type has more composite elements
deriving (Eq, Show, Read)
instance Eq Reservation where
x == y =
zonedTimeZone (date x) == zonedTimeZone (date y) &&
zonedTimeToLocalTime (date x) == zonedTimeToLocalTime (date y) &&
name x == name y &&
email x == email y &&
quantity x == quantity y
data Error = ValidationError String | CapacityExceeded
deriving (Show, Eq)
parseDate :: String -> Maybe ZonedTime
parseDate = parseTimeM True defaultTimeLocale (iso8601DateFormat Nothing)
validateReservation :: ReservationRendition -> Either Error Reservation
validateReservation r =
case parseDate (rDate r) of
Just d ->
Right Reservation
{ date = d
, name = rName r
, email = rEmail r
, quantity = rQuantity r }
Nothing -> Left (ValidationError "Invalid date.")
checkCapacity :: Int -> Int -> Reservation -> Either Error Reservation
checkCapacity capacity reservedSeats reservation =
if capacity < quantity reservation + reservedSeats
then Left CapacityExceeded
else Right reservation
checkCaravanCapacityOnError :: Error
-> Maybe Caravan
-> Reservation
-> Either Error Reservation
checkCaravanCapacityOnError CapacityExceeded (Just caravan) reservation =
if caravanCapacity caravan < quantity reservation
then Left CapacityExceeded
else Right reservation
checkCaravanCapacityOnError err _ _ = Left err
data StatusCode = Forbidden | Accepted -- add more at leisure
deriving (Eq, Show, Read)
data HttpResult a = OK a
| BadRequest String
| StatusCode StatusCode
deriving (Eq, Show, Read)
toHttpResult :: Either Error () -> HttpResult ()
toHttpResult (Left (ValidationError msg)) = BadRequest msg
toHttpResult (Left CapacityExceeded) = StatusCode Forbidden
toHttpResult (Right ()) = OK ()
module App
(
postReservation
) where
import ApiModel
import DB
import Control.Monad (forM_)
import Control.Monad.Trans (liftIO)
import Control.Monad.Trans.Either (EitherT(..), hoistEither, right, eitherT)
connStr :: ConnectionString
connStr = "."
svcAddr :: ServiceAddress
svcAddr = "."
checkCaravan :: Reservation -> Error -> EitherT Error IO Reservation
checkCaravan reservation err = do
c <- liftIO $ findCaravan svcAddr (quantity reservation) (date reservation)
newRes <- hoistEither $ checkCaravanCapacityOnError err c reservation
liftIO $ forM_ c $ reserveCaravan svcAddr (date newRes)
return newRes
postReservation :: ReservationRendition -> IO (HttpResult ())
postReservation candidate = fmap toHttpResult $ runEitherT $ do
r <- hoistEither $ validateReservation candidate
i <- liftIO $ getReservedSeatsFromDB connStr $ date r
eitherT (checkCaravan r) right $ hoistEither $ checkCapacity 10 i r
>>= liftIO . saveReservation connStr
module DB
(
ConnectionString
, readReservationsFromDB
, getReservedSeatsFromDB
, saveReservation
, ServiceAddress
, findCaravan
, reserveCaravan
) where
import Data.List (find)
import System.Directory (doesFileExist)
import System.FilePath ((</>))
import Data.Time (FormatTime(..), ZonedTime(..), formatTime, defaultTimeLocale)
import ApiModel
type ConnectionString = String
rawFileNameForDate :: FormatTime t => t -> String
rawFileNameForDate = formatTime defaultTimeLocale "%F"
fileNameForReservation :: Reservation -> FilePath
fileNameForReservation = (++ ".txt") . rawFileNameForDate . date
readReservationsFromDB :: ConnectionString -> ZonedTime -> IO [Reservation]
readReservationsFromDB dir d = do -- Imagine that this queries a database table instead of reading from a file
exists <- doesFileExist fileName
if exists
then read <$> readFile fileName
else return []
where fileName = dir </> rawFileNameForDate d ++ ".txt"
getReservedSeatsFromDB :: ConnectionString -> ZonedTime -> IO Int
getReservedSeatsFromDB dir d = do
reservations <- readReservationsFromDB dir d
return (foldr ((+) . quantity) 0 reservations)
saveReservation :: ConnectionString -> Reservation -> IO ()
saveReservation dir r = do --Imagine that this inserts into a database table instead of writing to a file
reservations <- readReservationsFromDB dir (date r)
-- Use of `seq` as described in http://stackoverflow.com/a/2530948/126014
length reservations `seq` writeFile fileName $ show (r : reservations)
where fileName = dir </> fileNameForReservation r
-- Caravan storage
caravanPool :: [Caravan]
caravanPool = map Caravan [4, 6, 8]
fileNameForCaravan :: ZonedTime -> FilePath
fileNameForCaravan = (++ ".caravan.txt") . rawFileNameForDate
type ServiceAddress = String
readReservedCaravans :: ServiceAddress -> ZonedTime -> IO [Caravan]
readReservedCaravans dir d = do -- Imagine that this queries a web service instead of reading from a file
exists <- doesFileExist fileName
if exists
then read <$> readFile fileName
else return []
where fileName = dir </> fileNameForCaravan d
findCaravan :: ServiceAddress -> Int -> ZonedTime -> IO (Maybe Caravan)
findCaravan dir requestedCapacity d = do
putStrLn "Finding a caravan..."
reservedCaravans <- readReservedCaravans dir d
let availableCaravans = filter (`notElem` reservedCaravans) caravanPool
return $ find (\c -> requestedCapacity <= caravanCapacity c) availableCaravans
reserveCaravan :: ServiceAddress -> ZonedTime -> Caravan -> IO ()
reserveCaravan dir d c = do --Imagine that this updates a web service instead of writing to a file
caravans <- readReservedCaravans dir d
-- Use of `seq` as described in http://stackoverflow.com/a/2530948/126014
length caravans `seq` writeFile fileName $ show (c : caravans)
where fileName = dir </> fileNameForCaravan d

I've created a gist with the contents of a Stack project for building the above modules.

iso8601DateFormat Nothing doesn't make sense, on line 31. – Shouldn't it be iso8601DateFormat (Just "%H:%M:%S") or similar?

Owner

ploeh commented May 17, 2016

Doesn't it work for you?

*App> parseDate "2016-05-17"
Just 2016-05-17 00:00:00 +0000

It does, but I'm thinking that when you make a reservation sometimes you might also want to specify the time.

Owner

ploeh commented May 17, 2016

Yes, in a real system, but in this proof of concept, you only reserve for a day.

(In fact, I recently had dinner in a restaurant in Brooklyn that came pretty close to being the restaurant of my demo: it only had 12 seats, there were no distinct tables, and serving started at exactly 18 for all guests; you couldn't book for any other time of day.)

Cool! Makes sense now O.o

Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment