88 lines
2.8 KiB
Haskell
88 lines
2.8 KiB
Haskell
{-# 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, IsString str) => String -> t -> m str
|
|
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 = toLocalTime $ UTCTime d 0
|
|
|
|
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) => (DateTimeFormat -> String) -> t -> m Text
|
|
formatTime proj t = flip formatTime' (toLocalTime t) =<< (proj <$> getDateTimeFormat)
|
|
|
|
getTimeLocale :: (MonadHandler m, HandlerSite m ~ UniWorX) => m TimeLocale
|
|
getTimeLocale = getTimeLocale' <$> languages
|
|
|
|
getDateTimeFormat :: (MonadHandler m, HandlerSite m ~ UniWorX) => m DateTimeFormat
|
|
getDateTimeFormat = do
|
|
mauth <- liftHandlerT maybeAuth
|
|
let
|
|
fmt
|
|
| Just (Entity _ User{..}) <- mauth
|
|
= userDateTimeFormat
|
|
| otherwise
|
|
= def
|
|
return fmt
|
|
|
|
validDateTimeFormats :: Set DateTimeFormat
|
|
validDateTimeFormats = Set.fromList $
|
|
[ DateTimeFormat "%a %d %b %Y %R" "%d.%m.%Y" "%R"
|
|
, DateTimeFormat "%a %d %b %Y %T" "%d.%m.%Y" "%T"
|
|
, DateTimeFormat "%a %d %b %Y %R" "%Y-%m-%d" "%R"
|
|
, DateTimeFormat "%a %d %b %Y %T" "%Y-%m-%d" "%T"
|
|
]
|
|
|
|
dateTimeFormatOptions :: (MonadHandler m, HandlerSite m ~ UniWorX) => m (OptionList DateTimeFormat)
|
|
dateTimeFormatOptions = do
|
|
now <- liftIO getCurrentTime
|
|
|
|
let
|
|
toOption fmt@DateTimeFormat{..} = do
|
|
dateTime <- formatTime' dateTimeFormat now
|
|
date <- formatTime' dateFormat now
|
|
time <- formatTime' timeFormat now
|
|
return $ (MsgDateTimeFormatOption dateTime date time, fmt)
|
|
|
|
optionsPairs <=< mapM toOption $ Set.toList validDateTimeFormats
|