-- SPDX-FileCopyrightText: 2022 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Sarah Vaupel <sarah.vaupel@ifi.lmu.de>,Steffen Jost <jost@cip.ifi.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>
--
-- SPDX-License-Identifier: AGPL-3.0-or-later

{-# OPTIONS_GHC -fno-warn-orphans #-}

module Handler.Utils.DateTime
  ( utcToLocalTime, utcToZonedTime
  , localTimeToUTC, TZ.LocalToUTCResult(..), localTimeToUTCSimple
  , toTimeOfDay
  , toMidnight, beforeMidnight, toMidday, toMorning
  , toFullHour, roundDownToMinutes, addHours
  , formatDiffDays, formatCalendarDiffDays
  , formatTime'
  , formatTime, formatTimeUser, formatTimeW, formatTimeMail
  , formatTimeRange, formatTimeRangeW, formatTimeRangeMail
  , getTimeLocale
  , getDateTimeFormat   , getDateTimeFormatUser   , getDateTimeFormatUser'
  , getDateTimeFormatter, getDateTimeFormatterUser, getDateTimeFormatterUser'
  , validDateTimeFormats, dateTimeFormatOptions
  , addLocalDays
  , addDiffDaysClip, addDiffDaysRollOver
  , addOneWeek, addWeeks
  , fromDays, fromMonths
  , weeksToAdd
  , setYear, getYear
  , firstDayOfWeekOnAfter
  , ceilingQuarterHour
  , formatGregorianW
  ) where

import Import.NoFoundation
import Foundation.Type

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

localTimeToUTCSimple :: LocalTime -> UTCTime
localTimeToUTCSimple = TZ.localTimeToUTCTZ 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

-- | Round up to next full hour
toFullHour :: UTCTime -> UTCTime
toFullHour t = t{utctDayTime=rounded}
  where
    rounded = fromInteger $ 3600 * (1 + (truncate (utctDayTime t) `div` 3600))

roundDownToMinutes :: Integer -> UTCTime -> UTCTime
roundDownToMinutes f t = t{utctDayTime=rounded}
  where
    rounded = fromInteger $ factor * (truncate (utctDayTime t) `div` factor)
    factor = 60 * f

-- | 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{..}

addHours :: Integer -> UTCTime -> UTCTime
addHours = addUTCTime . secondsToNominalDiffTime . fromInteger . (* 3600)

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, YesodAuthPersist UniWorX, AuthEntity UniWorX ~ User, AuthId UniWorX ~ UserId) => SelDateTimeFormat -> t -> m Text
formatTime proj t = flip formatTime' t . unDateTimeFormat =<< getDateTimeFormat proj

formatTimeUser :: (HasLocalTime t, MonadHandler m, HandlerSite m ~ UniWorX) => SelDateTimeFormat -> t  -> Maybe (Entity User) -> m Text
formatTimeUser proj t mUser = flip formatTime' t . unDateTimeFormat =<< getDateTimeFormatUser proj mUser

-- formatTimeH :: (HasLocalTime t) => SelDateTimeFormat -> t -> Handler Text
-- formatTimeH = formatTime

formatTimeW :: (HasLocalTime t, YesodAuthPersist UniWorX, AuthEntity UniWorX ~ User, AuthId UniWorX ~ UserId) => SelDateTimeFormat -> t -> WidgetFor UniWorX ()
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, YesodAuthPersist UniWorX, AuthEntity UniWorX ~ User, AuthId UniWorX ~ UserId) => SelDateTimeFormat -> m DateTimeFormat
getDateTimeFormat sel = liftHandler maybeAuth >>= getDateTimeFormatUser sel

getDateTimeFormatUser :: (MonadHandler m, HandlerSite m ~ UniWorX) => SelDateTimeFormat -> Maybe (Entity User) -> m DateTimeFormat
getDateTimeFormatUser sel mUser = do
  UserDefaultConf{..} <- getsYesod $ view _appUserDefaults
  let
    fmt
      | Just (Entity _ User{..}) <- mUser
      = case sel of
          SelFormatDateTime -> userDateTimeFormat
          SelFormatDate     -> userDateFormat
          SelFormatTime     -> userTimeFormat
      | otherwise
      = case sel of
          SelFormatDateTime -> userDefaultDateTimeFormat
          SelFormatDate     -> userDefaultDateFormat
          SelFormatTime     -> userDefaultTimeFormat
  return fmt

