diff --git a/nix/.stack.nix/default.nix b/nix/.stack.nix/default.nix index ecd9973801e..b1b5957b739 100644 --- a/nix/.stack.nix/default.nix +++ b/nix/.stack.nix/default.nix @@ -11,7 +11,6 @@ "hedgehog-quickcheck" = (((hackage.hedgehog-quickcheck)."0.1.1").revisions).default; "quickcheck-state-machine" = (((hackage.quickcheck-state-machine)."0.6.0").revisions).default; "splitmix" = (((hackage.splitmix)."0.0.2").revisions).default; - "time-units" = (((hackage.time-units)."1.0.0").revisions).default; "tasty-hedgehog" = (((hackage.tasty-hedgehog)."1.0.0.1").revisions).default; "Unique" = (((hackage.Unique)."0.4.7.6").revisions).default; "statistics-linreg" = (((hackage.statistics-linreg)."0.3").revisions).default; diff --git a/nix/.stack.nix/ntp-client.nix b/nix/.stack.nix/ntp-client.nix index e949946ee32..d6ceb2cbdf7 100644 --- a/nix/.stack.nix/ntp-client.nix +++ b/nix/.stack.nix/ntp-client.nix @@ -22,38 +22,17 @@ (hsPkgs.binary) (hsPkgs.bytestring) (hsPkgs.contra-tracer) - (hsPkgs.formatting) (hsPkgs.network) (hsPkgs.stm) - (hsPkgs.these) (hsPkgs.time) - (hsPkgs.time-units) ]; }; - exes = { - "ntp-app" = { - depends = [ - (hsPkgs.async) - (hsPkgs.base) - (hsPkgs.binary) - (hsPkgs.bytestring) - (hsPkgs.contra-tracer) - (hsPkgs.formatting) - (hsPkgs.network) - (hsPkgs.stm) - (hsPkgs.these) - (hsPkgs.time) - (hsPkgs.time-units) - ]; - }; - }; tests = { - "ntp-client-test" = { + "test-ntp-client" = { depends = [ (hsPkgs.base) (hsPkgs.binary) (hsPkgs.time) - (hsPkgs.time-units) (hsPkgs.QuickCheck) (hsPkgs.tasty) (hsPkgs.tasty-quickcheck) diff --git a/nix/pkgs.nix b/nix/pkgs.nix index ed68814ea1e..b3274f49c65 100644 --- a/nix/pkgs.nix +++ b/nix/pkgs.nix @@ -38,6 +38,7 @@ let packages.io-sim-classes.configureFlags = [ "--ghc-option=-Werror" ]; packages.Win32-network.configureFlags = [ "--ghc-option=-Werror" ]; packages.network-mux.configureFlags = [ "--ghc-option=-Werror" ]; + packages.ntp-client.configureFlags = [ "--ghc-option=-Werror" ]; packages.ouroboros-network.configureFlags = [ "--ghc-option=-Werror" ]; packages.ouroboros-network.flags.cddl = true; packages.ouroboros-network.components.tests.test-cddl.build-tools = [pkgs.cddl pkgs.cbor-diag]; diff --git a/ntp-client/ntp-client.cabal b/ntp-client/ntp-client.cabal index 44e62ffe39b..4fc827947f6 100644 --- a/ntp-client/ntp-client.cabal +++ b/ntp-client/ntp-client.cabal @@ -11,69 +11,37 @@ cabal-version: >=1.20 Library exposed-modules: Network.NTP.Client - Network.NTP.Util Network.NTP.Packet + Network.NTP.Query + Network.NTP.Test Network.NTP.Trace - build-depends: async - , base - , binary >= 0.8 - , bytestring - , contra-tracer - , formatting - , network - , stm - , these - , time - , time-units + build-depends: async >=2.2 && <2.3 + , base >=4.9 && <4.13 + , binary >=0.8 && <0.9 + , bytestring >=0.10 && <0.11 + , contra-tracer >=0.1 && <0.2 + , network >= 3.1 && <3.2 + , stm >=2.4 && <2.6 + , time >=1.6 && <1.10 hs-source-dirs: src default-language: Haskell2010 - ghc-options: -Wall -Werror -fwarn-redundant-constraints - default-extensions: DeriveDataTypeable - DeriveGeneric - GeneralizedNewtypeDeriving - OverloadedStrings - MonadFailDesugaring - --- Just for testing: to be removed later. -Executable ntp-app - hs-source-dirs: test, src - main-is: NtpApp.hs - default-language: Haskell2010 - ghc-options: -Wall -Werror -fwarn-redundant-constraints - other-modules: Network.NTP.Client - Network.NTP.Util - Network.NTP.Packet - Network.NTP.Trace - build-depends: async - , base - , binary >= 0.8 - , bytestring - , contra-tracer - , formatting - , network - , stm - , these - , time - , time-units + ghc-options: -Wall + default-extensions: GeneralizedNewtypeDeriving -test-suite ntp-client-test +test-suite test-ntp-client hs-source-dirs: test, src main-is: Test.hs type: exitcode-stdio-1.0 other-modules: Network.NTP.Packet - build-depends: base - , binary >= 0.8 + build-depends: base >=4.9 && <4.13 + , binary , time - , time-units , QuickCheck , tasty , tasty-quickcheck default-language: Haskell2010 - ghc-options: -threaded - -rtsopts - -Wall - -with-rtsopts=-N + ghc-options: -Wall default-extensions: OverloadedStrings , DeriveDataTypeable , GeneralizedNewtypeDeriving diff --git a/ntp-client/src/Network/NTP/Client.hs b/ntp-client/src/Network/NTP/Client.hs index 4a812377637..e89b7e1bab0 100644 --- a/ntp-client/src/Network/NTP/Client.hs +++ b/ntp-client/src/Network/NTP/Client.hs @@ -1,318 +1,114 @@ -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE GADTs #-} +{-# LANGUAGE NumericUnderscores #-} {-# LANGUAGE LambdaCase #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE ScopedTypeVariables #-} - --- | This module implements functionality of NTP client. - -module Network.NTP.Client - ( NtpClientSettings (..) - , NtpClient (..) - , withNtpClient - ) where +module Network.NTP.Client ( + NtpClient(..) + , withNtpClient + ) where import Control.Concurrent (threadDelay) -import Control.Concurrent.Async (async, concurrently_, race, race_) -import Control.Concurrent.STM -import Control.Exception (Exception, IOException, bracket, catch, handle) -import Control.Monad (forever, when) +import Control.Concurrent.Async +import Control.Concurrent.STM (STM, atomically, check) +import Control.Concurrent.STM.TVar +import Control.Monad (when) +import System.IO.Error (catchIOError) import Control.Tracer -import Data.Binary (decodeOrFail) -import qualified Data.ByteString.Lazy as LBS -import Data.List.NonEmpty (NonEmpty) -import qualified Data.List.NonEmpty as NE -import Data.Maybe (catMaybes) -import Data.Semigroup (Last (..)) -import Data.These (These (..)) -import Data.Time.Units (Microsecond) -import Data.Typeable (Typeable) -import qualified Network.Socket as Socket -import Network.Socket.ByteString (recvFrom) +import Data.Void (Void) -import Network.NTP.Packet (NtpOffset (..) , NtpPacket (..), clockOffset, - mkNtpPacket, ntpPacketSize) -import Network.NTP.Trace (NtpTrace (..)) -import Network.NTP.Util (AddrFamily (..), Addresses, Sockets, - WithAddrFamily (..), createAndBindSock, - resolveNtpHost, - runWithAddrFamily, sendPacket, udpLocalAddresses) +import Network.NTP.Query +import Network.NTP.Trace -data NtpClientSettings = NtpClientSettings - { ntpServers :: [String] - -- ^ list of servers addresses - , ntpResponseTimeout :: Microsecond - -- ^ delay between making requests and response collection - , ntpPollDelay :: Microsecond - -- ^ how long to wait between to send requests to the servers - , ntpSelection :: NonEmpty NtpOffset -> NtpOffset - -- ^ way to sumarize results received from different servers. - -- this may accept list of lesser size than @length ntpServers@ in case - -- some servers failed to respond in time, but never an empty list - } +-- | 'NtpClient' which recieves updates of the wall clcok drift every +-- 'ntpPollDelay'. It also allows to force engaging in ntp protocol. +-- data NtpClient = NtpClient { -- | Query the current NTP status. - ntpGetStatus :: STM NtpStatus - - -- | Bypass all internal threadDelays and trigger a new NTP query. - , ntpTriggerUpdate :: IO () + ntpGetStatus :: STM NtpStatus + -- | Force to update the ntp state, unless an ntp query is already + -- running. This is a blocking operation. + , ntpQueryBlocking :: IO NtpStatus + -- | Ntp client thread + , ntpThread :: Async Void } -data NtpStatus = - -- | The difference between NTP time and local system time - NtpDrift NtpOffset - -- | NTP client has send requests to the servers - | NtpSyncPending - -- | NTP is not available: the client has not received any respond within - -- `ntpResponseTimeout` or NTP was not configured. - | NtpSyncUnavailable deriving (Eq, Show) --- | Setup a NtpClient and run a computation that uses that client. --- Todo : proper bracket-style tear-down of the NTP client. -withNtpClient :: Tracer IO NtpTrace -> NtpClientSettings -> (NtpClient -> IO a) -> IO a -withNtpClient tracer ntpSettings action - = forkNtpClient tracer ntpSettings >>= action - --- This function should be called once, it will run an NTP client in a new --- thread until the program terminates. -forkNtpClient :: Tracer IO NtpTrace -> NtpClientSettings -> IO NtpClient -forkNtpClient tracer ntpSettings = do +-- | Setup a NtpClient and run an application that uses provided 'NtpClient'. +-- The 'NtpClient' is terminated when the callback returns. The application +-- can 'waitCatch' on 'ntpThread'. +-- +withNtpClient :: Tracer IO NtpTrace -> NtpSettings -> (NtpClient -> IO a) -> IO a +withNtpClient tracer ntpSettings action = do traceWith tracer NtpTraceStartNtpClient - ncStatus <- newTVarIO NtpSyncPending - -- using async so the NTP thread will be left running even if the parent - -- thread finished. - _ <- async (spawnNtpClient tracer ntpSettings ncStatus) - return $ NtpClient - { ntpGetStatus = readTVar ncStatus - , ntpTriggerUpdate = do - traceWith tracer NtpTraceClientActNow - atomically $ writeTVar ncStatus NtpSyncPending - } - -data NtpState = NtpState - { ncSockets :: TVar Sockets - -- ^ Ntp client sockets: ipv4 / ipv6 / both. - , ncState :: TVar [NtpOffset] - -- ^ List of ntp offsets and origin times (i.e. time when a request was - -- send) received from ntp servers since last polling interval. - , ncStatus :: TVar NtpStatus - -- ^ Ntp status: holds `NtpOffset` or a status of ntp client: - -- `NtpSyncPending`, `NtpSyncUnavailable`. It is computed from `ncState` - -- once all responses arrived. - , ncSettings :: NtpClientSettings - -- ^ Ntp client configuration. - } - -mkNtpClient :: NtpClientSettings -> TVar NtpStatus -> Sockets -> IO NtpState -mkNtpClient ncSettings ncStatus sock = do - ncSockets <- newTVarIO sock - ncState <- newTVarIO [] - return NtpState{..} - -data NoHostResolved = NoHostResolved - deriving (Show, Typeable) - -instance Exception NoHostResolved - -updateStatus :: Tracer IO NtpTrace -> NtpState -> IO () -updateStatus tracer cli = do - offsets <- readTVarIO (ncState cli) - status <- case offsets of - [] -> do - traceWith tracer NtpTraceUpdateStatusNoResponses - return NtpSyncUnavailable - l -> do - let o = ntpSelection (ncSettings cli) $ NE.fromList l - traceWith tracer $ NtpTraceUpdateStatusClockOffset $ getNtpOffset o - return $ NtpDrift o - atomically $ writeTVar (ncStatus cli) status - --- Every `ntpPollDelay` we send a request to the list of `ntpServers`. Before --- sending a request, we put `NtpSyncPending` to `ncState`. After sending --- all requests we wait until either all servers responded or --- `ntpResponseTimeout` passesed. If at least one server responded --- `handleCollectedResponses` will update `ncStatus` in `NtpClient` with a new --- drift. -sendLoop :: Tracer IO NtpTrace -> NtpState -> [Addresses] -> IO () -sendLoop tracer cli addrs = forever $ do - let respTimeout = ntpResponseTimeout (ncSettings cli) - let poll = ntpPollDelay (ncSettings cli) - - -- send packets and wait until end of poll delay - sock <- readTVarIO $ ncSockets cli - pack <- mkNtpPacket - sendPacket tracer sock pack addrs - - _ <- timeout respTimeout waitForResponses - updateStatus tracer cli - -- after @'updateStatus'@ @'ntpStatus'@ is guaranteed to be - -- different from @'NtpSyncPending'@, now we can wait until it was - -- changed back to @'NtpSyncPending'@ to force a request. - _ <- timeout poll waitForRequest - - -- reset state & status before next loop - atomically $ writeTVar (ncState cli) [] - atomically $ writeTVar (ncStatus cli) NtpSyncPending - - where - waitForResponses = do - atomically $ do - resps <- readTVar $ ncState cli - let svs = length $ ntpServers $ ncSettings cli - when (length resps < svs) - retry - traceWith tracer NtpTraceSendLoopCollectedAllResponses - - -- Wait for a request to force an ntp check. - waitForRequest = - atomically $ do - status <- readTVar $ ncStatus cli - check (status == NtpSyncPending) - return () - - timeout :: Microsecond -> IO a -> IO (Either () a) - timeout t io = race (threadDelay (fromIntegral t)) io - --- | --- Listen for responses on the socket @'ncSockets'@ -receiveLoop :: Tracer IO NtpTrace -> NtpState -> IO () -receiveLoop tracer cli = - readTVarIO (ncSockets cli) >>= \case - These (Last (WithIPv6 sock_ipv6)) (Last (WithIPv4 sock_ipv4)) -> - loop IPv6 sock_ipv6 - `concurrently_` - loop IPv4 sock_ipv4 - This (Last (WithIPv6 sock_ipv6)) -> - loop IPv6 sock_ipv6 - That (Last (WithIPv4 sock_ipv4)) -> - loop IPv4 sock_ipv4 - where - -- Receive responses from the network and update NTP client state. - loop :: AddrFamily -> Socket.Socket -> IO () - loop addressFamily sock - = handle (handleIOException addressFamily) $ forever $ do - (bs, _) <- recvFrom sock ntpPacketSize - case decodeOrFail $ LBS.fromStrict bs of - Left (_, _, err) -> - traceWith tracer $ NtpTraceReceiveLoopDecodeError err - Right (_, _, packet) -> - handleNtpPacket packet - - -- Restart the @loop@ in case of errors; wait 5s before recreating the - -- socket. - handleIOException - :: AddrFamily - -> IOException - -> IO () - handleIOException addressFamily e = do - traceWith tracer $ NtpTraceReceiveLoopHandleIOException e - threadDelay 5000000 - udpLocalAddresses >>= createAndBindSock tracer addressFamily >>= \case - Nothing -> do - traceWith tracer NtpTraceReceiveLoopException --- logWarning "recreating of sockets failed (retrying)" - handleIOException addressFamily e - Just sock -> do - atomically $ modifyTVar' (ncSockets cli) (\s -> s <> sock) - case sock of - This (Last sock_) - -> loop addressFamily $ runWithAddrFamily sock_ - That (Last sock_) - -> loop addressFamily $ runWithAddrFamily sock_ - These _ _ - -> error "NtpClient: startReceive: impossible" - - -- Compute the clock offset based on current time and record it in the NTP - -- client state. A packet will be disgarded if it came after - -- @'ntpResponseTimeout'@. - handleNtpPacket - :: NtpPacket - -> IO () - handleNtpPacket packet = do - traceWith tracer NtpTraceReceiveLoopPacketReceived -- packet - clockOffset (ntpResponseTimeout $ ncSettings cli) packet >>= \case - Nothing -> traceWith tracer NtpTraceReceiveLoopLatePacket - Just offset -> do - traceWith tracer $ NtpTraceReceiveLoopPacketDeltaTime $ getNtpOffset offset - atomically $ modifyTVar' (ncState cli) ( offset : ) - --- | --- Spawn NTP client which will send request to NTP servers every @'ntpPollDelay'@ --- and will listen for responses. The @'ncStatus'@ will be updated every --- @'ntpPollDelay'@ with the most recent value. It should be run in a separate --- thread, since it will block infinitely. -spawnNtpClient :: Tracer IO NtpTrace -> NtpClientSettings -> TVar NtpStatus -> IO () -spawnNtpClient tracer settings ncStatus = do - traceWith tracer NtpTraceSpawnNtpClientStarting - bracket (mkSockets tracer settings) closeSockets $ \sock -> do - cli <- mkNtpClient settings ncStatus sock - - addrs <- resolve - -- TODO - -- we should start listening for requests when we send something, since - -- we're not expecting anything to come unless we send something. This - -- way we could simplify the client and remove `ncState` mutable cell. - receiveLoop tracer cli - `concurrently_` sendLoop tracer cli addrs - `concurrently_` traceWith tracer NtpTraceSpawnNtpClientStarted - - where - closeSockets :: Sockets -> IO () - closeSockets sockets = do - case sockets of - This a -> fn a - That a -> fn a - These a b -> fn a >> fn b - traceWith tracer NtpTraceSpawnNtpClientSocketsClosed - - fn :: Last (WithAddrFamily t Socket.Socket) -> IO () - fn (Last sock) = Socket.close $ runWithAddrFamily sock - - -- Try to resolve addresses, on failure wait 30s and start again. - resolve = do - traceWith tracer NtpTraceSpawnNtpClientResolveDNS - addrs <- catMaybes <$> traverse (resolveNtpHost tracer) (ntpServers settings) - if null addrs - then do - atomically $ writeTVar ncStatus NtpSyncUnavailable - -- either wait 30s or wait for `NtpSyncPending` which might be set - -- by a client (e.g. wallet), in which case try to resolve the dns. - race_ - (threadDelay 30000000) - (do - atomically $ do - s <- readTVar ncStatus - case s of - NtpSyncPending -> return () - _ -> retry - traceWith tracer NtpTraceSpawnNtpClientResolvePending - ) - resolve - else return addrs - --- Try to create IPv4 and IPv6 socket. -mkSockets :: Tracer IO NtpTrace -> NtpClientSettings -> IO Sockets -mkSockets tracer settings = - doMkSockets `catch` handleIOException >>= \case - Just socks -> pure socks - Nothing -> do - traceWith tracer NtpTraceMkSocketsNoSockets --- logWarning "Couldn't create either IPv4 or IPv6 socket, retrying in 5 sec..." - threadDelay 5000000 - mkSockets tracer settings + ntpStatus <- newTVarIO NtpSyncPending + withAsync (ntpClientThread tracer ntpSettings ntpStatus) $ \tid -> do + let client = NtpClient + { ntpGetStatus = readTVar ntpStatus + , ntpQueryBlocking = do + traceWith tracer NtpTraceTriggerUpdate + -- trigger an update, unless an ntp query is not already + -- running + atomically $ do + status <- readTVar ntpStatus + when (status /= NtpSyncPending) + $ writeTVar ntpStatus NtpSyncPending + -- block until the state changes + atomically $ do + status <- readTVar ntpStatus + check $ status /= NtpSyncPending + return status + , ntpThread = tid + } + action client + +awaitPendingWithTimeout :: TVar NtpStatus -> Int -> IO () +awaitPendingWithTimeout tvar t + = race_ + ( threadDelay t ) + ( atomically $ do + s <- readTVar tvar + check $ s == NtpSyncPending + ) + +-- | ntp client thread which wakes up every 'ntpPollDelay' to make ntp queries. +-- It can be woken up earlier by setting 'NptStatus' to 'NtpSyncPending'. +-- +-- TODO: Reset the delay time if ntpQuery did one successful query. +ntpClientThread :: + Tracer IO NtpTrace + -> NtpSettings + -> TVar NtpStatus + -> IO Void +ntpClientThread tracer ntpSettings ntpStatus = go 0 where - doMkSockets :: IO (Maybe Sockets) - doMkSockets = do - addrs <- udpLocalAddresses - (<>) <$> (createAndBindSock tracer IPv4 addrs) - <*> (createAndBindSock tracer IPv6 addrs) - - handleIOException :: IOException -> IO (Maybe Sockets) - handleIOException e = do - traceWith tracer $ NtpTraceMkSocketsIOExecption e - threadDelay 5000000 - doMkSockets + -- outer loop of the ntp client. If inner loop errors we restart after the + -- 'delay' seconds + go :: Int -> IO Void + go delay | delay <= 0 = do + queryLoop + `catchIOError` (traceWith tracer . NtpTraceIOError) + atomically $ writeTVar ntpStatus NtpSyncUnavailable + go 5 + go delay = do + traceWith tracer $ NtpTraceRestartDelay delay + awaitPendingWithTimeout ntpStatus $ delay * 1_000_000 + traceWith tracer NtpTraceRestartingClient + queryLoop + `catchIOError` (traceWith tracer . NtpTraceIOError) + atomically $ writeTVar ntpStatus NtpSyncUnavailable + go (2 * delay `max` 600) + + -- inner loop of the ntp client. Note that 'nptQuery' will return either + -- 'NptDrift' or 'NptSyncUnavailable'. + queryLoop :: IO () + queryLoop = ntpQuery tracer ntpSettings >>= \case + status@NtpDrift{} -> do + atomically $ writeTVar ntpStatus status + traceWith tracer NtpTraceClientSleeping + awaitPendingWithTimeout ntpStatus $ fromIntegral $ ntpPollDelay ntpSettings + queryLoop + status@NtpSyncUnavailable -> + -- we need to update the status even if the result is + -- 'NptSyncUnavailable', so that the thread blocked on it will be + -- waken up. + atomically $ writeTVar ntpStatus status + NtpSyncPending -> error "ntpClientThread: impossible happend" diff --git a/ntp-client/src/Network/NTP/Packet.hs b/ntp-client/src/Network/NTP/Packet.hs index f4969abc415..4c0d06fb66b 100644 --- a/ntp-client/src/Network/NTP/Packet.hs +++ b/ntp-client/src/Network/NTP/Packet.hs @@ -1,16 +1,17 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE ViewPatterns #-} module Network.NTP.Packet ( NtpPacket (..) , ntpPacketSize , mkNtpPacket , NtpOffset (..) + , getCurrentTime , clockOffsetPure , clockOffset , realMcsToNtp , ntpToRealMcs + , Microsecond (..) ) where @@ -20,10 +21,11 @@ import Data.Binary.Get (getInt8, getWord32be, getWord8, skip) import Data.Binary.Put (putInt8, putWord32be, putWord8) import Data.Int (Int8) import Data.Time.Clock.POSIX (getPOSIXTime) -import Data.Time.Units (Microsecond, TimeUnit, fromMicroseconds, - toMicroseconds) import Data.Word (Word32, Word8) +newtype Microsecond = Microsecond Integer + deriving (Enum, Eq, Integral, Num, Ord, Real, Show) + data NtpPacket = NtpPacket { ntpParams :: Word8 -- ^ some magic parameters , ntpPoll :: Int8 -- ^ poll delay between requests @@ -98,7 +100,7 @@ ntpToRealMcs sec frac = -- ref: https://tools.ietf.org/html/rfc5905#section-6 fracMicro :: Integer fracMicro = (fromIntegral frac) `div` 4294 - in fromMicroseconds $ secMicro + fracMicro + in Microsecond $ secMicro + fracMicro -- | -- It is a partial function, since @Microsecond ~ Integer@; it is well defined @@ -108,7 +110,7 @@ ntpToRealMcs sec frac = -- @ -- (in microseconds; this is roughly 66 years, so we're fine untill 2036). realMcsToNtp :: Microsecond -> (Word32, Word32) -realMcsToNtp (toMicroseconds -> mcs) = +realMcsToNtp (Microsecond mcs) = let (sec, frac) = divMod mcs 1000000 in ( fromIntegral $ sec + ntpTimestampDelta , fromIntegral $ frac * 4294) @@ -127,7 +129,7 @@ mkNtpPacket = do -- | -- @'NtpOffset'@ is the difference between NTP time and local time. newtype NtpOffset = NtpOffset { getNtpOffset :: Microsecond } - deriving (Enum, Eq, Integral, Num, Ord, Real, Show, TimeUnit) + deriving (Enum, Eq, Integral, Num, Ord, Real, Show) clockOffsetPure :: NtpPacket -> Microsecond -> NtpOffset clockOffsetPure NtpPacket{..} localTime = NtpOffset @@ -152,4 +154,4 @@ clockOffset respTimeout packet = do -- | -- Helper function to get current time in @Microsecond@. getCurrentTime :: IO Microsecond -getCurrentTime = fromMicroseconds . round . ( * 1000000) <$> getPOSIXTime +getCurrentTime = Microsecond . round . ( * 1000000) <$> getPOSIXTime diff --git a/ntp-client/src/Network/NTP/Query.hs b/ntp-client/src/Network/NTP/Query.hs new file mode 100644 index 00000000000..56e552de6a1 --- /dev/null +++ b/ntp-client/src/Network/NTP/Query.hs @@ -0,0 +1,264 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NumericUnderscores #-} +module Network.NTP.Query ( + NtpSettings(..) + , NtpStatus(..) + , ntpQuery + ) where + +import Control.Concurrent (threadDelay) +import Control.Concurrent.Async +import Control.Concurrent.STM +import Control.Exception (bracket, mask, throwIO) +import System.IO.Error (tryIOError, userError, ioError) +import Control.Monad (forM, forM_, replicateM_) +import Control.Tracer +import Data.Binary (decodeOrFail, encode) +import qualified Data.ByteString.Lazy as LBS +import Data.Functor (void) +import Data.List (find) +import Data.Maybe +import Network.Socket ( AddrInfo + , AddrInfoFlag (AI_ADDRCONFIG, AI_PASSIVE) + , Family (AF_INET, AF_INET6) + , PortNumber + , Socket + , SockAddr (..) + , SocketOption (ReuseAddr) + , SocketType (Datagram) + , addrFamily + , addrFlags + , addrSocketType) +import qualified Network.Socket as Socket +import qualified Network.Socket.ByteString as Socket.ByteString (recvFrom, sendManyTo) +import Network.NTP.Packet ( mkNtpPacket + , ntpPacketSize + , Microsecond + , NtpOffset (..) + , getCurrentTime + , clockOffsetPure) +import Network.NTP.Trace (NtpTrace (..), IPVersion (..)) + +data NtpSettings = NtpSettings + { ntpServers :: [String] + -- ^ List of server addresses. At least three servers are needed. + , ntpResponseTimeout :: Microsecond + -- ^ Timeout between sending NTP requests and response collection. + , ntpPollDelay :: Microsecond + -- ^ How long to wait between two rounds of requests. + } + +data NtpStatus = + -- | The difference between NTP time and local system time + NtpDrift !NtpOffset + -- | NTP client has send requests to the servers + | NtpSyncPending + -- | NTP is not available: the client has not received any respond within + -- `ntpResponseTimeout` or NTP was not configured. + | NtpSyncUnavailable deriving (Eq, Show) + + +-- | Wait for at least three replies and report the minimum of the reported +-- offsets. +-- +minimumOfThree :: [NtpOffset] -> Maybe NtpOffset +minimumOfThree l + = if length l >= 3 + then Just $ minimum l + else Nothing + + +-- | Get a list local udp addresses. +-- +udpLocalAddresses :: IO [AddrInfo] +udpLocalAddresses = Socket.getAddrInfo (Just hints) Nothing Nothing + where + hints = Socket.defaultHints + { addrFlags = [AI_PASSIVE] + , addrSocketType = Datagram + } + + +-- | Resolve hostname into 'AddrInfo'. We use 'AI_ADDRCONFIG' so we get IPv4/6 +-- address only if the local. We don't need 'AI_V4MAPPED' which would be set +-- by default. +-- +resolveHost :: String -> IO [AddrInfo] +resolveHost host = Socket.getAddrInfo (Just hints) (Just host) Nothing + where + -- The library uses AI_ADDRCONFIG as simple test if IPv4 or IPv6 are configured. + -- According to the documentation, AI_ADDRCONFIG is not available on all platforms, + -- but it is expected to work on win32, Mac OS X and Linux. + -- TODO: use addrInfoFlagImplemented :: AddrInfoFlag -> Bool to test if the flag is available. + hints = Socket.defaultHints + { addrSocketType = Datagram + , addrFlags = [AI_ADDRCONFIG] + } + +firstAddr :: Family -> [AddrInfo] -> Maybe AddrInfo +firstAddr family l = find ((==) family . addrFamily ) l + +setNtpPort :: SockAddr -> SockAddr +setNtpPort addr = case addr of + (SockAddrInet _ host) -> SockAddrInet ntpPort host + (SockAddrInet6 _ flow host scope) -> SockAddrInet6 ntpPort flow host scope + sockAddr -> sockAddr + where + ntpPort :: PortNumber + ntpPort = 123 + + +-- | Resolve dns names +-- +lookupServers :: Tracer IO NtpTrace -> [String] -> IO ([AddrInfo], [AddrInfo]) +lookupServers tracer names = do + dests <- forM names $ \server -> do + addr <- resolveHost server + case (firstAddr AF_INET addr, firstAddr AF_INET6 addr) of + (Nothing, Nothing) -> do + traceWith tracer $ NtpTraceLookupServerFailed server + ioError $ userError $ "lookup NTP server failed " ++ server + l -> return l + return (mapMaybe fst dests, mapMaybe snd dests) + + +-- | Perform a series of NTP queries: one for each dns name. Resolve each dns +-- name, get local addresses: both IPv4 and IPv6 and engage in ntp protocol +-- towards one ip address per address family per dns name, but only for address +-- families for which we have a local address. This is to avoid trying to send +-- IPv4/6 requests if IPv4/6 gateway is not configured. +-- +-- It may throw an `IOException`: +-- +-- * if neither IPv4 nor IPv6 address is configured +-- * if network I/O errors +-- +ntpQuery :: + Tracer IO NtpTrace + -> NtpSettings + -> IO NtpStatus +ntpQuery tracer ntpSettings = do + traceWith tracer NtpTraceClientStartQuery + (v4Servers, v6Servers) <- lookupServers tracer $ ntpServers ntpSettings + localAddrs <- udpLocalAddresses + (v4LocalAddr, v6LocalAddr) <- case (firstAddr AF_INET localAddrs, firstAddr AF_INET6 localAddrs) of + (Nothing, Nothing) -> do + traceWith tracer NtpTraceNoLocalAddr + ioError $ userError "no local address IPv4 and IPv6" + l -> return l + (v4Replies, v6Replies) <- concurrently (runProtocol IPv4 v4LocalAddr v4Servers) + (runProtocol IPv6 v6LocalAddr v6Servers) + case v4Replies ++ v6Replies of + [] -> do + traceWith tracer NtpTraceIPv4IPv6NoReplies + return NtpSyncUnavailable + l -> case minimumOfThree l of + Nothing -> do + traceWith tracer NtpTraceReportPolicyQueryFailed + return NtpSyncUnavailable + Just offset -> do + traceWith tracer $ NtpTraceQueryResult $ getNtpOffset offset + return $ NtpDrift offset + where + runProtocol :: IPVersion -> Maybe AddrInfo -> [AddrInfo] -> IO [NtpOffset] + -- no addresses to sent to + runProtocol _protocol _localAddr [] = return [] + -- local address is not configured, e.g. no IPv6 or IPv6 gateway. + runProtocol _protocol Nothing _ = return [] + -- local address is configured, remote address list is non empty + runProtocol protocol (Just addr) servers = do + runNtpQueries tracer protocol ntpSettings addr servers >>= \case + Left err -> do + traceWith tracer $ NtpTraceRunProtocolError protocol err + return [] + Right [] -> do + traceWith tracer $ NtpTraceRunProtocolNoResult protocol + return [] + Right r -> do + traceWith tracer $ NtpTraceRunProtocolSuccess protocol + return r + + +-- | Run an ntp query towards each address +-- +runNtpQueries + :: Tracer IO NtpTrace + -> IPVersion -- ^ address family, it must afree with local and remote + -- addresses + -> NtpSettings + -> AddrInfo -- ^ local address + -> [AddrInfo] -- ^ remote addresses, they are assumed to have the same + -- family as the local address + -> IO (Either IOError [NtpOffset]) +runNtpQueries tracer protocol netSettings localAddr destAddrs + = tryIOError $ bracket acquire release action + where + acquire :: IO Socket + acquire = Socket.socket (addrFamily localAddr) Datagram Socket.defaultProtocol + + release :: Socket -> IO () + release s = do + Socket.close s + traceWith tracer $ NtpTraceSocketClosed protocol + + action :: Socket -> IO [NtpOffset] + action socket = do + traceWith tracer $ NtpTraceSocketOpen protocol + Socket.setSocketOption socket ReuseAddr 1 + inQueue <- atomically $ newTVar [] + withAsync timeout $ \timeoutT -> + withAsync (receiver socket inQueue ) $ \receiverT -> + -- mask async exceptions to guarantee that the other threads are + -- cancelled correctly. 'timeoutT' and 'receiverT' threads were + -- started using 'withAsync', so they will be terminated when the + -- callbak either returns or errors. + mask $ \unmask -> + async (unmask $ send socket) >>= \senderT -> unmask $ + waitCatch senderT >>= \case + Left e -> throwIO e + Right _ -> void $ waitAny [timeoutT, receiverT] + atomically $ readTVar inQueue + + -- + -- sending thread; send a series of requests: one towards each address + -- + send :: Socket -> IO () + send sock = forM_ destAddrs $ \addr -> do + p <- mkNtpPacket + err <- tryIOError + $ Socket.ByteString.sendManyTo sock + (LBS.toChunks $ encode p) + (setNtpPort $ Socket.addrAddress addr) + case err of + Right _ -> traceWith tracer $ NtpTracePacketSent protocol + Left e -> do + traceWith tracer $ NtpTracePacketSentError protocol e + ioError e + -- delay 100ms between sending requests, this avoids dealing with ntp + -- results at the same time from various ntp servers, and thus we + -- should get better results. + threadDelay 100_000 + + -- + -- timeout thread + -- + timeout = do + threadDelay + $ (fromIntegral $ ntpResponseTimeout netSettings) + + 100_000 * length destAddrs + traceWith tracer $ NtpTraceWaitingForRepliesTimeout protocol + + -- + -- receiving thread + -- + receiver :: Socket -> TVar [NtpOffset] -> IO () + receiver socket inQueue = replicateM_ (length destAddrs) $ do + (bs, _) <- Socket.ByteString.recvFrom socket ntpPacketSize + t <- getCurrentTime + case decodeOrFail $ LBS.fromStrict bs of + Left (_, _, err) -> traceWith tracer $ NtpTracePacketDecodeError protocol err + -- TODO : filter bad packets, i.e. late packets and spoofed packets + Right (_, _, packet) -> do + traceWith tracer $ NtpTracePacketReceived protocol + let offset = (clockOffsetPure packet t) + atomically $ modifyTVar' inQueue ((:) offset) diff --git a/ntp-client/src/Network/NTP/Test.hs b/ntp-client/src/Network/NTP/Test.hs new file mode 100644 index 00000000000..9f4e1229137 --- /dev/null +++ b/ntp-client/src/Network/NTP/Test.hs @@ -0,0 +1,37 @@ +{-# LANGUAGE NumericUnderscores #-} +module Network.NTP.Test +where + +import Control.Concurrent (threadDelay) +import Control.Concurrent.Async +import Control.Monad (forever) +import Control.Tracer + +import Network.NTP.Client +import Network.NTP.Query + +testClient :: IO () +testClient = withNtpClient (contramapM (return . show) stdoutTracer) testSettings runApplication + where + runApplication ntpClient = do + link $ ntpThread ntpClient -- propergate any errors in the NTP thread. + race_ getLine $ forever $ do + status <- ntpQueryBlocking ntpClient + traceWith stdoutTracer $ show ("main"::String, status) + threadDelay 10_000_000 + +testNtpQuery :: IO () +testNtpQuery = forever $ do + status <- ntpQuery tracer testSettings + traceWith stdoutTracer $ show ("main"::String, status) + threadDelay 10_000_000 + where + tracer = contramapM (return . show) stdoutTracer + +testSettings :: NtpSettings +testSettings = NtpSettings + { ntpServers = ["0.de.pool.ntp.org", "0.europe.pool.ntp.org", "0.pool.ntp.org" + , "1.pool.ntp.org", "2.pool.ntp.org", "3.pool.ntp.org"] + , ntpResponseTimeout = fromInteger 1_000_000 + , ntpPollDelay = fromInteger 300_000_000 + } diff --git a/ntp-client/src/Network/NTP/Trace.hs b/ntp-client/src/Network/NTP/Trace.hs index ad21a6c9d33..051c20fb948 100644 --- a/ntp-client/src/Network/NTP/Trace.hs +++ b/ntp-client/src/Network/NTP/Trace.hs @@ -1,35 +1,31 @@ module Network.NTP.Trace where -import Control.Exception (IOException) -import Data.Time.Units (Microsecond) +import Network.NTP.Packet (Microsecond) + +data IPVersion = IPv4 | IPv6 + deriving (Show) data NtpTrace = NtpTraceStartNtpClient - | NtpTraceClientActNow - | NtpTraceClientForceCheck - | NtpTraceClientAbort - | NtpTraceUpdateStatusNoResponses - | NtpTraceUpdateStatusClockOffset Microsecond - | NtpTraceSendLoopCollectedAllResponses - | NtpTraceSpawnNtpClientStarting - | NtpTraceSpawnNtpClientStarted - | NtpTraceSpawnNtpClientSocketsClosed - | NtpTraceSpawnNtpClientResolveDNS - | NtpTraceSpawnNtpClientResolvePending - | NtpTraceReceiveLoopDecodeError String - | NtpTraceReceiveLoopHandleIOException IOException - | NtpTraceReceiveLoopException - | NtpTraceReceiveLoopLatePacket - | NtpTraceReceiveLoopPacketReceived - | NtpTraceReceiveLoopPacketDeltaTime Microsecond - | NtpTraceMkSocketsNoSockets - | NtpTraceMkSocketsIOExecption IOException - | NtpTraceResolvHostIOException IOException - | NtpTraceResolveHostNotResolved String - | NtpTraceResolveHostResolved String -- todo also log addr - | NtpTraceSocketCreated String String - | NtpTraceSendPacketNoMatchingSocket String String - | NtpTraceSentToIOException String IOException - | NtpTraceSentTryResend String - | NtpTraceSentNotRetrying + | NtpTraceTriggerUpdate + | NtpTraceRestartDelay !Int + | NtpTraceRestartingClient + | NtpTraceClientSleeping + | NtpTraceIOError !IOError + | NtpTraceLookupServerFailed !String + | NtpTraceClientStartQuery + | NtpTraceNoLocalAddr + | NtpTraceIPv4IPv6NoReplies + | NtpTraceReportPolicyQueryFailed + | NtpTraceQueryResult !Microsecond + | NtpTraceRunProtocolError !IPVersion !IOError + | NtpTraceRunProtocolNoResult !IPVersion + | NtpTraceRunProtocolSuccess !IPVersion + | NtpTraceSocketOpen !IPVersion + | NtpTraceSocketClosed !IPVersion + | NtpTracePacketSent !IPVersion + | NtpTracePacketSentError !IPVersion !IOError + | NtpTracePacketDecodeError !IPVersion !String + | NtpTracePacketReceived !IPVersion + | NtpTraceWaitingForRepliesTimeout !IPVersion deriving (Show) diff --git a/ntp-client/src/Network/NTP/Util.hs b/ntp-client/src/Network/NTP/Util.hs deleted file mode 100644 index 58f87f45fd1..00000000000 --- a/ntp-client/src/Network/NTP/Util.hs +++ /dev/null @@ -1,270 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeApplications #-} - -module Network.NTP.Util - ( ntpPort - , WithAddrFamily (..) - , runWithAddrFamily - , getAddrFamily - , AddrFamily (..) - , Addresses - , Sockets - , resolveNtpHost - , sendPacket - - , createAndBindSock - , udpLocalAddresses - - , pairThese - ) where - -import Control.Exception (Exception, IOException, catch, throw) -import Control.Monad (void) -import Control.Tracer -import Data.Bifunctor (Bifunctor (..)) -import Data.Binary (encode) -import Data.ByteString (ByteString) -import qualified Data.ByteString.Lazy as LBS -import Data.Foldable (traverse_) -import Data.List (find) -import Data.Semigroup (First (..), Last (..), Option (..), - Semigroup (..)) -import Data.These (These (..)) -import Network.Socket (AddrInfo, - AddrInfoFlag (AI_ADDRCONFIG, AI_PASSIVE), - Family (AF_INET, AF_INET6), PortNumber, SockAddr (..), - Socket, SocketOption (ReuseAddr), SocketType (Datagram), - addrAddress, addrFamily, addrFlags, addrSocketType) -import qualified Network.Socket as Socket -import qualified Network.Socket.ByteString as Socket.ByteString (sendTo) - -import Network.NTP.Packet (NtpPacket) -import Network.NTP.Trace (NtpTrace (..)) - -data AddrFamily = IPv4 | IPv6 - deriving Show - --- | --- Newtype wrapper which tags the type with either IPv4 or IPv6 phantom type. -data WithAddrFamily (t :: AddrFamily) a where - WithIPv6 :: a -> WithAddrFamily 'IPv6 a - WithIPv4 :: a -> WithAddrFamily 'IPv4 a - -instance Show a => Show (WithAddrFamily t a) where - show a = show (getAddrFamily a) ++ " " ++ show (runWithAddrFamily a) - -instance Eq a => Eq (WithAddrFamily t a) where - a == b = runWithAddrFamily a == runWithAddrFamily b - -instance Functor (WithAddrFamily t) where - fmap f (WithIPv6 a) = WithIPv6 (f a) - fmap f (WithIPv4 a) = WithIPv4 (f a) - -runWithAddrFamily :: WithAddrFamily t a -> a -runWithAddrFamily (WithIPv6 a) = a -runWithAddrFamily (WithIPv4 a) = a - -getAddrFamily :: WithAddrFamily t a -> AddrFamily -getAddrFamily (WithIPv6 _) = IPv6 -getAddrFamily (WithIPv4 _) = IPv4 - --- | --- Note that the composition of `foldThese . bimap f g` is a proof that --- @'These a b@ is the [free --- product](https://en.wikipedia.org/wiki/Free_product) of two semigroups @a@ --- and @b@. -foldThese - :: Semigroup a - => These a a - -> a -foldThese (This a) = a -foldThese (That a) = a -foldThese (These a1 a2) = a1 <> a2 - -pairThese - :: These a b - -> These x y - -> Maybe (These (a, x) (b, y)) -pairThese (These a b) (These x y) = Just $ These (a, x) (b, y) -pairThese (This a) (This x) = Just $ This (a, x) -pairThese (These a _) (This x) = Just $ This (a, x) -pairThese (This a) (These x _) = Just $ This (a, x) -pairThese (That b) (That y) = Just $ That (b, y) -pairThese (These _ b) (That y) = Just $ That (b, y) -pairThese (That b) (These _ y) = Just $ That (b, y) -pairThese _ _ = Nothing - --- | --- Store created sockets. If system supports IPv6 and IPv4 we create socket for --- IPv4 and IPv6. Otherwise only one. -type Sockets = These - (Last (WithAddrFamily 'IPv6 Socket)) - (Last (WithAddrFamily 'IPv4 Socket)) - --- | --- A counter part of @'Ntp.Client.Sockets'@ data type. -type Addresses = These - (First (WithAddrFamily 'IPv6 SockAddr)) - (First (WithAddrFamily 'IPv4 SockAddr)) - -ntpPort :: PortNumber -ntpPort = 123 - --- | --- Returns a list of alternatives. At most of length two, --- at most one ipv6 / ipv4 address. -resolveHost :: Tracer IO NtpTrace -> String -> IO (Maybe Addresses) -resolveHost tracer host = do - let hints = Socket.defaultHints - { addrSocketType = Datagram - , addrFlags = [AI_ADDRCONFIG] -- since we use @AF_INET@ family - } - -- TBD why catch here? Why not let @'resolveHost'@ throw the exception? - addrInfos <- Socket.getAddrInfo (Just hints) (Just host) Nothing - `catch` (\(e :: IOException) -> (traceWith tracer $ NtpTraceResolvHostIOException e) >> return []) - - let maddr = getOption $ foldMap fn addrInfos - case maddr of - Nothing -> traceWith tracer $ NtpTraceResolveHostNotResolved host - Just _addr -> traceWith tracer $ NtpTraceResolveHostResolved host - {- - where - g :: First (WithAddrFamily t SockAddr) -> [SockAddr] - g (First a) = [runWithAddrFamily a] - addrs :: [SockAddr] - addrs = foldThese . bimap g g $ addr - -} - - return maddr - where - -- Return supported address: one ipv6 and one ipv4 address. - fn :: AddrInfo -> Option Addresses - fn addr = case Socket.addrFamily addr of - Socket.AF_INET6 -> - Option $ Just $ This $ First $ (WithIPv6 $ Socket.addrAddress addr) - Socket.AF_INET -> - Option $ Just $ That $ First $ (WithIPv4 $ Socket.addrAddress addr) - _ -> mempty - -resolveNtpHost :: Tracer IO NtpTrace -> String -> IO (Maybe Addresses) -resolveNtpHost tracer host = do - addr <- resolveHost tracer host - return $ fmap (bimap adjustPort adjustPort) addr - where - adjustPort :: First (WithAddrFamily t SockAddr) -> First (WithAddrFamily t SockAddr) - adjustPort = fmap $ fmap (replacePort ntpPort) - -replacePort :: PortNumber -> SockAddr -> SockAddr -replacePort port (SockAddrInet _ host) = SockAddrInet port host -replacePort port (SockAddrInet6 _ flow host scope) = SockAddrInet6 port flow host scope -replacePort _ sockAddr = sockAddr - -createAndBindSock - :: Tracer IO NtpTrace - -> AddrFamily - -- ^ indicates which socket family to create, either @AF_INET6@ or @AF_INET@ - -> [AddrInfo] - -- ^ list of local addresses - -> IO (Maybe Sockets) -createAndBindSock tracer addressFamily addrs = - traverse createDo (selectAddr addrs) - where - selectAddr :: [AddrInfo] -> Maybe AddrInfo - selectAddr = find $ \addr -> - case addressFamily of - IPv6 -> addrFamily addr == AF_INET6 - IPv4 -> addrFamily addr == AF_INET - - createDo addr = do - sock <- Socket.socket (addrFamily addr) Datagram Socket.defaultProtocol - Socket.setSocketOption sock ReuseAddr 1 - Socket.bind sock (addrAddress addr) - traceWith tracer $ NtpTraceSocketCreated (show $ addrFamily addr) (show $ addrAddress addr) --- logInfo $ --- sformat ("Created socket (family/addr): "%shown%"/"%shown) --- (addrFamily addr) (addrAddress addr) - case addressFamily of - IPv6 -> return $ This $ Last $ (WithIPv6 sock) - IPv4 -> return $ That $ Last $ (WithIPv4 sock) - -udpLocalAddresses :: IO [AddrInfo] -udpLocalAddresses = do - let hints = Socket.defaultHints - { addrFlags = [AI_PASSIVE] - , addrSocketType = Datagram } -#if MIN_VERSION_network(2,8,0) - port = Socket.defaultPort -#else - port = Socket.aNY_PORT -#endif - -- Hints Host Service - Socket.getAddrInfo (Just hints) Nothing (Just $ show port) - -data SendToException - = NoMatchingSocket - | SendToIOException AddrFamily IOException - deriving Show - -instance Exception SendToException - - --- | --- Send a request to @addr :: Addresses@ using @sock :: Sockets@. -sendTo - :: Sockets - -> ByteString - -> Addresses - -- ^ addresses to send to - -> IO () -sendTo sock bs addr = case pairThese sock addr of - Just s -> foldThese $ bimap fn fn s - Nothing -> throw NoMatchingSocket - where - fn :: ( Last (WithAddrFamily t Socket) - , First (WithAddrFamily t SockAddr) - ) - -> IO () - fn (Last sock_, First addr_) = - void (Socket.ByteString.sendTo (runWithAddrFamily sock_) bs (runWithAddrFamily addr_)) - `catch` handleIOException (getAddrFamily addr_) - - handleIOException :: AddrFamily -> IOException -> IO () - handleIOException addressFamily e = throw (SendToIOException addressFamily e) - --- | --- Low level primitive which sends a request to a single NTP server. -sendPacket - :: Tracer IO NtpTrace - -> Sockets - -> NtpPacket - -> [Addresses] - -> IO () -sendPacket tracer sock packet addrs = do - let bs = LBS.toStrict $ encode $ packet - traverse_ - (\addr -> - (sendTo sock bs addr) - `catch` handleSendToException addr - ) - addrs - where - handleSendToException :: Addresses -> SendToException -> IO () - handleSendToException addr NoMatchingSocket = - traceWith tracer $ NtpTraceSendPacketNoMatchingSocket (show addr) (show sock) - handleSendToException addr (SendToIOException addressFamily ioerr) = do - traceWith tracer $ NtpTraceSentToIOException (show addressFamily) ioerr - case (addr, addressFamily) of - -- try to send the packet to the other address in case the current - -- system does not support IPv4/6. - (These _ r, IPv6) -> do - traceWith tracer $ NtpTraceSentTryResend $ show $ runWithAddrFamily $ getFirst r - sendPacket tracer sock packet [That r] - (These l _, IPv4) -> do - traceWith tracer $ NtpTraceSentTryResend $ show $ runWithAddrFamily $ getFirst l - sendPacket tracer sock packet [This l] - _ -> traceWith tracer $ NtpTraceSentNotRetrying diff --git a/ntp-client/test/NtpApp.hs b/ntp-client/test/NtpApp.hs deleted file mode 100644 index c84afbd7dd5..00000000000 --- a/ntp-client/test/NtpApp.hs +++ /dev/null @@ -1,25 +0,0 @@ -module Main -where -import Control.Concurrent (threadDelay) -import Control.Concurrent.STM (atomically) -import Control.Concurrent.Async -import Control.Monad -import Control.Tracer - -import Network.NTP.Client - -settings :: NtpClientSettings -settings = NtpClientSettings - { ntpServers = ["0.de.pool.ntp.org","0.europe.pool.ntp.org","0.pool.ntp.org"] - , ntpResponseTimeout = fromInteger 1000000 - , ntpPollDelay = fromInteger 3000000 - , ntpSelection = minimum - } - -main :: IO () -main = withNtpClient (contramapM (return . show) stdoutTracer) settings runClient - where - runClient ntpClient = race_ getLine $ forever $ do - status <- atomically $ ntpGetStatus ntpClient - traceWith stdoutTracer $ show ("main",status) - threadDelay 3000000 diff --git a/ntp-client/test/Test.hs b/ntp-client/test/Test.hs index 2ada6f89966..6c903dbd84c 100644 --- a/ntp-client/test/Test.hs +++ b/ntp-client/test/Test.hs @@ -6,15 +6,27 @@ module Main ) where import Data.Binary (decodeOrFail, encode) -import Data.Time.Units (Microsecond, fromMicroseconds, toMicroseconds) import Data.Word (Word32) import Test.Tasty (TestTree, defaultMain, testGroup) import Test.Tasty.QuickCheck (testProperty) -import Test.QuickCheck (Arbitrary (..), Gen, Property, NonNegative(..) , arbitrary, choose, counterexample, sized, (.&&.), (===)) - -import Network.NTP.Packet (NtpOffset (..), NtpPacket (..), clockOffsetPure, - ntpToRealMcs, realMcsToNtp) +import Test.QuickCheck ( Arbitrary (..) + , Gen + , Property + , NonNegative(..) + , arbitrary + , choose + , counterexample + , sized + , (.&&.) + , (===)) + +import Network.NTP.Packet ( Microsecond (..) + , NtpOffset (..) + , NtpPacket (..) + , clockOffsetPure + , ntpToRealMcs + , realMcsToNtp) main :: IO () main = defaultMain tests @@ -27,12 +39,12 @@ data NtpPacketWithOffset = NtpPacketWithOffset deriving (Show) genMicro :: Gen Microsecond -genMicro = fromMicroseconds <$> arbitrary +genMicro = Microsecond <$> arbitrary genMicroNotBefore :: Microsecond -> Gen Microsecond -genMicroNotBefore t = do +genMicroNotBefore (Microsecond t) = do (NonNegative offset) <- arbitrary - return $ fromMicroseconds $ toMicroseconds t + offset + return $ Microsecond $ t + offset newtype ArbitraryNtpPacket = ArbitraryNtpPacket NtpPacket @@ -54,7 +66,7 @@ instance Arbitrary ArbitraryNtpPacket where instance Arbitrary NtpPacketWithOffset where arbitrary = sized $ \offset -> do let drift :: Microsecond - drift = fromMicroseconds $ fromIntegral offset + drift = Microsecond $ fromIntegral offset ntpParams <- arbitrary ntpPoll <- arbitrary ntpOriginTime <- genMicro @@ -86,7 +98,7 @@ newtype NtpMicrosecond = NtpMicrosecond Microsecond -- Generate NtpMicrosecond which must be smaller than -- @'maxBound' \@Word32 - 2200898800@ (we substract 70 years in seconds). instance Arbitrary NtpMicrosecond where - arbitrary = (NtpMicrosecond . fromMicroseconds) <$> choose (0, endTime) + arbitrary = (NtpMicrosecond . Microsecond) <$> choose (0, endTime) where endTime = (fromIntegral $ maxBound @Word32) - 2208988800 tests:: TestTree diff --git a/stack.yaml b/stack.yaml index 11788d3b8ae..c2d56680e86 100644 --- a/stack.yaml +++ b/stack.yaml @@ -70,7 +70,6 @@ extra-deps: - hedgehog-quickcheck-0.1.1 - quickcheck-state-machine-0.6.0 - splitmix-0.0.2 - - time-units-1.0.0 - tasty-hedgehog-1.0.0.1 - Unique-0.4.7.6 - statistics-linreg-0.3