module Data.Time.LocalTime.TimeZone.Olson.Parse
(
getTimeZoneSeriesFromOlsonFile,
getOlsonFromFile,
olsonToTimeZoneSeries,
getOlson,
OlsonError
)
where
import Data.Time.LocalTime.TimeZone.Olson.Types
import Data.Time.LocalTime.TimeZone.Series (TimeZoneSeries(..))
import Data.Time (TimeZone(TimeZone))
import Data.Time.Clock.POSIX (posixSecondsToUTCTime)
import Data.Binary.Get (Get, runGet, getWord8, getWord32be, getWord64be,
getByteString, getRemainingLazyByteString)
import qualified Data.ByteString as B
import qualified Data.ByteString.Lazy as L
import Data.Monoid (mappend)
import Data.Maybe (listToMaybe, fromMaybe)
import Data.Word (Word8)
import Data.Int (Int32, Int64)
import Data.Typeable (Typeable)
import Control.Monad (guard, replicateM, replicateM_, when)
import Control.Exception.Extensible (try, throw, Exception, ErrorCall)
data OlsonError = OlsonError String
deriving Typeable
instance Show OlsonError where
show (OlsonError msg) = msg
instance Exception OlsonError
olsonToTimeZoneSeries :: OlsonData -> Maybe TimeZoneSeries
olsonToTimeZoneSeries (OlsonData ttimes ttinfos@(dflt0:_) _ _) =
fmap (TimeZoneSeries $ mkTZ dflt) . mapM (lookupTZ ttinfos) $
reverse ttimes
where
dflt = fromMaybe dflt0 . listToMaybe $ filter isStd ttinfos
isStd (TtInfo _ isdst _ _) = not isdst
mkTZ (TtInfo gmtoff isdst _ abbr) =
TimeZone ((gmtoff + 30) `div` 60) isdst abbr
lookupTZ ttinfos ttime = fmap (((,) $ toUTC ttime) . mkTZ) . listToMaybe $
drop (transIndex ttime) ttinfos
toUTC = posixSecondsToUTCTime . fromIntegral . transTime
olsonToTimeZoneSeries _ = Nothing
getTimeZoneSeriesFromOlsonFile :: FilePath -> IO TimeZoneSeries
getTimeZoneSeriesFromOlsonFile fp = getOlsonFromFile fp >>=
maybe (throwOlson fp "no timezone found in OlsonData") return .
olsonToTimeZoneSeries
getOlsonFromFile :: FilePath -> IO OlsonData
getOlsonFromFile fp = do
e <- try . fmap (runGet $ getOlson defaultLimits) $ L.readFile fp
either (formatError fp) return e
formatError :: FilePath -> ErrorCall -> IO a
formatError fp e = throwOlson fp $ show e
getOlson :: SizeLimits -> Get OlsonData
getOlson limits = do
(version, part1) <- getOlsonPart True limits get32bitInteger
case version of
0 -> return part1
50 -> do (_, part2) <- getOlsonPart False limits get64bitInteger
posixTZ <- getPosixTZ
return $ part1 `mappend` part2 `mappend` posixTZ
_ -> verify (const False) "invalid version number" undefined
getOlsonPart :: Integral a => Bool -> SizeLimits -> Get a ->
Get (Word8, OlsonData)
getOlsonPart verifyMagic limits getTime = do
magic <- fmap (toASCII . B.unpack) $ getByteString 4
when verifyMagic $ verify_ (== "TZif") "missing magic number" magic
version <- getWord8
replicateM_ 15 getWord8
tzh_ttisgmtcnt <- get32bitInt
tzh_ttisstdcnt <- get32bitInt
tzh_leapcnt <- get32bitInt
>>= verify (withinLimit maxLeaps) "too many leap second specifications"
tzh_timecnt <- get32bitInt
>>= verify (withinLimit maxTimes) "too many timezone transitions"
tzh_typecnt <- get32bitInt
>>= verify (withinLimit maxTypes) "too many timezone type specifications"
verify (withinLimit maxTypes) "too many isgmt specifiers" tzh_ttisgmtcnt
verify (withinLimit maxTypes) "too many isstd specifiers" tzh_ttisstdcnt
tzh_charcnt <- get32bitInt
>>= verify (withinLimit maxAbbrChars) "too many tilezone specifiers"
times <- fmap (map toInteger) $ replicateM tzh_timecnt getTime
indexes <- replicateM tzh_timecnt get8bitInt
ttinfos <- replicateM tzh_typecnt getTtInfo
abbr_chars <- fmap (toASCII . B.unpack) $ getByteString tzh_charcnt
leaps <- replicateM tzh_leapcnt $ getLeapInfo getTime
isstds <- replicateM tzh_ttisstdcnt getBool
isgmts <- replicateM tzh_ttisgmtcnt getBool
return
(version,
OlsonData
(zipWith Transition times indexes)
(map (flip lookupAbbr abbr_chars) . zipWith setTtype ttinfos $
zipWithExtend boolsToTType False False isstds isgmts)
leaps
Nothing
)
where
withinLimit limit value = maybe True (value <=) $ limit limits
lookupAbbr (TtInfo gmtoff isdst ttype abbrind) =
TtInfo gmtoff isdst ttype . takeWhile (/= '\NUL') . drop abbrind
setTtype ttinfo ttype = ttinfo {tt_ttype = ttype}
boolsToTType _ isgmt | isgmt = UTC
boolsToTType isstd _
| isstd = Std
| otherwise = Wall
zipWithExtend :: (a -> b -> c) -> a -> b -> [a] -> [b] -> [c]
zipWithExtend f x0 y0 (x:xs) (y:ys) = f x y : zipWithExtend f x0 y0 xs ys
zipWithExtend f x0 _ [] ys = map (f x0) ys
zipWithExtend f _ y0 xs _ = map (flip f y0) xs
getPosixTZ :: Get OlsonData
getPosixTZ = do
getWord8 >>= verify (== 10)
"POSIX TZ string not preceded by newline"
posixTZ <- fmap (L.takeWhile (/= 10)) getRemainingLazyByteString
return . OlsonData [] [] [] $ do
guard (not $ L.null posixTZ)
Just . toASCII $ L.unpack posixTZ
getTtInfo :: Get (TtInfo Int)
getTtInfo = do
gmtoff <- get32bitInt
isdst <- getBool
abbrind <- get8bitInt
return $ TtInfo gmtoff isdst Wall abbrind
getLeapInfo :: Integral a => Get a -> Get LeapInfo
getLeapInfo getTime = do
lTime <- fmap toInteger getTime
lOffset <- get32bitInt
return $ LeapInfo lTime lOffset
get8bitInt :: Get Int
get8bitInt = fmap fromIntegral getWord8
getInt32 :: Get Int32
getInt32 = fmap fromIntegral getWord32be
get32bitInt :: Get Int
get32bitInt = fmap fromIntegral getInt32
get32bitInteger :: Get Integer
get32bitInteger = fmap fromIntegral getInt32
getInt64 :: Get Int64
getInt64 = fmap fromIntegral getWord64be
get64bitInteger :: Get Integer
get64bitInteger = fmap fromIntegral getInt64
getBool :: Get Bool
getBool = fmap (/= 0) getWord8
toASCII :: [Word8] -> String
toASCII = map (toEnum . fromIntegral)
verify :: Monad m => (a -> Bool) -> String -> a -> m a
verify pred msg val
| pred val = return val
| otherwise = error msg
verify_ :: Monad m => (a -> Bool) -> String -> a -> m ()
verify_ pred msg val
| pred val = return ()
| otherwise = error msg
throwOlson :: FilePath -> String -> IO a
throwOlson fp msg = throw . OlsonError $
fp ++ ": invalid timezone file: " ++ msg