ploeh · December 24, 2022 22:54 · Jul 4, 2016 · Mar 18, 2016
diff --git a/ApiModel.hs b/ApiModel.hs
@@ -16,6 +16,10 @@ data Reservation = Reservation
   , 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) &&
@@ -47,6 +51,16 @@ checkCapacity capacity reservedSeats reservation =
     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)
 
@@ -58,4 +72,4 @@ data HttpResult a = OK a
 toHttpResult :: Either Error () -> HttpResult ()
 toHttpResult (Left (ValidationError msg)) = BadRequest msg
 toHttpResult (Left CapacityExceeded) = StatusCode Forbidden
-toHttpResult (Right ()) = OK ()
+toHttpResult (Right ()) = OK ()
diff --git a/App.hs b/App.hs
@@ -5,15 +5,26 @@ module App
 
 import ApiModel
 import DB
+import Control.Monad (forM_)
 import Control.Monad.Trans (liftIO)
-import Control.Monad.Trans.Either (EitherT(..), hoistEither)
+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
-  hoistEither $ checkCapacity 10 i r
-  >>= liftIO . saveReservation connStr
+  eitherT (checkCaravan r) right $ hoistEither $ checkCapacity 10 i r
+  >>= liftIO . saveReservation connStr
diff --git a/DB.hs b/DB.hs
@@ -4,8 +4,12 @@ module DB
   , 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)
@@ -38,3 +42,35 @@ saveReservation dir r = do --Imagine that this inserts into a database table ins
     -- 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
diff --git a/ApiModel.hs b/ApiModel.hs
@@ -0,0 +1,61 @@
+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)
+
+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
+
+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 ()
diff --git a/App.hs b/App.hs
@@ -0,0 +1,19 @@
+module App
+    (
+      postReservation
+    ) where
+
+import ApiModel
+import DB
+import Control.Monad.Trans (liftIO)
+import Control.Monad.Trans.Either (EitherT(..), hoistEither)
+
+connStr :: ConnectionString
+connStr = "."
+
+postReservation :: ReservationRendition -> IO (HttpResult ())
+postReservation candidate = fmap toHttpResult $ runEitherT $ do
+  r <- hoistEither $ validateReservation candidate
+  i <- liftIO $ getReservedSeatsFromDB connStr $ date r
+  hoistEither $ checkCapacity 10 i r
+  >>= liftIO . saveReservation connStr
diff --git a/DB.hs b/DB.hs
@@ -0,0 +1,40 @@
+module DB
+  (
+    ConnectionString
+  , readReservationsFromDB
+  , getReservedSeatsFromDB
+  , saveReservation
+  ) where
+
+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
No results found