diff --git a/datadog.cabal b/datadog.cabal --- a/datadog.cabal +++ b/datadog.cabal @@ -1,11 +1,13 @@ --- This file has been generated from package.yaml by hpack version 0.20.0. +cabal-version: 1.12 + +-- This file has been generated from package.yaml by hpack version 0.31.0. -- -- see: https://github.com/sol/hpack -- --- hash: e9f4d5b9aa948a2ac508a5308ad44859778b1fadce4c21277be4be4cc42be39a +-- hash: 2c7b670048d1d09b538ce6bb32964fafec93971f0b144c73d13fca6c1e873591 name: datadog -version: 0.2.2.0 +version: 0.2.3.0 synopsis: Datadog client for Haskell. Supports both the HTTP API and StatsD. category: Network homepage: https://github.com/iand675/datadog @@ -14,9 +16,22 @@ license: MIT license-file: LICENSE build-type: Simple -cabal-version: >= 1.10 library + exposed-modules: + Network.Datadog + Network.Datadog.Check + Network.Datadog.Downtime + Network.Datadog.Event + Network.Datadog.Host + Network.Datadog.Internal + Network.Datadog.Lens + Network.Datadog.Metrics + Network.Datadog.Monitor + Network.Datadog.Types + Network.StatsD.Datadog + other-modules: + Paths_datadog hs-source-dirs: src default-extensions: ConstraintKinds DataKinds DeriveDataTypeable DeriveGeneric EmptyDataDecls FlexibleContexts FlexibleInstances GADTs GeneralizedNewtypeDeriving LambdaCase MultiParamTypeClasses NamedFieldPuns NoMonomorphismRestriction OverloadedStrings PackageImports PolyKinds QuasiQuotes RankNTypes RecordWildCards ScopedTypeVariables StandaloneDeriving TemplateHaskell TupleSections TypeFamilies TypeOperators ViewPatterns @@ -27,6 +42,7 @@ , base >=4.7 && <5 , buffer-builder , bytestring + , containers , dlist , http-client , http-client-tls @@ -39,27 +55,23 @@ , text , time , transformers-base + , unliftio , unordered-containers , vector - exposed-modules: - Network.Datadog - Network.Datadog.Check - Network.Datadog.Downtime - Network.Datadog.Event - Network.Datadog.Host - Network.Datadog.Internal - Network.Datadog.Lens - Network.Datadog.Metrics - Network.Datadog.Monitor - Network.Datadog.Types - Network.StatsD.Datadog - other-modules: - Paths_datadog default-language: Haskell2010 test-suite datadog-api-test type: exitcode-stdio-1.0 main-is: Spec.hs + other-modules: + Test.Network.Datadog + Test.Network.Datadog.Check + Test.Network.Datadog.Downtime + Test.Network.Datadog.Event + Test.Network.Datadog.Host + Test.Network.Datadog.Monitor + Test.Network.Datadog.StatsD + Paths_datadog hs-source-dirs: test default-extensions: ConstraintKinds DataKinds DeriveDataTypeable DeriveGeneric EmptyDataDecls FlexibleContexts FlexibleInstances GADTs GeneralizedNewtypeDeriving LambdaCase MultiParamTypeClasses NamedFieldPuns NoMonomorphismRestriction OverloadedStrings PackageImports PolyKinds QuasiQuotes RankNTypes RecordWildCards ScopedTypeVariables StandaloneDeriving TemplateHaskell TupleSections TypeFamilies TypeOperators ViewPatterns @@ -71,6 +83,7 @@ , base , buffer-builder , bytestring + , containers , datadog , dlist , exceptions @@ -87,15 +100,7 @@ , text , time , transformers-base + , unliftio , unordered-containers , vector - other-modules: - Test.Network.Datadog - Test.Network.Datadog.Check - Test.Network.Datadog.Downtime - Test.Network.Datadog.Event - Test.Network.Datadog.Host - Test.Network.Datadog.Monitor - Test.Network.Datadog.StatsD - Paths_datadog default-language: Haskell2010 diff --git a/src/Network/Datadog/Event.hs b/src/Network/Datadog/Event.hs --- a/src/Network/Datadog/Event.hs +++ b/src/Network/Datadog/Event.hs @@ -35,7 +35,7 @@ import Data.Aeson hiding (Error, Success) -- import qualified Data.Aeson (Result(Success)) import Data.List (intercalate) -import Data.Text (Text) +import Data.Text (Text, unpack) import Data.Time.Clock import Data.Time.Clock.POSIX @@ -88,7 +88,7 @@ loadEvents env (startTime, endTime) resultPriority filterTags = let path = "events" q = prependMaybe (\a -> ("priority", show a)) resultPriority $ - prependBool (not $ null filterTags) ("tags", intercalate "," (map show filterTags)) + prependBool (not $ null filterTags) ("tags", intercalate "," (map unpack filterTags)) [("start", show (floor (utcTimeToPOSIXSeconds startTime) :: Integer)) ,("end", show (floor (utcTimeToPOSIXSeconds endTime) :: Integer)) ] diff --git a/src/Network/StatsD/Datadog.hs b/src/Network/StatsD/Datadog.hs --- a/src/Network/StatsD/Datadog.hs +++ b/src/Network/StatsD/Datadog.hs @@ -1,5 +1,6 @@ {-| DogStatsD accepts custom application metrics points over UDP, and then periodically aggregates and forwards the metrics to Datadog, where they can be graphed on dashboards. The data is sent by using a client library such as this one that communicates with a DogStatsD server. -} +{-# LANGUAGE BangPatterns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE FunctionalDependencies #-} @@ -46,34 +47,38 @@ HasAlertType(..), HasHost(..), HasPort(..), + HasBufferSize(..), + HasMaxDelay(..), + HasOnException(..), HasStatus(..), HasMessage(..), -- * Dummy client StatsClient(Dummy) ) where import Control.Applicative ((<$>)) -import Control.Exception (bracket) +import Control.Exception (SomeException) import Control.Lens -import Control.Monad.Base -import Control.Monad.Trans.Control +import Control.Monad (void) import Control.Reaper +import Data.ByteString (ByteString) +import qualified Data.ByteString.Lazy as L import Data.BufferBuilder.Utf8 import Data.List (intersperse) -import Data.Monoid -import Data.Maybe (isNothing) -import Data.Int -import Data.Word +import qualified Data.Sequence as Seq import qualified Data.ByteString as B import qualified Data.Foldable as F import Data.Text (Text) import qualified Data.Text as T import Data.Time.Clock import Data.Time.Clock.POSIX -import Data.Time.Format import Data.Text.Encoding (encodeUtf8) -import Data.ByteString.Short hiding (empty) import Network.Socket hiding (send, sendTo, recv, recvFrom) -import System.IO (hClose, hSetBuffering, BufferMode(LineBuffering), IOMode(WriteMode), Handle) +import System.IO + ( BufferMode(BlockBuffering) + , Handle + , IOMode(WriteMode) + ) +import UnliftIO epochTime :: UTCTime -> Int epochTime = round . utcTimeToPOSIXSeconds @@ -272,7 +277,11 @@ appendBS7 "|#" sequence_ $ intersperse (appendChar7 ',') $ map fromTag ts -data ServiceCheckStatus = ServiceOk | ServiceWarning | ServiceCritical | ServiceUnknown +data ServiceCheckStatus + = ServiceOk + | ServiceWarning + | ServiceCritical + | ServiceUnknown deriving (Read, Show, Eq, Ord, Enum) -- | 'ServiceCheck' @@ -301,9 +310,10 @@ makeFields ''ServiceCheck -serviceCheck :: Text -- ^ name - -> ServiceCheckStatus - -> ServiceCheck +serviceCheck :: + Text -- ^ name + -> ServiceCheckStatus + -> ServiceCheck serviceCheck n s = ServiceCheck n s Nothing Nothing Nothing [] -- | Convert an 'Event', 'Metric', or 'StatusCheck' to their wire format. @@ -336,17 +346,49 @@ sequence_ $ intersperse (appendChar7 ',') $ map fromTag ts data DogStatsSettings = DogStatsSettings - { dogStatsSettingsHost :: HostName -- ^ The hostname or IP of the DogStatsD server (default: 127.0.0.1) - , dogStatsSettingsPort :: Int -- ^ The port that the DogStatsD server is listening on (default: 8125) + { dogStatsSettingsHost :: HostName -- ^ The hostname or IP of the DogStatsD server (default: 127.0.0.1) + , dogStatsSettingsPort :: !Int -- ^ The port that the DogStatsD server is listening on (default: 8125) + , dogStatsSettingsBufferSize :: !Int -- ^ Maximum buffer size. Stats are sent over UDP, so the maximum possible value is 65507 bytes per packet. In some scenarios, however, you may wish to send smaller packets. (default: 65507) + , dogStatsSettingsMaxDelay :: !Int -- ^ Maximum amount of time (in microseconds) between having no stats to send locally and when new stats will be sent to the statsd server. (default: 1 second) + , dogStatsSettingsOnException :: (SomeException -> Seq.Seq ByteString -> IO (Seq.Seq ByteString -> Seq.Seq ByteString)) -- ^ Handler to recover from exceptions thrown while sending stats to the server. Caution: Throwing an exception from this handler will shut down the worker that sends stats to the server, but is not able to prevent you from enqueuing stats via the client. Default: print the exception and throw away any accumulated stats. } makeFields ''DogStatsSettings defaultSettings :: DogStatsSettings -defaultSettings = DogStatsSettings "127.0.0.1" 8125 +defaultSettings = + DogStatsSettings + { dogStatsSettingsHost = "127.0.0.1" + , dogStatsSettingsPort = 8125 + , dogStatsSettingsBufferSize = 65507 + , dogStatsSettingsMaxDelay = 1000000 + , dogStatsSettingsOnException = + \e _ -> + putStrLn + (show e ++ + "\nDropping all accumulated stats due to error. This behavior may be overridden by setting the onException handler of DogStatsSettings.") >> + return (const Seq.empty) + } -mkStatsClient :: MonadBase IO m => DogStatsSettings -> m StatsClient -mkStatsClient s = liftBase $ do +accumulateStats :: + Int -- ^ Max buffer size + -> Seq.Seq ByteString -- ^ Items to send + -> (L.ByteString, Seq.Seq ByteString) +accumulateStats maxBufSize = go 0 [] + where + go :: Int -> [ByteString] -> Seq.Seq ByteString -> (L.ByteString, Seq.Seq ByteString) + go !accum chunks s = case Seq.viewl s of + Seq.EmptyL -> (finalizeChunks chunks, Seq.empty) + (bs Seq.:< rest) -> let newSize = B.length bs + accum in if newSize > maxBufSize + then (finalizeChunks chunks, s) + else go newSize (bs : chunks) rest + + finalizeChunks :: [ByteString] -> L.ByteString + finalizeChunks = L.fromChunks . reverse + +-- | Create a stats client. Be sure to close it with 'finalizeStatsClient' in order to send any pending stats and close the underlying handle when done using it. Alternatively, use 'withDogStatsD' to finalize it automatically. +mkStatsClient :: MonadIO m => DogStatsSettings -> m StatsClient +mkStatsClient s = liftIO $ do addrInfos <- getAddrInfo (Just $ defaultHints { addrFlags = [AI_PASSIVE] }) (Just $ s ^. host) @@ -357,27 +399,36 @@ sock <- socket (addrFamily serverAddr) Datagram defaultProtocol connect sock (addrAddress serverAddr) h <- socketToHandle sock WriteMode - hSetBuffering h LineBuffering - let builderAction work = do - F.mapM_ (B.hPut h . runUtf8Builder) work - return $ const Nothing - reaperSettings = defaultReaperSettings { reaperAction = builderAction - , reaperDelay = 1000000 -- one second - , reaperCons = \item work -> Just $ maybe item (>> item) work - , reaperNull = isNothing - , reaperEmpty = Nothing - } + hSetBuffering h (BlockBuffering $ Just $ dogStatsSettingsBufferSize s) + let reaperSettings = defaultReaperSettings + { reaperAction = \stats -> catch (builderAction h (dogStatsSettingsBufferSize s) stats) $ \e -> + dogStatsSettingsOnException s e stats + , reaperDelay = dogStatsSettingsMaxDelay s + , reaperCons = \item work -> work Seq.|> runUtf8Builder item + , reaperNull = Seq.null + , reaperEmpty = Seq.empty + } r <- mkReaper reaperSettings - return $ StatsClient h r + return $ StatsClient h r s -withDogStatsD :: MonadBaseControl IO m => DogStatsSettings -> (StatsClient -> m a) -> m a -withDogStatsD s f = liftBaseOp - (bracket (mkStatsClient s) (\c -> finalizeStatsClient c >> hClose (statsClientHandle c))) f +builderAction :: Handle -> Int -> Seq.Seq ByteString -> IO (Seq.Seq ByteString -> Seq.Seq ByteString) +builderAction h maxBufSize s = case Seq.viewl s of + Seq.EmptyL -> return $ const Seq.empty + _ -> do + let (toFlush, rest) = accumulateStats maxBufSize s + L.hPut h toFlush + hFlush h -- safety flush + builderAction h maxBufSize rest +-- | Create a 'StatsClient' and provide it to the provided function. The 'StatsClient' will be finalized as soon as the inner block is exited, whether normally or via an exception. +withDogStatsD :: MonadUnliftIO m => DogStatsSettings -> (StatsClient -> m a) -> m a +withDogStatsD s = bracket (mkStatsClient s) finalizeStatsClient + -- | Note that Dummy is not the only constructor, just the only publicly available one. data StatsClient = StatsClient { statsClientHandle :: !Handle - , statsClientReaper :: Reaper (Maybe (Utf8Builder ())) (Utf8Builder ()) + , statsClientReaper :: Reaper (Seq.Seq ByteString) (Utf8Builder ()) + , statsClientSettings :: DogStatsSettings } | Dummy -- ^ Just drops all stats. @@ -390,11 +441,16 @@ -- > send client $ event "Wombat attack" "A host of mighty wombats has breached the gates" -- > send client $ metric "wombat.force_count" Gauge (9001 :: Int) -- > send client $ serviceCheck "Wombat Radar" ServiceOk -send :: (MonadBase IO m, ToStatsD v) => StatsClient -> v -> m () -send (StatsClient _ r) v = liftBase $ reaperAdd r (toStatsD v >> appendChar7 '\n') +send :: (MonadIO m, ToStatsD v) => StatsClient -> v -> m () +send StatsClient {statsClientReaper} v = + liftIO $ reaperAdd statsClientReaper (toStatsD v >> appendChar7 '\n') send Dummy _ = return () {-# INLINEABLE send #-} -finalizeStatsClient :: StatsClient -> IO () -finalizeStatsClient (StatsClient h r) = reaperStop r >>= F.mapM_ (B.hPut h . runUtf8Builder) +-- | Send all pending unsent events and close the connection to the specified statsd server. +finalizeStatsClient :: MonadIO m => StatsClient -> m () +finalizeStatsClient (StatsClient h r s) = liftIO $ do + remainingStats <- reaperStop r + void $ builderAction h (dogStatsSettingsBufferSize s) remainingStats + hClose h finalizeStatsClient Dummy = return () diff --git a/test/Test/Network/Datadog/StatsD.hs b/test/Test/Network/Datadog/StatsD.hs --- a/test/Test/Network/Datadog/StatsD.hs +++ b/test/Test/Network/Datadog/StatsD.hs @@ -16,6 +16,7 @@ , recvFrom , socket ) +import Control.Monad import System.Timeout (timeout) import Test.Hspec (Spec, describe, expectationFailure, it) @@ -34,6 +35,20 @@ withDogStatsD defaultSettings $ \stats -> do send stats $ event "foo" "bar" val <- timeout 10000000 $ recvFrom conn 2048 + case val of + Just _ -> pure () + Nothing -> expectationFailure "Did not receive DogStatsD event" + it "Can handle more metrics than fit in a single UDP packet without erroring" $ do + let makeServer :: IO Socket + makeServer = do + (serverAddr:_) <- getAddrInfo (Just defaultHints { addrFlags = [AI_PASSIVE] }) Nothing (Just "8125") + sock <- socket (addrFamily serverAddr) Datagram defaultProtocol + bind sock (addrAddress serverAddr) + return sock + bracket makeServer close $ \conn -> do + withDogStatsD defaultSettings $ \stats -> do + replicateM 500000 $ send stats $ event "foo" "bar" + val <- timeout 50000000 $ recvFrom conn 2048 case val of Just _ -> pure () Nothing -> expectationFailure "Did not receive DogStatsD event"