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

module Handler.Utils.DateTime
  ( utcToLocalTime, utcToZonedTime
  , localTimeToUTC, TZ.LocalToUTCResult(..), localTimeToUTCSimple
  , toTimeOfDay
  , toMidnight, beforeMidnight, toMidday, toMorning
  , formatDiffDays
  , formatTime'
  , formatTime, formatTimeW, formatTimeMail
  , formatTimeRange, formatTimeRangeW, formatTimeRangeMail
  , getTimeLocale, getDateTimeFormat
  , getDateTimeFormatter
  , validDateTimeFormats, dateTimeFormatOptions
  , addLocalDays
  , addOneWeek, addWeeks
  , weeksToAdd
  , setYear
  , 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

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

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

-- 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 = 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

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

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"
  ]
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


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

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 }

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
                   , 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

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"]
        sep <- ["T", " "]
        doZone <- [True, False]
        let zone = bool "" "%z" doZone
        time <- ["%H:%M:%S", "%H:%M", ""]

        return . (doZone, ) $ date <> sep <> time <> zone

