Support.hs

{-# 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