getDateTimeFormatUser' :: SelDateTimeFormat -> User -> DateTimeFormat
getDateTimeFormatUser' SelFormatDateTime usr = usr & userDateTimeFormat
getDateTimeFormatUser' SelFormatDate     usr = usr & userDateFormat 
getDateTimeFormatUser' SelFormatTime     usr = usr & userTimeFormat   

getDateTimeFormatter :: (MonadHandler m, HandlerSite m ~ UniWorX, YesodAuthPersist UniWorX, AuthEntity UniWorX ~ User, AuthId UniWorX ~ UserId) => m DateTimeFormatter
getDateTimeFormatter = do
  locale <- getTimeLocale
  formatMap <- traverse getDateTimeFormat id
  return $ mkDateTimeFormatter locale formatMap appTZ

getDateTimeFormatterUser :: (MonadHandler m, HandlerSite m ~ UniWorX) => Maybe (Entity User) -> m DateTimeFormatter
getDateTimeFormatterUser mUser = do
  locale <- getTimeLocale
  formatMap <- traverse (`getDateTimeFormatUser` mUser) id
  return $ mkDateTimeFormatter locale formatMap appTZ

getDateTimeFormatterUser' :: (MonadHandler m) => User -> m DateTimeFormatter
getDateTimeFormatterUser' usr = do 
  locale <- getTimeLocale
  let formatMap = flip getDateTimeFormatUser' usr
  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"
  , DateTimeFormat "%d-%m-%Y"
  , DateTimeFormat "%d-%m-%y"
  ]
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 . not $ all (all 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

formatCalendarDiffDays :: CalendarDiffDays -> Text
formatCalendarDiffDays = pack . iso8601Show  

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

getYear :: Day -> Integer 
getYear date = y
  where 
    (y,_,_) = toGregorian date    

dayOfWeekDiff :: DayOfWeek -> DayOfWeek -> Int
dayOfWeekDiff a b = mod (fromEnum a - fromEnum b) 7

-- | The first day-of-week on or after some day
-- | from time-compat-1.9.5, not included
firstDayOfWeekOnAfter :: DayOfWeek -> Day -> Day
firstDayOfWeekOnAfter dw d = addDays (toInteger $ dayOfWeekDiff dw $ dayOfWeek d) d

addOneWeek :: UTCTime -> UTCTime
addOneWeek = addWeeks 1

addWeeks :: Integer -> UTCTime -> UTCTime
addWeeks = addLocalDays . (* 7)

addLocalDays :: Integer -> UTCTime -> UTCTime
addLocalDays n utct = localTimeToUTCTZ appTZ newLocal
  where
    oldLocal = utcToLocalTime utct
    oldDay   = localDay oldLocal
    newDay   = addDays n oldDay
    newLocal = oldLocal { localDay = newDay }

----------------------
-- CalendarDiffDays --
----------------------

fromMonths :: Integral a => a -> CalendarDiffDays 
fromMonths (toInteger -> m) = CalendarDiffDays { cdMonths = m, cdDays = 0 } -- above is equivalent

fromDays :: Integral a => a -> CalendarDiffDays 
fromDays (toInteger -> d) = CalendarDiffDays { cdMonths = 0, cdDays = d }

addDiffDaysClip :: CalendarDiffDays -> UTCTime -> UTCTime
addDiffDaysClip = over _utctDay . addGregorianDurationClip

addDiffDaysRollOver :: CalendarDiffDays -> UTCTime -> UTCTime
addDiffDaysRollOver = over _utctDay . addGregorianDurationRollOver

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
-- In order to abbreviate common same month time ranges, e.g. 24--26.12.23 on must take into account all DateFormatString, as some have the day on the end or feature a weekday
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
                   , YesodAuthPersist UniWorX, AuthEntity UniWorX ~ User, AuthId UniWorX ~ UserId
                   )
                => SelDateTimeFormat
                -> t -- ^ Start
                -> Maybe t' -- ^ End
                -> m Text
formatTimeRange = formatTimeRange' formatTime

formatTimeRangeW :: (HasLocalTime t, HasLocalTime t', YesodAuthPersist UniWorX, AuthEntity UniWorX ~ User, AuthId UniWorX ~ UserId) => SelDateTimeFormat -> t -> Maybe t' -> WidgetFor UniWorX ()
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 :: (YesodAuthPersist UniWorX, AuthEntity UniWorX ~ User, AuthId UniWorX ~ UserId) => Integer -> Int -> Int -> WidgetFor UniWorX ()
formatGregorianW y m d = formatTimeW SelFormatDate $ fromGregorian y m d

instance Csv.ToField ZonedTime where 
  toField = Csv.toField . iso8601Show

-- also see Data.Time.Clock.Instances
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", "%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