Rakka/W3CDateTime.hs

   1 module Rakka.W3CDateTime
   2     ( formatW3CDateTime
   3     , parseW3CDateTime
   4     )
   5     where
   6
   7 import           Control.Monad
   8 import           Data.Time
   9 import           Prelude hiding (min)
  10 import           Text.ParserCombinators.Parsec
  11 import           Text.Printf
  12
  13
  14 formatW3CDateTime :: ZonedTime -> String
  15 formatW3CDateTime zonedTime
  16     = formatLocalTime (zonedTimeToLocalTime zonedTime)
  17       ++
  18       formatTimeZone (zonedTimeZone zonedTime)
  19     where
  20       formatLocalTime :: LocalTime -> String
  21       formatLocalTime localTime
  22           = let (year, month, day) = toGregorian (localDay localTime)
  23                 timeOfDay          = localTimeOfDay localTime
  24                 (secInt, secFrac)  = properFraction (todSec timeOfDay)
  25             in
  26               printf "%04d-%02d-%02dT%02d:%02d:%02d"
  27                      year
  28                      month
  29                      day
  30                      (todHour timeOfDay)
  31                      (todMin timeOfDay)
  32                      (secInt :: Int)
  33               ++
  34               (if secFrac == 0
  35                then ""
  36                else tail (show secFrac))
  37
  38       formatTimeZone :: TimeZone -> String
  39       formatTimeZone tz
  40           = case timeZoneMinutes tz of
  41               offset | offset <  0 -> '-' : (showTZ $ negate offset)
  42                      | offset == 0 -> "Z"
  43                      | otherwise   -> '+' : showTZ offset
  44
  45       showTZ :: Int -> String
  46       showTZ offset
  47           = let hour   = offset `div` 60
  48                 minute = offset - hour * 60
  49             in
  50               show2 hour ++ ":" ++ show2 minute
  51
  52       show2 :: Int -> String
  53       show2 n | n < 10    = '0' : show n
  54               | otherwise = show n
  55
  56
  57 parseW3CDateTime :: String -> Maybe ZonedTime
  58 parseW3CDateTime src
  59     = case parse w3cDateTime "" src of
  60         Right zt -> Just zt
  61         Left  _  -> Nothing
  62
  63 w3cDateTime :: Parser ZonedTime
  64 w3cDateTime = do year <- liftM read (count 4 digit)
  65                  mon  <- option 1 (char '-' >> liftM read (count 2 digit))
  66                  day  <- option 1 (char '-' >> liftM read (count 2 digit))
  67                  (hour, min, sec, offMin)
  68                      <- option (0, 0, 0, 0) time
  69                  eof
  70
  71                  let julianDay = fromGregorian year mon day
  72                      timeOfDay = TimeOfDay hour min (fromRational $ toRational sec)
  73                      localTime = LocalTime julianDay timeOfDay
  74                      timeZone  = minutesToTimeZone offMin
  75                      zonedTime = ZonedTime localTime timeZone
  76
  77                  return zonedTime
  78     where
  79       time :: Parser (Int, Int, Double, Int)
  80       time = do char 'T'
  81                 hour   <- liftM read (count 2 digit)
  82                 char ':'
  83                 min    <- liftM read (count 2 digit)
  84                 sec    <- option 0 $ do char ':'
  85                                         secInt  <- count 2 digit
  86                                         secFrac <- option "" $ do c  <- char '.'
  87                                                                   cs <- many1 digit
  88                                                                   return (c:cs)
  89                                         return $ read (secInt ++ secFrac)
  90                 offMin <- (char 'Z' >> return 0)
  91                         <|>
  92                         (do sign <- (char '+' >> return 1)
  93                                     <|>
  94                                     (char '-' >> return (-1))
  95                             h    <- liftM read (count 2 digit)
  96                             char ':'
  97                             m    <- liftM read (count 2 digit)
  98                             return $ sign * h * 60 + m)
  99                 return (hour, min, sec, offMin)