408 lines
15 KiB
Haskell
408 lines
15 KiB
Haskell
-- SPDX-FileCopyrightText: 2022 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Sarah Vaupel <sarah.vaupel@ifi.lmu.de>,Steffen Jost <jost@cip.ifi.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>
|
|
--
|
|
-- SPDX-License-Identifier: AGPL-3.0-or-later
|
|
|
|
{-# OPTIONS_GHC -fno-warn-orphans #-}
|
|
|
|
module Handler.Utils.DateTime
|
|
( utcToLocalTime, utcToZonedTime
|
|
, localTimeToUTC, TZ.LocalToUTCResult(..), localTimeToUTCSimple
|
|
, toTimeOfDay
|
|
, toMidnight, beforeMidnight, toMidday, toMorning, addHours
|
|
, formatDiffDays, formatCalendarDiffDays
|
|
, formatTime'
|
|
, formatTime, formatTimeUser, formatTimeW, formatTimeMail
|
|
, formatTimeRange, formatTimeRangeW, formatTimeRangeMail
|
|
, getTimeLocale
|
|
, getDateTimeFormat , getDateTimeFormatUser , getDateTimeFormatUser'
|
|
, getDateTimeFormatter, getDateTimeFormatterUser, getDateTimeFormatterUser'
|
|
, validDateTimeFormats, dateTimeFormatOptions
|
|
, addLocalDays
|
|
, addDiffDaysClip, addDiffDaysRollOver
|
|
, addOneWeek, addWeeks
|
|
, fromDays, fromMonths
|
|
, weeksToAdd
|
|
, setYear, getYear
|
|
, firstDayOfWeekOnAfter
|
|
, ceilingQuarterHour
|
|
, formatGregorianW
|
|
) where
|
|
|
|
import Import.NoFoundation
|
|
import Foundation.Type
|
|
|
|
import Data.Time.Zones
|
|
import qualified Data.Time.Zones as TZ
|
|
|
|
import qualified Data.Time.Format as Time
|
|
import Data.Time.Format.ISO8601 (iso8601Show)
|
|
|
|
import qualified Data.Set as Set
|
|
|
|
import qualified Data.Csv as Csv
|
|
|
|
import qualified Data.Char as Char
|
|
|
|
|
|
-------------
|
|
-- UTCTime --
|
|
-------------
|
|
|
|
utcToLocalTime :: UTCTime -> LocalTime
|
|
utcToLocalTime = TZ.utcToLocalTimeTZ appTZ
|
|
|
|
utcToZonedTime :: UTCTime -> ZonedTime
|
|
utcToZonedTime = ZonedTime <$> TZ.utcToLocalTimeTZ appTZ <*> TZ.timeZoneForUTCTime appTZ
|
|
|
|
localTimeToUTC :: LocalTime -> LocalToUTCResult
|
|
localTimeToUTC = TZ.localTimeToUTCFull appTZ
|
|
|
|
localTimeToUTCSimple :: LocalTime -> UTCTime
|
|
localTimeToUTCSimple = TZ.localTimeToUTCTZ appTZ
|
|
|
|
-- | Local midnight of given day
|
|
toMidnight :: Day -> UTCTime
|
|
toMidnight = toTimeOfDay 0 0 0
|
|
|
|
-- | Local midday of given day
|
|
toMidday :: Day -> UTCTime
|
|
toMidday = toTimeOfDay 12 0 0
|
|
|
|
-- | One second before the end of day
|
|
beforeMidnight :: Day -> UTCTime
|
|
beforeMidnight = toTimeOfDay 23 59 59
|
|
|
|
-- | 6am in the morning
|
|
toMorning :: Day -> UTCTime
|
|
toMorning = toTimeOfDay 6 0 0
|
|
|
|
toTimeOfDay :: Int -> Int -> Pico -> Day -> UTCTime
|
|
toTimeOfDay todHour todMin todSec d = localTimeToUTCTZ appTZ $ LocalTime d TimeOfDay{..}
|
|
|
|
addHours :: Integer -> UTCTime -> UTCTime
|
|
addHours = addUTCTime . secondsToNominalDiffTime . fromInteger . (* 3600)
|
|
|
|
instance HasLocalTime UTCTime where
|
|
toLocalTime = utcToLocalTime
|
|
|
|
formatTime' :: (HasLocalTime t, MonadHandler m) => String -> t -> m Text
|
|
formatTime' fmtStr t = fmap fromString $ Time.formatTime <$> getTimeLocale <*> pure fmtStr <*> pure (utcToZonedTime . localTimeToUTCTZ appTZ $ toLocalTime t)
|
|
|
|
-- formatTime :: (FormatTime t, MonadHandler m, HandlerSite m ~ UniWorX, IsString str) => (DateTimeFormat -> String) -> t -> m str
|
|
-- Restricted type for safety
|
|
formatTime :: (HasLocalTime t, MonadHandler m, HandlerSite m ~ UniWorX, YesodAuthPersist UniWorX, AuthEntity UniWorX ~ User, AuthId UniWorX ~ UserId) => SelDateTimeFormat -> t -> m Text
|
|
formatTime proj t = flip formatTime' t . unDateTimeFormat =<< getDateTimeFormat proj
|
|
|
|
formatTimeUser :: (HasLocalTime t, MonadHandler m, HandlerSite m ~ UniWorX) => SelDateTimeFormat -> t -> Maybe (Entity User) -> m Text
|
|
formatTimeUser proj t mUser = flip formatTime' t . unDateTimeFormat =<< getDateTimeFormatUser proj mUser
|
|
|
|
-- formatTimeH :: (HasLocalTime t) => SelDateTimeFormat -> t -> Handler Text
|
|
-- formatTimeH = formatTime
|
|
|
|
formatTimeW :: (HasLocalTime t, YesodAuthPersist UniWorX, AuthEntity UniWorX ~ User, AuthId UniWorX ~ UserId) => SelDateTimeFormat -> t -> WidgetFor UniWorX ()
|
|
formatTimeW s t = toWidget =<< formatTime s t
|
|
|
|
formatTimeMail :: (MonadMail m, HasLocalTime t) => SelDateTimeFormat -> t -> m Text
|
|
formatTimeMail sel t = fmap fromString $ Time.formatTime <$> (getTimeLocale' . view _Wrapped <$> askMailLanguages) <*> (unDateTimeFormat <$> askMailDateTimeFormat sel) <*> pure (toLocalTime t)
|
|
|
|
getTimeLocale :: MonadHandler m => m TimeLocale
|
|
getTimeLocale = getTimeLocale' <$> languages
|
|
|
|
getDateTimeFormat :: (MonadHandler m, HandlerSite m ~ UniWorX, YesodAuthPersist UniWorX, AuthEntity UniWorX ~ User, AuthId UniWorX ~ UserId) => SelDateTimeFormat -> m DateTimeFormat
|
|
getDateTimeFormat sel = liftHandler maybeAuth >>= getDateTimeFormatUser sel
|
|
|
|
getDateTimeFormatUser :: (MonadHandler m, HandlerSite m ~ UniWorX) => SelDateTimeFormat -> Maybe (Entity User) -> m DateTimeFormat
|
|
getDateTimeFormatUser sel mUser = do
|
|
UserDefaultConf{..} <- getsYesod $ view _appUserDefaults
|
|
let
|
|
fmt
|
|
| Just (Entity _ User{..}) <- mUser
|
|
= case sel of
|
|
SelFormatDateTime -> userDateTimeFormat
|
|
SelFormatDate -> userDateFormat
|
|
SelFormatTime -> userTimeFormat
|
|
| otherwise
|
|
= case sel of
|
|
SelFormatDateTime -> userDefaultDateTimeFormat
|
|
SelFormatDate -> userDefaultDateFormat
|
|
SelFormatTime -> userDefaultTimeFormat
|
|
return fmt
|
|
|
|
getDateTimeFormatUser' :: SelDateTimeFormat -> User -> DateTimeFormat
|
|
getDateTimeFormatUser' SelFormatDateTime usr = usr & userDateTimeFormat
|
|
getDateTimeFormatUser' SelFormatDate usr = usr & userDateFormat
|
|
getDateTimeFormatUser' SelFormatTime usr = usr & userTimeFormat
|
|
|
|
getDateTimeFormatter :: (MonadHandler m, HandlerSite m ~ UniWorX, YesodAuthPersist UniWorX, AuthEntity UniWorX ~ User, AuthId UniWorX ~ UserId) => m DateTimeFormatter
|
|
getDateTimeFormatter = do
|
|
locale <- getTimeLocale
|
|
formatMap <- traverse getDateTimeFormat id
|
|
return $ mkDateTimeFormatter locale formatMap appTZ
|
|
|
|
getDateTimeFormatterUser :: (MonadHandler m, HandlerSite m ~ UniWorX) => Maybe (Entity User) -> m DateTimeFormatter
|
|
getDateTimeFormatterUser mUser = do
|
|
locale <- getTimeLocale
|
|
formatMap <- traverse (`getDateTimeFormatUser` mUser) id
|
|
return $ mkDateTimeFormatter locale formatMap appTZ
|
|
|
|
getDateTimeFormatterUser' :: (MonadHandler m) => User -> m DateTimeFormatter
|
|
getDateTimeFormatterUser' usr = do
|
|
locale <- getTimeLocale
|
|
let formatMap = flip getDateTimeFormatUser' usr
|
|
return $ mkDateTimeFormatter locale formatMap appTZ
|
|
|
|
|
|
validDateTimeFormats :: TimeLocale -> SelDateTimeFormat -> Set DateTimeFormat
|
|
-- ^ We use a whitelist instead of just letting the user specify their own format string since vulnerabilities in printf-like functions are not uncommon
|
|
validDateTimeFormats tl SelFormatDateTime = Set.fromList $
|
|
[ DateTimeFormat "%Y-%m-%dT%R"
|
|
, DateTimeFormat "%Y-%m-%dT%T"
|
|
] ++
|
|
[ DateTimeFormat $ unwords [firstF, secondF]
|
|
| DateTimeFormat tFormat <- Set.toList $ validDateTimeFormats tl SelFormatTime
|
|
, DateTimeFormat dFormat <- Set.toList $ validDateTimeFormats tl SelFormatDate
|
|
, (firstF, secondF) <- [(tFormat, dFormat), (dFormat, tFormat)]
|
|
] ++
|
|
[ DateTimeFormat $ unwords [dayFmt, timeFmt, yearFmt]
|
|
| dayFmt <- [ "%a %d %b"
|
|
, "%a %b %d"
|
|
, "%A, %d %B"
|
|
, "%A, %B %d"
|
|
, "%d.%m"
|
|
, "%a %d.%m"
|
|
, "%A %d.%m"
|
|
]
|
|
, timeFmt <- [ "%R"
|
|
, "%T"
|
|
]
|
|
, yearFmt <- [ "%y", "%Y" ]
|
|
]
|
|
validDateTimeFormats _ SelFormatDate = Set.fromList
|
|
[ DateTimeFormat "%a %d %b %Y"
|
|
, DateTimeFormat "%a %b %d %Y"
|
|
, DateTimeFormat "%d %b %Y"
|
|
, DateTimeFormat "%b %d %Y"
|
|
, DateTimeFormat "%d %B %Y"
|
|
, DateTimeFormat "%B %d %Y"
|
|
, DateTimeFormat "%d %b %y"
|
|
, DateTimeFormat "%b %d %y"
|
|
, DateTimeFormat "%d %B %y"
|
|
, DateTimeFormat "%B %d %y"
|
|
, DateTimeFormat "%A, %d %B %Y"
|
|
, DateTimeFormat "%A, %B %d %Y"
|
|
, DateTimeFormat "%A, %d %b %Y"
|
|
, DateTimeFormat "%A, %b %d %Y"
|
|
, DateTimeFormat "%d.%m.%y"
|
|
, DateTimeFormat "%d.%m.%Y"
|
|
, DateTimeFormat "%a %d.%m.%y"
|
|
, DateTimeFormat "%a %d.%m.%Y"
|
|
, DateTimeFormat "%A %d.%m.%y"
|
|
, DateTimeFormat "%A %d.%m.%Y"
|
|
, DateTimeFormat "%Y-%m-%d"
|
|
, DateTimeFormat "%y-%m-%d"
|
|
, DateTimeFormat "%d-%m-%Y"
|
|
, DateTimeFormat "%d-%m-%y"
|
|
]
|
|
validDateTimeFormats TimeLocale{..} SelFormatTime = Set.fromList . concat . catMaybes $
|
|
[ Just
|
|
[ DateTimeFormat "%R"
|
|
, DateTimeFormat "%T"
|
|
]
|
|
, do
|
|
guard $ uncurry (/=) amPm
|
|
Just
|
|
[ DateTimeFormat "%I:%M %p"
|
|
, DateTimeFormat "%I:%M:%S %p"
|
|
]
|
|
, do
|
|
guard $ uncurry (/=) amPm
|
|
guard . not $ all (all Char.isLower) [fst amPm, snd amPm]
|
|
Just
|
|
[ DateTimeFormat "%I:%M %P"
|
|
, DateTimeFormat "%I:%M:%S %P"
|
|
]
|
|
]
|
|
|
|
dateTimeFormatOptions :: (MonadHandler m, HandlerSite m ~ UniWorX) => SelDateTimeFormat -> m (OptionList DateTimeFormat)
|
|
dateTimeFormatOptions sel = do
|
|
now <- liftIO getCurrentTime
|
|
tl <- getTimeLocale
|
|
|
|
let
|
|
toOption fmt@DateTimeFormat{..} = do
|
|
dateTime <- formatTime' unDateTimeFormat now
|
|
return (dateTime, fmt)
|
|
|
|
optionsPairs <=< mapM toOption . Set.toList $ validDateTimeFormats tl sel
|
|
|
|
|
|
formatDiffDays :: NominalDiffTime -> Text
|
|
formatDiffDays t
|
|
| t > nominalDay = inDays <> "d"
|
|
| t > nominalHour = inHours <> "h"
|
|
| t > nominalMinute = inMinutes <> "m"
|
|
| otherwise = tshow $ roundToDigits 0 t
|
|
where
|
|
convertBy :: NominalDiffTime -> Double
|
|
convertBy len = realToFrac $ roundToDigits 1 $ t / len
|
|
inDays = tshow $ convertBy nominalDay
|
|
inHours = tshow $ convertBy nominalHour
|
|
inMinutes = tshow $ convertBy nominalMinute
|
|
|
|
formatCalendarDiffDays :: CalendarDiffDays -> Text
|
|
formatCalendarDiffDays = pack . iso8601Show
|
|
|
|
setYear :: Integer -> Day -> Day
|
|
setYear year date = fromGregorian year m d
|
|
where
|
|
(_,m,d) = toGregorian date
|
|
|
|
getYear :: Day -> Integer
|
|
getYear date = y
|
|
where
|
|
(y,_,_) = toGregorian date
|
|
|
|
dayOfWeekDiff :: DayOfWeek -> DayOfWeek -> Int
|
|
dayOfWeekDiff a b = mod (fromEnum a - fromEnum b) 7
|
|
|
|
-- | The first day-of-week on or after some day
|
|
-- | from time-compat-1.9.5, not included
|
|
firstDayOfWeekOnAfter :: DayOfWeek -> Day -> Day
|
|
firstDayOfWeekOnAfter dw d = addDays (toInteger $ dayOfWeekDiff dw $ dayOfWeek d) d
|
|
|
|
addOneWeek :: UTCTime -> UTCTime
|
|
addOneWeek = addWeeks 1
|
|
|
|
addWeeks :: Integer -> UTCTime -> UTCTime
|
|
addWeeks = addLocalDays . (* 7)
|
|
|
|
addLocalDays :: Integer -> UTCTime -> UTCTime
|
|
addLocalDays n utct = localTimeToUTCTZ appTZ newLocal
|
|
where
|
|
oldLocal = utcToLocalTime utct
|
|
oldDay = localDay oldLocal
|
|
newDay = addDays n oldDay
|
|
newLocal = oldLocal { localDay = newDay }
|
|
|
|
----------------------
|
|
-- CalendarDiffDays --
|
|
----------------------
|
|
|
|
fromMonths :: Integral a => a -> CalendarDiffDays
|
|
fromMonths (toInteger -> m) = CalendarDiffDays { cdMonths = m, cdDays = 0 } -- above is equivalent
|
|
|
|
fromDays :: Integral a => a -> CalendarDiffDays
|
|
fromDays (toInteger -> d) = CalendarDiffDays { cdMonths = 0, cdDays = d }
|
|
|
|
addDiffDaysClip :: CalendarDiffDays -> UTCTime -> UTCTime
|
|
addDiffDaysClip = over _utctDay . addGregorianDurationClip
|
|
|
|
addDiffDaysRollOver :: CalendarDiffDays -> UTCTime -> UTCTime
|
|
addDiffDaysRollOver = over _utctDay . addGregorianDurationRollOver
|
|
|
|
weeksToAdd :: UTCTime -> UTCTime -> Integer
|
|
-- ^ Number of weeks needed to add so that first
|
|
-- time occurs later than second time
|
|
-- (loop avoids off-by-one error with corner cases)
|
|
weeksToAdd old new = loop 0 old
|
|
where
|
|
loop n t
|
|
| t > new = n
|
|
| otherwise = loop (succ n) (addOneWeek t)
|
|
|
|
-- | round up the next full quarter hour with a margin of at least 5 minutes
|
|
ceilingQuarterHour :: UTCTime -> UTCTime
|
|
ceilingQuarterHour = ceilingMinuteBy 5 15
|
|
|
|
-- | round up the next full @roundto@ minutes with a margin of at least @margin@ minutes
|
|
ceilingMinuteBy :: Int -> Int -> UTCTime -> UTCTime
|
|
ceilingMinuteBy margin roundto utct = addUTCTime bonus utct
|
|
where
|
|
oldTime = localTimeOfDay $ utcToLocalTime utct
|
|
oldMin = todMin oldTime
|
|
newMin = roundToNearestMultiple roundto $ oldMin + margin
|
|
newTime = oldTime { todMin = newMin, todSec = 0 } -- might be invalid, but correctly treated by `timeOfDayToTime`
|
|
bonus = realToFrac $ timeOfDayToTime newTime - timeOfDayToTime oldTime
|
|
|
|
|
|
formatTimeRange' :: ( HasLocalTime t, HasLocalTime t'
|
|
, Monad m
|
|
)
|
|
=> (forall t2. HasLocalTime t2 => SelDateTimeFormat -> t2 -> m Text) -- ^ @formatTime@
|
|
-> SelDateTimeFormat
|
|
-> t -- ^ Start
|
|
-> Maybe t' -- ^ End
|
|
-> m Text
|
|
formatTimeRange' cont proj startT Nothing = cont proj startT
|
|
formatTimeRange' cont proj startT (Just endT) = do
|
|
let
|
|
locDayStart = localDay $ toLocalTime startT
|
|
locDayEnd = localDay $ toLocalTime endT
|
|
(yearStart, monthStart, dayStart) = toGregorian locDayStart
|
|
(yearEnd , monthEnd , dayEnd ) = toGregorian locDayEnd
|
|
endProj = (/\ proj) $ if
|
|
| locDayStart == locDayEnd
|
|
-> SelFormatTime
|
|
| otherwise
|
|
-> SelFormatDateTime
|
|
startT' <- cont proj startT
|
|
endT' <- cont endProj endT
|
|
return $ if
|
|
| SelFormatDate == endProj
|
|
, yearStart == yearEnd
|
|
, monthStart == monthEnd
|
|
-> if dayStart == dayEnd
|
|
then startT'
|
|
else [st|#{dayStart} - #{endT'}|] -- does not work all date/time format strings!
|
|
| otherwise
|
|
-> [st|#{startT'} - #{endT'}|]
|
|
|
|
formatTimeRange :: ( HasLocalTime t, HasLocalTime t'
|
|
, MonadHandler m
|
|
, HandlerSite m ~ UniWorX
|
|
, YesodAuthPersist UniWorX, AuthEntity UniWorX ~ User, AuthId UniWorX ~ UserId
|
|
)
|
|
=> SelDateTimeFormat
|
|
-> t -- ^ Start
|
|
-> Maybe t' -- ^ End
|
|
-> m Text
|
|
formatTimeRange = formatTimeRange' formatTime
|
|
|
|
formatTimeRangeW :: (HasLocalTime t, HasLocalTime t', YesodAuthPersist UniWorX, AuthEntity UniWorX ~ User, AuthId UniWorX ~ UserId) => SelDateTimeFormat -> t -> Maybe t' -> WidgetFor UniWorX ()
|
|
formatTimeRangeW s t t' = toWidget =<< formatTimeRange s t t'
|
|
|
|
formatTimeRangeMail :: (MonadMail m, HasLocalTime t, HasLocalTime t') => SelDateTimeFormat -> t -> Maybe t' -> m Text
|
|
formatTimeRangeMail = formatTimeRange' formatTimeMail
|
|
|
|
|
|
formatGregorianW :: (YesodAuthPersist UniWorX, AuthEntity UniWorX ~ User, AuthId UniWorX ~ UserId) => Integer -> Int -> Int -> WidgetFor UniWorX ()
|
|
formatGregorianW y m d = formatTimeW SelFormatDate $ fromGregorian y m d
|
|
|
|
instance Csv.ToField ZonedTime where
|
|
toField = Csv.toField . iso8601Show
|
|
|
|
-- also see Data.Time.Clock.Instances
|
|
instance Csv.FromField ZonedTime where
|
|
parseField = parse <=< Csv.parseField
|
|
where
|
|
parse t = asum $ do
|
|
(doZone, fmt) <- parseFormats
|
|
return $ do
|
|
zonedRes <- parseTimeM False defaultTimeLocale fmt t
|
|
if | doZone -> return zonedRes
|
|
| otherwise -> do
|
|
let localRes = zonedTimeToLocalTime zonedRes
|
|
utcRes = localTimeToUTC localRes
|
|
LTUUnique{_ltuResult} <- pure utcRes
|
|
return $ utcToZonedTime _ltuResult
|
|
|
|
parseFormats = do
|
|
date <- ["%Y-%m-%d", "%d.%m.%Y", "%d-%m-%Y"]
|
|
sep <- ["T", " "]
|
|
doZone <- [True, False]
|
|
let zone = bool "" "%z" doZone
|
|
time <- ["%H:%M:%S", "%H:%M", ""]
|
|
|
|
return . (doZone, ) $ date <> sep <> time <> zone
|
|
|