{-# LANGUAGE NoImplicitPrelude
           , TemplateHaskell
           , OverloadedStrings
           , RecordWildCards
           , TypeFamilies
  #-}

module Handler.Utils.DateTime
  ( utcToLocalTime
  , localTimeToUTC, TZ.LocalToUTCResult(..)
  , formatTime'
  , formatTime
  , getTimeLocale, getDateTimeFormat
  , validDateTimeFormats, dateTimeFormatOptions
  ) where

import Import

import Data.Time.Zones hiding (localTimeToUTCFull)
import qualified Data.Time.Zones as TZ

import Data.Time hiding (formatTime, localTimeToUTC, utcToLocalTime)
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

formatTime' :: (FormatTime t, MonadHandler m, HandlerSite m ~ UniWorX) => String -> t -> m Text
formatTime' fmtStr t = fmap fromString $ Time.formatTime <$> getTimeLocale <*> pure fmtStr <*> pure t

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 t = utcToLocalTime 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' (toLocalTime t) =<< (unDateTimeFormat <$> getDateTimeFormat proj)

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{..} <- getsYesod appSettings
  let
    fmt
      | Just (Entity _ User{..}) <- mauth
      = case sel of
          SelFormatDateTime -> userDateTimeFormat
          SelFormatDate     -> userDateFormat
          SelFormatTime     -> userTimeFormat
      | otherwise
      = case sel of
          SelFormatDateTime -> appDefaultDateTimeFormat
          SelFormatDate     -> appDefaultDateFormat
          SelFormatTime     -> appDefaultTimeFormat
  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, %d %B %Y %R"
  , DateTimeFormat "%a %d %b %Y %T"
  , DateTimeFormat "%A, %d %B %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, %d %B %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