208 lines
7.0 KiB
Haskell
208 lines
7.0 KiB
Haskell
module Handler.Utils.DateTime
|
|
( utcToLocalTime
|
|
, localTimeToUTC, TZ.LocalToUTCResult(..)
|
|
, toMidnight, beforeMidnight, toMidday, toMorning
|
|
, formatTime, formatTime', formatTimeW
|
|
, getTimeLocale, getDateTimeFormat
|
|
, validDateTimeFormats, dateTimeFormatOptions
|
|
, formatTimeMail
|
|
, addOneWeek, addWeeks
|
|
, weeksToAdd
|
|
, setYear
|
|
, ceilingQuarterHour
|
|
) where
|
|
|
|
import Import
|
|
|
|
import Utils.Lens
|
|
|
|
import Data.Time.Zones
|
|
import qualified Data.Time.Zones as TZ
|
|
|
|
import Data.Time hiding (formatTime, localTimeToUTC, utcToLocalTime)
|
|
-- import Data.Time.Clock (addUTCTime,nominalDay)
|
|
import qualified Data.Time.Format as Time
|
|
|
|
import Data.Set (Set)
|
|
import qualified Data.Set as Set
|
|
|
|
import Data.Time.Clock.System (systemEpochDay)
|
|
|
|
|
|
utcToLocalTime :: UTCTime -> LocalTime
|
|
utcToLocalTime = TZ.utcToLocalTimeTZ appTZ
|
|
|
|
localTimeToUTC :: LocalTime -> LocalToUTCResult
|
|
localTimeToUTC = TZ.localTimeToUTCFull appTZ
|
|
|
|
-- | Local midnight of given day
|
|
toMidnight :: Day -> UTCTime
|
|
toMidnight d = localTimeToUTCTZ appTZ $ LocalTime d midnight
|
|
|
|
-- | Local midnight of given day
|
|
toMidday :: Day -> UTCTime
|
|
toMidday d = localTimeToUTCTZ appTZ $ LocalTime d midday
|
|
|
|
-- | One second before the end of day
|
|
beforeMidnight :: Day -> UTCTime
|
|
beforeMidnight d = localTimeToUTCTZ appTZ $ LocalTime d $ TimeOfDay 23 59 59
|
|
|
|
-- | 6am in the morning
|
|
toMorning :: Day -> UTCTime
|
|
toMorning d = localTimeToUTCTZ appTZ $ LocalTime d $ TimeOfDay 6 0 0
|
|
|
|
|
|
|
|
class FormatTime t => HasLocalTime t where
|
|
toLocalTime :: t -> LocalTime
|
|
|
|
instance HasLocalTime LocalTime where
|
|
toLocalTime = id
|
|
|
|
instance HasLocalTime Day where
|
|
toLocalTime d = LocalTime d midnight
|
|
|
|
instance HasLocalTime UTCTime where
|
|
toLocalTime = utcToLocalTime
|
|
|
|
instance HasLocalTime TimeOfDay where
|
|
toLocalTime = LocalTime systemEpochDay
|
|
|
|
formatTime' :: (HasLocalTime t, MonadHandler m, HandlerSite m ~ UniWorX) => String -> t -> m Text
|
|
formatTime' fmtStr t = fmap fromString $ Time.formatTime <$> getTimeLocale <*> pure fmtStr <*> pure (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' . mailLanguages <$> askMailLanguages) <*> (unDateTimeFormat <$> askMailDateTimeFormat sel) <*> pure (toLocalTime t)
|
|
|
|
getTimeLocale :: (MonadHandler m, HandlerSite m ~ UniWorX) => m TimeLocale
|
|
getTimeLocale = getTimeLocale' <$> languages
|
|
|
|
getDateTimeFormat :: (MonadHandler m, HandlerSite m ~ UniWorX) => SelDateTimeFormat -> m DateTimeFormat
|
|
getDateTimeFormat sel = do
|
|
mauth <- liftHandlerT 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
|
|
|
|
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 _ SelFormatDateTime = Set.fromList
|
|
[ DateTimeFormat "%a %d %b %Y %R"
|
|
, DateTimeFormat "%a %b %d %Y %R"
|
|
, DateTimeFormat "%A, %d %B %Y %R"
|
|
, DateTimeFormat "%A, %B %d %Y %R"
|
|
, DateTimeFormat "%a %d %b %Y %T"
|
|
, DateTimeFormat "%a %b %d %Y %T"
|
|
, DateTimeFormat "%A, %d %B %Y %T"
|
|
, DateTimeFormat "%A, %B %d %Y %T"
|
|
, DateTimeFormat "%d.%m.%Y %R"
|
|
, DateTimeFormat "%d.%m.%Y %T"
|
|
, DateTimeFormat "%a %d.%m.%y %R"
|
|
, DateTimeFormat "%R %d.%m.%Y"
|
|
, DateTimeFormat "%T %d.%m.%Y"
|
|
, DateTimeFormat "%Y-%m-%d %R"
|
|
, DateTimeFormat "%Y-%m-%d %T"
|
|
, DateTimeFormat "%Y-%m-%dT%T"
|
|
]
|
|
validDateTimeFormats _ SelFormatDate = Set.fromList
|
|
[ 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 "%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 %P"
|
|
, DateTimeFormat "%I:%M:%S %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
|
|
|
|
|
|
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
|