diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,7 @@ +## [*Unreleased*](https://github.com/freckle/aws-xray-client/tree/aws-xray-client-v0.1.0.0...main) + +None + +## [v0.1.0.0](https://github.com/freckle/aws-xray-client/tree/aws-xray-client-v0.1.0.0) + +First tagged release. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,3 @@ +# aws-xray-client + +A Haskell client for AWS X-Ray. diff --git a/aws-xray-client.cabal b/aws-xray-client.cabal new file mode 100644 --- /dev/null +++ b/aws-xray-client.cabal @@ -0,0 +1,113 @@ +cabal-version: 1.12 +name: aws-xray-client +version: 0.1.0.0 +license: MIT +copyright: 2021 Renaissance Learning Inc +maintainer: engineering@freckle.com +author: Freckle R&D +homepage: https://github.com/freckle/aws-xray-client#readme +bug-reports: https://github.com/freckle/aws-xray-client/issues +synopsis: A client for AWS X-Ray. +description: + The core client for enabling AWX X-Ray. + . + See other `aws-xray-client-*` packages for usage and integration examples. + +category: Tracing +build-type: Simple +extra-source-files: + README.md + CHANGELOG.md + +source-repository head + type: git + location: https://github.com/freckle/aws-xray-client + +library + exposed-modules: + Network.AWS.XRayClient + Network.AWS.XRayClient.JSONHelpers + Network.AWS.XRayClient.Segment + Network.AWS.XRayClient.SendSegments + Network.AWS.XRayClient.TraceId + System.Random.XRayCustom + + hs-source-dirs: library + other-modules: Paths_aws_xray_client + default-language: Haskell2010 + default-extensions: + BangPatterns DataKinds DeriveAnyClass DeriveFoldable DeriveFunctor + DeriveGeneric DeriveLift DeriveTraversable DerivingStrategies + FlexibleContexts FlexibleInstances GADTs GeneralizedNewtypeDeriving + LambdaCase MultiParamTypeClasses NoImplicitPrelude + NoMonomorphismRestriction OverloadedStrings RankNTypes + RecordWildCards ScopedTypeVariables StandaloneDeriving + TypeApplications TypeFamilies + + build-depends: + aeson >=1.4.2.0, + base >=4.12.0.0 && <5, + bytestring >=0.10.8.2, + deepseq >=1.4.4.0, + http-types >=0.12.3, + lens >=4.17.1, + network >=2.8.0.1, + random >=1.1, + text >=1.2.3.1, + time >=1.8.0.2 + +test-suite spec + type: exitcode-stdio-1.0 + main-is: Spec.hs + hs-source-dirs: tests + other-modules: + Network.AWS.XRayClient.SegmentSpec + Network.AWS.XRayClient.TraceIdSpec + Paths_aws_xray_client + + default-language: Haskell2010 + default-extensions: + BangPatterns DataKinds DeriveAnyClass DeriveFoldable DeriveFunctor + DeriveGeneric DeriveLift DeriveTraversable DerivingStrategies + FlexibleContexts FlexibleInstances GADTs GeneralizedNewtypeDeriving + LambdaCase MultiParamTypeClasses NoImplicitPrelude + NoMonomorphismRestriction OverloadedStrings RankNTypes + RecordWildCards ScopedTypeVariables StandaloneDeriving + TypeApplications TypeFamilies + + ghc-options: -threaded -rtsopts -O0 -with-rtsopts=-N + build-depends: + QuickCheck >=2.12.6.1, + aeson >=1.4.2.0, + aeson-qq >=0.8.2, + aws-xray-client -any, + base >=4.12.0.0 && <5, + generic-arbitrary >=0.1.0, + hspec >=2.6.1, + lens >=4.17.1, + random >=1.1, + text >=1.2.3.1 + +benchmark bench + type: exitcode-stdio-1.0 + main-is: Bench.hs + hs-source-dirs: benchmarks + other-modules: Paths_aws_xray_client + default-language: Haskell2010 + default-extensions: + BangPatterns DataKinds DeriveAnyClass DeriveFoldable DeriveFunctor + DeriveGeneric DeriveLift DeriveTraversable DerivingStrategies + FlexibleContexts FlexibleInstances GADTs GeneralizedNewtypeDeriving + LambdaCase MultiParamTypeClasses NoImplicitPrelude + NoMonomorphismRestriction OverloadedStrings RankNTypes + RecordWildCards ScopedTypeVariables StandaloneDeriving + TypeApplications TypeFamilies + + ghc-options: -threaded -O2 -with-rtsopts=-N + build-depends: + async >=2.2.2, + aws-xray-client -any, + base >=4.12.0.0 && <5, + criterion >=1.5.5.0, + random >=1.1, + time >=1.8.0.2 diff --git a/benchmarks/Bench.hs b/benchmarks/Bench.hs new file mode 100644 --- /dev/null +++ b/benchmarks/Bench.hs @@ -0,0 +1,81 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Main + ( main + ) where + +import Prelude + +import Control.Concurrent.Async +import Control.Monad (replicateM_) +import Criterion.Main +import Data.Char (intToDigit) +import Data.IORef +import Data.Time.Clock.POSIX +import Network.AWS.XRayClient +import System.Random + +main :: IO () +main = do + stdGenIORef <- newIORef =<< newStdGen + + let + segmentIdNotShared = splitActionAcrossThreads + (pure ()) + (const $ getStdRandom generateXRaySegmentId) + segmentIdShared = splitActionAcrossThreads + (newStdGen >>= newIORef) + (`withRandomGenIORef` generateXRaySegmentId) + parNewStdGen = splitActionAcrossThreads (pure ()) (const newStdGen) + defaultMain + [ bgroup + "single-threaded timings" + [ -- These ID generation functions use the machine's random number generator, + -- which can be slow if used improperly. + bench "generateTraceId" $ nfIO (generateXRayTraceId stdGenIORef) + , bench "generateSegmentId" + $ nfIO (withRandomGenIORef stdGenIORef generateXRaySegmentId) + , bench "getPOSIXTime" $ nfIO getPOSIXTime + , bench "intToDigit" $ nf intToDigit 0 + , bench "newStdGen" $ whnfIO newStdGen + , bench "makeSegment" $ whnfIO (makeSegment stdGenIORef) + ] + , bgroup + "generateXRaySegmentId not shared parallel" + [ benchGenerateXRaySegmentId 100 segmentIdNotShared + , benchGenerateXRaySegmentId 4 segmentIdNotShared + , benchGenerateXRaySegmentId 2 segmentIdNotShared + , benchGenerateXRaySegmentId 1 segmentIdNotShared + ] + , bgroup + "generateXRaySegmentId shared parallel" + [ benchGenerateXRaySegmentId 100 segmentIdShared + , benchGenerateXRaySegmentId 4 segmentIdShared + , benchGenerateXRaySegmentId 2 segmentIdShared + , benchGenerateXRaySegmentId 1 segmentIdShared + ] + , bgroup + "newStdGen parallel" + [ bench "newStdGen parallel 100" $ whnfIO $ parNewStdGen 100 10000 + , bench "newStdGen parallel 4" $ whnfIO $ parNewStdGen 4 10000 + , bench "newStdGen parallel 2" $ whnfIO $ parNewStdGen 2 10000 + , bench "newStdGen parallel 1" $ whnfIO $ parNewStdGen 1 10000 + ] + ] + +benchGenerateXRaySegmentId :: Int -> (Int -> Int -> IO a) -> Benchmark +benchGenerateXRaySegmentId n segmentIdSharing = + bench ("generateXRaySegmentId " ++ show n) $ whnfIO $ segmentIdSharing n 10000 + +makeSegment :: IORef StdGen -> IO XRaySegment +makeSegment stdGenIORef = do + startTime <- getPOSIXTime + endTime <- getPOSIXTime + segmentId <- withRandomGenIORef stdGenIORef generateXRaySegmentId + pure $ xraySubsegment "segment" segmentId startTime (Just endTime) + +splitActionAcrossThreads :: IO a -> (a -> IO b) -> Int -> Int -> IO () +splitActionAcrossThreads setup action numThreads totalActions = + replicateConcurrently_ numThreads $ do + setupArg <- setup + replicateM_ (totalActions `div` numThreads) (action setupArg) diff --git a/library/Network/AWS/XRayClient.hs b/library/Network/AWS/XRayClient.hs new file mode 100644 --- /dev/null +++ b/library/Network/AWS/XRayClient.hs @@ -0,0 +1,7 @@ +module Network.AWS.XRayClient + ( module X + ) where + +import Network.AWS.XRayClient.Segment as X +import Network.AWS.XRayClient.TraceId as X +import System.Random.XRayCustom as X diff --git a/library/Network/AWS/XRayClient/JSONHelpers.hs b/library/Network/AWS/XRayClient/JSONHelpers.hs new file mode 100644 --- /dev/null +++ b/library/Network/AWS/XRayClient/JSONHelpers.hs @@ -0,0 +1,41 @@ +module Network.AWS.XRayClient.JSONHelpers + ( xrayAesonOptions + ) where + +import Prelude + +import Data.Aeson +import qualified Data.Char as C +import Data.List (isPrefixOf) + +-- | Aeson 'Options' to remove prefix and apply snake_case. +xrayAesonOptions :: String -> Options +xrayAesonOptions prefix = defaultOptions + { fieldLabelModifier = snakeCaseify . unCapitalize . dropPrefix prefix + , omitNothingFields = True + } + +-- | Lower-case and insert an underscore before upper-case letters +-- +-- >>> snakeCaseify "levelSubtraction" +-- "level_subtraction" +-- +snakeCaseify :: String -> String +snakeCaseify [] = [] +snakeCaseify (c : cs) + | C.isLower c || C.isNumber c = c : snakeCaseify cs + | otherwise = '_' : C.toLower c : snakeCaseify cs + +-- | Lower-case leading character +-- +-- >>> unCapitalize "Capped" +-- "capped" +-- +unCapitalize :: String -> String +unCapitalize [] = [] +unCapitalize (c : cs) = C.toLower c : cs + +dropPrefix :: String -> String -> String +dropPrefix prefix x = if prefix `isPrefixOf` x + then drop (length prefix) x + else error $ "dropPrefix: " ++ show prefix ++ " is not a prefix of " ++ show x diff --git a/library/Network/AWS/XRayClient/Segment.hs b/library/Network/AWS/XRayClient/Segment.hs new file mode 100644 --- /dev/null +++ b/library/Network/AWS/XRayClient/Segment.hs @@ -0,0 +1,479 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} + +module Network.AWS.XRayClient.Segment + ( -- * Segment + XRaySegment(..) + , xraySegment + , xraySubsegment + , xrayIndependentSubsegment + + , xraySegmentName + , xraySegmentId + , xraySegmentTraceId + , xraySegmentStartTime + , xraySegmentEndTime + , xraySegmentInProgress + , xraySegmentParentId + , xraySegmentType + , xraySegmentOrigin + , xraySegmentUser + , xraySegmentNamespace + , xraySegmentService + , xraySegmentError + , xraySegmentThrottle + , xraySegmentFault + , xraySegmentCause + , xraySegmentHttp + , xraySegmentAnnotations + , xraySegmentMetadata + , xraySegmentSubsegments + , xraySegmentAws + , xraySegmentSql + + , XRaySegmentService(..) + , xraySegmentServiceVersion + + -- * HTTP + , XRaySegmentHttp(..) + , xraySegmentHttpDef + , xraySegmentHttpRequest + , xraySegmentHttpResponse + + , XRaySegmentHttpRequest(..) + , xraySegmentHttpRequestDef + , xraySegmentHttpRequestMethod + , xraySegmentHttpRequestUrl + , xraySegmentHttpRequestUserAgent + , xraySegmentHttpRequestClientIp + , xraySegmentHttpRequestXForwardedFor + , xraySegmentHttpRequestTraced + + , XRaySegmentHttpResponse(..) + , xraySegmentHttpResponseDef + , xraySegmentHttpResponseStatus + , xraySegmentHttpResponseContentLength + + -- * AWS Resource Data + , XRaySegmentAws(..) + , xraySegmentAwsDef + , xraySegmentAwsAccountId + , xraySegmentAwsEcs + , xraySegmentAwsEc2 + , xraySegmentAwsElasticBeanstalk + , xraySegmentAwsOperation + , xraySegmentAwsRegion + , xraySegmentAwsRequestId + , xraySegmentAwsQueueUrl + , xraySegmentAwsTableName + + , XRaySegmentAwsEcs(..) + , xraySegmentAwsEcsDef + , xraySegmentAwsEcsContainer + + , XRaySegmentAwsEc2(..) + , xraySegmentAwsEc2Def + , xraySegmentAwsEc2InstanceId + , xraySegmentAwsEc2AvailabilityZone + + , XRaySegmentAwsElasticBeanstalk(..) + , xraySegmentAwsElasticBeanstalkDef + , xraySegmentAwsElasticBeanstalkEnvironmentName + , xraySegmentAwsElasticBeanstalkVersionLabel + , xraySegmentAwsElasticBeanstalkDeploymentId + + -- * SQL + , XRaySegmentSql(..) + , xraySegmentSqlDef + , xraySegmentSqlConnectionString + , xraySegmentSqlUrl + , xraySegmentSqlSanitizedQuery + , xraySegmentSqlDatabaseType + , xraySegmentSqlDatabaseVersion + , xraySegmentSqlDriverVersion + , xraySegmentSqlUser + , xraySegmentSqlPreparation + ) where + +import Prelude + +import Control.Lens.TH +import Data.Aeson +import Data.Aeson.TH +import Data.Maybe (isNothing) +import Data.Text (Text) +import Data.Time.Clock.POSIX +import Network.AWS.XRayClient.JSONHelpers +import Network.AWS.XRayClient.TraceId + +-- TODO: Make different types for segment, subsegment, and independent +-- subsegment instead of relying on different smart constructors. The +-- sub-sections, like aws, will also have different variants. + +-- | Represents an entire X-Ray Segment document. See +-- +data XRaySegment + = XRaySegment + { _xraySegmentName :: !Text + -- ^ The logical name of the service that handled the request, up to 200 + -- characters. For example, your application's name or domain name. Names + -- can contain Unicode letters, numbers, and whitespace, and the following + -- symbols: _, ., :, /, %, &, #, =, +, \, -, @ + , _xraySegmentId :: !XRaySegmentId + -- ^ A 64-bit identifier for the segment, unique among segments in the same + -- trace, in 16 hexadecimal digits. + , _xraySegmentTraceId :: !(Maybe XRayTraceId) + -- ^ A unique identifier that connects all segments and subsegments + -- originating from a single client request. + , _xraySegmentStartTime :: !POSIXTime + -- ^ number that is the time the segment was created, in floating point + -- seconds in epoch time. For example, 1480615200.010 or 1.480615200010E9. + -- Use as many decimal places as you need. Microsecond resolution is + -- recommended when available. + , _xraySegmentEndTime :: !(Maybe POSIXTime) + -- ^ number that is the time the segment was closed. For example, + -- 1480615200.090 or 1.480615200090E9. Specify either an end_time or + -- in_progress. + , _xraySegmentInProgress :: !(Maybe Bool) + -- ^ boolean, set to true instead of specifying an end_time to record that + -- a segment is started, but is not complete. Send an in-progress segment + -- when your application receives a request that will take a long time to + -- serve, to trace the request receipt. When the response is sent, send the + -- complete segment to overwrite the in-progress segment. Only send one + -- complete segment, and one or zero in-progress segments, per request. + , _xraySegmentParentId :: !(Maybe XRaySegmentId) + -- ^ A subsegment ID you specify if the request originated from an + -- instrumented application. The X-Ray SDK adds the parent subsegment ID to + -- the tracing header for downstream HTTP calls. + , _xraySegmentType :: !(Maybe Text) + -- ^ Set this to @"subsegment"@ if this is an independent subsegment. + , _xraySegmentOrigin :: !(Maybe Text) + -- ^ The type of AWS resource running your application. + , _xraySegmentUser :: !(Maybe Text) + -- ^ A string that identifies the user who sent the request. + , _xraySegmentNamespace :: !(Maybe Text) + -- ^ "aws" for AWS SDK calls; "remote" for other downstream calls. + , _xraySegmentService :: !(Maybe XRaySegmentService) + -- ^ An object with information about your application. + , _xraySegmentError :: !(Maybe Bool) + -- ^ fields that indicate an error occurred and that include information + -- about the exception that caused the error. + , _xraySegmentThrottle :: !(Maybe Bool) + -- ^ fields that indicate an error occurred and that include information + -- about the exception that caused the error. + , _xraySegmentFault :: !(Maybe Bool) + -- ^ fields that indicate an error occurred and that include information + -- about the exception that caused the error. + + -- TODO: Make cause more type-safe + , _xraySegmentCause :: !(Maybe Value) + -- ^ fields that indicate an error occurred and that include information + -- about the exception that caused the error. + , _xraySegmentHttp :: !(Maybe XRaySegmentHttp) + -- ^ 'XRaySegmentHttp' object with information about the original HTTP + -- request. + , _xraySegmentAnnotations :: !(Maybe Object) + -- ^ object with key-value pairs that you want X-Ray to index for search. + , _xraySegmentMetadata :: !(Maybe Object) + -- ^ object with any additional data that you want to store in the segment. + , _xraySegmentSubsegments :: !(Maybe [XRaySegment]) + -- ^ array of 'XRaySegment' objects. See 'xraySubSegment' for a smart + -- constructor. + , _xraySegmentAws :: !(Maybe XRaySegmentAws) + -- ^ object with information about the AWS resource on which your + -- application served the request. + , _xraySegmentSql :: !(Maybe XRaySegmentSql) + -- ^ Object representing a sql query. + } deriving (Show, Eq) + +-- | Smart constructor for 'XRaySegment' with all the required fields. +-- +-- Note that in 'XRaySegment', @end_time@ and @in_progress@ are mutually +-- exclusive. If your @end_time@ is 'Nothing', then @in_progress@ will be set +-- to 'True'. +xraySegment + :: Text -- ^ name + -> XRaySegmentId -- ^ id + -> XRayTraceId -- ^ trace_id + -> POSIXTime -- ^ start_time + -> Maybe POSIXTime -- ^ end_time + -> XRaySegment +xraySegment name segmentId traceId startTime mEndTime = + (xraySubsegment name segmentId startTime mEndTime) + { _xraySegmentTraceId = Just traceId + } + +-- | An 'XRaySegment' meant to be used as an embedded subsegment in another +-- 'XRaySegment'. +xraySubsegment + :: Text -- ^ name + -> XRaySegmentId -- ^ id + -> POSIXTime -- ^ start_time + -> Maybe POSIXTime -- ^ end_time + -> XRaySegment +xraySubsegment name segmentId startTime mEndTime = XRaySegment + { _xraySegmentName = name + , _xraySegmentId = segmentId + , _xraySegmentTraceId = Nothing + , _xraySegmentStartTime = startTime + -- NB: We must either specify end time or in_progress = true + , _xraySegmentEndTime = mEndTime + , _xraySegmentInProgress = if isNothing mEndTime then Just True else Nothing + , _xraySegmentParentId = Nothing + , _xraySegmentType = Nothing + , _xraySegmentOrigin = Nothing + , _xraySegmentUser = Nothing + , _xraySegmentNamespace = Nothing + , _xraySegmentService = Nothing + , _xraySegmentError = Nothing + , _xraySegmentThrottle = Nothing + , _xraySegmentFault = Nothing + , _xraySegmentCause = Nothing + , _xraySegmentHttp = Nothing + , _xraySegmentAnnotations = Nothing + , _xraySegmentMetadata = Nothing + , _xraySegmentSubsegments = Nothing + , _xraySegmentAws = Nothing + , _xraySegmentSql = Nothing + } + +-- | Smart constructor for an independent subsegment. Includes additional +-- required fields. +xrayIndependentSubsegment + :: Text -- ^ name + -> XRaySegmentId -- ^ id + -> XRayTraceId -- ^ trace_id + -> POSIXTime -- ^ start_time + -> Maybe POSIXTime -- ^ end_time + -> XRaySegmentId -- ^ parent_id + -> XRaySegment +xrayIndependentSubsegment name segmentId traceId startTime mEndTime parentId = + (xraySegment name segmentId traceId startTime mEndTime) + { _xraySegmentType = Just "subsegment" + , _xraySegmentParentId = Just parentId + } + +-- | Type for the @service@ field of a segment document. +newtype XRaySegmentService + = XRaySegmentService + { _xraySegmentServiceVersion :: Text + -- ^ A string that identifies the version of your application that served + -- the request. + } deriving (Show, Eq) + +-- | See +-- +data XRaySegmentHttp + = XRaySegmentHttp + { _xraySegmentHttpRequest :: !(Maybe XRaySegmentHttpRequest) + , _xraySegmentHttpResponse :: !(Maybe XRaySegmentHttpResponse) + } deriving (Show, Eq) + +-- | Constructor for 'XRaySegmentHttp' with fields initialized to 'Nothing'. +xraySegmentHttpDef :: XRaySegmentHttp +xraySegmentHttpDef = XRaySegmentHttp + { _xraySegmentHttpRequest = Nothing + , _xraySegmentHttpResponse = Nothing + } + +data XRaySegmentHttpRequest + = XRaySegmentHttpRequest + { _xraySegmentHttpRequestMethod :: !(Maybe Text) + -- ^ The request method. For example, GET. + , _xraySegmentHttpRequestUrl :: !(Maybe Text) + -- ^ The full URL of the request, compiled from the protocol, hostname, and + -- path of the request. + , _xraySegmentHttpRequestUserAgent :: !(Maybe Text) + -- ^ The user agent string from the requester's client. + , _xraySegmentHttpRequestClientIp :: !(Maybe Text) + -- ^ The IP address of the requester. Can be retrieved from the IP packet's + -- Source Address or, for forwarded requests, from an X-Forwarded-For + -- header. + , _xraySegmentHttpRequestXForwardedFor :: !(Maybe Bool) + -- ^ (segments only) boolean indicating that the client_ip was read from an + -- X-Forwarded-For header and is not reliable as it could have been forged. + , _xraySegmentHttpRequestTraced :: !(Maybe Bool) + -- ^ (subsegments only) boolean indicating that the downstream call is to + -- another traced service. If this field is set to true, X-Ray considers + -- the trace to be broken until the downstream service uploads a segment + -- with a parent_id that matches the id of the subsegment that contains + -- this block. + } deriving (Show, Eq) + +-- | Constructor for 'XRaySegmentHttpRequest' with fields initialized to 'Nothing'. +xraySegmentHttpRequestDef :: XRaySegmentHttpRequest +xraySegmentHttpRequestDef = XRaySegmentHttpRequest + { _xraySegmentHttpRequestMethod = Nothing + , _xraySegmentHttpRequestUrl = Nothing + , _xraySegmentHttpRequestUserAgent = Nothing + , _xraySegmentHttpRequestClientIp = Nothing + , _xraySegmentHttpRequestXForwardedFor = Nothing + , _xraySegmentHttpRequestTraced = Nothing + } + +data XRaySegmentHttpResponse + = XRaySegmentHttpResponse + { _xraySegmentHttpResponseStatus :: !(Maybe Int) + -- ^ number indicating the HTTP status of the response. + , _xraySegmentHttpResponseContentLength :: !(Maybe Int) + -- ^ number indicating the length of the response body in bytes. + } deriving (Show, Eq) + +-- | Constructor for 'XRaySegmentHttpResponse' with fields initialized to 'Nothing'. +xraySegmentHttpResponseDef :: XRaySegmentHttpResponse +xraySegmentHttpResponseDef = XRaySegmentHttpResponse + { _xraySegmentHttpResponseStatus = Nothing + , _xraySegmentHttpResponseContentLength = Nothing + } + +-- | Type for the @aws@ field in a segment. See +-- +-- +-- NOTE: Please see the documentation for what fields are allowed in a segment +-- versus a subsegment. +data XRaySegmentAws + = XRaySegmentAws + { _xraySegmentAwsAccountId :: !(Maybe Text) + -- ^ If your application sends segments to a different AWS account, record + -- the ID of the account running your application. + , _xraySegmentAwsEcs :: !(Maybe XRaySegmentAwsEcs) + -- ^ Information about an Amazon ECS container. + , _xraySegmentAwsEc2 :: !(Maybe XRaySegmentAwsEc2) + -- ^ Information about an EC2 instance. + , _xraySegmentAwsElasticBeanstalk :: !(Maybe XRaySegmentAwsElasticBeanstalk) + -- ^ Information about an Elastic Beanstalk environment. You can find this + -- information in a file named /var/elasticbeanstalk/xray/environment.conf + -- on the latest Elastic Beanstalk platforms. + , _xraySegmentAwsOperation :: !(Maybe Text) + -- ^ The name of the API action invoked against an AWS service or resource. + , _xraySegmentAwsRegion :: !(Maybe Text) + -- ^ If the resource is in a region different from your application, record + -- the region. For example, us-west-2. + , _xraySegmentAwsRequestId :: !(Maybe Text) + -- ^ Unique identifier for the request. + , _xraySegmentAwsQueueUrl :: !(Maybe Text) + -- ^ For operations on an Amazon SQS queue, the queue's URL. + , _xraySegmentAwsTableName :: !(Maybe Text) + -- ^ For operations on a DynamoDB table, the name of the table. + } deriving (Show, Eq) + +-- | Constructor for 'XRaySegmentAws' with fields initialized to 'Nothing'. +xraySegmentAwsDef :: XRaySegmentAws +xraySegmentAwsDef = XRaySegmentAws + { _xraySegmentAwsAccountId = Nothing + , _xraySegmentAwsEcs = Nothing + , _xraySegmentAwsEc2 = Nothing + , _xraySegmentAwsElasticBeanstalk = Nothing + , _xraySegmentAwsOperation = Nothing + , _xraySegmentAwsRegion = Nothing + , _xraySegmentAwsRequestId = Nothing + , _xraySegmentAwsQueueUrl = Nothing + , _xraySegmentAwsTableName = Nothing + } + +newtype XRaySegmentAwsEcs + = XRaySegmentAwsEcs + { _xraySegmentAwsEcsContainer :: Maybe Text + -- ^ The container ID of the container running your application. + } deriving (Show, Eq) + +-- | Constructor for 'XRaySegmentAwsEcs' with fields initialized to 'Nothing'. +xraySegmentAwsEcsDef :: XRaySegmentAwsEcs +xraySegmentAwsEcsDef = + XRaySegmentAwsEcs {_xraySegmentAwsEcsContainer = Nothing} + +data XRaySegmentAwsEc2 + = XRaySegmentAwsEc2 + { _xraySegmentAwsEc2InstanceId :: !(Maybe Text) + -- ^ The instance ID of the EC2 instance. + , _xraySegmentAwsEc2AvailabilityZone :: !(Maybe Text) + -- ^ The Availability Zone in which the instance is running. + } deriving (Show, Eq) + +-- | Constructor for 'XRaySegmentAwsEc2' with fields initialized to 'Nothing'. +xraySegmentAwsEc2Def :: XRaySegmentAwsEc2 +xraySegmentAwsEc2Def = XRaySegmentAwsEc2 + { _xraySegmentAwsEc2InstanceId = Nothing + , _xraySegmentAwsEc2AvailabilityZone = Nothing + } + +data XRaySegmentAwsElasticBeanstalk + = XRaySegmentAwsElasticBeanstalk + { _xraySegmentAwsElasticBeanstalkEnvironmentName :: !(Maybe Text) + -- ^ The name of the environment. + , _xraySegmentAwsElasticBeanstalkVersionLabel :: !(Maybe Text) + -- ^ The name of the application version that is currently deployed to the + -- instance that served the request. + , _xraySegmentAwsElasticBeanstalkDeploymentId :: !(Maybe Int) + -- ^ number indicating the ID of the last successful deployment to the + -- instance that served the request. + } deriving (Show, Eq) + +-- | Constructor for 'XRaySegmentAwsElasticBeanstalk' with fields initialized +-- to 'Nothing'. +xraySegmentAwsElasticBeanstalkDef :: XRaySegmentAwsElasticBeanstalk +xraySegmentAwsElasticBeanstalkDef = XRaySegmentAwsElasticBeanstalk + { _xraySegmentAwsElasticBeanstalkEnvironmentName = Nothing + , _xraySegmentAwsElasticBeanstalkVersionLabel = Nothing + , _xraySegmentAwsElasticBeanstalkDeploymentId = Nothing + } + +data XRaySegmentSql + = XRaySegmentSql + { _xraySegmentSqlConnectionString :: !(Maybe Text) + -- ^ For SQL Server or other database connections that don't use URL + -- connection strings, record the connection string, excluding passwords. + , _xraySegmentSqlUrl :: !(Maybe Text) + -- ^ For a database connection that uses a URL connection string, record + -- the URL, excluding passwords. + , _xraySegmentSqlSanitizedQuery :: !(Maybe Text) + -- ^ The database query, with any user provided values removed or replaced + -- by a placeholder. + , _xraySegmentSqlDatabaseType :: !(Maybe Text) + -- ^ The name of the database engine. + , _xraySegmentSqlDatabaseVersion :: !(Maybe Text) + -- ^ The version number of the database engine. + , _xraySegmentSqlDriverVersion :: !(Maybe Text) + -- ^ The name and version number of the database engine driver that your + -- application uses. + , _xraySegmentSqlUser :: !(Maybe Text) + -- ^ The database username. + , _xraySegmentSqlPreparation :: !(Maybe Text) + -- ^ call if the query used a PreparedCall; statement if the query used a + -- PreparedStatement. + } deriving (Show, Eq) + +-- | Constructor for 'XRaySegmentSql' with fields initialized to 'Nothing'. +xraySegmentSqlDef :: XRaySegmentSql +xraySegmentSqlDef = XRaySegmentSql + { _xraySegmentSqlConnectionString = Nothing + , _xraySegmentSqlUrl = Nothing + , _xraySegmentSqlSanitizedQuery = Nothing + , _xraySegmentSqlDatabaseType = Nothing + , _xraySegmentSqlDatabaseVersion = Nothing + , _xraySegmentSqlDriverVersion = Nothing + , _xraySegmentSqlUser = Nothing + , _xraySegmentSqlPreparation = Nothing + } + +makeLenses ''XRaySegment +makeLenses ''XRaySegmentHttp +makeLenses ''XRaySegmentHttpRequest +makeLenses ''XRaySegmentHttpResponse +makeLenses ''XRaySegmentAws +makeLenses ''XRaySegmentAwsEcs +makeLenses ''XRaySegmentAwsEc2 +makeLenses ''XRaySegmentAwsElasticBeanstalk +makeLenses ''XRaySegmentSql +makeLenses ''XRaySegmentService + +deriveJSON (xrayAesonOptions "_xraySegment") ''XRaySegment +deriveJSON (xrayAesonOptions "_xraySegmentHttp") ''XRaySegmentHttp +deriveJSON (xrayAesonOptions "_xraySegmentHttpRequest") ''XRaySegmentHttpRequest +deriveJSON (xrayAesonOptions "_xraySegmentHttpResponse") ''XRaySegmentHttpResponse +deriveJSON (xrayAesonOptions "_xraySegmentAws") ''XRaySegmentAws +deriveJSON (xrayAesonOptions "_xraySegmentAwsEcs") ''XRaySegmentAwsEcs +deriveJSON (xrayAesonOptions "_xraySegmentAwsEc2") ''XRaySegmentAwsEc2 +deriveJSON (xrayAesonOptions "_xraySegmentAwsElasticBeanstalk") ''XRaySegmentAwsElasticBeanstalk +deriveJSON (xrayAesonOptions "_xraySegmentSql") ''XRaySegmentSql +deriveJSON (xrayAesonOptions "_xraySegmentService") ''XRaySegmentService diff --git a/library/Network/AWS/XRayClient/SendSegments.hs b/library/Network/AWS/XRayClient/SendSegments.hs new file mode 100644 --- /dev/null +++ b/library/Network/AWS/XRayClient/SendSegments.hs @@ -0,0 +1,60 @@ +-- | Module for sending segments to the XRay daemon. + +module Network.AWS.XRayClient.SendSegments + ( sendSegmentsToDaemon + , NoAddressInfoException(..) + ) where + +import Prelude + +import Control.Exception (Exception, SomeException, catch, throwIO) +import Data.Aeson +import Data.ByteString (ByteString) +import qualified Data.ByteString.Lazy as BSL +import Data.Foldable (traverse_) +import Data.Monoid ((<>)) +import Data.Text (Text) +import qualified Data.Text as T +import Data.Typeable +import Network.AWS.XRayClient.Segment as X +import Network.Socket +import Network.Socket.ByteString (sendAll) +import System.IO (hPutStrLn, stderr) + +-- | Makes JSON payloads for each segment and sends it to the daemon. +sendSegmentsToDaemon :: Text -> Int -> [XRaySegment] -> IO () +sendSegmentsToDaemon host port segments = catch + (sendUDPByteStrings host port $ makeXRayPayload <$> segments) + (\(err :: SomeException) -> + hPutStrLn stderr ("sendUDPByteStrings: " ++ show err) + ) + +makeXRayPayload :: XRaySegment -> ByteString +makeXRayPayload segment = + let header = object ["format" .= ("json" :: String), "version" .= (1 :: Int)] + in BSL.toStrict $ encode header <> "\n" <> encode segment + +-- | Sends the entirety of multiple 'ByteString' values to a given host/port +-- via UDP Datagrams. +sendUDPByteStrings :: Text -> Int -> [ByteString] -> IO () +sendUDPByteStrings host port payloads = do + addrInfos <- getAddrInfo Nothing (Just $ T.unpack host) (Just $ show port) + case addrInfos of + [] -> + throwIO + $ NoAddressInfoException + $ "No address info for " + ++ T.unpack host + ++ ":" + ++ show port + (serverAddr : _) -> do + sock <- socket (addrFamily serverAddr) Datagram defaultProtocol + connect sock (addrAddress serverAddr) + traverse_ (sendAll sock) payloads + close sock + +newtype NoAddressInfoException + = NoAddressInfoException String + deriving (Show, Typeable) + +instance Exception NoAddressInfoException diff --git a/library/Network/AWS/XRayClient/TraceId.hs b/library/Network/AWS/XRayClient/TraceId.hs new file mode 100644 --- /dev/null +++ b/library/Network/AWS/XRayClient/TraceId.hs @@ -0,0 +1,143 @@ +{-# LANGUAGE FlexibleContexts #-} + +module Network.AWS.XRayClient.TraceId + ( amazonTraceIdHeaderName + , -- * Trace ID + XRayTraceId(..) + , generateXRayTraceId + , makeXRayTraceId + , XRaySegmentId(..) + , generateXRaySegmentId + -- * Trace ID Header + , XRayTraceIdHeaderData(..) + , xrayTraceIdHeaderData + , parseXRayTraceIdHeaderData + , makeXRayTraceIdHeaderValue + ) where + +import Prelude + +import Control.DeepSeq (NFData) +import Data.Aeson +import Data.Bifunctor (first) +import Data.ByteString (ByteString) +import qualified Data.ByteString.Char8 as BS8 +import Data.Char (intToDigit) +import Data.IORef +import Data.Monoid ((<>)) +import Data.Text (Text) +import qualified Data.Text as T +import qualified Data.Text.Encoding as T +import Data.Time.Clock.POSIX (getPOSIXTime) +import GHC.Generics +import Network.HTTP.Types.Header +import Numeric (showHex) +import System.Random +import System.Random.XRayCustom + +-- | Variable for "X-Amzn-Trace-Id" so you don't have to worry about +-- misspelling it. +amazonTraceIdHeaderName :: HeaderName +amazonTraceIdHeaderName = "X-Amzn-Trace-Id" + +-- | A trace_id consists of three numbers separated by hyphens. For example, +-- 1-58406520-a006649127e371903a2de979. This includes: The version number, that +-- is, 1. The time of the original request, in Unix epoch time, in 8 +-- hexadecimal digits. For example, 10:00AM December 2nd, 2016 PST in epoch +-- time is 1480615200 seconds, or 58406520 in hexadecimal. A 96-bit identifier +-- for the trace, globally unique, in 24 hexadecimal digits. +newtype XRayTraceId = XRayTraceId { unXRayTraceId :: Text } + deriving (Show, Eq) + deriving newtype (FromJSON, ToJSON, NFData) + +-- TODO: Make a parse function and don't export constructor +-- parseXRayTraceId :: (MonadError String m) => ByteString -> m XRayTraceId + +-- | Generates an 'XRayTraceId' in 'IO'. WARNING: This uses the global +-- 'StdGen', so this can be a bottleneck in multi-threaded applications. +generateXRayTraceId :: IORef StdGen -> IO XRayTraceId +generateXRayTraceId ioRef = do + timeInSeconds <- round <$> getPOSIXTime + withRandomGenIORef ioRef $ makeXRayTraceId timeInSeconds + +makeXRayTraceId :: Int -> StdGen -> (XRayTraceId, StdGen) +makeXRayTraceId timeInSeconds gen = first make $ randomHexString 24 gen + where + make hexString = + XRayTraceId $ T.pack $ "1-" ++ showHex timeInSeconds "" ++ "-" ++ hexString + +-- | Generates a random hexadecimal string of a given length. +randomHexString :: Int -> StdGen -> (String, StdGen) +randomHexString n gen = + replicateRandom n gen $ first intToDigit . randomR (0, 15) + +-- | A 64-bit identifier for the segment, unique among segments in the same +-- trace, in 16 hexadecimal digits. +newtype XRaySegmentId = XRaySegmentId { unXRaySegmentId :: Text } + deriving (Show, Eq) + deriving newtype (FromJSON, ToJSON, NFData) + +-- TODO: Make parse function for XRaySegmentId so it is safer. + +-- | Generates an 'XRaySegmentId' using a given 'StdGen'. +generateXRaySegmentId :: StdGen -> (XRaySegmentId, StdGen) +generateXRaySegmentId = first (XRaySegmentId . T.pack) . randomHexString 16 + +-- | This holds the data from the X-Amzn-Trace-Id header. See +-- http://docs.aws.amazon.com/xray/latest/devguide/xray-concepts.html#xray-concepts-tracingheader +data XRayTraceIdHeaderData + = XRayTraceIdHeaderData + { xrayTraceIdHeaderDataRootTraceId :: !XRayTraceId + , xrayTraceIdHeaderDataParentId :: !(Maybe XRaySegmentId) + , xrayTraceIdHeaderDataSampled :: !(Maybe Bool) + } deriving (Show, Eq, Generic) + +-- | Constructor for 'XRayTraceIdHeaderData'. +xrayTraceIdHeaderData :: XRayTraceId -> XRayTraceIdHeaderData +xrayTraceIdHeaderData traceId = XRayTraceIdHeaderData + { xrayTraceIdHeaderDataRootTraceId = traceId + , xrayTraceIdHeaderDataParentId = Nothing + , xrayTraceIdHeaderDataSampled = Nothing + } + +-- | Try to parse the value of the X-Amzn-Trace-Id into a +-- 'XRayTraceIdHeaderData'. +parseXRayTraceIdHeaderData :: ByteString -> Maybe XRayTraceIdHeaderData +parseXRayTraceIdHeaderData rawHeader = do + components <- traverse parseHeaderComponent $ BS8.split ';' rawHeader + traceId <- lookup "Root" components + pure XRayTraceIdHeaderData + { xrayTraceIdHeaderDataRootTraceId = XRayTraceId (T.decodeUtf8 traceId) + , xrayTraceIdHeaderDataParentId = XRaySegmentId + . T.decodeUtf8 + <$> lookup "Parent" components + , xrayTraceIdHeaderDataSampled = lookup "Sampled" components >>= readSampled + } + where + readSampled :: ByteString -> Maybe Bool + readSampled "0" = Just False + readSampled "1" = Just True + readSampled _ = Nothing + +-- | Turns a 'XRayTraceIdHeaderData' into a 'ByteString' meant for the +-- X-Amzn-Trace-Id header value. +makeXRayTraceIdHeaderValue :: XRayTraceIdHeaderData -> ByteString +makeXRayTraceIdHeaderValue XRayTraceIdHeaderData {..} = + traceIdPart <> parentPart <> sampledPart + where + traceIdPart = + "Root=" <> T.encodeUtf8 (unXRayTraceId xrayTraceIdHeaderDataRootTraceId) + parentPart = maybe + "" + ((";Parent=" <>) . T.encodeUtf8 . unXRaySegmentId) + xrayTraceIdHeaderDataParentId + sampledPart = maybe + "" + ((";Sampled=" <>) . BS8.pack . show . fromEnum) + xrayTraceIdHeaderDataSampled + +-- | Header components look like Name=Value +parseHeaderComponent :: ByteString -> Maybe (ByteString, ByteString) +parseHeaderComponent rawComponent = case BS8.split '=' rawComponent of + [name, value] -> Just (name, value) + _ -> Nothing diff --git a/library/System/Random/XRayCustom.hs b/library/System/Random/XRayCustom.hs new file mode 100644 --- /dev/null +++ b/library/System/Random/XRayCustom.hs @@ -0,0 +1,28 @@ +-- | Helpful functions that should have been included in System.Random. + +module System.Random.XRayCustom + ( withRandomGenIORef + , replicateRandom + ) where + +import Prelude + +import Data.IORef +import System.Random + +-- | Like 'getStdRandom', except use a given 'IORef StdGen' instead of the +-- global 'theStdGen'. +withRandomGenIORef :: (RandomGen g) => IORef g -> (g -> (a, g)) -> IO a +withRandomGenIORef ioRef f = atomicModifyIORef' ioRef (swap . f) + where swap (x, y) = (y, x) + +-- | Runs the supplied function a specified number of times, each time using +-- the new 'RandomGen' value. +replicateRandom :: (RandomGen g) => Int -> g -> (g -> (a, g)) -> ([a], g) +replicateRandom n gen f = replicateRandom' n ([], gen) + where + replicateRandom' n' (xs, gen') + | n' <= 0 + = (xs, gen') + | otherwise + = let ~(x, gen'') = f gen' in replicateRandom' (n' - 1) (x : xs, gen'') diff --git a/tests/Network/AWS/XRayClient/SegmentSpec.hs b/tests/Network/AWS/XRayClient/SegmentSpec.hs new file mode 100644 --- /dev/null +++ b/tests/Network/AWS/XRayClient/SegmentSpec.hs @@ -0,0 +1,196 @@ +{-# LANGUAGE MonomorphismRestriction #-} +{-# LANGUAGE OverloadedLists #-} +{-# LANGUAGE QuasiQuotes #-} + +module Network.AWS.XRayClient.SegmentSpec + ( spec + ) where + +import Prelude + +import Control.Lens hiding ((.=)) +import Data.Aeson +import Data.Aeson.QQ +import Test.Hspec + +import Network.AWS.XRayClient.Segment +import Network.AWS.XRayClient.TraceId + +spec :: Spec +spec = do + let + traceId = XRayTraceId "1-5880168b-fd5158284b67678a3bb5a78c" + segmentId = XRaySegmentId "6b55dcc497934f1a" + startTime = 123.456 + endTime = 789.123 + + describe "Segment JSON instances" $ do + it "should correctly encode the minimum segment" $ do + let + segment = + xraySegment + "my-service" + segmentId + traceId + startTime + (Just endTime) + toJSON segment `shouldBe` + [aesonQQ| + { + "id": #{segmentId}, + "trace_id": #{traceId}, + "name": "my-service", + "start_time": #{startTime}, + "end_time": #{endTime} + } + |] + + it "should handle in_progress properly" $ do + let + segment = + xraySegment + "my-service" + segmentId + traceId + startTime + Nothing + toJSON segment `shouldBe` + [aesonQQ| + { + "id": #{segmentId}, + "trace_id": #{traceId}, + "name": "my-service", + "start_time": #{startTime}, + "in_progress": true + } + |] + + -- NB: This is basically a big integration test taken from the AWS docs + it "should handle a super long segment" $ do + toJSON bigSegment `shouldBe` bigSegmentJSON + +bigSegment :: XRaySegment +bigSegment = + xraySegment + "www.example.com" + (XRaySegmentId "6b55dcc497934f1a") + (XRayTraceId "1-5880168b-fd5158284b67678a3bb5a78c") + 1484789387.126 + (Just 1484789387.535) + & xraySegmentOrigin ?~ "AWS::EC2::Instance" + & xraySegmentHttp ?~ ( + xraySegmentHttpDef + & xraySegmentHttpRequest ?~ ( + xraySegmentHttpRequestDef + & xraySegmentHttpRequestMethod ?~ "POST" + & xraySegmentHttpRequestClientIp ?~ "78.255.233.48" + & xraySegmentHttpRequestUrl ?~ "http://www.example.com/api/user" + & xraySegmentHttpRequestUserAgent ?~ "Mozilla/5.0 (Windows NT 6.1; WOW64; rv:45.0) Gecko/20100101 Firefox/45.0" + & xraySegmentHttpRequestXForwardedFor ?~ True + ) + & xraySegmentHttpResponse ?~ ( + xraySegmentHttpResponseDef + & xraySegmentHttpResponseStatus ?~ 200 + ) + ) + & xraySegmentAnnotations ?~ + [ "customer_category" .= (124 :: Int) + , "zip_code" .= (98101 :: Int) + , "country" .= ("United States" :: String) + , "internal" .= False + ] + & xraySegmentAws ?~ ( + xraySegmentAwsDef + & xraySegmentAwsEc2 ?~ ( + xraySegmentAwsEc2Def + & xraySegmentAwsEc2InstanceId ?~ "i-0b5a4678fc325bg98" + & xraySegmentAwsEc2AvailabilityZone ?~ "us-west-2c" + ) + ) + & xraySegmentSubsegments ?~ + [ xraySubsegment + "RDS" + (XRaySegmentId "0f910026178b71eb") + 1484789387.502 + (Just 1484789387.534) + & xraySegmentNamespace ?~ "aws" + & xraySegmentHttp ?~ ( + xraySegmentHttpDef + & xraySegmentHttpResponse ?~ ( + xraySegmentHttpResponseDef + & xraySegmentHttpResponseStatus ?~ 200 + & xraySegmentHttpResponseContentLength ?~ 58 + ) + ) + & xraySegmentSql ?~ ( + xraySegmentSqlDef + & xraySegmentSqlUrl ?~ "jdbc:postgresql://aawijb5u25wdoy.cpamxznpdoq8.us-west-2.rds.amazonaws.com:5432/ebdb" + & xraySegmentSqlPreparation ?~ "statement" + & xraySegmentSqlDatabaseType ?~ "PostgreSQL" + & xraySegmentSqlDatabaseVersion ?~ "9.5.4" + & xraySegmentSqlDriverVersion ?~ "PostgreSQL 9.4.1211.jre7" + & xraySegmentSqlUser ?~ "dbuser" + & xraySegmentSqlSanitizedQuery ?~ "SELECT * FROM customers WHERE customer_id=?;" + ) + ] + +bigSegmentJSON :: Value +bigSegmentJSON = + [aesonQQ| +{ + "id": "6b55dcc497934f1a", + "start_time": 1484789387.126, + "end_time": 1484789387.535, + "trace_id": "1-5880168b-fd5158284b67678a3bb5a78c", + "name": "www.example.com", + "origin": "AWS::EC2::Instance", + "aws": { + "ec2": { + "availability_zone": "us-west-2c", + "instance_id": "i-0b5a4678fc325bg98" + } + }, + "annotations": { + "customer_category" : 124, + "zip_code" : 98101, + "country" : "United States", + "internal" : false + }, + "http": { + "request": { + "method": "POST", + "client_ip": "78.255.233.48", + "url": "http://www.example.com/api/user", + "user_agent": "Mozilla/5.0 (Windows NT 6.1; WOW64; rv:45.0) Gecko/20100101 Firefox/45.0", + "x_forwarded_for": true + }, + "response": { + "status": 200 + } + }, + "subsegments": [ + { + "id": "0f910026178b71eb", + "start_time": 1484789387.502, + "end_time": 1484789387.534, + "name": "RDS", + "namespace": "aws", + "http": { + "response": { + "content_length": 58, + "status": 200 + } + }, + "sql" : { + "url": "jdbc:postgresql://aawijb5u25wdoy.cpamxznpdoq8.us-west-2.rds.amazonaws.com:5432/ebdb", + "preparation": "statement", + "database_type": "PostgreSQL", + "database_version": "9.5.4", + "driver_version": "PostgreSQL 9.4.1211.jre7", + "user" : "dbuser", + "sanitized_query" : "SELECT * FROM customers WHERE customer_id=?;" + } + } + ] +} +|] diff --git a/tests/Network/AWS/XRayClient/TraceIdSpec.hs b/tests/Network/AWS/XRayClient/TraceIdSpec.hs new file mode 100644 --- /dev/null +++ b/tests/Network/AWS/XRayClient/TraceIdSpec.hs @@ -0,0 +1,38 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Network.AWS.XRayClient.TraceIdSpec + ( spec + ) where + +import Prelude + +import qualified Data.Text as T +import Network.AWS.XRayClient.TraceId +import System.Random +import Test.Hspec +import Test.QuickCheck +import Test.QuickCheck.Arbitrary.Generic + +instance Arbitrary XRayTraceId where + arbitrary = do + -- aws expects a timestamp in a specific range for their hex + timeStamp <- choose (1000000000, 4000000000) + gen <- mkStdGen . getPositive <$> arbitrary + pure . fst $ makeXRayTraceId timeStamp gen + +instance Arbitrary XRaySegmentId where + arbitrary = fst . generateXRaySegmentId . mkStdGen . getPositive <$> arbitrary + +instance Arbitrary XRayTraceIdHeaderData where + arbitrary = genericArbitrary + +spec :: Spec +spec = do + describe "generateXRayTraceId" $ do + it "should always be of length 35" $ property $ \(XRayTraceId traceId) -> + T.length traceId `shouldBe` 35 + + describe "parseXRayTraceIdHeaderData/makeXRayTraceIdHeaderValue" $ do + it "should be idempotent between writes/reads" $ property $ \headerData -> + parseXRayTraceIdHeaderData (makeXRayTraceIdHeaderValue headerData) + `shouldBe` Just headerData diff --git a/tests/Spec.hs b/tests/Spec.hs new file mode 100644 --- /dev/null +++ b/tests/Spec.hs @@ -0,0 +1,1 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover #-}