hzdump.hs

-- | A clone in Haskell of the zdump(8) command, including most of
-- the bugs, that takes paths to Olson files instead of timezone
-- names. This is useful for testing the Haskell implementation
-- of the Olson timezone parser and renderer against the reference
-- implementation in C. But less useful than it might seem at first,
-- because Haskell rounds historical solar mean timezones to the
-- nearest minute, whereas the C implementation rounds to the nearest
-- second.
module Main where

import Data.Time.LocalTime.TimeZone.Series
import Data.Time.LocalTime.TimeZone.Olson
import Data.Time
import Data.Maybe (listToMaybe)
import System.Environment (getArgs)
import System.Exit (exitWith, exitSuccess, ExitCode(ExitFailure))
import System.Locale (defaultTimeLocale)
import Control.Monad (guard)

version :: IO a
version = do
  putStrLn "hzdump version 0.1, clone of zdump 1.7  -c option fixed,"
  putStrLn "takes zone file paths instead of zone specifications"
  exitSuccess

usage :: IO a
usage = do
  putStrLn "usage: hzdump [--version] [-v] [-c cutoff] zone-file-path ..."
  putStrLn "  where cutoff is lo-year,hi-year or hi-year"
  exitWith $ ExitFailure 1

illegalOpt :: Char -> IO a -- sic
illegalOpt opt = do
  putStrLn $ "hzdump: illegal option -- " ++ [opt]
  usage

data Option = Version | Illegal Char |
              Verbose (Maybe Integer, Maybe Integer) | Now
  deriving (Eq, Ord, Show)

main = do
    (opts, zones) <- fmap parseArgs getArgs
    (getTimes, displayTime) <- case opts of
      Version     -> version
      Illegal opt -> illegalOpt opt
      Verbose rng -> return (transitionTimes rng, displayVerbose)
      _           -> do now <- getCurrentTime
                        return (const [now], displayConcise)
    tzss <- mapM getZone zones
    putStr . unlines . concat $
      zipWith (displayZone getTimes displayTime) zones tzss
  where
    getZone "-" = return utcTZ -- sic
    getZone z   = getTimeZoneSeriesFromOlsonFile z

    displayZone getTimes displayTime zone tzs =
      map ((zone ++) . ("  " ++) . displayTime tzs) $ getTimes tzs

parseArgs :: [String] -> (Option, [FilePath])
parseArgs args | "--version" `elem` args = (Version, [])
parseArgs args = getOpts False (Nothing, Nothing) args
  where
    getOpts _ cutoff  ("-v":args)   = getOpts True cutoff args
    getOpts v _       ("-c":c:args) = maybe (Illegal 'c', [])
                                      (\y -> getOpts v y args) $
                                      parseCutoff c
    getOpts v cutoff  ("--":zones ) = (opts v cutoff, zones)
    getOpts _ _       (('-':x:_):_) = (Illegal x, [])
    getOpts v cutoff  zones         = (opts v cutoff, zones)

    opts v cutoff = if v then Verbose cutoff else Now

    parseCutoff c = let p0  = listToMaybe $ reads c
                        los = fmap fst p0
                        his = do str <- fmap snd p0
                                 let (comma, str1) = splitAt 1 str
                                 guard $ comma == ","
                                 maybeRead str1
                    in los >> Just (maybe (Nothing, los) ((,) los . Just) his)

displayConcise :: TimeZoneSeries -> UTCTime -> String
displayConcise tzs t = formatTime defaultTimeLocale format $
                       ZoneSeriesTime t tzs
  where
    format = "%a %b %e %T %Y %Z"

displayVerbose :: TimeZoneSeries -> UTCTime -> String
displayVerbose tzs t = concat [displayConcise utcTZ t, " = ",
    displayConcise tzs t, " isdst=", if isdst then "1" else "0"]
  where
    isdst = timeZoneSummerOnly $ timeZoneFromSeries tzs t

transitionTimes :: (Maybe Integer, Maybe Integer) -> TimeZoneSeries ->
                   [UTCTime]
transitionTimes (lo, hi) =
    maybe id (takeWhile . (>)) (fmap happyNewYear hi) .
    maybe id (dropWhile . (>)) (fmap happyNewYear lo) .
    addBugs . addPrevSecond . actualTransitions
  where
    happyNewYear y = UTCTime (fromGregorian y 1 1) 0
    actualTransitions (TimeZoneSeries d cs) =
      let rs = reverse cs
      in map snd . filter fst $
         zipWith (\(t, tz) prevTz -> (tz /= prevTz, t))
                 rs
                 (d : map snd rs)
    addPrevSecond = concatMap (\t -> [(-1) `addUTCTime` t, t])
    addBugs = (bug0 ++) . (++ bug1) -- sic
    bug0 = [UTCTime (fromGregorian 1901 12 13) (20*3600+45*60+52),
            UTCTime (fromGregorian 1901 12 14) (20*3600+45*60+52)]
    bug1 = [UTCTime (fromGregorian 2038  1 18) ( 3*3600+14*60+ 7),
            UTCTime (fromGregorian 2038  1 19) ( 3*3600+14*60+ 7)]

utcTZ :: TimeZoneSeries
utcTZ = TimeZoneSeries utc []

maybeRead :: Read a => String -> Maybe a
maybeRead = fmap fst . listToMaybe . filter (null . snd) . reads