323 lines
11 KiB
Haskell
323 lines
11 KiB
Haskell
{-# OPTIONS_GHC -fno-warn-orphans #-}
|
||
|
||
module Handler.Utils.DateTime
|
||
( utcToLocalTime, utcToZonedTime
|
||
, localTimeToUTC, TZ.LocalToUTCResult(..)
|
||
, toTimeOfDay
|
||
, toMidnight, beforeMidnight, toMidday, toMorning
|
||
, formatDiffDays
|
||
, formatTime'
|
||
, formatTime, formatTimeW, formatTimeMail
|
||
, formatTimeRange, formatTimeRangeW, formatTimeRangeMail
|
||
, getTimeLocale, getDateTimeFormat
|
||
, getDateTimeFormatter
|
||
, validDateTimeFormats, dateTimeFormatOptions
|
||
, addOneWeek, addWeeks
|
||
, weeksToAdd
|
||
, setYear
|
||
, ceilingQuarterHour
|
||
, formatGregorianW
|
||
) where
|
||
|
||
import Import
|
||
|
||
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
|
||
|
||
-- | 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{..}
|
||
|
||
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) => SelDateTimeFormat -> t -> m Text
|
||
formatTime proj t = flip formatTime' t =<< (unDateTimeFormat <$> getDateTimeFormat proj)
|
||
|
||
-- formatTimeH :: (HasLocalTime t) => SelDateTimeFormat -> t -> Handler Text
|
||
-- formatTimeH = formatTime
|
||
|
||
formatTimeW :: (HasLocalTime t) => SelDateTimeFormat -> t -> Widget
|
||
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) => SelDateTimeFormat -> m DateTimeFormat
|
||
getDateTimeFormat sel = do
|
||
mauth <- liftHandler maybeAuth
|
||
UserDefaultConf{..} <- getsYesod $ view _appUserDefaults
|
||
let
|
||
fmt
|
||
| Just (Entity _ User{..}) <- mauth
|
||
= case sel of
|
||
SelFormatDateTime -> userDateTimeFormat
|
||
SelFormatDate -> userDateFormat
|
||
SelFormatTime -> userTimeFormat
|
||
| otherwise
|
||
= case sel of
|
||
SelFormatDateTime -> userDefaultDateTimeFormat
|
||
SelFormatDate -> userDefaultDateFormat
|
||
SelFormatTime -> userDefaultTimeFormat
|
||
return fmt
|
||
|
||
getDateTimeFormatter :: (MonadHandler m, HandlerSite m ~ UniWorX) => m DateTimeFormatter
|
||
getDateTimeFormatter = do
|
||
locale <- getTimeLocale
|
||
formatMap <- traverse getDateTimeFormat id
|
||
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"
|
||
]
|
||
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 $ any (any $ not . 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
|
||
|
||
|
||
setYear :: Integer -> Day -> Day
|
||
setYear year date = fromGregorian year month day
|
||
where
|
||
(_,month,day) = toGregorian date
|
||
|
||
addOneWeek :: UTCTime -> UTCTime
|
||
addOneWeek = addWeeks 1
|
||
|
||
addWeeks :: Integer -> UTCTime -> UTCTime
|
||
addWeeks n utct = localTimeToUTCTZ appTZ newLocal
|
||
where
|
||
oldLocal = utcToLocalTime utct
|
||
oldDay = localDay oldLocal
|
||
newDay = addDays (7*n) oldDay
|
||
newLocal = oldLocal { localDay = newDay }
|
||
|
||
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 endT = do
|
||
startT' <- cont proj startT
|
||
let
|
||
endProj = (/\ proj) $ if
|
||
| Just endT' <- endT
|
||
, ((==) `on` localDay) (toLocalTime startT) (toLocalTime endT')
|
||
-> SelFormatTime
|
||
| otherwise
|
||
-> SelFormatDateTime
|
||
endT' <- for endT $ cont endProj
|
||
|
||
return $ case endT' of
|
||
Nothing -> startT'
|
||
Just endT'' -> [st|#{startT'} – #{endT''}|]
|
||
|
||
|
||
formatTimeRange :: ( HasLocalTime t, HasLocalTime t'
|
||
, MonadHandler m
|
||
, HandlerSite m ~ UniWorX
|
||
)
|
||
=> SelDateTimeFormat
|
||
-> t -- ^ Start
|
||
-> Maybe t' -- ^ End
|
||
-> m Text
|
||
formatTimeRange = formatTimeRange' formatTime
|
||
|
||
formatTimeRangeW :: (HasLocalTime t, HasLocalTime t') => SelDateTimeFormat -> t -> Maybe t' -> Widget
|
||
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 :: Integer -> Int -> Int -> Widget
|
||
formatGregorianW year month day = formatTimeW SelFormatDate $ fromGregorian year month day
|
||
|
||
instance Csv.ToField ZonedTime where
|
||
toField = Csv.toField . iso8601Show
|
||
|
||
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"]
|
||
sep <- ["T", " "]
|
||
doZone <- [True, False]
|
||
let zone = bool "" "%z" doZone
|
||
time <- ["%H:%M:%S", "%H:%M", ""]
|
||
|
||
return . (doZone, ) $ date <> sep <> time <> zone
|
||
|