diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright Scrive 2014 + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Scrive nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/Network/NTP/Control.hs b/Network/NTP/Control.hs new file mode 100644 --- /dev/null +++ b/Network/NTP/Control.hs @@ -0,0 +1,52 @@ +module Network.NTP.Control + ( sendTo + , recvFrom + , query + , response + , queryHost + ) where + +import Control.Exception (bracket) +import Control.Monad (void) +import Data.Serialize (decode, encode) +import Network.BSD (getHostByName, hostAddress) +import qualified Network.NTP.Control.Packet as P +import Network.Socket (Socket, SocketType(..), SockAddr(..), Family(..), socket, close, defaultProtocol) +import qualified Network.Socket.ByteString as N + +-- | Send an NTP control packet +sendTo :: Socket -> SockAddr -> P.Packet -> IO Int +sendTo s sa p = N.sendTo s (encode p) sa + +-- | Receive an NTP control packet +recvFrom :: Socket -> IO (P.Packet, SockAddr) +recvFrom s = do + (b, sa) <- N.recvFrom s 1024 + case decode b of + Left e -> fail e + Right p -> return (p, sa) + +-- | Create a socket and send an NTP control message to a server +query :: SockAddr -> P.Packet -> IO Socket +query sa p = do + s <- socket AF_INET Datagram defaultProtocol + void $ sendTo s sa p + return s + +-- | Wait for a response for an issued query +response :: SockAddr -> P.Packet -> Socket -> IO P.Packet +response sa p s = do + let wait = do + (p', sa') <- recvFrom s + if sa' == sa && P.sequence p == P.sequence p' + then return p' + else wait + wait + +-- | Convenience wrapper for 'query' that looks up a host name, +-- queries its standard NTP port, and waits for a response +queryHost :: String -> P.Packet -> IO P.Packet +queryHost host p = do + he <- getHostByName host + let sa = SockAddrInet 123 (hostAddress he) + bracket (query sa p) close (response sa p) diff --git a/Network/NTP/Control/Packet.hs b/Network/NTP/Control/Packet.hs new file mode 100644 --- /dev/null +++ b/Network/NTP/Control/Packet.hs @@ -0,0 +1,325 @@ +{-# LANGUAGE OverloadedStrings #-} +module Network.NTP.Control.Packet + ( Op(..) + , Variable(..) + , Variables(..) + , LeapIndicator(..) + , ClockSource(..) + , EventCode(..) + , ErrorCode(..) + , Status(..) + , Packet(..) + , emptyPacket + , opVariables + , readVariables + ) where + +import Control.Monad (when, replicateM_, foldM, liftM) +import Data.Bits ((.&.), (.|.), shiftR, shiftL) +import Data.Char (isSpace) +import qualified Data.ByteString as BS +import qualified Data.ByteString.Char8 as BSC +import Data.ByteString.Lex.Integral (readHexadecimal) +import Data.Fixed (Pico) +import Data.Serialize (Serialize(..), getByteString, putWord8, getWord16be, putWord16be, putByteString) +import Data.Time.Clock (DiffTime) +import Data.Time.Clock.POSIX (POSIXTime) +import Data.Word (Word8, Word16) + +-- | Available NTP control commands +data Op = + UnspecifiedOp + | ReadStatus + | ReadVariables + | WriteVariables + | ReadClockVariables + | WriteClockVariables + | SetTrapAddress + | AsynchronousMessage + | RuntimeConfiguration + | SaveConfig + | UnsetTrap + deriving (Eq, Show) + +decodeTime :: Monad m => BS.ByteString -> m DiffTime +decodeTime b = case (reads :: ReadS Pico) (BSC.unpack b) of + [(d,"")] -> return $ realToFrac (d / 1000) + _ -> fail $ "decodeTime: " ++ show b + +decodeTimeStamp :: Monad m => BS.ByteString -> m POSIXTime +decodeTimeStamp s | "0x" `BS.isPrefixOf` s = do + t <- case BSC.split '.' (BS.drop 2 s) of + [i] -> fromIntegral `liftM` readHex i + [i,f] -> do + i' <- readHex i + f' <- readHex f + return $ fromIntegral i' + fromIntegral f' / 16 ^ BS.length f + _ -> fail $ "decodeTimeStamp: " ++ show s + return $ t - 0x83aa7e80 -- seconds between 1900 and 1970 +decodeTimeStamp s = fail $ "decodeTimeStamp: " ++ show s + +readHex :: Monad m => BS.ByteString -> m Integer +readHex s = case readHexadecimal s of + Just (a,"") -> return a + _ -> fail $ "readHex: " ++ show s + + +-- | Currently supported NTP system variables +data Variable = + Clock + | RootDispersion + deriving Show + +-- | Record with system variables from a response +data Variables = Variables + { clock :: Maybe POSIXTime + , rootDispersion :: Maybe DiffTime + } + deriving Show + +encodeVariable :: Variable -> BS.ByteString +encodeVariable Clock = "clock" +encodeVariable RootDispersion = "rootdisp" + +decodeVariable :: Monad m => BS.ByteString -> m Variable +decodeVariable "clock" = return Clock +decodeVariable "rootdisp" = return RootDispersion +decodeVariable a = fail $ "decodeVariable: " ++ BSC.unpack a + +-- | Construct a packet that for querying an NTP daemon's variables +opVariables :: [Variable] -> Packet +opVariables vs = emptyPacket{ op = ReadVariables + , data_ = BS.intercalate "," (map encodeVariable vs) + } + +-- | Extract variable values from q response packet from an 'opVariables' request +readVariables :: Monad m => Packet -> m Variables +readVariables p = do + let assign vs [vn,a] = do + v <- decodeVariable vn + case v of + Clock -> do + ts <- decodeTimeStamp a + return vs{ clock = Just ts} + RootDispersion -> do + t <- decodeTime a + return vs{ rootDispersion = Just t} + assign _ s = fail $ "readVariables: " ++ show s + foldM assign (Variables Nothing Nothing) $ + map (BSC.split '=') $ + BSC.split ',' $ + BSC.filter (not . isSpace) $ + data_ p + +encodeOp :: Num a => Op -> a +encodeOp UnspecifiedOp = 0 +encodeOp ReadStatus = 1 +encodeOp ReadVariables = 2 +encodeOp WriteVariables = 3 +encodeOp ReadClockVariables = 4 +encodeOp WriteClockVariables = 5 +encodeOp SetTrapAddress = 6 +encodeOp AsynchronousMessage = 7 +encodeOp RuntimeConfiguration = 8 +encodeOp SaveConfig = 9 +encodeOp UnsetTrap = 31 + +decodeOp :: (Num a, Eq a, Show a, Monad m) => a -> m Op +decodeOp 0 = return UnspecifiedOp +decodeOp 1 = return ReadStatus +decodeOp 2 = return ReadVariables +decodeOp 3 = return WriteVariables +decodeOp 4 = return ReadClockVariables +decodeOp 5 = return WriteClockVariables +decodeOp 6 = return SetTrapAddress +decodeOp 7 = return AsynchronousMessage +decodeOp 8 = return RuntimeConfiguration +decodeOp 9 = return SaveConfig +decodeOp 31 = return UnsetTrap +decodeOp a = fail $ "decodeOp: " ++ show a + +data LeapIndicator = + NoWarning + | Has61Seconds + | Has59Seconds + | AlarmCondition + deriving Show + +decodeLeapIndicator :: (Num a, Eq a, Show a, Monad m) => a -> m LeapIndicator +decodeLeapIndicator 0 = return NoWarning +decodeLeapIndicator 1 = return Has61Seconds +decodeLeapIndicator 2 = return Has59Seconds +decodeLeapIndicator 3 = return AlarmCondition +decodeLeapIndicator a = fail $ "decodeLeapIndicator: " ++ show a + +data ClockSource = + UnspecifiedClockSource + | CalibratedAtomicClock + | LFRadio + | HFRadio + | UHFRadio + | Local + | Ntp + | OtherClockSource + | WristWatch + | Telephone + deriving Show + +decodeClockSource :: (Num a, Eq a, Show a, Monad m) => a -> m ClockSource +decodeClockSource 0 = return UnspecifiedClockSource +decodeClockSource 1 = return CalibratedAtomicClock +decodeClockSource 2 = return LFRadio +decodeClockSource 3 = return HFRadio +decodeClockSource 4 = return UHFRadio +decodeClockSource 5 = return Local +decodeClockSource 6 = return Ntp +decodeClockSource 7 = return OtherClockSource +decodeClockSource 8 = return WristWatch +decodeClockSource 9 = return Telephone +decodeClockSource a = fail $ "decodeClockSource: " ++ show a + +data EventCode = + UnspecifiedEventCode + | FrequencyNotSet + | FrequencySet + | SpikeDetect + | FrequencyMode + | ClockSync + | Restart + | PanicStop + | NoSysPeer + | LeapArmed + | LeapDisarmed + | LeapEvent + | ClockStep + | KernelEvent + | TAI + | StaleLeapsecondValues + | Clockhop + deriving Show + +decodeEventCode :: (Num a, Eq a, Show a, Monad m) => a -> m EventCode +decodeEventCode 0 = return UnspecifiedEventCode +decodeEventCode 1 = return FrequencyNotSet +decodeEventCode 2 = return FrequencySet +decodeEventCode 3 = return SpikeDetect +decodeEventCode 4 = return FrequencyMode +decodeEventCode 5 = return ClockSync +decodeEventCode 6 = return Restart +decodeEventCode 7 = return PanicStop +decodeEventCode 8 = return NoSysPeer +decodeEventCode 9 = return LeapArmed +decodeEventCode 10 = return LeapDisarmed +decodeEventCode 11 = return LeapEvent +decodeEventCode 12 = return ClockStep +decodeEventCode 13 = return KernelEvent +decodeEventCode 14 = return TAI +decodeEventCode 15 = return StaleLeapsecondValues +decodeEventCode 16 = return Clockhop +decodeEventCode a = fail $ "decodeEventCode: " ++ show a + + +data ErrorCode = + UnspecifiedErrorCode + | AuthenticationFailure + | BadFormat + | InvalidOpcode + | UnknownAssociationID + | UnknownVariable + | InvalidVariableValue + | AdministrativelyProhibited + deriving Show + +decodeErrorCode :: (Num a, Eq a, Show a, Monad m) => a -> m ErrorCode +decodeErrorCode 0 = return UnspecifiedErrorCode +decodeErrorCode 1 = return AuthenticationFailure +decodeErrorCode 2 = return BadFormat +decodeErrorCode 3 = return InvalidOpcode +decodeErrorCode 4 = return UnknownAssociationID +decodeErrorCode 5 = return UnknownVariable +decodeErrorCode 6 = return InvalidVariableValue +decodeErrorCode 7 = return AdministrativelyProhibited +decodeErrorCode a = fail $ "decodeErrorCode: " ++ show a + +data Status = + System LeapIndicator ClockSource Word8 EventCode + | Error ErrorCode + | OtherStatus Word16 + deriving Show + +toBool :: (Num a, Eq a) => a -> Bool +toBool 0 = False +toBool _ = True + +fromBool :: Num a => Bool -> a +fromBool a = if a then 1 else 0 + +data Packet = Packet + { responseBit :: Bool + , errorBit :: Bool + , moreBit :: Bool + , op :: Op + , sequence :: Word16 + , status :: Status + , associationID :: Word16 + , offset :: Word16 + , data_ :: BS.ByteString + } + deriving Show + +emptyPacket :: Packet +emptyPacket = Packet False False False UnspecifiedOp 0 (OtherStatus 0) 0 0 BS.empty + +maxDataLength :: Int +maxDataLength = 468 + +padWord :: Integral a => a -> a +padWord a = (4 - a `mod` 4) `mod` 4 + +version :: Num a => a +version = 2 + +mode :: Num a => a +mode = 6 -- NTP control message + +instance Serialize Packet where + put (Packet responseBit' errorBit' moreBit' op' sequence' _status associationID' offset' data_') = do + putWord16be $ version `shiftL` 11 + .|. mode `shiftL` 8 + .|. fromBool responseBit' `shiftL` 7 + .|. fromBool errorBit' `shiftL` 6 + .|. fromBool moreBit' `shiftL` 5 + .|. encodeOp op' + putWord16be $ sequence' + putWord16be $ 0 + putWord16be $ associationID' + putWord16be $ offset' + putWord16be $ fromIntegral $ BS.length data_' + putByteString data_' + replicateM_ (padWord (BS.length data_')) $ putWord8 0 + + get = do + w <- getWord16be + when (w `shiftR` 11 .&. 0x7 /= version) $ fail "Illegal version" + when (w `shiftR` 8 .&. 0x7 /= mode) $ fail "Illegal mode" + let responseBit' = toBool (w `shiftR` 7 .&. 1) + errorBit' = toBool (w `shiftR` 6 .&. 1) + moreBit' = toBool (w `shiftR` 5 .&. 1) + op' <- decodeOp (w .&. 0x1f) + sequence' <- getWord16be + s <- getWord16be + associationID' <- getWord16be + status' <- case (errorBit',op',associationID') of + (True,_,_) -> Error `fmap` decodeErrorCode (s `shiftR` 8 .&. 0xff) + (_,_,0) | op' `elem` [ReadStatus, ReadVariables] -> do + leapIndicator <- decodeLeapIndicator (s `shiftR` 14 .&. 3) + clockSource <- decodeClockSource (s `shiftR` 8 .&. 0x3f) + let eventCounter = fromIntegral (s `shiftR` 4 .&. 0xf) + eventCode <- decodeEventCode (s .&. 0xf) + return $ System leapIndicator clockSource eventCounter eventCode + _ -> return $ OtherStatus s + offset' <- getWord16be + count <- fromIntegral `fmap` getWord16be + when (count > maxDataLength) $ fail $ "count too large: " ++ show count + data_' <- getByteString count + return $ Packet responseBit' errorBit' moreBit' op' sequence' status' associationID' offset' data_' diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/Test/Query.hs b/Test/Query.hs new file mode 100644 --- /dev/null +++ b/Test/Query.hs @@ -0,0 +1,13 @@ +import Network.NTP.Control (queryHost) +import Network.NTP.Control.Packet (opVariables, Variable(..), readVariables) +import System.Timeout (timeout) + +main :: IO () +main = do + mres <- timeout 1000000 $ do + queryHost "localhost" $ opVariables [Clock, RootDispersion] + case mres of + Nothing -> fail "Timeout" + Just p -> do + print p + readVariables p >>= print diff --git a/ntp-control.cabal b/ntp-control.cabal new file mode 100644 --- /dev/null +++ b/ntp-control.cabal @@ -0,0 +1,45 @@ +name: ntp-control +version: 0.1 +synopsis: Client library for NTP control messaging +description: Support for monitoring NTP server performance, including quering NTP system variables and system status. +category: Network, Time +license: BSD3 +license-file: LICENSE +author: Scrive +maintainer: magnus@scrive.com + +Cabal-Version: >= 1.8 +build-type: Simple + + +Library + + exposed-modules: Network.NTP.Control, Network.NTP.Control.Packet + + build-depends: base >= 3 && < 5 + build-depends: bytestring + build-depends: bytestring-lexing + build-depends: cereal + build-depends: network + build-depends: old-locale + build-depends: time + + ghc-options: -Wall + +Test-Suite test-query + type: exitcode-stdio-1.0 + main-is: Test/Query.hs + + build-depends: base >= 3 && < 5 + build-depends: bytestring + build-depends: bytestring-lexing + build-depends: cereal + build-depends: network + build-depends: old-locale + build-depends: time + + ghc-options: -Wall + +source-repository head + type: git + location: https://github.com/scrive/ntp-control