{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveFoldable #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE NumericUnderscores #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Network.NTP.Client.Query (
NtpSettings(..)
, NtpStatus(..)
, ntpQuery
, NtpTrace(..)
, IPVersion (..)
, ResultOrFailure (..)
) where
import Control.Concurrent (threadDelay)
import Control.Concurrent.Async
import Control.Concurrent.STM
import Control.Exception (Exception (..), IOException, bracket, catch, throwIO)
import Control.Monad (foldM, forM_, replicateM_, when)
import Control.Tracer
import Data.Binary (decodeOrFail, encode)
import Data.Bifunctor (bimap)
import qualified Data.ByteString.Lazy as LBS
import Data.Either (partitionEithers)
import Data.Functor (void)
import Data.Foldable (Foldable (..), fold)
import Data.Maybe
import Network.Socket (Socket, SockAddr (..), AddrInfo (..))
import qualified Network.Socket as Socket
#if !defined(mingw32_HOST_OS)
import qualified Network.Socket.ByteString as Socket.ByteString (recvFrom, sendManyTo)
#else
import qualified System.Win32.Async.Socket.ByteString as Win32.Async
#endif
import System.IOManager
import Network.NTP.Client.Packet
( NtpPacket
, mkNtpPacket
, ntpPacketSize
, Microsecond
, NtpOffset (..)
, getCurrentTime
, clockOffsetPure
)
data NtpSettings = NtpSettings
{ NtpSettings -> [String]
ntpServers :: [String]
, NtpSettings -> Int
ntpRequiredNumberOfResults :: Int
, NtpSettings -> Microsecond
ntpResponseTimeout :: Microsecond
, NtpSettings -> Microsecond
ntpPollDelay :: Microsecond
}
data NtpStatus =
NtpDrift !NtpOffset
| NtpSyncPending
| NtpSyncUnavailable deriving (NtpStatus -> NtpStatus -> Bool
(NtpStatus -> NtpStatus -> Bool)
-> (NtpStatus -> NtpStatus -> Bool) -> Eq NtpStatus
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: NtpStatus -> NtpStatus -> Bool
$c/= :: NtpStatus -> NtpStatus -> Bool
== :: NtpStatus -> NtpStatus -> Bool
$c== :: NtpStatus -> NtpStatus -> Bool
Eq, Int -> NtpStatus -> ShowS
[NtpStatus] -> ShowS
NtpStatus -> String
(Int -> NtpStatus -> ShowS)
-> (NtpStatus -> String)
-> ([NtpStatus] -> ShowS)
-> Show NtpStatus
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [NtpStatus] -> ShowS
$cshowList :: [NtpStatus] -> ShowS
show :: NtpStatus -> String
$cshow :: NtpStatus -> String
showsPrec :: Int -> NtpStatus -> ShowS
$cshowsPrec :: Int -> NtpStatus -> ShowS
Show)
minimumOfSome :: Int -> [NtpOffset] -> Maybe NtpOffset
minimumOfSome :: Int -> [NtpOffset] -> Maybe NtpOffset
minimumOfSome Int
threshold [NtpOffset]
l
= if [NtpOffset] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [NtpOffset]
l Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
threshold
then NtpOffset -> Maybe NtpOffset
forall a. a -> Maybe a
Just (NtpOffset -> Maybe NtpOffset) -> NtpOffset -> Maybe NtpOffset
forall a b. (a -> b) -> a -> b
$ [NtpOffset] -> NtpOffset
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
minimum [NtpOffset]
l
else Maybe NtpOffset
forall a. Maybe a
Nothing
udpLocalAddresses :: IO [AddrInfo]
udpLocalAddresses :: IO [AddrInfo]
udpLocalAddresses = Maybe AddrInfo -> Maybe String -> Maybe String -> IO [AddrInfo]
Socket.getAddrInfo (AddrInfo -> Maybe AddrInfo
forall a. a -> Maybe a
Just AddrInfo
hints) Maybe String
forall a. Maybe a
Nothing (String -> Maybe String
forall a. a -> Maybe a
Just (String -> Maybe String) -> String -> Maybe String
forall a b. (a -> b) -> a -> b
$ PortNumber -> String
forall a. Show a => a -> String
show PortNumber
port)
where
hints :: AddrInfo
hints = AddrInfo
Socket.defaultHints
{ addrFlags :: [AddrInfoFlag]
addrFlags = [AddrInfoFlag
Socket.AI_PASSIVE]
, addrSocketType :: SocketType
addrSocketType = SocketType
Socket.Datagram
}
port :: PortNumber
port = PortNumber
Socket.defaultPort
lookupNtpServers :: Tracer IO NtpTrace -> NtpSettings -> IO ([SockAddr], [SockAddr])
lookupNtpServers :: Tracer IO NtpTrace -> NtpSettings -> IO ([SockAddr], [SockAddr])
lookupNtpServers Tracer IO NtpTrace
tracer NtpSettings { [String]
ntpServers :: [String]
ntpServers :: NtpSettings -> [String]
ntpServers, Int
ntpRequiredNumberOfResults :: Int
ntpRequiredNumberOfResults :: NtpSettings -> Int
ntpRequiredNumberOfResults } = do
addrs :: ([SockAddr], [SockAddr])
addrs@([SockAddr]
ipv4s, [SockAddr]
ipv6s) <- (([SockAddr], [SockAddr]) -> String -> IO ([SockAddr], [SockAddr]))
-> ([SockAddr], [SockAddr])
-> [String]
-> IO ([SockAddr], [SockAddr])
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM ([SockAddr], [SockAddr]) -> String -> IO ([SockAddr], [SockAddr])
fn ([], []) [String]
ntpServers
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ([SockAddr] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([SockAddr]
ipv4s [SockAddr] -> [SockAddr] -> [SockAddr]
forall a. [a] -> [a] -> [a]
++ [SockAddr]
ipv6s) Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
ntpRequiredNumberOfResults) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
Tracer IO NtpTrace -> NtpTrace -> IO ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer IO NtpTrace
tracer (NtpTrace -> IO ()) -> NtpTrace -> IO ()
forall a b. (a -> b) -> a -> b
$ NtpTrace
NtpTraceLookupsFails
IOError -> IO ()
forall a. IOError -> IO a
ioError (IOError -> IO ()) -> IOError -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> IOError
userError String
"lookup NTP servers failed"
([SockAddr], [SockAddr]) -> IO ([SockAddr], [SockAddr])
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([SockAddr], [SockAddr])
addrs
where
fn :: ([SockAddr], [SockAddr]) -> String -> IO ([SockAddr], [SockAddr])
fn ([SockAddr]
as, [SockAddr]
bs) String
host = do
[AddrInfo]
addrs <- Maybe AddrInfo -> Maybe String -> Maybe String -> IO [AddrInfo]
Socket.getAddrInfo (AddrInfo -> Maybe AddrInfo
forall a. a -> Maybe a
Just AddrInfo
hints) (String -> Maybe String
forall a. a -> Maybe a
Just String
host) Maybe String
forall a. Maybe a
Nothing
case ([AddrInfo] -> Maybe AddrInfo)
-> ([AddrInfo] -> Maybe AddrInfo)
-> ([AddrInfo], [AddrInfo])
-> (Maybe AddrInfo, Maybe AddrInfo)
forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap [AddrInfo] -> Maybe AddrInfo
forall a. [a] -> Maybe a
listToMaybe [AddrInfo] -> Maybe AddrInfo
forall a. [a] -> Maybe a
listToMaybe (([AddrInfo], [AddrInfo]) -> (Maybe AddrInfo, Maybe AddrInfo))
-> ([AddrInfo], [AddrInfo]) -> (Maybe AddrInfo, Maybe AddrInfo)
forall a b. (a -> b) -> a -> b
$ [AddrInfo] -> ([AddrInfo], [AddrInfo])
partitionAddrInfos [AddrInfo]
addrs of
(Maybe AddrInfo
mipv4, Maybe AddrInfo
mipv6) ->
([SockAddr], [SockAddr]) -> IO ([SockAddr], [SockAddr])
forall (f :: * -> *) a. Applicative f => a -> f a
pure (([SockAddr], [SockAddr]) -> IO ([SockAddr], [SockAddr]))
-> ([SockAddr], [SockAddr]) -> IO ([SockAddr], [SockAddr])
forall a b. (a -> b) -> a -> b
$
( (SockAddr -> SockAddr
setNtpPort (SockAddr -> SockAddr)
-> (AddrInfo -> SockAddr) -> AddrInfo -> SockAddr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AddrInfo -> SockAddr
Socket.addrAddress (AddrInfo -> SockAddr) -> [AddrInfo] -> [SockAddr]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe AddrInfo -> [AddrInfo]
forall a. Maybe a -> [a]
maybeToList Maybe AddrInfo
mipv4) [SockAddr] -> [SockAddr] -> [SockAddr]
forall a. [a] -> [a] -> [a]
++ [SockAddr]
as
, (SockAddr -> SockAddr
setNtpPort (SockAddr -> SockAddr)
-> (AddrInfo -> SockAddr) -> AddrInfo -> SockAddr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AddrInfo -> SockAddr
Socket.addrAddress (AddrInfo -> SockAddr) -> [AddrInfo] -> [SockAddr]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe AddrInfo -> [AddrInfo]
forall a. Maybe a -> [a]
maybeToList Maybe AddrInfo
mipv6) [SockAddr] -> [SockAddr] -> [SockAddr]
forall a. [a] -> [a] -> [a]
++ [SockAddr]
bs
)
setNtpPort :: SockAddr -> SockAddr
setNtpPort :: SockAddr -> SockAddr
setNtpPort SockAddr
addr = case SockAddr
addr of
(SockAddrInet PortNumber
_ HostAddress
host) -> PortNumber -> HostAddress -> SockAddr
SockAddrInet PortNumber
ntpPort HostAddress
host
(SockAddrInet6 PortNumber
_ HostAddress
flow HostAddress6
host HostAddress
scope) -> PortNumber
-> HostAddress -> HostAddress6 -> HostAddress -> SockAddr
SockAddrInet6 PortNumber
ntpPort HostAddress
flow HostAddress6
host HostAddress
scope
SockAddr
sockAddr -> SockAddr
sockAddr
where
ntpPort :: Socket.PortNumber
ntpPort :: PortNumber
ntpPort = PortNumber
123
hints :: AddrInfo
hints =
AddrInfo
Socket.defaultHints
{ addrSocketType :: SocketType
addrSocketType = SocketType
Socket.Datagram
, addrFlags :: [AddrInfoFlag]
addrFlags =
if AddrInfoFlag -> Bool
Socket.addrInfoFlagImplemented AddrInfoFlag
Socket.AI_ADDRCONFIG
then [AddrInfoFlag
Socket.AI_ADDRCONFIG]
else []
}
waitCatchIOException :: Async a -> IO (Either IOException a)
waitCatchIOException :: Async a -> IO (Either IOError a)
waitCatchIOException Async a
a =
Async a -> IO (Either SomeException a)
forall a. Async a -> IO (Either SomeException a)
waitCatch Async a
a IO (Either SomeException a)
-> (Either SomeException a -> IO (Either IOError a))
-> IO (Either IOError a)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Left SomeException
err ->
case SomeException -> Maybe IOError
forall e. Exception e => SomeException -> Maybe e
fromException SomeException
err of
Just IOError
ioerr -> Either IOError a -> IO (Either IOError a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (IOError -> Either IOError a
forall a b. a -> Either a b
Left IOError
ioerr)
Maybe IOError
Nothing -> SomeException -> IO (Either IOError a)
forall e a. Exception e => e -> IO a
throwIO SomeException
err
Right a
x -> Either IOError a -> IO (Either IOError a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (a -> Either IOError a
forall a b. b -> Either a b
Right a
x)
partitionAddrInfos :: [AddrInfo] -> ([AddrInfo], [AddrInfo])
partitionAddrInfos :: [AddrInfo] -> ([AddrInfo], [AddrInfo])
partitionAddrInfos = [Either AddrInfo AddrInfo] -> ([AddrInfo], [AddrInfo])
forall a b. [Either a b] -> ([a], [b])
partitionEithers ([Either AddrInfo AddrInfo] -> ([AddrInfo], [AddrInfo]))
-> ([AddrInfo] -> [Either AddrInfo AddrInfo])
-> [AddrInfo]
-> ([AddrInfo], [AddrInfo])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (AddrInfo -> Maybe (Either AddrInfo AddrInfo))
-> [AddrInfo] -> [Either AddrInfo AddrInfo]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe AddrInfo -> Maybe (Either AddrInfo AddrInfo)
fn
where
fn :: AddrInfo -> Maybe (Either AddrInfo AddrInfo)
fn :: AddrInfo -> Maybe (Either AddrInfo AddrInfo)
fn AddrInfo
a | AddrInfo -> Family
Socket.addrFamily AddrInfo
a Family -> Family -> Bool
forall a. Eq a => a -> a -> Bool
== Family
Socket.AF_INET = Either AddrInfo AddrInfo -> Maybe (Either AddrInfo AddrInfo)
forall a. a -> Maybe a
Just (AddrInfo -> Either AddrInfo AddrInfo
forall a b. a -> Either a b
Left AddrInfo
a)
| AddrInfo -> Family
Socket.addrFamily AddrInfo
a Family -> Family -> Bool
forall a. Eq a => a -> a -> Bool
== Family
Socket.AF_INET6 = Either AddrInfo AddrInfo -> Maybe (Either AddrInfo AddrInfo)
forall a. a -> Maybe a
Just (AddrInfo -> Either AddrInfo AddrInfo
forall a b. b -> Either a b
Right AddrInfo
a)
| Bool
otherwise = Maybe (Either AddrInfo AddrInfo)
forall a. Maybe a
Nothing
data IPVersion = IPv4 | IPv6
deriving (IPVersion -> IPVersion -> Bool
(IPVersion -> IPVersion -> Bool)
-> (IPVersion -> IPVersion -> Bool) -> Eq IPVersion
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: IPVersion -> IPVersion -> Bool
$c/= :: IPVersion -> IPVersion -> Bool
== :: IPVersion -> IPVersion -> Bool
$c== :: IPVersion -> IPVersion -> Bool
Eq, Int -> IPVersion -> ShowS
[IPVersion] -> ShowS
IPVersion -> String
(Int -> IPVersion -> ShowS)
-> (IPVersion -> String)
-> ([IPVersion] -> ShowS)
-> Show IPVersion
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [IPVersion] -> ShowS
$cshowList :: [IPVersion] -> ShowS
show :: IPVersion -> String
$cshow :: IPVersion -> String
showsPrec :: Int -> IPVersion -> ShowS
$cshowsPrec :: Int -> IPVersion -> ShowS
Show)
data ResultOrFailure a
= BothSucceeded !a
| SuccessAndFailure !a !IPVersion !IOException
| BothFailed !IOException !IOException
deriving (ResultOrFailure a -> ResultOrFailure a -> Bool
(ResultOrFailure a -> ResultOrFailure a -> Bool)
-> (ResultOrFailure a -> ResultOrFailure a -> Bool)
-> Eq (ResultOrFailure a)
forall a. Eq a => ResultOrFailure a -> ResultOrFailure a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ResultOrFailure a -> ResultOrFailure a -> Bool
$c/= :: forall a. Eq a => ResultOrFailure a -> ResultOrFailure a -> Bool
== :: ResultOrFailure a -> ResultOrFailure a -> Bool
$c== :: forall a. Eq a => ResultOrFailure a -> ResultOrFailure a -> Bool
Eq, ResultOrFailure a -> Bool
(a -> m) -> ResultOrFailure a -> m
(a -> b -> b) -> b -> ResultOrFailure a -> b
(forall m. Monoid m => ResultOrFailure m -> m)
-> (forall m a. Monoid m => (a -> m) -> ResultOrFailure a -> m)
-> (forall m a. Monoid m => (a -> m) -> ResultOrFailure a -> m)
-> (forall a b. (a -> b -> b) -> b -> ResultOrFailure a -> b)
-> (forall a b. (a -> b -> b) -> b -> ResultOrFailure a -> b)
-> (forall b a. (b -> a -> b) -> b -> ResultOrFailure a -> b)
-> (forall b a. (b -> a -> b) -> b -> ResultOrFailure a -> b)
-> (forall a. (a -> a -> a) -> ResultOrFailure a -> a)
-> (forall a. (a -> a -> a) -> ResultOrFailure a -> a)
-> (forall a. ResultOrFailure a -> [a])
-> (forall a. ResultOrFailure a -> Bool)
-> (forall a. ResultOrFailure a -> Int)
-> (forall a. Eq a => a -> ResultOrFailure a -> Bool)
-> (forall a. Ord a => ResultOrFailure a -> a)
-> (forall a. Ord a => ResultOrFailure a -> a)
-> (forall a. Num a => ResultOrFailure a -> a)
-> (forall a. Num a => ResultOrFailure a -> a)
-> Foldable ResultOrFailure
forall a. Eq a => a -> ResultOrFailure a -> Bool
forall a. Num a => ResultOrFailure a -> a
forall a. Ord a => ResultOrFailure a -> a
forall m. Monoid m => ResultOrFailure m -> m
forall a. ResultOrFailure a -> Bool
forall a. ResultOrFailure a -> Int
forall a. ResultOrFailure a -> [a]
forall a. (a -> a -> a) -> ResultOrFailure a -> a
forall m a. Monoid m => (a -> m) -> ResultOrFailure a -> m
forall b a. (b -> a -> b) -> b -> ResultOrFailure a -> b
forall a b. (a -> b -> b) -> b -> ResultOrFailure a -> b
forall (t :: * -> *).
(forall m. Monoid m => t m -> m)
-> (forall m a. Monoid m => (a -> m) -> t a -> m)
-> (forall m a. Monoid m => (a -> m) -> t a -> m)
-> (forall a b. (a -> b -> b) -> b -> t a -> b)
-> (forall a b. (a -> b -> b) -> b -> t a -> b)
-> (forall b a. (b -> a -> b) -> b -> t a -> b)
-> (forall b a. (b -> a -> b) -> b -> t a -> b)
-> (forall a. (a -> a -> a) -> t a -> a)
-> (forall a. (a -> a -> a) -> t a -> a)
-> (forall a. t a -> [a])
-> (forall a. t a -> Bool)
-> (forall a. t a -> Int)
-> (forall a. Eq a => a -> t a -> Bool)
-> (forall a. Ord a => t a -> a)
-> (forall a. Ord a => t a -> a)
-> (forall a. Num a => t a -> a)
-> (forall a. Num a => t a -> a)
-> Foldable t
product :: ResultOrFailure a -> a
$cproduct :: forall a. Num a => ResultOrFailure a -> a
sum :: ResultOrFailure a -> a
$csum :: forall a. Num a => ResultOrFailure a -> a
minimum :: ResultOrFailure a -> a
$cminimum :: forall a. Ord a => ResultOrFailure a -> a
maximum :: ResultOrFailure a -> a
$cmaximum :: forall a. Ord a => ResultOrFailure a -> a
elem :: a -> ResultOrFailure a -> Bool
$celem :: forall a. Eq a => a -> ResultOrFailure a -> Bool
length :: ResultOrFailure a -> Int
$clength :: forall a. ResultOrFailure a -> Int
null :: ResultOrFailure a -> Bool
$cnull :: forall a. ResultOrFailure a -> Bool
toList :: ResultOrFailure a -> [a]
$ctoList :: forall a. ResultOrFailure a -> [a]
foldl1 :: (a -> a -> a) -> ResultOrFailure a -> a
$cfoldl1 :: forall a. (a -> a -> a) -> ResultOrFailure a -> a
foldr1 :: (a -> a -> a) -> ResultOrFailure a -> a
$cfoldr1 :: forall a. (a -> a -> a) -> ResultOrFailure a -> a
foldl' :: (b -> a -> b) -> b -> ResultOrFailure a -> b
$cfoldl' :: forall b a. (b -> a -> b) -> b -> ResultOrFailure a -> b
foldl :: (b -> a -> b) -> b -> ResultOrFailure a -> b
$cfoldl :: forall b a. (b -> a -> b) -> b -> ResultOrFailure a -> b
foldr' :: (a -> b -> b) -> b -> ResultOrFailure a -> b
$cfoldr' :: forall a b. (a -> b -> b) -> b -> ResultOrFailure a -> b
foldr :: (a -> b -> b) -> b -> ResultOrFailure a -> b
$cfoldr :: forall a b. (a -> b -> b) -> b -> ResultOrFailure a -> b
foldMap' :: (a -> m) -> ResultOrFailure a -> m
$cfoldMap' :: forall m a. Monoid m => (a -> m) -> ResultOrFailure a -> m
foldMap :: (a -> m) -> ResultOrFailure a -> m
$cfoldMap :: forall m a. Monoid m => (a -> m) -> ResultOrFailure a -> m
fold :: ResultOrFailure m -> m
$cfold :: forall m. Monoid m => ResultOrFailure m -> m
Foldable)
instance Show a => Show (ResultOrFailure a) where
show :: ResultOrFailure a -> String
show (BothSucceeded a
a) = String
"BothSucceded " String -> ShowS
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Show a => a -> String
show a
a
show (SuccessAndFailure a
a IPVersion
ipVersion IOError
e) = [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
[ String
"SuccessAndFailure "
, a -> String
forall a. Show a => a -> String
show a
a
, String
" "
, (IPVersion, IOError) -> String
forall a. Show a => a -> String
show (IPVersion
ipVersion, IOError
e)
]
show (BothFailed IOError
e4 IOError
e6) = [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
[ String
"BothFailed "
, IOError -> String
forall a. Show a => a -> String
show IOError
e4
, String
" "
, IOError -> String
forall a. Show a => a -> String
show IOError
e6
]
ntpQuery
:: IOManager
-> Tracer IO NtpTrace
-> NtpSettings
-> IO NtpStatus
ntpQuery :: IOManager -> Tracer IO NtpTrace -> NtpSettings -> IO NtpStatus
ntpQuery IOManager
ioManager Tracer IO NtpTrace
tracer ntpSettings :: NtpSettings
ntpSettings@NtpSettings { Int
ntpRequiredNumberOfResults :: Int
ntpRequiredNumberOfResults :: NtpSettings -> Int
ntpRequiredNumberOfResults } = do
Tracer IO NtpTrace -> NtpTrace -> IO ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer IO NtpTrace
tracer NtpTrace
NtpTraceClientStartQuery
([SockAddr]
v4Servers, [SockAddr]
v6Servers) <- Tracer IO NtpTrace -> NtpSettings -> IO ([SockAddr], [SockAddr])
lookupNtpServers Tracer IO NtpTrace
tracer NtpSettings
ntpSettings
[AddrInfo]
localAddrs <- IO [AddrInfo]
udpLocalAddresses
(Maybe AddrInfo
v4LocalAddr, Maybe AddrInfo
v6LocalAddr)
<- case [AddrInfo] -> ([AddrInfo], [AddrInfo])
partitionAddrInfos [AddrInfo]
localAddrs of
([], []) -> do
Tracer IO NtpTrace -> NtpTrace -> IO ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer IO NtpTrace
tracer NtpTrace
NtpTraceNoLocalAddr
IOError -> IO (Maybe AddrInfo, Maybe AddrInfo)
forall a. IOError -> IO a
ioError (IOError -> IO (Maybe AddrInfo, Maybe AddrInfo))
-> IOError -> IO (Maybe AddrInfo, Maybe AddrInfo)
forall a b. (a -> b) -> a -> b
$ String -> IOError
userError String
"no local address IPv4 and IPv6"
([AddrInfo]
ipv4s, [AddrInfo]
ipv6s) -> (Maybe AddrInfo, Maybe AddrInfo)
-> IO (Maybe AddrInfo, Maybe AddrInfo)
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((Maybe AddrInfo, Maybe AddrInfo)
-> IO (Maybe AddrInfo, Maybe AddrInfo))
-> (Maybe AddrInfo, Maybe AddrInfo)
-> IO (Maybe AddrInfo, Maybe AddrInfo)
forall a b. (a -> b) -> a -> b
$
( [AddrInfo] -> Maybe AddrInfo
forall a. [a] -> Maybe a
listToMaybe [AddrInfo]
ipv4s
, [AddrInfo] -> Maybe AddrInfo
forall a. [a] -> Maybe a
listToMaybe [AddrInfo]
ipv6s
)
IO [NtpOffset]
-> (Async [NtpOffset] -> IO NtpStatus) -> IO NtpStatus
forall a b. IO a -> (Async a -> IO b) -> IO b
withAsync (IPVersion -> Maybe AddrInfo -> [SockAddr] -> IO [NtpOffset]
runProtocol IPVersion
IPv4 Maybe AddrInfo
v4LocalAddr [SockAddr]
v4Servers) ((Async [NtpOffset] -> IO NtpStatus) -> IO NtpStatus)
-> (Async [NtpOffset] -> IO NtpStatus) -> IO NtpStatus
forall a b. (a -> b) -> a -> b
$ \Async [NtpOffset]
ipv4Async ->
IO [NtpOffset]
-> (Async [NtpOffset] -> IO NtpStatus) -> IO NtpStatus
forall a b. IO a -> (Async a -> IO b) -> IO b
withAsync (IPVersion -> Maybe AddrInfo -> [SockAddr] -> IO [NtpOffset]
runProtocol IPVersion
IPv6 Maybe AddrInfo
v6LocalAddr [SockAddr]
v6Servers) ((Async [NtpOffset] -> IO NtpStatus) -> IO NtpStatus)
-> (Async [NtpOffset] -> IO NtpStatus) -> IO NtpStatus
forall a b. (a -> b) -> a -> b
$ \Async [NtpOffset]
ipv6Async -> do
ResultOrFailure [NtpOffset]
results <- Either IOError [NtpOffset]
-> Either IOError [NtpOffset] -> ResultOrFailure [NtpOffset]
forall a.
Either IOError [a] -> Either IOError [a] -> ResultOrFailure [a]
mkResultOrFailure
(Either IOError [NtpOffset]
-> Either IOError [NtpOffset] -> ResultOrFailure [NtpOffset])
-> IO (Either IOError [NtpOffset])
-> IO (Either IOError [NtpOffset] -> ResultOrFailure [NtpOffset])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Async [NtpOffset] -> IO (Either IOError [NtpOffset])
forall a. Async a -> IO (Either IOError a)
waitCatchIOException Async [NtpOffset]
ipv4Async
IO (Either IOError [NtpOffset] -> ResultOrFailure [NtpOffset])
-> IO (Either IOError [NtpOffset])
-> IO (ResultOrFailure [NtpOffset])
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Async [NtpOffset] -> IO (Either IOError [NtpOffset])
forall a. Async a -> IO (Either IOError a)
waitCatchIOException Async [NtpOffset]
ipv6Async
Tracer IO NtpTrace -> NtpTrace -> IO ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer IO NtpTrace
tracer (ResultOrFailure [NtpOffset] -> NtpTrace
NtpTraceRunProtocolResults ResultOrFailure [NtpOffset]
results)
[NtpOffset] -> IO NtpStatus
handleResults (ResultOrFailure [NtpOffset] -> [NtpOffset]
forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold ResultOrFailure [NtpOffset]
results)
where
mkResultOrFailure :: Either IOException [a]
-> Either IOException [a]
-> ResultOrFailure [a]
mkResultOrFailure :: Either IOError [a] -> Either IOError [a] -> ResultOrFailure [a]
mkResultOrFailure (Right [a]
a0) (Right [a]
a1) = [a] -> ResultOrFailure [a]
forall a. a -> ResultOrFailure a
BothSucceeded ([a]
a0 [a] -> [a] -> [a]
forall a. Semigroup a => a -> a -> a
<> [a]
a1)
mkResultOrFailure (Left IOError
e) (Right [a]
a) = [a] -> IPVersion -> IOError -> ResultOrFailure [a]
forall a. a -> IPVersion -> IOError -> ResultOrFailure a
SuccessAndFailure [a]
a IPVersion
IPv4 IOError
e
mkResultOrFailure (Right [a]
a) (Left IOError
e) = [a] -> IPVersion -> IOError -> ResultOrFailure [a]
forall a. a -> IPVersion -> IOError -> ResultOrFailure a
SuccessAndFailure [a]
a IPVersion
IPv6 IOError
e
mkResultOrFailure (Left IOError
e0) (Left IOError
e1) = IOError -> IOError -> ResultOrFailure [a]
forall a. IOError -> IOError -> ResultOrFailure a
BothFailed IOError
e0 IOError
e1
runProtocol :: IPVersion -> Maybe AddrInfo -> [SockAddr] -> IO [NtpOffset]
runProtocol :: IPVersion -> Maybe AddrInfo -> [SockAddr] -> IO [NtpOffset]
runProtocol IPVersion
_protocol Maybe AddrInfo
_localAddr [] = [NtpOffset] -> IO [NtpOffset]
forall (m :: * -> *) a. Monad m => a -> m a
return []
runProtocol IPVersion
_protocol Maybe AddrInfo
Nothing [SockAddr]
_ = [NtpOffset] -> IO [NtpOffset]
forall (m :: * -> *) a. Monad m => a -> m a
return []
runProtocol IPVersion
protocol (Just AddrInfo
addr) [SockAddr]
servers = do
IOManager
-> Tracer IO NtpTrace
-> IPVersion
-> NtpSettings
-> AddrInfo
-> [SockAddr]
-> IO [NtpOffset]
runNtpQueries IOManager
ioManager Tracer IO NtpTrace
tracer IPVersion
protocol NtpSettings
ntpSettings AddrInfo
addr [SockAddr]
servers
handleResults :: [NtpOffset] -> IO NtpStatus
handleResults :: [NtpOffset] -> IO NtpStatus
handleResults [NtpOffset]
results = do
let result :: NtpStatus
result =
NtpStatus
-> (NtpOffset -> NtpStatus) -> Maybe NtpOffset -> NtpStatus
forall b a. b -> (a -> b) -> Maybe a -> b
maybe NtpStatus
NtpSyncUnavailable NtpOffset -> NtpStatus
NtpDrift
(Maybe NtpOffset -> NtpStatus) -> Maybe NtpOffset -> NtpStatus
forall a b. (a -> b) -> a -> b
$ Int -> [NtpOffset] -> Maybe NtpOffset
minimumOfSome Int
ntpRequiredNumberOfResults [NtpOffset]
results
Tracer IO NtpTrace -> NtpTrace -> IO ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer IO NtpTrace
tracer (NtpStatus -> NtpTrace
NtpTraceResult NtpStatus
result)
NtpStatus -> IO NtpStatus
forall (m :: * -> *) a. Monad m => a -> m a
return NtpStatus
result
runNtpQueries
:: IOManager
-> Tracer IO NtpTrace
-> IPVersion
-> NtpSettings
-> AddrInfo
-> [SockAddr]
-> IO [NtpOffset]
runNtpQueries :: IOManager
-> Tracer IO NtpTrace
-> IPVersion
-> NtpSettings
-> AddrInfo
-> [SockAddr]
-> IO [NtpOffset]
runNtpQueries IOManager
ioManager Tracer IO NtpTrace
tracer IPVersion
protocol NtpSettings
netSettings AddrInfo
localAddr [SockAddr]
destAddrs
= IO Socket
-> (Socket -> IO ())
-> (Socket -> IO [NtpOffset])
-> IO [NtpOffset]
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracket IO Socket
acquire Socket -> IO ()
release Socket -> IO [NtpOffset]
action
where
acquire :: IO Socket
acquire :: IO Socket
acquire = Family -> SocketType -> ProtocolNumber -> IO Socket
Socket.socket (AddrInfo -> Family
addrFamily AddrInfo
localAddr) SocketType
Socket.Datagram ProtocolNumber
Socket.defaultProtocol
release :: Socket -> IO ()
release :: Socket -> IO ()
release = Socket -> IO ()
Socket.close
action :: Socket -> IO [NtpOffset]
action :: Socket -> IO [NtpOffset]
action Socket
socket = do
IOManager -> Either Any Socket -> IO ()
IOManager -> forall hole. hole -> IO ()
associateWithIOManager IOManager
ioManager (Socket -> Either Any Socket
forall a b. b -> Either a b
Right Socket
socket)
Socket -> SocketOption -> Int -> IO ()
Socket.setSocketOption Socket
socket SocketOption
Socket.ReuseAddr Int
1
Socket -> SockAddr -> IO ()
Socket.bind Socket
socket (AddrInfo -> SockAddr
Socket.addrAddress AddrInfo
localAddr)
TVar [NtpOffset]
inQueue <- STM (TVar [NtpOffset]) -> IO (TVar [NtpOffset])
forall a. STM a -> IO a
atomically (STM (TVar [NtpOffset]) -> IO (TVar [NtpOffset]))
-> STM (TVar [NtpOffset]) -> IO (TVar [NtpOffset])
forall a b. (a -> b) -> a -> b
$ [NtpOffset] -> STM (TVar [NtpOffset])
forall a. a -> STM (TVar a)
newTVar []
IO () -> (Async () -> IO ()) -> IO ()
forall a b. IO a -> (Async a -> IO b) -> IO b
withAsync IO ()
timeout ((Async () -> IO ()) -> IO ()) -> (Async () -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Async ()
timeoutAsync ->
IO () -> (Async () -> IO ()) -> IO ()
forall a b. IO a -> (Async a -> IO b) -> IO b
withAsync (Socket -> TVar [NtpOffset] -> IO ()
receiver Socket
socket TVar [NtpOffset]
inQueue) ((Async () -> IO ()) -> IO ()) -> (Async () -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Async ()
receiverAsync -> do
[SockAddr] -> (SockAddr -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [SockAddr]
destAddrs ((SockAddr -> IO ()) -> IO ()) -> (SockAddr -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \SockAddr
addr ->
Socket -> SockAddr -> IO ()
sendNtpPacket Socket
socket SockAddr
addr
IO () -> (IOError -> IO ()) -> IO ()
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`catch`
\(IOError
e :: IOException) -> Tracer IO NtpTrace -> NtpTrace -> IO ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer IO NtpTrace
tracer (SockAddr -> IOError -> NtpTrace
NtpTracePacketSendError SockAddr
addr IOError
e)
IO (Async (), ()) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO (Async (), ()) -> IO ()) -> IO (Async (), ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ [Async ()] -> IO (Async (), ())
forall a. [Async a] -> IO (Async a, a)
waitAny [Async ()
timeoutAsync, Async ()
receiverAsync]
STM [NtpOffset] -> IO [NtpOffset]
forall a. STM a -> IO a
atomically (STM [NtpOffset] -> IO [NtpOffset])
-> STM [NtpOffset] -> IO [NtpOffset]
forall a b. (a -> b) -> a -> b
$ TVar [NtpOffset] -> STM [NtpOffset]
forall a. TVar a -> STM a
readTVar TVar [NtpOffset]
inQueue
sendNtpPacket :: Socket -> SockAddr -> IO ()
sendNtpPacket :: Socket -> SockAddr -> IO ()
sendNtpPacket Socket
sock SockAddr
addr = do
NtpPacket
p <- IO NtpPacket
mkNtpPacket
#if !defined(mingw32_HOST_OS)
()
_ <- Socket -> [ByteString] -> SockAddr -> IO ()
Socket.ByteString.sendManyTo Socket
sock (ByteString -> [ByteString]
LBS.toChunks (ByteString -> [ByteString]) -> ByteString -> [ByteString]
forall a b. (a -> b) -> a -> b
$ NtpPacket -> ByteString
forall a. Binary a => a -> ByteString
encode NtpPacket
p) SockAddr
addr
#else
_ <- Win32.Async.sendAllTo sock (LBS.toStrict $ encode p) addr
#endif
Int -> IO ()
threadDelay Int
100_000
timeout :: IO ()
timeout = do
Int -> IO ()
threadDelay
(Int -> IO ()) -> Int -> IO ()
forall a b. (a -> b) -> a -> b
$ (Microsecond -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Microsecond -> Int) -> Microsecond -> Int
forall a b. (a -> b) -> a -> b
$ NtpSettings -> Microsecond
ntpResponseTimeout NtpSettings
netSettings)
Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
100_000 Int -> Int -> Int
forall a. Num a => a -> a -> a
* [SockAddr] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [SockAddr]
destAddrs
Tracer IO NtpTrace -> NtpTrace -> IO ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer IO NtpTrace
tracer (NtpTrace -> IO ()) -> NtpTrace -> IO ()
forall a b. (a -> b) -> a -> b
$ IPVersion -> NtpTrace
NtpTraceWaitingForRepliesTimeout IPVersion
protocol
receiver :: Socket -> TVar [NtpOffset] -> IO ()
receiver :: Socket -> TVar [NtpOffset] -> IO ()
receiver Socket
socket TVar [NtpOffset]
inQueue = Int -> IO () -> IO ()
forall (m :: * -> *) a. Applicative m => Int -> m a -> m ()
replicateM_ ([SockAddr] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [SockAddr]
destAddrs) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
#if !defined(mingw32_HOST_OS)
(ByteString
bs, SockAddr
senderAddr) <- Socket -> Int -> IO (ByteString, SockAddr)
Socket.ByteString.recvFrom Socket
socket Int
ntpPacketSize
#else
(bs, senderAddr) <- Win32.Async.recvFrom socket ntpPacketSize
#endif
Microsecond
t <- IO Microsecond
getCurrentTime
case ByteString
-> Either
(ByteString, ByteOffset, String)
(ByteString, ByteOffset, NtpPacket)
forall a.
Binary a =>
ByteString
-> Either
(ByteString, ByteOffset, String) (ByteString, ByteOffset, a)
decodeOrFail (ByteString
-> Either
(ByteString, ByteOffset, String)
(ByteString, ByteOffset, NtpPacket))
-> ByteString
-> Either
(ByteString, ByteOffset, String)
(ByteString, ByteOffset, NtpPacket)
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
LBS.fromStrict ByteString
bs of
Left (ByteString
_, ByteOffset
_, String
err) -> Tracer IO NtpTrace -> NtpTrace -> IO ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer IO NtpTrace
tracer (NtpTrace -> IO ()) -> NtpTrace -> IO ()
forall a b. (a -> b) -> a -> b
$ SockAddr -> String -> NtpTrace
NtpTracePacketDecodeError SockAddr
senderAddr String
err
Right (ByteString
_, ByteOffset
_, NtpPacket
packet) -> do
Tracer IO NtpTrace -> NtpTrace -> IO ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer IO NtpTrace
tracer (NtpTrace -> IO ()) -> NtpTrace -> IO ()
forall a b. (a -> b) -> a -> b
$ SockAddr -> NtpPacket -> NtpTrace
NtpTracePacketReceived SockAddr
senderAddr NtpPacket
packet
let offset :: NtpOffset
offset = (NtpPacket -> Microsecond -> NtpOffset
clockOffsetPure NtpPacket
packet Microsecond
t)
STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ TVar [NtpOffset] -> ([NtpOffset] -> [NtpOffset]) -> STM ()
forall a. TVar a -> (a -> a) -> STM ()
modifyTVar' TVar [NtpOffset]
inQueue (NtpOffset
offset NtpOffset -> [NtpOffset] -> [NtpOffset]
forall a. a -> [a] -> [a]
:)
data NtpTrace
= NtpTraceStartNtpClient
| NtpTraceRestartDelay Int
| NtpTraceRestartingClient
| NtpTraceIOError IOError
| NtpTraceLookupsFails
| NtpTraceClientStartQuery
| NtpTraceNoLocalAddr
| NtpTraceResult NtpStatus
| NtpTraceRunProtocolResults (ResultOrFailure [NtpOffset])
| NtpTracePacketSent SockAddr NtpPacket
| NtpTracePacketSendError SockAddr IOException
| NtpTracePacketDecodeError SockAddr String
| NtpTracePacketReceived SockAddr NtpPacket
| NtpTraceWaitingForRepliesTimeout IPVersion
deriving (Int -> NtpTrace -> ShowS
[NtpTrace] -> ShowS
NtpTrace -> String
(Int -> NtpTrace -> ShowS)
-> (NtpTrace -> String) -> ([NtpTrace] -> ShowS) -> Show NtpTrace
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [NtpTrace] -> ShowS
$cshowList :: [NtpTrace] -> ShowS
show :: NtpTrace -> String
$cshow :: NtpTrace -> String
showsPrec :: Int -> NtpTrace -> ShowS
$cshowsPrec :: Int -> NtpTrace -> ShowS
Show)