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


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

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)