{- |
Module      : Data.Time.Zones.Read
Copyright   : (C) 2014 Mihaly Barasz
License     : Apache-2.0, see LICENSE
Maintainer  : Janus Troelsen <ysangkok@gmail.com>
Stability   : experimental
-}

{-# LANGUAGE OverloadedStrings #-}

module Data.Time.Zones.Read (
  -- * Various ways of loading `TZ`
  loadTZFromFile,
  loadSystemTZ,
  pathForSystemTZ,
  loadLocalTZ,
  loadTZFromDB,
  -- * Parsing Olson data
  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

-- Suppress 'redundant imports' warning
import Prelude

-- | Reads and parses a time zone information file (in @tzfile(5)@
-- aka. Olson file format) and returns the corresponding TZ data
-- structure.
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

-- | Looks for the time zone file in the system timezone directory, which is
-- @\/usr\/share\/zoneinfo@, or if the @TZDIR@ environment variable is
-- set, then there.
--
-- Note, this is unlikely to work on non-posix systems (e.g.,
-- Windows), use `loadTZFromDB` or `loadTZFromFile` instead.
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

-- | Return the path for a time zone file in the system time zone directory.
--
-- The system directory is specified by the @TZDIR@ environment variable,
-- or @\/usr\/share\/zoneinfo@ if it's not set.
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

-- | Returns the local `TZ` based on the @TZ@ and @TZDIR@
-- environment variables.
--
-- See @tzset(3)@ for details, but basically:
--
-- * If @TZ@ environment variable is unset, we @loadTZFromFile \"\/etc\/localtime\"@.
--
-- * If @TZ@ is set, but empty, we @loadSystemTZ \"UTC\"@.
--
-- * Otherwise, we just @loadSystemTZ@ it.
--
-- Note, this means we don't support POSIX-style @TZ@ variables (like
-- @\"EST5EDT\"@), only those that are explicitly present in the time
-- zone database.
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)

-- | Reads the corresponding file from the time zone database shipped
-- with this package.
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
      -- TODO(klao): read the rule string
    ()
_ -> 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
olsonHeader :: Get Char
olsonHeader = 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
      -- Older tz databases didn't have an explicit first transition,
      -- but since 2014c they do.  (In 2014c it's minBound and in
      -- later versions it's the large negative constant below.)
      (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)  -- (gmtoff, isdst, abbrind)
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