module Data.Time.Clock.TAI64
( TAI64
, tai64
, taiSecs
, taiNanos
, taiAttos
, addTAI64
, diffTAI64
, sumTAI64
, subTAI64
, toAbsoluteTime
, fromAbsoluteTime
, Libtai
, libtai
, unLibtai
, taia_now
, tai64nlocal
, libtaiToUTC
, libtaiToPOSIX
, libtaiLabel
, sumLibtai
, subLibtai
, addLibtai
, diffLibtai
, Label (..)
, fromLabel
, toText
, fromText
, toByteString
, fromByteString
, parse
, parseText
, parseByteString
)
where
import Control.Applicative
import Control.Monad (liftM)
import qualified Data.Attoparsec.ByteString.Char8 as PB
import Data.Attoparsec.Combinator (option)
import Data.Attoparsec.Internal.Types (Parser)
import qualified Data.Attoparsec.Text as PT
import Data.Binary
import qualified Data.Binary as Binary
import Data.Binary.Get
import Data.Binary.Put
import Data.Bits
import Data.ByteString (ByteString)
import qualified Data.ByteString.Base16.Lazy as Hex
import qualified Data.ByteString.Lazy as BL
import Data.Text (Text)
import Data.Text.Encoding (decodeUtf8)
import Data.Time
import Data.Time.Clock.POSIX
import Data.Time.Clock.TAI
import qualified Data.Vector.Generic as VG
import qualified Data.Vector.Generic.Mutable as VM
import Data.Vector.Unboxed.Base
import Test.QuickCheck
data TAI64 = TAI64
{ taiSecs :: !Word64
, taiNanos :: !Word32
, taiAttos :: !Word32
} deriving (Eq, Show, Ord)
instance Bounded TAI64 where
minBound = TAI64 0 0 0
maxBound = TAI64 maxBound 999999999 999999999
instance Arbitrary TAI64 where
arbitrary = TAI64
<$> choose (0, (2^(63 :: Int)) 1)
<*> choose (0, 999999999)
<*> choose (0, 999999999)
tai64 :: Word64 -> Word32 -> Word32 -> TAI64
tai64 s n as
| n > 999999999 = if s >= maxBound 1 then
maxBound
else
tai64 (s + 1) (n 1000000000) as
| as > 999999999 = tai64 s (n + 1) (as 1000000000)
| otherwise = let (s', n' ) = divMod n 1000000000
(n'',as') = divMod as 1000000000
secs = s + fromIntegral s'
in TAI64 (if secs < s then maxBound else secs)
(n' + n'')
as'
newtype instance MVector s TAI64 = MV_TAI64 (MVector s (Word64,Word32,Word32))
newtype instance Vector TAI64 = V_TAI64 (Vector (Word64,Word32,Word32))
instance VM.MVector MVector TAI64 where
basicLength (MV_TAI64 x)
= VM.basicLength x
basicUnsafeSlice i n (MV_TAI64 v)
= MV_TAI64 $ VM.basicUnsafeSlice i n v
basicOverlaps (MV_TAI64 v1) (MV_TAI64 v2)
= VM.basicOverlaps v1 v2
basicUnsafeNew n
= MV_TAI64 `liftM` VM.basicUnsafeNew n
#if MIN_VERSION_vector(0,11,0)
basicInitialize (MV_TAI64 v)
= VM.basicInitialize v
#endif
basicUnsafeReplicate n (TAI64 s n' a)
= MV_TAI64 `liftM` VM.basicUnsafeReplicate n (s,n',a)
basicUnsafeRead (MV_TAI64 v) i
= (\(s,n,a) -> TAI64 s n a) `liftM` VM.basicUnsafeRead v i
basicUnsafeWrite (MV_TAI64 v) i (TAI64 s n a)
= VM.basicUnsafeWrite v i (s,n,a)
basicClear (MV_TAI64 v)
= VM.basicClear v
basicSet (MV_TAI64 v) (TAI64 s n a)
= VM.basicSet v (s,n,a)
basicUnsafeCopy (MV_TAI64 v1) (MV_TAI64 v2)
= VM.basicUnsafeCopy v1 v2
basicUnsafeMove (MV_TAI64 v1) (MV_TAI64 v2)
= VM.basicUnsafeMove v1 v2
basicUnsafeGrow (MV_TAI64 v) n
= MV_TAI64 `liftM` VM.basicUnsafeGrow v n
instance VG.Vector Vector TAI64 where
basicUnsafeFreeze (MV_TAI64 v)
= V_TAI64 `liftM` VG.basicUnsafeFreeze v
basicUnsafeThaw (V_TAI64 v)
= MV_TAI64 `liftM` VG.basicUnsafeThaw v
basicLength (V_TAI64 v)
= VG.basicLength v
basicUnsafeSlice i n (V_TAI64 v)
= V_TAI64 $ VG.basicUnsafeSlice i n v
basicUnsafeIndexM (V_TAI64 v) i
= (\(s,n,a) -> TAI64 s n a) `liftM` VG.basicUnsafeIndexM v i
basicUnsafeCopy (MV_TAI64 mv) (V_TAI64 v)
= VG.basicUnsafeCopy mv v
elemseq _ (TAI64 s n a) z
= VG.elemseq (undefined :: Vector a) s
$ VG.elemseq (undefined :: Vector a) n
$ VG.elemseq (undefined :: Vector a) a z
instance Unbox TAI64
addTAI64 :: DiffTime -> TAI64 -> TAI64
addTAI64 d = sumTAI64 (fromDiffTime d)
diffTAI64 :: TAI64 -> TAI64 -> DiffTime
diffTAI64 a = toDiffTime . subTAI64 a
sumTAI64 :: TAI64 -> TAI64 -> TAI64
sumTAI64 a b =
let secs = taiSecs a + taiSecs b
nanos = taiNanos a + taiNanos b
attos = taiAttos a + taiAttos b
(nanos',attos') = if attos > 999999999
then (nanos + 1, attos 1000000000)
else (nanos, attos)
(secs',nanos'') = if nanos > 999999999
then (secs + 1, nanos' 1000000000)
else (secs, nanos')
in TAI64 secs' nanos'' attos'
subTAI64 :: TAI64 -> TAI64 -> TAI64
subTAI64 a b | b >= a = minBound
subTAI64 a b =
let secs = taiSecs a taiSecs b
nanos = taiNanos a taiNanos b
attos = taiAttos a taiAttos b
(nanos',attos') = if attos > taiAttos a
then (nanos 1, attos + 1000000000)
else (nanos, attos)
(secs',nanos'') = if nanos' > taiNanos a
then (secs 1, nanos' + 1000000000)
else (secs, nanos')
in TAI64 secs' nanos'' attos'
toAbsoluteTime :: TAI64 -> AbsoluteTime
toAbsoluteTime (TAI64 s n as)
| s >= 0 && s < piv = before1970 (secs (piv s))
| s >= piv && s < upp = after1970 (secs (s piv))
| otherwise = error "Outside universe lifetime"
where
before1970
= addAbsoluteTime (negate attos)
. addAbsoluteTime (negate nanos)
. (`addAbsoluteTime` tai64Epoch)
. negate
after1970
= addAbsoluteTime attos
. addAbsoluteTime nanos
. (`addAbsoluteTime` tai64Epoch)
secs :: Word64 -> DiffTime
secs = secondsToDiffTime . fromIntegral
nanos = picosecondsToDiffTime (fromIntegral n * 1000)
attos = picosecondsToDiffTime (fromIntegral as `div` 1000000)
fromAbsoluteTime :: AbsoluteTime -> TAI64
fromAbsoluteTime = mk . diffAbsoluteTime tai64Epoch
where
mk d = let (TAI64 s n as) = fromDiffTime d
in TAI64 (piv s) n as
newtype Libtai = Libtai TAI64
deriving (Eq, Show, Ord, Bounded, Arbitrary)
newtype instance MVector s Libtai = MV_Libtai (MVector s TAI64)
newtype instance Vector Libtai = V_Libtai (Vector TAI64)
instance VM.MVector MVector Libtai where
basicLength (MV_Libtai x)
= VM.basicLength x
basicUnsafeSlice i n (MV_Libtai v)
= MV_Libtai $ VM.basicUnsafeSlice i n v
basicOverlaps (MV_Libtai v1) (MV_Libtai v2)
= VM.basicOverlaps v1 v2
basicUnsafeNew n
= MV_Libtai `liftM` VM.basicUnsafeNew n
#if MIN_VERSION_vector(0,11,0)
basicInitialize (MV_Libtai v)
= VM.basicInitialize v
#endif
basicUnsafeReplicate n (Libtai tai)
= MV_Libtai `liftM` VM.basicUnsafeReplicate n tai
basicUnsafeRead (MV_Libtai v) i
= Libtai `liftM` VM.basicUnsafeRead v i
basicUnsafeWrite (MV_Libtai v) i (Libtai tai)
= VM.basicUnsafeWrite v i tai
basicClear (MV_Libtai v)
= VM.basicClear v
basicSet (MV_Libtai v) (Libtai tai)
= VM.basicSet v tai
basicUnsafeCopy (MV_Libtai v1) (MV_Libtai v2)
= VM.basicUnsafeCopy v1 v2
basicUnsafeMove (MV_Libtai v1) (MV_Libtai v2)
= VM.basicUnsafeMove v1 v2
basicUnsafeGrow (MV_Libtai v) n
= MV_Libtai `liftM` VM.basicUnsafeGrow v n
instance VG.Vector Vector Libtai where
basicUnsafeFreeze (MV_Libtai v)
= V_Libtai `liftM` VG.basicUnsafeFreeze v
basicUnsafeThaw (V_Libtai v)
= MV_Libtai `liftM` VG.basicUnsafeThaw v
basicLength (V_Libtai v)
= VG.basicLength v
basicUnsafeSlice i n (V_Libtai v)
= V_Libtai $ VG.basicUnsafeSlice i n v
basicUnsafeIndexM (V_Libtai v) i
= Libtai `liftM` VG.basicUnsafeIndexM v i
basicUnsafeCopy (MV_Libtai mv) (V_Libtai v)
= VG.basicUnsafeCopy mv v
elemseq _ (Libtai tai) z
= VG.elemseq (undefined :: Vector a) tai z
instance Unbox Libtai
libtai :: TAI64 -> Libtai
libtai tai = Libtai tai { taiAttos = 0 }
unLibtai :: LeapSecondTable -> Libtai -> TAI64
unLibtai lst = fromAbsoluteTime . utcToTAITime lst . libtaiToUTC
taia_now :: IO Libtai
taia_now = do
posix <- getPOSIXTime
let tai = fromDiffTime (realToFrac posix)
pure . Libtai $ tai
{ taiSecs = taiSecs tai + piv + 10
, taiNanos = taiNanos tai + 500
, taiAttos = 0
}
tai64nlocal :: Libtai -> IO ZonedTime
tai64nlocal t = utcToZonedTime <$> getCurrentTimeZone <*> pure (libtaiToUTC t)
libtaiToUTC :: Libtai -> UTCTime
libtaiToUTC = posixSecondsToUTCTime . libtaiToPOSIX
libtaiToPOSIX :: Libtai -> POSIXTime
libtaiToPOSIX (Libtai tai)
= realToFrac . toDiffTime $ tai { taiSecs = taiSecs tai piv 10 }
libtaiLabel :: Libtai -> Label
libtaiLabel (Libtai tai) = TAI64N tai
sumLibtai :: Libtai -> Libtai -> Libtai
sumLibtai (Libtai a) (Libtai b) = Libtai $ sumTAI64 a b
subLibtai :: Libtai -> Libtai -> Libtai
subLibtai (Libtai a) (Libtai b) = Libtai $ subTAI64 a b
addLibtai :: DiffTime -> Libtai -> Libtai
addLibtai d (Libtai t) = Libtai $ addTAI64 d t
diffLibtai :: Libtai -> Libtai -> DiffTime
diffLibtai (Libtai a) (Libtai b) = diffTAI64 a b
data Label
= TAI64S !TAI64
| TAI64N !TAI64
| TAI64NA !TAI64
deriving Show
fromLabel :: Label -> TAI64
fromLabel (TAI64S t) = t { taiNanos = 0, taiAttos = 0 }
fromLabel (TAI64N t) = t { taiAttos = 0 }
fromLabel (TAI64NA t) = t
instance Eq Label where
a == b = case a of
TAI64S (TAI64 s _ _ ) -> s == s'
TAI64N (TAI64 s n _ ) -> s == s' && n == n'
TAI64NA (TAI64 s n as) -> s == s' && n == n' && as == as'
where
(TAI64 s' n' as') = fromLabel b
instance Ord Label where
a <= b = case a of
TAI64S (TAI64 s _ _ ) -> s <= s' && 0 <= n' && 0 <= as'
TAI64N (TAI64 s n _ ) -> s <= s' && n <= n' && 0 <= as'
TAI64NA (TAI64 s n as) -> s <= s' && n <= n' && as <= as'
where
(TAI64 s' n' as') = fromLabel b
instance Arbitrary Label where
arbitrary = oneof
[ TAI64S <$> arbitrary
, TAI64N <$> arbitrary
, TAI64NA <$> arbitrary
]
instance Binary Label where
put (TAI64S tai) = putWord64be (taiSecs tai)
put (TAI64N tai) = putWord64be (taiSecs tai) *> putWord32be (taiNanos tai)
put (TAI64NA tai) = putWord64be (taiSecs tai) *> putWord32be (taiNanos tai)
*> putWord32be (taiAttos tai)
get = do
elts <- (,,) <$> getWord64be
<*> optional getWord32be
<*> optional getWord32be
pure $ case elts of
(s, Just n, Just a) -> TAI64NA (TAI64 s n a)
(s, Just n, Nothing) -> TAI64N (TAI64 s n 0)
(s, Nothing, Nothing) -> TAI64S (TAI64 s 0 0)
(s, Nothing, Just n) -> TAI64N (TAI64 s n 0)
toText :: Label -> Text
toText = decodeUtf8 . toByteString
fromText :: Text -> Either String TAI64
fromText = PT.parseOnly parseText
toByteString :: Label -> ByteString
toByteString = BL.toStrict . Hex.encode . Binary.encode
fromByteString :: ByteString -> Either String TAI64
fromByteString = PB.parseOnly parseByteString
class ParseInput a where
_parseOnly :: Parser a b -> a -> Either String b
_take :: Int -> Parser a a
_hexadecimal :: (Integral x, Bits x) => Parser a x
_at :: Parser a Char
instance ParseInput Text where
_parseOnly = PT.parseOnly
_take = PT.take
_hexadecimal = PT.hexadecimal
_at = PT.char '@'
instance ParseInput ByteString where
_parseOnly = PB.parseOnly
_take = PB.take
_hexadecimal = PB.hexadecimal
_at = PB.char '@'
parse :: ParseInput a => Parser a TAI64
parse = TAI64 <$> (optional _at *> word64Hex)
<*> option 0 word32Hex
<*> option 0 word32Hex
where
word64Hex = runParser _hexadecimal =<< _take 16
word32Hex = runParser _hexadecimal =<< _take 8
runParser p = either fail return . _parseOnly p
parseText :: Parser Text TAI64
parseText = parse
parseByteString :: Parser ByteString TAI64
parseByteString = parse
fromDiffTime :: DiffTime -> TAI64
fromDiffTime d = TAI64 s n as
where
(s,f) = properFraction d
n = nanos f
as = attos f (n * 10^(9 :: Int))
nanos = truncate . (* 10^( 9 :: Int)) . abs
attos = truncate . (* 10^(18 :: Int)) . abs
toDiffTime :: TAI64 -> DiffTime
toDiffTime (TAI64 s n as) = secs + nanos + attos
where
secs = fromIntegral s
nanos = fromRational (toRational n * 10^^( 9 :: Int))
attos = fromRational (toRational as * 10^^(18 :: Int))
tai64Epoch :: AbsoluteTime
tai64Epoch = addAbsoluteTime (secondsToDiffTime 3506716800) taiEpoch
piv,upp :: Word64
piv = 2^(62 :: Int)
upp = 2^(63 :: Int)