Handling a reservation request in Haskell. Proof of concept

ApiModel.hs

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 ()

App.hs

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

DB.hs

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?

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.

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