fradrive/src/Handler/Utils/DateTime.hs

module Handler.Utils.DateTime
  ( utcToLocalTime
  , localTimeToUTC, TZ.LocalToUTCResult(..)
  , formatTime, formatTime', formatTimeW
  , getTimeLocale, getDateTimeFormat
  , validDateTimeFormats, dateTimeFormatOptions
  , formatTimeMail
  , addOneWeek, addWeeks
  , weekDiff, weeksToAdd
  , setYear
  ) where

import Import

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


utcToLocalTime :: UTCTime -> LocalTime
utcToLocalTime = TZ.utcToLocalTimeTZ appTZ

localTimeToUTC :: LocalTime -> LocalToUTCResult
localTimeToUTC = TZ.localTimeToUTCFull appTZ

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

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
  AppSettings{ appUserDefaults = UserDefaultConf{..} } <- getsYesod appSettings
  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 "%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 "%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


addOneWeek :: UTCTime -> UTCTime
addOneWeek = addWeeks 1

addWeeks :: Integer -> UTCTime -> UTCTime
addWeeks n utct = utct { utctDay = newDay }
  where
    oldDay = utctDay utct
    -- newDay = addGregorianDurationRollOver $ stimes n calendarWeek -- only available in newer version 1.9 of Data.Time.Calendar
    newDay = addDays (7*n) oldDay

weekDiff :: UTCTime -> UTCTime -> Integer
-- ^ Difference between times, rounded down to weeks
weekDiff old new = dayDiff `div` 7
  where
    dayOld  = utctDay old
    dayNew  = utctDay new
    dayDiff = diffDays dayNew dayOld

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 weekDiff corner cases)
weeksToAdd old new = loop 0 old
  where
    loop n t
      | t > new   = n
      | otherwise = loop (succ n) (addOneWeek t)


setYear :: Integer -> Day -> Day
setYear year date = fromGregorian year month day
  where
    (_,month,day) = toGregorian date