Create a gist now

Instantly share code, notes, and snippets.

@ploeh /ApiModel.hs
Last active Jul 4, 2016

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
@moodmosaic

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

@moodmosaic

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

@ploeh
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
@moodmosaic

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

@ploeh
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.)

@moodmosaic

Cool! Makes sense now O.o

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