packages feed

helics (empty) → 0.1.0

raw patch · 10 files changed

+565/−0 lines, 10 filesdep +basedep +bytestringdep +bytestring-showsetup-changed

Dependencies added: base, bytestring, bytestring-show, data-default-class, helics, time, unix

Files

+ LICENSE view
@@ -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.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ example.hs view
@@ -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)
+ helics.cabal view
@@ -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(<https://docs.newrelic.com/docs/agents/agent-sdk/using-agent-sdk/getting-started-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
+ src/Network/Helics.hs view
@@ -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)
+ src/Network/Helics/Foreign/Client.hsc view
@@ -0,0 +1,28 @@+{-# LANGUAGE ForeignFunctionInterface #-}++module Network.Helics.Foreign.Client where++#include <newrelic_collector_client.h>++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
+ src/Network/Helics/Foreign/Common.hsc view
@@ -0,0 +1,42 @@+{-# LANGUAGE ForeignFunctionInterface #-}+{-# LANGUAGE DeriveDataTypeable #-}++module Network.Helics.Foreign.Common where++#include <newrelic_common.h>++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)
+ src/Network/Helics/Foreign/System.hsc view
@@ -0,0 +1,44 @@+{-# LANGUAGE ForeignFunctionInterface #-}+{-# LANGUAGE OverloadedStrings #-}++module Network.Helics.Foreign.System+    ( clockTick+    , pageSize+    , getPages+    ) where++#include <unistd.h>+#include <sys/times.h>++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
+ src/Network/Helics/Foreign/Transaction.hsc view
@@ -0,0 +1,57 @@+{-# LANGUAGE ForeignFunctionInterface #-}++module Network.Helics.Foreign.Transaction where++#include <newrelic_transaction.h>++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
+ src/Network/Helics/Sampler.hs view
@@ -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'