tai (empty) → 0

raw patch · 7 files changed

+480/−0 lines, 7 filesdep +basedep +clockdep +lenssetup-changed

Dependencies added: base, clock, lens, mtl, parsers, time, trifecta, wreq

Files

• ChangeLog.md +5/−0
• LICENSE +30/−0
• Setup.hs +2/−0
• src/Data/Time/Clock/TAI/LeapData.hs +83/−0
• src/Data/Time/Clock/TAI/Parser.hs +143/−0
• src/Data/Time/Clock/TAI/Support.hs +182/−0
• tai.cabal +35/−0

@@ -0,0 +1,5 @@+# Revision history for tai++## 0  -- YYYY-mm-dd++* First version. Released on an unsuspecting world.

@@ -0,0 +1,30 @@+Copyright (c) 2017, davean, tolt++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++    * Redistributions of source code must retain the above copyright+      notice, this list of conditions and the following disclaimer.++    * Redistributions in binary form must reproduce the above+      copyright notice, this list of conditions and the following+      disclaimer in the documentation and/or other materials provided+      with the distribution.++    * Neither the name of davean, tolt nor the names of other+      contributors may be used to endorse or promote products derived+      from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain

@@ -0,0 +1,83 @@+{-# LANGUAGE ScopedTypeVariables #-}+module Data.Time.Clock.TAI.LeapData (+   SourceType(..), LeapSource(..), LeapSources+ , parseLeapSource, mayRetrieveList, parseFileMaybe+ , leapSources+ , sourceLeapData+ ) where++import qualified Control.Exception as E+import Control.Lens+import Data.List (stripPrefix, sort)+import Data.Maybe+import Data.Text.Lazy.Lens+import Data.Time+import Data.Time.Clock.TAI.Parser+import qualified Network.Wreq as Wreq++-- | A support type for deperating out the protocol over which to retrieve data.+data SourceType = File | HTTPS+  deriving (Show, Read, Eq, Bounded, Enum, Ord)++-- | A leap second list location tagged with a protocol for retrieving it.+data LeapSource+  = LeapSource+    { sourceType :: SourceType+    , source :: String+    }+  deriving (Show, Read, Eq, Ord)++-- | Convert a string source to a LeapSource +parseLeapSource :: String -> Maybe LeapSource+parseLeapSource s' | Just s <- stripPrefix "file://" s'  = Just $ LeapSource File s+parseLeapSource s | Just _ <- stripPrefix "https://" s = Just $ LeapSource HTTPS s+parseLeapSource _ = Nothing++-- | LeapSources is a list of strings, specifying URIs the program can+--   potentially access up-to-date leap-second.lists from.+--   Each source begins with a protocol:+--     For local sources "file://" followed by a path to the local file.+--     For remote source sources "https://" prefixed URIs.+type LeapSources = [LeapSource]++-- | A few places we should be able to download up-to-date leap-seconds.list data.+leapSources :: LeapSources+leapSources = sort . mapMaybe parseLeapSource $+  [ "file:///usr/share/zoneinfo/leap-seconds.list"+  , "https://hpiers.obspm.fr/iers/bul/bulc/ntp/leap-seconds.list"+  , "https://www.ietf.org/timezones/data/leap-seconds.list"+  , "https://www.meinberg.de/download/ntp/leap-seconds.list"+  ]++-- | Given a LeapSource, perform the actual aquasition and parsing+mayRetrieveList :: LeapSource -> IO (Maybe LeapSecondList)+mayRetrieveList (LeapSource ty s) = E.handle (\(_::E.SomeException) -> return Nothing) $ do+  curDay <- utctDay <$> getCurrentTime+  case ty of+    File -> parseFileMaybe curDay <$> readFile s+    HTTPS -> do+      r <- Wreq.get s+      return . parseFileMaybe curDay $ (r ^. Wreq.responseBody.utf8.unpacked)++-- | Parse a leap second list file, failing if it is expired.+parseFileMaybe :: Day -> String -> Maybe LeapSecondList+parseFileMaybe curDay str =+  -- We get the day to know if the file is valid, but its not entire clear how to compare \+  -- our UTC day to the day specified in the file.+  case parseLeapSecondList str of+    Left _ -> Nothing+    Right lsl | curDay >= expirationDate lsl -> Nothing+              | otherwise -> Just lsl++-- | Aquire leap-seconds files and parse them,+--   Trying the provided list of sources in order from local, to secure remote (HTTPS),+--   until an up-to-date source is aquired or all options are exausted.+--+--   Currently only local and HTTPS has been implimented.+sourceLeapData :: LeapSources -> IO LeapSecondList+sourceLeapData = do+    firstOption . map mayRetrieveList . sort+  where+    firstOption :: Monad m => [m (Maybe a)] -> m a+    firstOption (io:t) = maybe (firstOption t) return =<< io+    firstOption [] = error "No option for leap-seconds.list serviced our needs!"

@@ -0,0 +1,143 @@+module Data.Time.Clock.TAI.Parser (+   parseLeapSecondList+ , LeapSecondList(..)+ ) where++import Control.Applicative+import Control.Monad+import Data.Int+import Data.Maybe++import Text.Parser.Char+import Text.Parser.Combinators+import Text.Parser.Token+import Text.Trifecta.Delta+import Text.Trifecta.Parser+import Text.Trifecta.Result++import Data.Time++-- | Possible entries for the TAI leap-seconds file+data TAIEntry =+    TAILastUpdate Day+  | TAIExpiration Day+  | TAILeapSecond Day Int32+  | TAIHash String+  deriving (Eq, Ord, Show)++data LeapSecondList = LeapSecondList {+  expirationDate :: Day+, lastUpdate :: Day+, expectedHash :: String+, leapSeconds :: [(Day, Int32)]+} deriving (Eq, Ord, Show)++-- | Parse a leap second list+parseLeapSecondList :: String -> Either String LeapSecondList+parseLeapSecondList contents =+  case parseString parseTAIEntries (Columns 0 0) contents of+    (Failure parseError) -> Left $ show parseError+    (Success entries) -> buildLeapSecondList entries++-- | Build a leap second list from a list of TAIEntry. +-- should add in checking of the hash+buildLeapSecondList :: [TAIEntry] -> Either String LeapSecondList+buildLeapSecondList list =+  LeapSecondList <$> expiration <*> updated <*> hash <*> leaps+  where+    expiration =+      single expirations "Too many expiration definitions\n"+    updated =+      single updates "Too many last update definitions\n"+    hash =+      single hashes "Too many hash definitions\n"+    leaps =+      return $ catMaybes $ getLeapSecond <$> list+    expirations =+      catMaybes $ getExpiration <$> list+    updates =+      catMaybes $ getLastUpdate <$> list+    hashes =+      catMaybes $ getHash <$> list+    single (x:[]) _ = Right x+    single _ e = Left e++getExpiration :: TAIEntry -> Maybe Day+getExpiration (TAIExpiration d) = Just d+getExpiration _ = Nothing++getLastUpdate :: TAIEntry -> Maybe Day+getLastUpdate (TAILastUpdate d) = Just d+getLastUpdate _ = Nothing++getLeapSecond :: TAIEntry -> Maybe (Day, Int32)+getLeapSecond (TAILeapSecond day dtai) = Just (day, dtai)+getLeapSecond _ = Nothing++getHash :: TAIEntry -> Maybe String+getHash (TAIHash h) = Just h+getHash _ = Nothing++eol :: Parser ()+eol = void $ char '\n'++parseTAIEntries :: Parser [TAIEntry]+parseTAIEntries =+  catMaybes <$> manyTill taiEntry eof+  where+    taiEntry =+          (Just <$> taiParser)+      <|> (const Nothing <$> parseComment)+    taiParser =+          (parseLeapSecond <?> "Leap second")+      <|> (parseLastUpdate <?> "Last update")+      <|> (parseExpiration <?> "Expiration")+      <|> (parseTAIHash <?> "Hash")++consumeLine :: Parser ()+consumeLine = do+  _<- spaces+  (parseComment <|> eol)++parseComment :: Parser ()+parseComment = void $ do+  _<- char '#'+  _<- manyTill anyChar eol+  return ()++parseLastUpdate :: Parser TAIEntry+parseLastUpdate = do+  _<- string "#$"+  _<- spaces+  lastUpdateNtp <- natural <?> "Last Update"+  _<- spaces+  return . TAILastUpdate $ ntpToDay lastUpdateNtp++parseExpiration :: Parser TAIEntry+parseExpiration = do+  _<- string "#@"+  _<- spaces+  expiration <- natural <?> "Expiration date"+  _<- spaces+  return . TAIExpiration $ ntpToDay expiration++parseLeapSecond :: Parser TAIEntry+parseLeapSecond = do+  time <- natural <?> "Leap second time"+  _<- spaces+  dtai <- natural <?> "dtai"+  _<- consumeLine+  return $ TAILeapSecond (ntpToDay time) $ fromIntegral dtai++parseTAIHash :: Parser TAIEntry+parseTAIHash = do+  _<- string "#h"+  _<- spaces+  hash <- manyTill anyChar eol <?> "Hash"+  return $ TAIHash hash++ntpToDay :: Integer -> Day+ntpToDay n = addDays (div n 86400) ntpEpochDay++ntpEpochDay :: Day+ntpEpochDay = ModifiedJulianDay 15020

@@ -0,0 +1,182 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE DeriveAnyClass #-}+module Data.Time.Clock.TAI.Support (+   TAISync, UpdatePolicy+ , initSync+ , getTAI, absGuessUtc, utcGuessAbs+ , currentLeapMap+ , periodicBackgroundDownload+ ) where++import qualified Control.Exception as E+import Control.Monad+import Control.Monad.Trans+import Data.Int+import Data.IORef+import Data.Maybe+import Data.Time+import Data.Time.Clock.TAI+import Data.Time.Clock.TAI.LeapData+import Data.Time.Clock.TAI.Parser+import qualified GHC.Event as TM+import qualified System.Clock as Clock+import System.Mem.Weak++-- | Our data about TAI in relation to UTC and this system.+data TAISync =+    TAISync+    { _tsSystemBootEpoch :: AbsoluteTime+      -- ^ The TAI of CLOCK_BOOTTIME's 0 time.+      --   This allows us to keep giving TAI time as accurately as the system's clock+      --   even in the face of failure to update our leap second table in the future.+    , _lslRef :: IORef LeapSecondList+      -- ^ Our TAI/UTC offset information, maintained in the background to the best+      --   of our UpdatePolicy's ability.+    }++-- | A function that enacts the periodic update of the LeapSecondList leap second data.+--   Usually periodicBackgroundDownload will satisfy a user's needs, but some enviroments+--   may want another policy.+type UpdatePolicy = IO (IORef LeapSecondList)++data TimeSyncException =+    TimeSyncTooLongException+  deriving (Show, E.Exception)++-- | Given an UpdatePolicy, generate a TAISync to be used to interact with TAI+--   though the other library functions.+initSync :: MonadIO m => UpdatePolicy -> m TAISync+initSync uppolicy = liftIO $ do+    -- We don't try to be too precise,+    -- if we wanted higher accuracy we'd have to bounce back and forth a few times+    -- Instead we just assume its in the middle of the two times,+    -- and error if the seperation is large.+    sinceBoot <- Clock.getTime Clock.Boottime+    now <- getCurrentTime+    sinceBoot' <- Clock.getTime Clock.Boottime+    -- We get the leap second list after we get our times just to be extra sure+    -- that we have to be able to convert the times.+    lslRef <- liftIO uppolicy+    lsl <- readIORef lslRef+    let nowTAI = utcGuessAbs' lsl now+    let d1 = timeSpec2DiffTime sinceBoot+    let d2 = timeSpec2DiffTime sinceBoot'+    let diffSinceBootMiddle = (d1 + d2) / 2+    -- We don't want too low an accuracy+    unless (d2-d1 < 10^^(-4::Int)) . E.throw $ TimeSyncTooLongException+    return $ TAISync ((negate diffSinceBootMiddle) `addAbsoluteTime` nowTAI) lslRef++-- | Update the leap second table by redownloading the tables periodicly in the background.+--   This policy uses the TimeoutManager to check for a new table every dbetween days,+--   trying again dretry if there is a failure. Recomended values are 30 and 1 for these.+--   Given the validity period for leap second data, this should generally suffice.+--   There can be problems with local files being near their expiration though.+--+--   This policy requires a threaded runtime.+periodicBackgroundDownload :: LeapSources -> Int -> Int -> UpdatePolicy+periodicBackgroundDownload ls dbetween dretry = do+    -- We use a week reference to the leap second list data for simplicity of background+    -- task termination. This is not prompt, but as the background task doesn't directly+    -- hold data other then a weak reference (including not having a stack), or perform+    -- actions, promptness seemed unworthy of the overhead.+    lsl <- sourceLeapData ls+    lslRef <- newIORef lsl+    lslWRef <- mkWeakIORef lslRef (return ())+    regTimed dbetween lslWRef+    return lslRef+  where+    -- Register the leapsecond update handler to be run in a given number of days (approximate)+    regTimed :: Int -> Weak (IORef LeapSecondList) -> IO ()+    regTimed d wr = do+      tm <- TM.getSystemTimerManager+      -- Update a little less then monthly+      void $ TM.registerTimeout tm (d*24*60*60*1000000) (timedUpdater wr)+    timedUpdater :: Weak (IORef LeapSecondList) -> IO ()+    timedUpdater wr = do+      mr <- deRefWeak wr+      case mr of+        -- If the weak ref doesn't deref our need for existance is over.+        Nothing -> return ()+        -- Try to update the leapsecond data, trying again sooner if we fail.+        Just r -> E.handle (\(_::E.SomeException) -> regTimed dretry wr) $ do+          lsl <- sourceLeapData ls+          atomicModifyIORef' r (const (lsl, ()))+          regTimed dbetween wr++timeSpec2DiffTime :: Clock.TimeSpec -> DiffTime+timeSpec2DiffTime ct =+  picosecondsToDiffTime (10^(12::Int) * (fromIntegral $ Clock.sec ct)+                        + 1000 *  (fromIntegral $ Clock.nsec ct))++-- | Get the current TAI time.+getTAI :: MonadIO m => TAISync -> m AbsoluteTime+getTAI (TAISync btb _) =+  liftIO $ ((`addAbsoluteTime` btb) . timeSpec2DiffTime) <$> Clock.getTime Clock.Boottime++lookupDayInList :: LeapSecondList -> Day -> Maybe Int32+lookupDayInList list day+  | day >= expirationDate list = Nothing+  | otherwise = foldl go Nothing $ leapSeconds list+    where+      go Nothing (dayOfLeapSecond, dtai)+        | day >= dayOfLeapSecond = Just dtai+      go (Just dtai) (dayOfLeapSecond, dtai')+        | day >= dayOfLeapSecond = Just $ max dtai dtai'+      go x _ = x++handlingOutOfRange :: LeapSecondList -> Day -> Integer+handlingOutOfRange lsl day = fromIntegral $+  let (maxMapDay, maxDayLeaps) = maximum . leapSeconds $ lsl+      (minMapDay, minDayLeaps) = minimum . leapSeconds $ lsl+   in case (day < minMapDay, day > maxMapDay) of+        (True, False) -> minDayLeaps+        (False, True) -> maxDayLeaps+        (False, False) -> fromJust $ lookupDayInList lsl day+        _ -> error "Day both larger then max and smaller then min!"++-- | Given our information about leap seconds, generate a UTC time from a TAI time+--   as a total function. As the relation between TAI is only known for a specific+--   time range, we give a best-guess outside said time range.+--   Specificly we only know the offset after some point in the past, and+--   up to about 6 months into the future. Outside this range we assume the last+--   known mapping between UTC and TAI doesn't drift.+absGuessUtc :: MonadIO m => TAISync -> AbsoluteTime -> m UTCTime+absGuessUtc (TAISync _ lr) at = liftIO $ (`absGuessUtc'` at) <$> readIORef lr++absGuessUtc' :: LeapSecondList -> AbsoluteTime -> UTCTime++-- | Given our information about leap seconds, generate a TAI time rom a UTC time+--   as a total function. As the relation between TAI is only known for a specific+--   time range, we give a best-guess outside said time range.+--   Specificly we only know the offset after some point in the past, and+--   up to about 6 months into the future. Outside this range we assume the last+--   known mapping between UTC and TAI doesn't drift.+utcGuessAbs :: MonadIO m => TAISync -> UTCTime -> m AbsoluteTime+utcGuessAbs (TAISync _ lr) ut = liftIO $ (`utcGuessAbs'` ut) <$> readIORef lr++utcGuessAbs' :: LeapSecondList -> UTCTime -> AbsoluteTime++#if MIN_VERSION_time(1,7,0)+-- | Gets the current leap second data in a 'time' compatable form.+currentLeapMap :: MonadIO m => TAISync -> m LeapSecondMap+currentLeapMap = fmap leapListToMap . liftIO . readIORef . _lslRef++leapListToMap :: LeapSecondList -> LeapSecondMap+leapListToMap lsl day = fmap fromIntegral . lookup day . leapSeconds $ lsl++absGuessUtc' lsl = fromJust . taiToUTCTime (Just . fromIntegral . handlingOutOfRange lsl)++utcGuessAbs' lsl =  fromJust . utcToTAITime (Just . fromIntegral . handlingOutOfRange lsl)+#else+-- | Gets the current leap second data in a 'time' compatable form.+currentLeapMap :: MonadIO m => TAISync -> m LeapSecondTable+currentLeapMap = fmap leapListToMap . liftIO . readIORef . _lslRef++leapListToMap :: LeapSecondList -> LeapSecondTable+leapListToMap lsl day = fromIntegral . fromJust . lookup day . leapSeconds $ lsl++absGuessUtc' lsl = taiToUTCTime (handlingOutOfRange lsl)++utcGuessAbs' lsl = utcToTAITime (handlingOutOfRange lsl)+#endif

@@ -0,0 +1,35 @@+name:                tai+version:             0+synopsis:            Support library to enable TAI usage on systems with time kept in UTC.+description:         This library manages leap second data to allow using TAI time inspite of the system clock being kept in UTC.+homepage:            https://oss.xkcd.com/+license:             BSD3+license-file:        LICENSE+author:              davean, tolt+maintainer:          oss@xkcd.com+copyright:           davean & tolt 2017+category:            Time, System+build-type:          Simple+extra-source-files:  ChangeLog.md+cabal-version:       >=1.10++source-repository head+  type: git+  location: https://code.xkrd.net/haskell/tai.git++library+  hs-source-dirs:      src+  default-language:    Haskell2010+  exposed-modules:+        Data.Time.Clock.TAI.Support+        Data.Time.Clock.TAI.Parser+        Data.Time.Clock.TAI.LeapData+  build-depends:+        base >=4.9 && <4.11+      , time >= 1.6.0.1 && < 1.9+      , mtl >= 2.2 && < 2.3+      , trifecta >= 1.6 && < 1.7+      , parsers >= 0.12 && < 0.13+      , clock >= 0.7 && < 0.8+      , wreq >= 0.5 && < 0.6+      , lens >= 4.5 && < 4.16