module Handler.Utils.DateTime
  ( utcToLocalTime, utcToZonedTime
  , localTimeToUTC, TZ.LocalToUTCResult(..)
  , toMidnight, beforeMidnight, toMidday, toMorning
  , formatDiffDays
  , formatTime'
  , formatTime, formatTimeW, formatTimeMail
  , formatTimeRange, formatTimeRangeW, formatTimeRangeMail
  , getTimeLocale, getDateTimeFormat
  , validDateTimeFormats, dateTimeFormatOptions
  , addOneWeek, addWeeks
  , weeksToAdd
  , setYear
  , ceilingQuarterHour
  , formatGregorianW
  ) where

import Import

import Data.Time.Zones
import qualified Data.Time.Zones as TZ

import Data.Time hiding (formatTime, localTimeToUTC, utcToLocalTime, utcToZonedTime)
-- import Data.Time.Clock (addUTCTime,nominalDay)
import qualified Data.Time.Format as Time

import qualified Data.Set as Set

import Data.Time.Clock.System (systemEpochDay)


-------------
-- 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     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) => 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' . 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

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


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