diff --git a/ChangeLog.md b/ChangeLog.md new file mode 100644 --- /dev/null +++ b/ChangeLog.md @@ -0,0 +1,5 @@ +# Revision history for tai + +## 0 -- YYYY-mm-dd + +* First version. Released on an unsuspecting world. diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/src/Data/Time/Clock/TAI/LeapData.hs b/src/Data/Time/Clock/TAI/LeapData.hs new file mode 100644 --- /dev/null +++ b/src/Data/Time/Clock/TAI/LeapData.hs @@ -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!" diff --git a/src/Data/Time/Clock/TAI/Parser.hs b/src/Data/Time/Clock/TAI/Parser.hs new file mode 100644 --- /dev/null +++ b/src/Data/Time/Clock/TAI/Parser.hs @@ -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 diff --git a/src/Data/Time/Clock/TAI/Support.hs b/src/Data/Time/Clock/TAI/Support.hs new file mode 100644 --- /dev/null +++ b/src/Data/Time/Clock/TAI/Support.hs @@ -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 diff --git a/tai.cabal b/tai.cabal new file mode 100644 --- /dev/null +++ b/tai.cabal @@ -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