I am currently working on a sort of reservation system that needs to generate availabilities. A key requirement is thus to generate different lists of times in a given range.

data TimeslotGenMode
  = Monthly
  | Daily
  | WorkDays
  | Weekends
  | Hourly
  | FiveMinutes
  | Minute
  | TenMinutes
  | FifteenMinutes
  deriving (Eq, Generic, FromJSON, ToJSON, ToSchema)

So if some request comes in with “Hourly” then we will get current time, and calculate all 1 hour ranges between 2 hours ago and 60 hours later, for example.

I want to work with this data type or something like this:

data TimeRange = TimeRange
  { slotStart :: !ZonedTime,
    slotEnd :: !ZonedTime
  }
  deriving (Show, Generic, FromJSON, ToJSON, ToSchema)

makeFieldLabelsNoPrefix ''TimeRange

In my example, the “Daily” mode works perfectly fine, but the “Hourly” somehow has a TERRIBLE memory leak, to the point that it fills my 64GB RAM and then proceeds to crash.

I tried to change some things betweeen hourly and daily, also to using a list comprehension but it’s not really helping.

availabilityFromMode :: (MonadIO m) => TimeslotGenMode -> m [TimeRange]
availabilityFromMode Daily = do
  now <- liftIO getZonedTime
  timeZone <- liftIO getCurrentTimeZone
  let today = utctDay $ zonedTimeToUTC now

  let advancedRanges =
        map (mkAdvanceRange timeZone . warpNDaysAtMidnight timeZone today) [0 .. daysInAdvanceToShow]
      previousRanges =
        map (mkPreviousRange timeZone . warpNDaysAtMidnight timeZone today) [daysInPastToShow .. 0]

  pure $ previousRanges ++ advancedRanges
  where
    daysInAdvanceToShow = 60
    daysInPastToShow = -2
    mkPreviousRange timeZone moment =
      TimeRange
        { slotStart = addSecondsToZonedTime timeZone moment (-86400),
          slotEnd = moment
        }
    mkAdvanceRange timeZone moment =
      TimeRange
        { slotStart = moment,
          slotEnd = addSecondsToZonedTime timeZone moment 86400
        }
availabilityFromMode Hourly = do
  now <- liftIO getZonedTime
  timeZone <- liftIO getCurrentTimeZone

  let advancedRanges =
        [mkAdvanceRange timeZone . addSecondsToZonedTime timeZone now $ (i * 3600) | i <- [0 .. hoursInAdvanceToShow]]
      previousRanges =
        [mkPreviousRange timeZone . addSecondsToZonedTime timeZone now $ (i * 3600) | i <- [hoursInPastToShow .. 0]]

  pure $ previousRanges ++ advancedRanges
  where
    hoursInAdvanceToShow = 5
    hoursInPastToShow = -4
    mkPreviousRange timeZone moment =
      TimeRange
        { slotStart = addSecondsToZonedTime timeZone moment (-3600),
          slotEnd = moment
        }
    mkAdvanceRange timeZone moment =
      TimeRange
        { slotStart = moment,
          slotEnd = addSecondsToZonedTime timeZone moment 3600
        }
availabilityFromMode _ = pure []

addSecondsToZonedTime :: TimeZone -> ZonedTime -> Pico -> ZonedTime
addSecondsToZonedTime zone x seconds = utcToZonedTime zone (addUTCTime (secondsToNominalDiffTime seconds) (zonedTimeToUTC x))

warpNDaysAtMidnight :: TimeZone -> Day -> Integer -> ZonedTime
warpNDaysAtMidnight timeZone today daysToAdd =
  localTimeToZoned $
    LocalTime
      { localDay = addDays daysToAdd today,
        localTimeOfDay = midnight
      }
  where
    localTimeToZoned = utcToZonedTime timeZone . localTimeToUTC timeZone

Any idea how I could go about finding and fixing the problem ?

btw see the entire project here: https://gitlab.com/projekt-dobos/jdb-api