diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,20 @@ +Copyright (c) 2014 HirotomoMoriwaki + +Permission is hereby granted, free of charge, to any person obtaining +a copy of this software and associated documentation files (the +"Software"), to deal in the Software without restriction, including +without limitation the rights to use, copy, modify, merge, publish, +distribute, sublicense, and/or sell copies of the Software, and to +permit persons to whom the Software is furnished to do so, subject to +the following conditions: + +The above copyright notice and this permission notice shall be included +in all copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. +IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY +CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, +TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE +SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. 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/example.hs b/example.hs new file mode 100644 --- /dev/null +++ b/example.hs @@ -0,0 +1,23 @@ +{-# LANGUAGE OverloadedStrings #-} +import Control.Monad +import Control.Concurrent +import System.Environment +import Network.Helics +import qualified Data.ByteString.Char8 as S +import Control.Exception +import System.IO.Error + +main :: IO () +main = do + k:_ <- getArgs + _ <- forkIO $ sampler 60 + withHelics def { licenseKey = S.pack k } $ putStrLn "start" >> loop 0 + where + loop i = do + withTransaction "test" def (\tid -> do + genericSegment autoScope "neko" (threadDelay (10^5)) tid + when (i `mod` 97 == 0) $ ioError $ userError "user error!" + when (i `mod` 101 == 0) $ throwIO Overflow + ) `catch` (\e -> print (e::SomeException)) + threadDelay (2 * 10^5) + loop (succ i) diff --git a/helics.cabal b/helics.cabal new file mode 100644 --- /dev/null +++ b/helics.cabal @@ -0,0 +1,61 @@ +name: helics +version: 0.1.0 +synopsis: New Relic® agent SDK wrapper for Haskell. +description: + New Relic® agent SDK wrapper for Haskell. + . + Please get New Relic Agent SDK() before you install this package. + . + Copy include\/lib dir of SDK to system include\/lib path, or specify extra include\/lib path when installing this package. + . + @ + cabal insstall helics --extra-lib-dirs=$SDK_LIB_DIR --extra-include-dir=$SDK_INCLUDE_DIR + @ + . + +license: MIT +license-file: LICENSE +author: HirotomoMoriwaki +maintainer: philopon.dependence@gmail.com +-- copyright: +category: Network +build-type: Simple +-- extra-source-files: +cabal-version: >=1.10 + +flag example + default: False + +library + exposed-modules: Network.Helics + Network.Helics.Sampler + other-modules: Network.Helics.Foreign.Common + Network.Helics.Foreign.Client + Network.Helics.Foreign.Transaction + Network.Helics.Foreign.System + -- other-extensions: + build-depends: base >=4.7 && <4.8 + , data-default-class >=0.0 && <0.1 + , time >=1.2 && <1.6 + , unix >=2.6 && <2.8 + , bytestring >=0.10 && <0.11 + , bytestring-show >=0.3 && <0.4 + ghc-options: -Wall -O2 + hs-source-dirs: src + build-tools: hsc2hs + extra-libraries: newrelic-collector-client + , newrelic-transaction + , newrelic-common + default-language: Haskell2010 + +executable helics-example + main-is: example.hs + if flag(example) + build-depends: base >=4.7 && <4.8 + , helics + , bytestring + buildable: True + else + buildable: False + ghc-options: -Wall -O2 -threaded + default-language: Haskell2010 diff --git a/src/Network/Helics.hs b/src/Network/Helics.hs new file mode 100644 --- /dev/null +++ b/src/Network/Helics.hs @@ -0,0 +1,244 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} + +module Network.Helics + ( HelicsConfig(..) + , withHelics + , sampler + -- * metric + , recordMetric + , recordCpuUsage + , recordMemoryUsage + -- * transaction + , TransactionType(..) + , TransactionId + , withTransaction + , addAttribute + , setRequestUrl + , setMaxTraceSegments + -- * segment + , SegmentId + , autoScope + , rootSegment + , genericSegment + , DatastoreSegment(..) + , datastoreSegment + , externalSegment + -- * status code + , StatusCode + , statusShutdown + , statusStarting + , statusStopping + , statusStarted + -- * reexports + , def + ) where + +import System.IO.Error + +import Control.Exception +import Control.Monad +import Control.Concurrent + +import Foreign.C +import Foreign.Ptr +import Foreign.Marshal +import Foreign.Storable + +import Data.Word +import Data.Default.Class +import qualified Data.ByteString as S + +import qualified Network.Helics.Sampler as Sampler +import Network.Helics.Foreign.Common +import Network.Helics.Foreign.Client +import Network.Helics.Foreign.Transaction + +data HelicsConfig = HelicsConfig + { licenseKey :: S.ByteString + , appName :: S.ByteString + , language :: S.ByteString + , languageVersion :: S.ByteString + , statusCallback :: Maybe (StatusCode -> IO ()) + } + +instance Default HelicsConfig where + def = HelicsConfig + (error "license key is not set.") + "App" + "Haskell" + TOOL_VERSION_ghc + Nothing + +guardNr :: CInt -> IO () +guardNr c = unless (c == 0) $ throwIO $ ReturnCode c + +initialize :: HelicsConfig -> IO () +initialize HelicsConfig{..} = + S.useAsCString licenseKey $ \key -> + S.useAsCString appName $ \app -> + S.useAsCString language $ \lng -> + S.useAsCString languageVersion $ \ver -> + newrelic_init key app lng ver >>= guardNr + +shutdown :: S.ByteString -> IO () +shutdown reason = + S.useAsCString reason $ \r -> + newrelic_request_shutdown r >>= \c -> + guardNr c + +-- | start new relic® collector client. +-- you must call this function when embed-mode. +withHelics :: HelicsConfig -> IO a -> IO a +withHelics cfg m = bracket bra ket (const m) + where + bra = do + mv <- newEmptyMVar + cb <- makeStatusCallback (\i -> do + when (i == 3 || i == 0) $ putMVar mv () + maybe (return ()) ($ StatusCode i) $ statusCallback cfg) + newrelic_register_status_callback cb + + newrelic_register_message_handler newrelic_message_handler + + initialize cfg + takeMVar mv + return (freeHaskellFunPtr cb, mv) + + ket (freePtr, mv) = do + shutdown "withHelics: shutdown" + takeMVar mv :: IO () + freePtr :: IO () + +-- | record custom metric. +recordMetric :: S.ByteString -> Double -> IO () +recordMetric str d = S.useAsCString str $ \mtr -> + newrelic_record_metric mtr (realToFrac d) >>= guardNr + +-- | sample and send metric of cpu/memory usage. +sampler :: Int -- ^ sampling frequency (sec) + -> IO () +sampler s = flip Sampler.sampler (s * 10^(6::Int)) $ \user cpu mem -> do + recordCpuUsage user cpu + recordMemoryUsage (fromIntegral mem / (1024 * 1024)) + +-- | record CPU usage. Normally, you don't need to call this function. use sampler. +recordCpuUsage :: Double -> Double -> IO () +recordCpuUsage ut p = + newrelic_record_cpu_usage (realToFrac ut) (realToFrac p) >>= guardNr + +-- | record memory usage. Normally, you don't need to call this function. use sampler. +recordMemoryUsage :: Double -> IO () +recordMemoryUsage mb = + newrelic_record_memory_usage (realToFrac mb) >>= guardNr + +data TransactionType + = Default + | Web S.ByteString + | Other S.ByteString + +instance Default TransactionType where + def = Default + +withTransaction :: S.ByteString -- ^ name of transaction + -> TransactionType -> (TransactionId -> IO c) -> IO c +withTransaction name typ act = bracket bra ket + (\tid -> act tid `catch` exceptionHandler tid) + where + bra = do + tid <- newrelic_transaction_begin + guardNr =<< S.useAsCString name (newrelic_transaction_set_name tid) + return $ TransactionId tid + ket (TransactionId tid) = do + case typ of + Default -> return () + Web cat -> + guardNr =<< S.useAsCString cat (newrelic_transaction_set_category tid) + Other cat -> do + guardNr =<< newrelic_transaction_set_type_other tid + guardNr =<< S.useAsCString cat (newrelic_transaction_set_category tid) + guardNr =<< newrelic_transaction_end tid + + exceptionHandler (TransactionId tid) se = case fromException se of + Just e -> do + withCString (show $ ioeGetErrorType e) $ \et -> + withCString (ioeGetErrorString e) $ \msg -> + newrelic_transaction_notice_error tid et msg nullPtr nullPtr >>= guardNr + ioError e + + Nothing -> do + withCString (show se) $ \et -> + newrelic_transaction_notice_error tid et nullPtr nullPtr nullPtr >>= guardNr + throwIO se + +guardSid :: CLong -> IO CLong +guardSid sid = + if sid >= 0 + then return sid + else throwIO $ ReturnCode (fromIntegral sid) + +segment :: CLong -> IO CLong -> IO a -> IO a +segment tid m a = bracket (m >>= guardSid) (newrelic_segment_end tid) (const a) + +genericSegment :: SegmentId -- ^ parent segment id + -> S.ByteString -- ^ name of represent segment + -> IO c -- ^ action in segment + -> TransactionId + -> IO c +genericSegment (SegmentId pid) name act (TransactionId tid) = segment tid + (S.useAsCString name $ newrelic_segment_generic_begin tid pid) act + +data DatastoreSegment = DatastoreSegment + { table :: S.ByteString + , operation :: S.ByteString + , sql :: S.ByteString + , sqlTraceRollupName :: S.ByteString + , sqlObFuscator :: Maybe (S.ByteString -> S.ByteString) + } + +toCObfuscator :: (S.ByteString -> S.ByteString) -> CString -> IO CString +toCObfuscator f i = do + s <- S.packCString i + m <- mallocBytes (S.length s + 1) + pokeByteOff m (S.length s) (0 :: Word8) + S.useAsCString (f s) (\c -> copyBytes m c (S.length s)) + return m + +datastoreSegment :: SegmentId -> DatastoreSegment -> IO a -> TransactionId -> IO a +datastoreSegment (SegmentId pid) DatastoreSegment{..} act (TransactionId tid) = + S.useAsCString table $ \tbl -> + S.useAsCString operation $ \op -> + S.useAsCString sql $ \q -> + S.useAsCString sqlTraceRollupName $ \tr -> do + case sqlObFuscator of + Nothing -> segment tid + (newrelic_segment_datastore_begin tid pid tbl op q tr + newrelic_basic_literal_replacement_obfuscator) act + Just f -> + bracket (makeObfuscator $ toCObfuscator f) freeHaskellFunPtr $ \cf -> + segment tid + (newrelic_segment_datastore_begin tid pid tbl op q tr cf) act + +externalSegment :: SegmentId + -> S.ByteString -- ^ host of segment + -> S.ByteString -- ^ name of segment + -> IO a -> TransactionId -> IO a +externalSegment (SegmentId pid) host name act (TransactionId tid) = + S.useAsCString host $ \h -> + S.useAsCString name $ \n -> + segment tid (newrelic_segment_external_begin tid pid h n) act + +addAttribute :: S.ByteString -> S.ByteString -> TransactionId -> IO () +addAttribute name value (TransactionId tid) = + S.useAsCString name $ \n -> + S.useAsCString value $ \v -> + guardNr =<< newrelic_transaction_add_attribute tid n v + +setRequestUrl :: S.ByteString -> TransactionId -> IO () +setRequestUrl req (TransactionId tid) = + guardNr =<< S.useAsCString req (newrelic_transaction_set_request_url tid) + +setMaxTraceSegments :: Int -> TransactionId -> IO () +setMaxTraceSegments mx (TransactionId tid) = guardNr =<< + newrelic_transaction_set_max_trace_segments tid (fromIntegral mx) diff --git a/src/Network/Helics/Foreign/Client.hsc b/src/Network/Helics/Foreign/Client.hsc new file mode 100644 --- /dev/null +++ b/src/Network/Helics/Foreign/Client.hsc @@ -0,0 +1,28 @@ +{-# LANGUAGE ForeignFunctionInterface #-} + +module Network.Helics.Foreign.Client where + +#include + +import Foreign.C +import Foreign.Ptr + +newtype StatusCode = StatusCode CInt + deriving (Eq, Show) + +#{enum StatusCode, StatusCode + , statusShutdown = NEWRELIC_STATUS_CODE_SHUTDOWN + , statusStarting = NEWRELIC_STATUS_CODE_STARTING + , statusStopping = NEWRELIC_STATUS_CODE_STOPPING + , statusStarted = NEWRELIC_STATUS_CODE_STARTED + } + +foreign import ccall "&newrelic_message_handler" newrelic_message_handler :: FunPtr (Ptr rawMessage -> IO ()) + +type StatusCallback = CInt -> IO () +foreign import ccall "wrapper" makeStatusCallback :: StatusCallback -> IO (FunPtr StatusCallback) +foreign import ccall newrelic_register_status_callback :: FunPtr StatusCallback -> IO () + +foreign import ccall newrelic_init :: CString -> CString -> CString -> CString -> IO CInt + +foreign import ccall newrelic_request_shutdown :: CString -> IO CInt diff --git a/src/Network/Helics/Foreign/Common.hsc b/src/Network/Helics/Foreign/Common.hsc new file mode 100644 --- /dev/null +++ b/src/Network/Helics/Foreign/Common.hsc @@ -0,0 +1,42 @@ +{-# LANGUAGE ForeignFunctionInterface #-} +{-# LANGUAGE DeriveDataTypeable #-} + +module Network.Helics.Foreign.Common where + +#include + +import Data.Typeable +import Control.Exception +import Foreign.C +import Foreign.Ptr + +newtype ReturnCode = ReturnCode CInt + deriving (Eq, Typeable) + +instance Show ReturnCode where + show c@(ReturnCode i) + | c == returnCodeOther = "ReturnCode Other(" ++ show (#{const NEWRELIC_RETURN_CODE_OTHER} :: Int) ++ ")" + | c == returnCodeDisabled = "ReturnCode Disabled(" ++ show (#{const NEWRELIC_RETURN_CODE_DISABLED} :: Int) ++ ")" + | c == returnCodeInvalidParam = "ReturnCode Invalid param(" ++ show (#{const NEWRELIC_RETURN_CODE_INVALID_PARAM} :: Int) ++ ")" + | c == returnCodeInvalidId = "ReturnCode Invalid id(" ++ show (#{const NEWRELIC_RETURN_CODE_INVALID_ID} :: Int) ++ ")" + | c == returnCodeTransactionNotStarted = "ReturnCode Transaction not started(" ++ show (#{const NEWRELIC_RETURN_CODE_TRANSACTION_NOT_STARTED} :: Int) ++ ")" + | c == returnCodeTransactionInProgress = "ReturnCode Transaction in progress(" ++ show (#{const NEWRELIC_RETURN_CODE_TRANSACTION_IN_PROGRESS} :: Int) ++ ")" + | c == returnCodeTransactionNotNamed = "ReturnCode Transaction not named(" ++ show (#{const NEWRELIC_RETURN_CODE_TRANSACTION_NOT_NAMED} :: Int) ++ ")" + | otherwise = "ReturnCode Unknown(" ++ show i ++ ")" + + +instance Exception ReturnCode + +#{enum ReturnCode, ReturnCode + , returnCodeOk = NEWRELIC_RETURN_CODE_OK + , returnCodeOther = NEWRELIC_RETURN_CODE_OTHER + , returnCodeDisabled = NEWRELIC_RETURN_CODE_DISABLED + , returnCodeInvalidParam = NEWRELIC_RETURN_CODE_INVALID_PARAM + , returnCodeInvalidId = NEWRELIC_RETURN_CODE_INVALID_ID + , returnCodeTransactionNotStarted = NEWRELIC_RETURN_CODE_TRANSACTION_NOT_STARTED + , returnCodeTransactionInProgress = NEWRELIC_RETURN_CODE_TRANSACTION_IN_PROGRESS + , returnCodeTransactionNotNamed = NEWRELIC_RETURN_CODE_TRANSACTION_NOT_NAMED + } + +foreign import ccall "&newrelic_basic_literal_replacement_obfuscator" newrelic_basic_literal_replacement_obfuscator + :: FunPtr (CString -> IO CString) diff --git a/src/Network/Helics/Foreign/System.hsc b/src/Network/Helics/Foreign/System.hsc new file mode 100644 --- /dev/null +++ b/src/Network/Helics/Foreign/System.hsc @@ -0,0 +1,44 @@ +{-# LANGUAGE ForeignFunctionInterface #-} +{-# LANGUAGE OverloadedStrings #-} + +module Network.Helics.Foreign.System + ( clockTick + , pageSize + , getPages + ) where + +#include +#include + +import System.Posix.Types +import System.Posix.IO.ByteString + +import Foreign.C +import Foreign.Ptr +import Foreign.Marshal + +import qualified Data.ByteString.Char8 as S8 +import qualified Data.ByteString.Lazy as L +import qualified Text.Show.ByteString as L + +import qualified Data.ByteString.Unsafe as U + +foreign import ccall sysconf :: CInt -> IO CLong + +clockTick :: IO CLong +clockTick = sysconf #const _SC_CLK_TCK + +pageSize :: IO CLong +pageSize = sysconf #const _SC_PAGESIZE + +bufSize :: Int +bufSize = 1024 + +getPages :: CPid -> IO Int +getPages (CPid pid) = do + let name = S8.concat ["/proc/", L.toStrict $ L.show pid, "/statm"] + fd <- openFd name ReadOnly Nothing defaultFileFlags + allocaBytes bufSize $ \ptr -> do + CSize l <- fdReadBuf fd ptr $ fromIntegral bufSize + bs <- U.unsafePackCStringLen (castPtr ptr, fromIntegral l) + return . maybe 0 fst . S8.readInt . S8.tail . snd $ S8.break (== ' ') bs diff --git a/src/Network/Helics/Foreign/Transaction.hsc b/src/Network/Helics/Foreign/Transaction.hsc new file mode 100644 --- /dev/null +++ b/src/Network/Helics/Foreign/Transaction.hsc @@ -0,0 +1,57 @@ +{-# LANGUAGE ForeignFunctionInterface #-} + +module Network.Helics.Foreign.Transaction where + +#include + +import Foreign.C +import Foreign.Ptr + +newtype TransactionId = TransactionId CLong + +newtype SegmentId = SegmentId CLong + +autoScope, rootSegment :: SegmentId +autoScope = SegmentId #const NEWRELIC_AUTOSCOPE +rootSegment = SegmentId #const NEWRELIC_ROOT_SEGMENT + +foreign import ccall newrelic_enable_instrumentation :: CInt -> IO () + +foreign import ccall newrelic_register_message_handler :: FunPtr (Ptr rawMessage -> IO a) -> IO () + +foreign import ccall newrelic_record_metric :: CString -> CDouble -> IO CInt + +foreign import ccall newrelic_record_cpu_usage :: CDouble -> CDouble -> IO CInt + +foreign import ccall newrelic_record_memory_usage :: CDouble -> IO CInt + +foreign import ccall newrelic_transaction_begin :: IO CLong + +foreign import ccall newrelic_transaction_set_type_web :: CLong -> IO CInt + +foreign import ccall newrelic_transaction_set_type_other :: CLong -> IO CInt + +foreign import ccall newrelic_transaction_set_category :: CLong -> CString -> IO CInt + +foreign import ccall newrelic_transaction_notice_error :: CLong -> CString -> CString -> CString -> CString -> IO CInt + +foreign import ccall newrelic_transaction_add_attribute :: CLong -> CString -> CString -> IO CInt + +foreign import ccall newrelic_transaction_set_name :: CLong -> CString -> IO CInt + +foreign import ccall newrelic_transaction_set_request_url :: CLong -> CString -> IO CInt + +foreign import ccall newrelic_transaction_set_max_trace_segments :: CLong -> CInt -> IO CInt + +foreign import ccall newrelic_transaction_end :: CLong -> IO CInt + +foreign import ccall newrelic_segment_generic_begin :: CLong -> CLong -> CString -> IO CLong + +type SqlObfuscator = CString -> IO CString +foreign import ccall "wrapper" makeObfuscator :: SqlObfuscator -> IO (FunPtr SqlObfuscator) +foreign import ccall newrelic_segment_datastore_begin + :: CLong -> CLong -> CString -> CString -> CString -> CString -> FunPtr SqlObfuscator -> IO CLong + +foreign import ccall newrelic_segment_external_begin :: CLong -> CLong -> CString -> CString -> IO CLong + +foreign import ccall newrelic_segment_end :: CLong -> CLong -> IO CInt diff --git a/src/Network/Helics/Sampler.hs b/src/Network/Helics/Sampler.hs new file mode 100644 --- /dev/null +++ b/src/Network/Helics/Sampler.hs @@ -0,0 +1,44 @@ +module Network.Helics.Sampler where + +import System.Posix.Process + +import Foreign.C.Types + +import GHC.Conc + +import Control.Applicative + +import Network.Helics.Foreign.System + +import Data.Time.Clock + +type Callback = Double -> Double -> Int -> IO () + +sampler :: Callback -> Int -> IO () +sampler callback sleep = do + t <- fromIntegral <$> clockTick + core <- fromIntegral <$> getNumCapabilities + cTime <- getCurrentTime + uTime <- fromIntegral <$> getUserTime + pSize <- fromIntegral <$> pageSize + pid <- getProcessID + threadDelay sleep + go t core pSize pid cTime uTime + where + + unCClock (CClock c) = c + getUserTime = unCClock . userTime <$> getProcessTimes + + go tick core pSize pid = loop + where + loop cTime uTime = do + cTime' <- getCurrentTime + uTime' <- fromIntegral <$> getUserTime + pages <- getPages pid + let real = realToFrac $ diffUTCTime cTime' cTime + user = (uTime' - uTime) / tick + cpu = user / (real * core) + mem = pages * pSize + callback user cpu mem + threadDelay sleep + loop cTime' uTime'