{-# LANGUAGE OverloadedStrings #-}
module Data.Time.Zones.Read (
loadTZFromFile,
loadSystemTZ,
pathForSystemTZ,
loadLocalTZ,
loadTZFromDB,
olsonGet,
parseOlson,
) where
import Control.Applicative
import Control.Exception (assert)
import Control.Monad
import Data.Binary
import Data.Binary.Get (getByteString, getWord32be, getWord64be, runGet, skip)
import qualified Data.ByteString.Char8 as BS
import qualified Data.ByteString.Lazy.Char8 as BL
import Data.Maybe
import qualified Data.Vector.Unboxed as VU
import qualified Data.Vector as VB
import Data.Int
import Data.Time.Zones.Files
import Data.Time.Zones.Types
import System.Environment
import System.IO.Error
import Prelude
loadTZFromFile :: FilePath -> IO TZ
loadTZFromFile :: FilePath -> IO TZ
loadTZFromFile FilePath
fname = Get TZ -> ByteString -> TZ
forall a. Get a -> ByteString -> a
runGet Get TZ
olsonGet (ByteString -> TZ) -> IO ByteString -> IO TZ
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FilePath -> IO ByteString
BL.readFile FilePath
fname
loadSystemTZ :: String -> IO TZ
loadSystemTZ :: FilePath -> IO TZ
loadSystemTZ FilePath
tzName = FilePath -> IO FilePath
pathForSystemTZ FilePath
tzName IO FilePath -> (FilePath -> IO TZ) -> IO TZ
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= FilePath -> IO TZ
loadTZFromFile
pathForSystemTZ :: String -> IO FilePath
pathForSystemTZ :: FilePath -> IO FilePath
pathForSystemTZ FilePath
tzName = do
FilePath
dir <- FilePath -> Maybe FilePath -> FilePath
forall a. a -> Maybe a -> a
fromMaybe FilePath
"/usr/share/zoneinfo" (Maybe FilePath -> FilePath) -> IO (Maybe FilePath) -> IO FilePath
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FilePath -> IO (Maybe FilePath)
getEnvMaybe FilePath
"TZDIR"
FilePath -> IO FilePath
forall (m :: * -> *) a. Monad m => a -> m a
return (FilePath -> IO FilePath) -> FilePath -> IO FilePath
forall a b. (a -> b) -> a -> b
$ FilePath
dir FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
"/" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
tzName
loadLocalTZ :: IO TZ
loadLocalTZ :: IO TZ
loadLocalTZ = do
Maybe FilePath
tzEnv <- FilePath -> IO (Maybe FilePath)
getEnvMaybe FilePath
"TZ"
case Maybe FilePath
tzEnv of
Maybe FilePath
Nothing -> FilePath -> IO TZ
loadTZFromFile FilePath
"/etc/localtime"
Just FilePath
"" -> FilePath -> IO TZ
loadSystemTZ FilePath
"UTC"
Just FilePath
z -> FilePath -> IO TZ
loadSystemTZ FilePath
z
getEnvMaybe :: String -> IO (Maybe String)
getEnvMaybe :: FilePath -> IO (Maybe FilePath)
getEnvMaybe FilePath
var =
(FilePath -> Maybe FilePath) -> IO FilePath -> IO (Maybe FilePath)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap FilePath -> Maybe FilePath
forall a. a -> Maybe a
Just (FilePath -> IO FilePath
getEnv FilePath
var) IO (Maybe FilePath)
-> (IOError -> IO (Maybe FilePath)) -> IO (Maybe FilePath)
forall a. IO a -> (IOError -> IO a) -> IO a
`catchIOError`
(\IOError
e -> if IOError -> Bool
isDoesNotExistError IOError
e then Maybe FilePath -> IO (Maybe FilePath)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe FilePath
forall a. Maybe a
Nothing else IOError -> IO (Maybe FilePath)
forall a. IOError -> IO a
ioError IOError
e)
loadTZFromDB :: String -> IO TZ
loadTZFromDB :: FilePath -> IO TZ
loadTZFromDB FilePath
tzName = do
FilePath
fn <- FilePath -> IO FilePath
timeZonePathFromDB FilePath
tzName
FilePath -> IO TZ
loadTZFromFile FilePath
fn
olsonGet :: Get TZ
olsonGet :: Get TZ
olsonGet = do
Char
version <- Get Char
olsonHeader
case () of
() | Char
version Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'\0' -> Int -> Get Int64 -> Get TZ
olsonGetWith Int
4 Get Int64
getTime32
() | Char
version Char -> FilePath -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Char
'2', Char
'3'] -> do
Get ()
skipOlson0 Get () -> Get () -> Get ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Get Char -> Get ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void Get Char
olsonHeader
Int -> Get Int64 -> Get TZ
olsonGetWith Int
8 Get Int64
getTime64
()
_ -> FilePath -> Get TZ
forall (m :: * -> *) a. MonadFail m => FilePath -> m a
fail (FilePath -> Get TZ) -> FilePath -> Get TZ
forall a b. (a -> b) -> a -> b
$ FilePath
"olsonGet: invalid version character: " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ Char -> FilePath
forall a. Show a => a -> FilePath
show Char
version
parseOlson :: BL.ByteString -> TZ
parseOlson :: ByteString -> TZ
parseOlson = Get TZ -> ByteString -> TZ
forall a. Get a -> ByteString -> a
runGet Get TZ
olsonGet
olsonHeader :: Get Char
= do
ByteString
magic <- Int -> Get ByteString
getByteString Int
4
Bool -> Get () -> Get ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (ByteString
magic ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString
"TZif") (Get () -> Get ()) -> Get () -> Get ()
forall a b. (a -> b) -> a -> b
$ FilePath -> Get ()
forall (m :: * -> *) a. MonadFail m => FilePath -> m a
fail FilePath
"olsonHeader: bad magic"
Char
version <- Int -> Char
forall a. Enum a => Int -> a
toEnum (Int -> Char) -> Get Int -> Get Char
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get Int
getInt8
Int -> Get ()
skip Int
15
Char -> Get Char
forall (m :: * -> *) a. Monad m => a -> m a
return Char
version
skipOlson0 :: Get ()
skipOlson0 :: Get ()
skipOlson0 = do
Int
tzh_ttisgmtcnt <- Get Int
getInt32
Int
tzh_ttisstdcnt <- Get Int
getInt32
Int
tzh_leapcnt <- Get Int
getInt32
Int
tzh_timecnt <- Get Int
getInt32
Int
tzh_typecnt <- Get Int
getInt32
Int
tzh_charcnt <- Get Int
getInt32
Int -> Get ()
skip (Int -> Get ()) -> Int -> Get ()
forall a b. (a -> b) -> a -> b
$ (Int
4 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
tzh_timecnt) Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
tzh_timecnt Int -> Int -> Int
forall a. Num a => a -> a -> a
+ (Int
6 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
tzh_typecnt) Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
tzh_charcnt Int -> Int -> Int
forall a. Num a => a -> a -> a
+
(Int
8 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
tzh_leapcnt) Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
tzh_ttisstdcnt Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
tzh_ttisgmtcnt
olsonGetWith :: Int -> Get Int64 -> Get TZ
olsonGetWith :: Int -> Get Int64 -> Get TZ
olsonGetWith Int
szTime Get Int64
getTime = do
Int
tzh_ttisgmtcnt <- Get Int
getInt32
Int
tzh_ttisstdcnt <- Get Int
getInt32
Int
tzh_leapcnt <- Get Int
getInt32
Int
tzh_timecnt <- Get Int
getInt32
Int
tzh_typecnt <- Get Int
getInt32
Int
tzh_charcnt <- Get Int
getInt32
Vector Int64
transitions <- Int -> Get Int64 -> Get (Vector Int64)
forall (m :: * -> *) a.
(Monad m, Unbox a) =>
Int -> m a -> m (Vector a)
VU.replicateM Int
tzh_timecnt Get Int64
getTime
Vector Int
indices <- Int -> Get Int -> Get (Vector Int)
forall (m :: * -> *) a.
(Monad m, Unbox a) =>
Int -> m a -> m (Vector a)
VU.replicateM Int
tzh_timecnt Get Int
getInt8
Vector (Int, Bool, Int)
infos <- Int -> Get (Int, Bool, Int) -> Get (Vector (Int, Bool, Int))
forall (m :: * -> *) a.
(Monad m, Unbox a) =>
Int -> m a -> m (Vector a)
VU.replicateM Int
tzh_typecnt Get (Int, Bool, Int)
getTTInfo
ByteString
abbrs <- Int -> Get ByteString
getByteString Int
tzh_charcnt
Int -> Get ()
skip (Int -> Get ()) -> Int -> Get ()
forall a b. (a -> b) -> a -> b
$ Int
tzh_leapcnt Int -> Int -> Int
forall a. Num a => a -> a -> a
* (Int
szTime Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
4)
Int -> Get ()
skip Int
tzh_ttisstdcnt
Int -> Get ()
skip Int
tzh_ttisgmtcnt
let isDst :: (a, b, c) -> b
isDst (a
_,b
x,c
_) = b
x
gmtOff :: (a, b, c) -> a
gmtOff (a
x,b
_,c
_) = a
x
isDstName :: (a, a, Int) -> (a, FilePath)
isDstName (a
_,a
d,Int
ni) = (a
d, Int -> ByteString -> FilePath
abbrForInd Int
ni ByteString
abbrs)
vInfos :: Vector (Int, Bool, Int)
vInfos = (Int -> (Int, Bool, Int)) -> Vector Int -> Vector (Int, Bool, Int)
forall a b. (Unbox a, Unbox b) => (a -> b) -> Vector a -> Vector b
VU.map (Vector (Int, Bool, Int)
infos Vector (Int, Bool, Int) -> Int -> (Int, Bool, Int)
forall a. Unbox a => Vector a -> Int -> a
VU.!) Vector Int
indices
(Vector Int64
eTransitions, Vector (Int, Bool, Int)
eInfos) = case () of
()
_ | Bool
hasInitTrans -> Bool
-> (Vector Int64, Vector (Int, Bool, Int))
-> (Vector Int64, Vector (Int, Bool, Int))
forall a. (?callStack::CallStack) => Bool -> a -> a
assert Bool
infosHeadIsDst (Vector Int64
transitions', Vector (Int, Bool, Int)
vInfos)
()
_ -> (Int64 -> Vector Int64 -> Vector Int64
forall a. Unbox a => a -> Vector a -> Vector a
VU.cons Int64
forall a. Bounded a => a
minBound Vector Int64
transitions, (Int, Bool, Int)
-> Vector (Int, Bool, Int) -> Vector (Int, Bool, Int)
forall a. Unbox a => a -> Vector a -> Vector a
VU.cons (Int, Bool, Int)
first Vector (Int, Bool, Int)
vInfos)
where
hasInitTrans :: Bool
hasInitTrans = Bool -> Bool
not (Vector Int64 -> Bool
forall a. Unbox a => Vector a -> Bool
VU.null Vector Int64
transitions)
Bool -> Bool -> Bool
&& Vector Int64 -> Int64
forall a. Unbox a => Vector a -> a
VU.head Vector Int64
transitions Int64 -> Int64 -> Bool
forall a. Ord a => a -> a -> Bool
<= -Int64
0x800000000000000
transitions' :: Vector Int64
transitions' = Vector Int64
transitions Vector Int64 -> [(Int, Int64)] -> Vector Int64
forall a. Unbox a => Vector a -> [(Int, a)] -> Vector a
VU.// [(Int
0, Int64
forall a. Bounded a => a
minBound)]
infosHeadIsDst :: Bool
infosHeadIsDst = Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ (Int, Bool, Int) -> Bool
forall a b c. (a, b, c) -> b
isDst ((Int, Bool, Int) -> Bool) -> (Int, Bool, Int) -> Bool
forall a b. (a -> b) -> a -> b
$ Vector (Int, Bool, Int) -> (Int, Bool, Int)
forall a. Unbox a => Vector a -> a
VU.head Vector (Int, Bool, Int)
infos
lInfos :: [(Int, Bool, Int)]
lInfos = Vector (Int, Bool, Int) -> [(Int, Bool, Int)]
forall a. Unbox a => Vector a -> [a]
VU.toList Vector (Int, Bool, Int)
infos
first :: (Int, Bool, Int)
first = [(Int, Bool, Int)] -> (Int, Bool, Int)
forall a. [a] -> a
head ([(Int, Bool, Int)] -> (Int, Bool, Int))
-> [(Int, Bool, Int)] -> (Int, Bool, Int)
forall a b. (a -> b) -> a -> b
$ ((Int, Bool, Int) -> Bool)
-> [(Int, Bool, Int)] -> [(Int, Bool, Int)]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool)
-> ((Int, Bool, Int) -> Bool) -> (Int, Bool, Int) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int, Bool, Int) -> Bool
forall a b c. (a, b, c) -> b
isDst) [(Int, Bool, Int)]
lInfos [(Int, Bool, Int)] -> [(Int, Bool, Int)] -> [(Int, Bool, Int)]
forall a. [a] -> [a] -> [a]
++ [(Int, Bool, Int)]
lInfos
diffs :: Vector Int
diffs = ((Int, Bool, Int) -> Int) -> Vector (Int, Bool, Int) -> Vector Int
forall a b. (Unbox a, Unbox b) => (a -> b) -> Vector a -> Vector b
VU.map (Int, Bool, Int) -> Int
forall a b c. (a, b, c) -> a
gmtOff Vector (Int, Bool, Int)
eInfos
tzInfos :: Vector (Bool, FilePath)
tzInfos = Int -> [(Bool, FilePath)] -> Vector (Bool, FilePath)
forall a. Int -> [a] -> Vector a
VB.fromListN (Vector (Int, Bool, Int) -> Int
forall a. Unbox a => Vector a -> Int
VU.length Vector (Int, Bool, Int)
eInfos) ([(Bool, FilePath)] -> Vector (Bool, FilePath))
-> [(Bool, FilePath)] -> Vector (Bool, FilePath)
forall a b. (a -> b) -> a -> b
$ ((Int, Bool, Int) -> (Bool, FilePath))
-> [(Int, Bool, Int)] -> [(Bool, FilePath)]
forall a b. (a -> b) -> [a] -> [b]
map (Int, Bool, Int) -> (Bool, FilePath)
forall a a. (a, a, Int) -> (a, FilePath)
isDstName ([(Int, Bool, Int)] -> [(Bool, FilePath)])
-> [(Int, Bool, Int)] -> [(Bool, FilePath)]
forall a b. (a -> b) -> a -> b
$ Vector (Int, Bool, Int) -> [(Int, Bool, Int)]
forall a. Unbox a => Vector a -> [a]
VU.toList Vector (Int, Bool, Int)
eInfos
TZ -> Get TZ
forall (m :: * -> *) a. Monad m => a -> m a
return (TZ -> Get TZ) -> TZ -> Get TZ
forall a b. (a -> b) -> a -> b
$ Vector Int64 -> Vector Int -> Vector (Bool, FilePath) -> TZ
TZ Vector Int64
eTransitions Vector Int
diffs Vector (Bool, FilePath)
tzInfos
abbrForInd :: Int -> BS.ByteString -> String
abbrForInd :: Int -> ByteString -> FilePath
abbrForInd Int
i = ByteString -> FilePath
BS.unpack (ByteString -> FilePath)
-> (ByteString -> ByteString) -> ByteString -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> ByteString -> ByteString
BS.takeWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'\0') (ByteString -> ByteString)
-> (ByteString -> ByteString) -> ByteString -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> ByteString -> ByteString
BS.drop Int
i
getTTInfo :: Get (Int, Bool, Int)
getTTInfo :: Get (Int, Bool, Int)
getTTInfo = (,,) (Int -> Bool -> Int -> (Int, Bool, Int))
-> Get Int -> Get (Bool -> Int -> (Int, Bool, Int))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get Int
getInt32 Get (Bool -> Int -> (Int, Bool, Int))
-> Get Bool -> Get (Int -> (Int, Bool, Int))
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Get Bool
forall t. Binary t => Get t
get Get (Int -> (Int, Bool, Int)) -> Get Int -> Get (Int, Bool, Int)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Get Int
getInt8
getInt8 :: Get Int
{-# INLINE getInt8 #-}
getInt8 :: Get Int
getInt8 = Word8 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word8 -> Int) -> Get Word8 -> Get Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get Word8
getWord8
getInt32 :: Get Int
{-# INLINE getInt32 #-}
getInt32 :: Get Int
getInt32 = (Int32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral :: Int32 -> Int) (Int32 -> Int) -> (Word32 -> Int32) -> Word32 -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word32 -> Int32
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word32 -> Int) -> Get Word32 -> Get Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get Word32
getWord32be
getTime32 :: Get Int64
{-# INLINE getTime32 #-}
getTime32 :: Get Int64
getTime32 = Int -> Int64
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Int64) -> Get Int -> Get Int64
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get Int
getInt32
getTime64 :: Get Int64
{-# INLINE getTime64 #-}
getTime64 :: Get Int64
getTime64 = Word64 -> Int64
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word64 -> Int64) -> Get Word64 -> Get Int64
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get Word64
getWord64be