{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NumericUnderscores #-}
{-# LANGUAGE TypeApplications #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}

-- |
-- Copyright: © 2020 IOHK
-- License: Apache-2.0
--
-- This module provides the Ntp client related settings, types
-- and re-exports used in a number of places throughout codebase.

module Network.Ntp
    ( withWalletNtpClient
    , getNtpStatus

    -- * re-exports from ntp-client
    , NtpTrace (..)
    , NtpClient (..)
    ) where

import Prelude

import Cardano.BM.Data.Severity
    ( Severity (..) )
import Cardano.BM.Data.Tracer
    ( HasPrivacyAnnotation (..), HasSeverityAnnotation (..) )
import Cardano.Wallet.Api.Types
    ( ApiNetworkClock (..), ApiNtpStatus (..), NtpSyncingStatus (..) )
import Control.Tracer
    ( Tracer )
import Data.Quantity
    ( Quantity (..) )
import Data.Text
    ( Text )
import Data.Text.Class
    ( ToText (..) )
import Network.NTP.Client
    ( IPVersion (..)
    , NtpClient (..)
    , NtpSettings (..)
    , NtpStatus (..)
    , NtpTrace (..)
    , ResultOrFailure (..)
    , withNtpClient
    )
import System.IOManager
    ( IOManager )
import UnliftIO.STM
    ( atomically, checkSTM )

import qualified Data.Text as T

-- | Set up a 'NtpClient' and pass it to the given action. The 'NtpClient' is
-- terminated when the callback returns.
withWalletNtpClient
    :: IOManager
    -- ^ The global 'IOManager' instance, set up by the application main function.
    -> Tracer IO NtpTrace
    -- ^ Logging object
    -> (NtpClient -> IO a)
    -- ^ Action to run
    -> IO a
withWalletNtpClient :: IOManager -> Tracer IO NtpTrace -> (NtpClient -> IO a) -> IO a
withWalletNtpClient IOManager
ioManager Tracer IO NtpTrace
tr = IOManager
-> Tracer IO NtpTrace -> NtpSettings -> (NtpClient -> IO a) -> IO a
forall a.
IOManager
-> Tracer IO NtpTrace -> NtpSettings -> (NtpClient -> IO a) -> IO a
withNtpClient IOManager
ioManager Tracer IO NtpTrace
tr NtpSettings
ntpSettings

-- | Hard-coded NTP servers for cardano-wallet.
ntpSettings :: NtpSettings
ntpSettings :: NtpSettings
ntpSettings = NtpSettings :: [String] -> Int -> Microsecond -> Microsecond -> NtpSettings
NtpSettings
    { ntpServers :: [String]
ntpServers = [ String
"0.de.pool.ntp.org", String
"0.europe.pool.ntp.org"
                   , String
"0.pool.ntp.org", String
"1.pool.ntp.org"
                   , String
"2.pool.ntp.org", String
"3.pool.ntp.org" ]
    , ntpRequiredNumberOfResults :: Int
ntpRequiredNumberOfResults = Int
3
    , ntpResponseTimeout :: Microsecond
ntpResponseTimeout = Microsecond
1_000_000
    , ntpPollDelay :: Microsecond
ntpPollDelay = Microsecond
300_000_000
    }

-- TODO: Move this upstream.
prettyNtpStatus :: NtpStatus -> Text
prettyNtpStatus :: NtpStatus -> Text
prettyNtpStatus = \case
    NtpDrift NtpOffset
o -> Text
"drifting by " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> NtpOffset -> Text
forall a. Integral a => a -> Text
prettyNtpOffset NtpOffset
o
    NtpStatus
NtpSyncPending -> Text
"pending"
    NtpStatus
NtpSyncUnavailable -> Text
"unavailable"

-- Using 'Integral' here because 'NtpOffset' is not exposed :/
--
-- TODO: Move this upstream.
prettyNtpOffset :: Integral a => a -> Text
prettyNtpOffset :: a -> Text
prettyNtpOffset a
n =
    String -> Text
T.pack (Integer -> String
forall a. Show a => a -> String
show (Integer -> String) -> Integer -> String
forall a b. (a -> b) -> a -> b
$ a -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral @_ @Integer a
n) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"μs"

-- TODO: Move this upstream
prettyResultOrFailure :: (a -> Text) -> ResultOrFailure a -> Text
prettyResultOrFailure :: (a -> Text) -> ResultOrFailure a -> Text
prettyResultOrFailure a -> Text
prettyA = \case
    BothSucceeded a
a ->
        a -> Text
prettyA a
a
    SuccessAndFailure a
a IPVersion
ip IOException
e ->
        Text
"succeeded and failed with " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> a -> Text
prettyA a
a Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack ((IPVersion, IOException) -> String
forall a. Show a => a -> String
show (IPVersion
ip, IOException
e))
    BothFailed IOException
e0 IOException
e1 ->
        Text
"failed with " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack (IOException -> String
forall a. Show a => a -> String
show IOException
e0) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack (IOException -> String
forall a. Show a => a -> String
show IOException
e1)

instance ToText IPVersion where
    toText :: IPVersion -> Text
toText IPVersion
IPv4 = Text
"IPv4"
    toText IPVersion
IPv6 = Text
"IPv6"

instance ToText NtpTrace where
    toText :: NtpTrace -> Text
toText NtpTrace
msg = case NtpTrace
msg of
        NtpTrace
NtpTraceStartNtpClient ->
            Text
"Starting ntp client"
        NtpTraceRestartDelay Int
d ->
            Text
"ntp client restart delay is " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall a. ToText a => a -> Text
toText Int
d
        NtpTrace
NtpTraceRestartingClient ->
            Text
"ntp client is restarting"
        NtpTraceIOError IOException
e ->
            Text
"ntp client experienced io error " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
forall a. ToText a => a -> Text
toText (IOException -> String
forall a. Show a => a -> String
show IOException
e)
        NtpTrace
NtpTraceLookupsFails ->
            Text
"ntp client failed to lookup the ntp servers"
        NtpTrace
NtpTraceClientStartQuery ->
            Text
"query to ntp client invoked"
        NtpTrace
NtpTraceNoLocalAddr ->
            Text
"no local address error when running ntp client"
        NtpTraceResult NtpStatus
a ->
            Text
"local clock is " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> NtpStatus -> Text
prettyNtpStatus NtpStatus
a
        NtpTraceRunProtocolResults ResultOrFailure [NtpOffset]
a ->
            Text
"ntp client run protocol results: "
            Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ([NtpOffset] -> Text) -> ResultOrFailure [NtpOffset] -> Text
forall a. (a -> Text) -> ResultOrFailure a -> Text
prettyResultOrFailure (Text -> [Text] -> Text
T.intercalate Text
", " ([Text] -> Text) -> ([NtpOffset] -> [Text]) -> [NtpOffset] -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (NtpOffset -> Text) -> [NtpOffset] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map NtpOffset -> Text
forall a. Integral a => a -> Text
prettyNtpOffset) ResultOrFailure [NtpOffset]
a
        NtpTracePacketSent SockAddr
_ NtpPacket
a ->
            Text
"ntp client sent packet when running " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
forall a. ToText a => a -> Text
toText (NtpPacket -> String
forall a. Show a => a -> String
show NtpPacket
a)
        NtpTracePacketSendError SockAddr
_ IOException
e ->
            Text
"ntp client experienced error " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
forall a. ToText a => a -> Text
toText (IOException -> String
forall a. Show a => a -> String
show IOException
e)
            Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" when sending packet"
        NtpTracePacketDecodeError SockAddr
_ String
e ->
            Text
"ntp client experienced error " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
forall a. ToText a => a -> Text
toText (String -> String
forall a. Show a => a -> String
show String
e)
            Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" when decoding packet"
        NtpTracePacketReceived SockAddr
_ NtpPacket
a ->
            Text
"ntp client received packet: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
forall a. ToText a => a -> Text
toText (NtpPacket -> String
forall a. Show a => a -> String
show NtpPacket
a)
        NtpTraceWaitingForRepliesTimeout IPVersion
v ->
            Text
"ntp client experienced timeout using " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> IPVersion -> Text
forall a. ToText a => a -> Text
toText IPVersion
v Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" protocol"

instance HasPrivacyAnnotation NtpTrace
instance HasSeverityAnnotation NtpTrace where
    getSeverityAnnotation :: NtpTrace -> Severity
getSeverityAnnotation NtpTrace
ev = case NtpTrace
ev of
        NtpTrace
NtpTraceStartNtpClient -> Severity
Debug
        NtpTraceRestartDelay Int
_ -> Severity
Debug
        NtpTrace
NtpTraceRestartingClient -> Severity
Debug
        NtpTraceIOError IOException
_ -> Severity
Notice
        NtpTrace
NtpTraceLookupsFails -> Severity
Notice
        NtpTrace
NtpTraceClientStartQuery -> Severity
Debug
        NtpTrace
NtpTraceNoLocalAddr -> Severity
Notice
        NtpTraceResult (NtpDrift NtpOffset
micro)
            | NtpOffset -> NtpOffset
forall a. Num a => a -> a
abs NtpOffset
micro NtpOffset -> NtpOffset -> Bool
forall a. Ord a => a -> a -> Bool
< (NtpOffset
500NtpOffset -> NtpOffset -> NtpOffset
forall a. Num a => a -> a -> a
*NtpOffset
ms)  -> Severity
Debug   -- Not sure what limits actually
            | NtpOffset -> NtpOffset
forall a. Num a => a -> a
abs NtpOffset
micro NtpOffset -> NtpOffset -> Bool
forall a. Ord a => a -> a -> Bool
< (NtpOffset
1000NtpOffset -> NtpOffset -> NtpOffset
forall a. Num a => a -> a -> a
*NtpOffset
ms) -> Severity
Notice  -- matter, but these seem
            | Bool
otherwise             -> Severity
Warning -- reasonable.
        NtpTraceResult NtpStatus
_ -> Severity
Debug
        NtpTraceRunProtocolResults ResultOrFailure [NtpOffset]
_ -> Severity
Debug
        NtpTracePacketSent SockAddr
_ NtpPacket
_ -> Severity
Debug
        NtpTracePacketSendError SockAddr
_ IOException
_ -> Severity
Notice
        NtpTracePacketDecodeError SockAddr
_ String
_ -> Severity
Notice
        NtpTracePacketReceived SockAddr
_ NtpPacket
_ -> Severity
Debug
        NtpTraceWaitingForRepliesTimeout IPVersion
_ -> Severity
Notice
      where
        ms :: NtpOffset
ms = NtpOffset
1000

getNtpStatus
    :: NtpClient
    -> Bool
        -- ^ When 'True', will block and force a NTP check instead of using cached results
    -> IO ApiNetworkClock
getNtpStatus :: NtpClient -> Bool -> IO ApiNetworkClock
getNtpStatus NtpClient
client Bool
forceCheck = (ApiNtpStatus -> ApiNetworkClock
ApiNetworkClock (ApiNtpStatus -> ApiNetworkClock)
-> (NtpStatus -> ApiNtpStatus) -> NtpStatus -> ApiNetworkClock
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NtpStatus -> ApiNtpStatus
toStatus) (NtpStatus -> ApiNetworkClock)
-> IO NtpStatus -> IO ApiNetworkClock
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
    if Bool
forceCheck
    -- Forces an NTP check / query on the central servers, use with care
    then do
        NtpClient -> IO NtpStatus
ntpQueryBlocking NtpClient
client

    else STM NtpStatus -> IO NtpStatus
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM NtpStatus -> IO NtpStatus) -> STM NtpStatus -> IO NtpStatus
forall a b. (a -> b) -> a -> b
$ do
      -- Reads a cached NTP status from an STM.TVar so we don't get
      -- blacklisted by the central NTP "authorities" for sending too many NTP
      -- requests.
      NtpStatus
s <- NtpClient -> STM NtpStatus
ntpGetStatus NtpClient
client
      Bool -> STM ()
checkSTM (NtpStatus
s NtpStatus -> NtpStatus -> Bool
forall a. Eq a => a -> a -> Bool
/= NtpStatus
NtpSyncPending)
      NtpStatus -> STM NtpStatus
forall (f :: * -> *) a. Applicative f => a -> f a
pure NtpStatus
s
  where
    toStatus :: NtpStatus -> ApiNtpStatus
toStatus = \case
        NtpStatus
NtpSyncPending ->
            NtpSyncingStatus
-> Maybe (Quantity "microsecond" Integer) -> ApiNtpStatus
ApiNtpStatus NtpSyncingStatus
NtpSyncingStatusPending Maybe (Quantity "microsecond" Integer)
forall a. Maybe a
Nothing
        NtpStatus
NtpSyncUnavailable ->
            NtpSyncingStatus
-> Maybe (Quantity "microsecond" Integer) -> ApiNtpStatus
ApiNtpStatus NtpSyncingStatus
NtpSyncingStatusUnavailable Maybe (Quantity "microsecond" Integer)
forall a. Maybe a
Nothing
        NtpDrift NtpOffset
ms ->
            NtpSyncingStatus
-> Maybe (Quantity "microsecond" Integer) -> ApiNtpStatus
ApiNtpStatus NtpSyncingStatus
NtpSyncingStatusAvailable
            (Quantity "microsecond" Integer
-> Maybe (Quantity "microsecond" Integer)
forall a. a -> Maybe a
Just (Quantity "microsecond" Integer
 -> Maybe (Quantity "microsecond" Integer))
-> Quantity "microsecond" Integer
-> Maybe (Quantity "microsecond" Integer)
forall a b. (a -> b) -> a -> b
$ Integer -> Quantity "microsecond" Integer
forall (unit :: Symbol) a. a -> Quantity unit a
Quantity (NtpOffset -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral NtpOffset
ms :: Integer))