packages feed

helics 0.2.1 → 0.3.0

raw patch · 9 files changed

+221/−348 lines, 9 files

Files

+ common/Network/Helics/Types.hs view
@@ -0,0 +1,72 @@+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE CPP #-}++module Network.Helics.Types where++import Control.Exception++import Foreign.C.Types+import Foreign.C.String++import Data.Typeable+import Data.Default.Class+import qualified Data.ByteString as S++-- common+newtype ReturnCode = ReturnCode CInt deriving (Eq, Typeable, Show)+instance Exception ReturnCode++-- client+type StatusCallback = CInt -> IO ()+newtype StatusCode = StatusCode CInt deriving (Eq, Show)++-- transaction+newtype TransactionId = TransactionId CLong++newtype SegmentId = SegmentId CLong+type SqlObfuscator = CString -> IO CString++-- main+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"+        COMPILER_VERSION+        Nothing++data TransactionType+    = Default+    | Web   S.ByteString+    | Other S.ByteString++instance Default TransactionType where+    def = Default++data Operation+    = SELECT+    | INSERT+    | UPDATE+    | DELETE+    deriving (Show)++data DatastoreSegment = DatastoreSegment+    { table              :: S.ByteString+    , operation          :: Operation+    , sql                :: S.ByteString+    , sqlTraceRollupName :: S.ByteString+    , sqlObFuscator      :: Maybe (S.ByteString -> S.ByteString)+    }+instance Default DatastoreSegment where+    def = DatastoreSegment "unknown" SELECT "" "unknown" Nothing++
+ dummy/Network/Helics.hs view
@@ -0,0 +1,116 @@+{-# 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+    , Operation(..)+    , 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.Types++autoScope, rootSegment :: SegmentId+autoScope   = SegmentId 0+rootSegment = SegmentId 1++statusShutdown, statusStarting, statusStopping, statusStarted :: StatusCode+statusShutdown = StatusCode 0+statusStarting = StatusCode 1+statusStopping = StatusCode 2+statusStarted  = StatusCode 3++-- | start new relic®  collector client.+-- you must call this function when embed-mode.+withHelics :: HelicsConfig -> IO a -> IO a+withHelics _ m = m++-- | record custom metric.+recordMetric :: S.ByteString -> Double -> IO ()+recordMetric _ _ = return ()++-- | sample and send metric of cpu/memory usage.+sampler :: Int -- ^ sampling frequency (sec)+        -> IO ()+sampler _ = return ()++-- | record CPU usage. Normally, you don't need to call this function. use sampler.+recordCpuUsage :: Double -> Double -> IO ()+recordCpuUsage _ _ = return ()++-- | record memory usage. Normally, you don't need to call this function. use sampler.+recordMemoryUsage :: Double -> IO ()+recordMemoryUsage _ = return ()++withTransaction :: S.ByteString -- ^ name of transaction+                -> TransactionType -> (TransactionId -> IO c) -> IO c+withTransaction _ _ m = m (TransactionId 0)++genericSegment :: SegmentId     -- ^ parent segment id+               -> S.ByteString  -- ^ name of represent segment+               -> IO c          -- ^ action in segment+               -> TransactionId+               -> IO c+genericSegment _ _ m _ = m++datastoreSegment :: SegmentId -> DatastoreSegment -> IO a -> TransactionId -> IO a+datastoreSegment _ _ m _ = m++externalSegment :: SegmentId+                -> S.ByteString -- ^ host of segment+                -> S.ByteString -- ^ name of segment+                -> IO a -> TransactionId -> IO a+externalSegment _ _ _ m _ = m++addAttribute :: S.ByteString -> S.ByteString -> TransactionId -> IO ()+addAttribute _ _ _ = return ()++setRequestUrl :: S.ByteString -> TransactionId -> IO ()+setRequestUrl _ _ = return ()++setMaxTraceSegments :: Int -> TransactionId -> IO ()+setMaxTraceSegments _ _ = return ()
+ dummy/Network/Helics/Sampler.hs view
@@ -0,0 +1,6 @@+module Network.Helics.Sampler where++type Callback = Double -> Double -> Int -> IO ()++sampler :: Callback -> Int -> IO ()+sampler _ _ = return ()
helics.cabal view
@@ -1,5 +1,5 @@ name:                helics-version:             0.2.1+version:             0.3.0 synopsis:            New Relic® agent SDK wrapper for Haskell. description:            New Relic® agent SDK wrapper for Haskell.@@ -28,27 +28,35 @@ flag example   default: False +flag dummy+  description: compile dummy modules on !linux.+  default:     True+ 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:    +  other-modules:       Network.Helics.Types+  ghc-options:         -Wall -O2+  default-language:    Haskell2010   build-depends:       base               >=4.6  && <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++  if flag(dummy) && !os(linux)+    hs-source-dirs:      common, dummy+  else+    other-modules:       Network.Helics.Foreign.Common+                         Network.Helics.Foreign.Client+                         Network.Helics.Foreign.Transaction+                         Network.Helics.Foreign.System+    build-depends:       time               >=1.2  && <1.6+                       , unix               >=2.6  && <2.8+                       , bytestring-show    >=0.3  && <0.4+    hs-source-dirs:      common, src+    build-tools:         hsc2hs+    extra-libraries:     newrelic-collector-client+                       , newrelic-transaction+                       , newrelic-common  executable helics-example   main-is:             example.hs
− src/Network/Helics.hs 
@@ -1,260 +0,0 @@-{-# 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-    , Operation(..)-    , 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"-        COMPILER_VERSION-        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 Operation-    = SELECT-    | INSERT-    | UPDATE-    | DELETE-    deriving (Show)--opToBS :: Operation -> S.ByteString-opToBS SELECT = newrelicDatastoreSelect-opToBS INSERT = newrelicDatastoreInsert-opToBS UPDATE = newrelicDatastoreUpdate-opToBS DELETE = newrelicDatastoreDelete--data DatastoreSegment = DatastoreSegment-    { table              :: S.ByteString-    , operation          :: Operation-    , sql                :: S.ByteString-    , sqlTraceRollupName :: S.ByteString-    , sqlObFuscator      :: Maybe (S.ByteString -> S.ByteString)-    }-instance Default DatastoreSegment where-    def = DatastoreSegment "unknown" SELECT "" "unknown" Nothing--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 (opToBS 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
@@ -6,9 +6,7 @@  import Foreign.C import Foreign.Ptr--newtype StatusCode = StatusCode CInt-    deriving (Eq, Show)+import Network.Helics.Types  #{enum StatusCode, StatusCode  , statusShutdown = NEWRELIC_STATUS_CODE_SHUTDOWN@@ -19,7 +17,6 @@  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 ()
src/Network/Helics/Foreign/Common.hsc view
@@ -5,27 +5,9 @@  #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+import Network.Helics.Types  #{enum ReturnCode, ReturnCode  , returnCodeOk                    = NEWRELIC_RETURN_CODE_OK
src/Network/Helics/Foreign/Transaction.hsc view
@@ -8,10 +8,7 @@ import Foreign.C import Foreign.Ptr import qualified Data.ByteString as S--newtype TransactionId = TransactionId CLong--newtype SegmentId = SegmentId CLong+import Network.Helics.Types  autoScope, rootSegment :: SegmentId autoScope   = SegmentId #const NEWRELIC_AUTOSCOPE@@ -55,7 +52,6 @@  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
− src/Network/Helics/Sampler.hs 
@@ -1,44 +0,0 @@-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'