eventlog-socket-control (empty) → 0.1.0.0
raw patch · 4 files changed
+504/−0 lines, 4 filesdep +basedep +binarydep +bytestring
Dependencies added: base, binary, bytestring, text
Files
- CHANGELOG.md +5/−0
- LICENSE +29/−0
- eventlog-socket-control.cabal +53/−0
- src/GHC/Eventlog/Socket/Control.hs +417/−0
+ CHANGELOG.md view
@@ -0,0 +1,5 @@+# Revision history for eventlog-socket-command++## 0.1.0.0 -- 2026-03-04++* First version. Released on an unsuspecting world.
+ LICENSE view
@@ -0,0 +1,29 @@+Copyright (c) 2025, Wen Kokke+++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * Neither the name of the copyright holder nor the names of its+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ eventlog-socket-control.cabal view
@@ -0,0 +1,53 @@+cabal-version: 3.0+name: eventlog-socket-control+version: 0.1.0.0+synopsis: Control command protocol for eventlog-socket.+description:+ The @eventlog-socket-control@ package contains utilities for creating messages for @eventlog-socket@'s control command protocol.++license: BSD-3-Clause+license-file: LICENSE+author: Eventlog Socket Contributors+maintainer: wen@well-typed.com+copyright: (c) 2025-2026 Well-Typed+category: System+build-type: Simple+extra-doc-files: CHANGELOG.md+tested-with:+ GHC ==9.2.8+ || ==9.4.8+ || ==9.6.7+ || ==9.8.4+ || ==9.10.2+ || ==9.12.2++source-repository head+ type: git+ location: https://github.com/well-typed/eventlog-socket.git+ subdir: eventlog-socket-control++source-repository this+ type: git+ location: https://github.com/well-typed/eventlog-socket.git+ tag: eventlog-socket-control-0.1.0.0+ subdir: eventlog-socket-control++common language+ ghc-options: -Wall+ default-extensions:+ FlexibleInstances+ ImportQualifiedPost+ InstanceSigs++ default-language: Haskell2010++library+ import: language+ exposed-modules: GHC.Eventlog.Socket.Control+ build-depends:+ , base >=4.14 && <5+ , binary >=0.8 && <0.9+ , bytestring >=0.9 && <0.13+ , text >=1 && <3++ hs-source-dirs: src
+ src/GHC/Eventlog/Socket/Control.hs view
@@ -0,0 +1,417 @@+{- |+Module : GHC.Eventlog.Socket.Control+Description : Construct @eventlog-socket@ control command messages.+Stability : stable+Portability : portable++This modules has utilities for constructing @eventlog-socket@ control command messages.+The builtin commands are `startHeapProfiling`, `stopHeapProfiling`, and `requestHeapCensus`.+To construct custom command messages, use `userNamespace` and `userCommand`.++The t`Command` type exposes a t`Binary` instance, and can be used with the functions from+the [@binary@](https://hackage.haskell.org/package/binary) package. For convenience, this+module exposes `encodeLazy` and `encodeStrict`, which encode a command to a lazy+`BSL.ByteString` or a strict `BS.ByteString`, respectively.++For instance, the following snippet defines @sendRequestHeapCensus@,+which serialises and sends a `requestHeapCensus` message over an open eventlog socket.++@+import Network.Socket (Socket)+import Network.Socket.ByteString.Lazy (sendAll)+import GHC.Eventlog.Socket.Control (encodeLazy, requestHeapCensus)++sendRequestHeapCensus :: Socket -> IO ()+sendRequestHeapCensus eventlogSocket =+ sendAll eventlogSocket (`encodeLazy` `requestHeapCensus`)+@+-}+module GHC.Eventlog.Socket.Control (+ -- * Control Commands+ Command,+ CommandId (..),+ Namespace,+ startHeapProfiling,+ stopHeapProfiling,+ requestHeapCensus,+ userNamespace,+ userCommand,+ encodeLazy,+ encodeStrict,++ -- ** Protocol Version+ ProtocolVersion (..),+ protocolVersion,+ minProtocolVersion,+ ProtocolVersionNotSupportedError (..),++ -- ** Namespace Errors+ NamespaceReservedError (..),+ NamespaceTooLongError (..),+) where++import Control.Exception (Exception (..), assert, throw)+import Control.Monad (replicateM, unless)+import Data.Binary (Binary (..), Get, Put, getWord8, putWord8)+import Data.Binary qualified as B (encode)+import Data.ByteString qualified as BS+import Data.ByteString.Lazy qualified as BSL+import Data.Foldable (for_, traverse_)+import Data.String (IsString (..))+import Data.Text (Text)+import Data.Text qualified as T (pack, unpack)+import Data.Text.Encoding qualified as TE (decodeUtf8, encodeUtf8)+import Data.Word (Word8)+import Text.Printf (printf)++--------------------------------------------------------------------------------+-- Magic+--------------------------------------------------------------------------------++{- |+Internal helper.++A constant that serialises to the magic byte sequence.+-}+data Magic = Magic++{- |+Internal helper.++The magic byte sequence that starts a protocol message.+-}+magicBytes :: [Word8]+magicBytes = [0xF0, 0x9E, 0x97, 0x8C]++instance Binary (WithBinary Magic) where+ put :: (WithBinary Magic) -> Put+ put (WithBinary Magic) = traverse_ putWord8 magicBytes++ get :: Get (WithBinary Magic)+ get = do+ for_ magicBytes $ \expect ->+ getWord8 >>= \actual ->+ unless (expect == actual) . fail $+ printf "Unexpected %02x, expected %02x" actual expect+ pure $ WithBinary Magic++--------------------------------------------------------------------------------+-- Protocol Versions+--------------------------------------------------------------------------------++{- |+Version numbers for @eventlog-socket@'s control command protocol.++@since 0.1.0.0+-}+newtype ProtocolVersion = ProtocolVersion Word8+ deriving (Eq, Ord, Show)++{- |+The error thrown when deserialising a protocol message from an incompatible protocol version.++@since 0.1.0.0+-}+data ProtocolVersionNotSupportedError = ProtocolVersionNotSupportedError ProtocolVersion+ deriving (Show)++instance Exception ProtocolVersionNotSupportedError++{- |+The version of the protocol implemented by this package.++@since 0.1.0.0+-}+protocolVersion :: ProtocolVersion+protocolVersion = ProtocolVersion 0++{- |+The minimum version of the protocol supported by this package.++@since 0.1.0.0+-}+minProtocolVersion :: ProtocolVersion+minProtocolVersion = protocolVersion++{- |+Internal helper.++Check if the given protocol version is supported.+-}+isProtocolVersionSupported :: ProtocolVersion -> Bool+isProtocolVersionSupported = (>= minProtocolVersion)++instance Binary (WithBinary ProtocolVersion) where+ put :: (WithBinary ProtocolVersion) -> Put+ put (WithBinary (ProtocolVersion protocolVersionByte)) = putWord8 protocolVersionByte++ get :: Get (WithBinary ProtocolVersion)+ get = WithBinary . ProtocolVersion <$> getWord8++--------------------------------------------------------------------------------+-- Namespaces+--------------------------------------------------------------------------------++{- |+The type of control command namespaces.++Namespaces are opaque and can only be obtained using `userNamespace`.++@since 0.1.0.0+-}+data Namespace = Namespace+ { namespaceText :: !Text+ -- ^ The namespace name.+ , namespaceUtf8 :: BS.ByteString+ -- ^ Must satisfy the following invariants:+ -- prop> namespaceUtf8 == encodeUtf8 namespaceText+ -- prop> length namespaceUtf8 <= fromIntegral (maxBound :: Word8)+ }+ deriving (Eq)++{- |+__Warning__: This instance uses `userNamespace` and may throw the same errors.+-}+instance IsString Namespace where+ fromString :: String -> Namespace+ fromString = userNamespace . T.pack++instance Show Namespace where+ show :: Namespace -> String+ show = show . T.unpack . namespaceText++instance Binary (WithBinary Namespace) where+ put :: WithBinary Namespace -> Put+ put (WithBinary Namespace{namespaceUtf8 = namespaceBytes}) = do+ let namespaceNumBytes = BS.length namespaceBytes+ assert (namespaceNumBytes <= namespaceMaxBytes) $ do+ -- Put the namespace length as a Word8+ putWord8 (fromIntegral namespaceNumBytes)+ -- -- Put the namespace bytes+ for_ [0 .. namespaceNumBytes - 1] $ \i ->+ for_ (BS.indexMaybe namespaceBytes i) $ \namespaceByte ->+ putWord8 namespaceByte++ get :: Get (WithBinary Namespace)+ get = do+ -- Get the namespace length as a Word8+ namespaceNumBytes <- fromIntegral <$> getWord8+ -- Get the namespace bytes+ namespaceBytes <- BS.pack <$> replicateM namespaceNumBytes getWord8+ -- Create a namespace+ pure . WithBinary $+ Namespace+ { namespaceText = TE.decodeUtf8 namespaceBytes+ , namespaceUtf8 = namespaceBytes+ }++{- |+Internal helper.++Construct a namespace ignoring the user namespace invariants.+-}+unsafeMakeNamespace :: Text -> Namespace+unsafeMakeNamespace namespaceText' =+ Namespace+ { namespaceText = namespaceText'+ , namespaceUtf8 = TE.encodeUtf8 namespaceText'+ }++{- |+Internal helper.++The namespace for builtin control commands.+-}+eventlogSocketNamespace :: Namespace+eventlogSocketNamespace = unsafeMakeNamespace (T.pack "eventlog-socket")++{- |+Internal helper.++Check if a namespace uses a reserved name.+-}+isNamespaceReserved :: Namespace -> Bool+isNamespaceReserved = (== eventlogSocketNamespace)++{- |+The error thrown when the name passed to `userNamespace` is reserved.++@since 0.1.0.0+-}+newtype NamespaceReservedError = NamespaceReservedError Namespace+ deriving (Show)++instance Exception NamespaceReservedError++{- |+Internal helper.++The maximum size for a namespace name.+-}+namespaceMaxBytes :: Int+namespaceMaxBytes = fromIntegral (maxBound :: Word8)++{- |+Internal helper.++Check if a namespace name is too long.+-}+isNamespaceTooLong :: Namespace -> Bool+isNamespaceTooLong Namespace{namespaceUtf8 = namespaceBytes} =+ BS.length namespaceBytes > namespaceMaxBytes++{- |+The error thrown when the name passed to `userNamespace` is longer than 255 bytes.++@since 0.1.0.0+-}+data NamespaceTooLongError = NamespaceTooLongError Namespace+ deriving (Show)++instance Exception NamespaceTooLongError++{- |+Construct a namespace for use in constructing a custom control command message.++This function may throw t`NamespaceReservedError` or t`NamespaceTooLongError`.++@since 0.1.0.0+-}+userNamespace :: Text -> Namespace+userNamespace namespaceText'+ | isNamespaceReserved namespace = throw (NamespaceReservedError namespace)+ | isNamespaceTooLong namespace = throw (NamespaceTooLongError namespace)+ | otherwise = namespace+ where+ namespace = unsafeMakeNamespace namespaceText'++--------------------------------------------------------------------------------+-- Command ID+--------------------------------------------------------------------------------++{- |+The type of control command IDs.++Command IDs must be non-zero integers between 1 and 255.++@since 0.1.0.0+-}+newtype CommandId = CommandId Word8+ deriving (Eq, Show)++-- NOTE: Take care that this definition does not drift too far from the+-- definition of the same name in @eventlog-socket@. The two live+-- in different packages and serve different purposes. Notably,+-- the definition in @eventlog-socket@ has a `Storable` instance+-- whereas this one has a `Binary` instance. However, that does not+-- mean we should be giving the user any surprises.++instance Binary (WithBinary CommandId) where+ put :: (WithBinary CommandId) -> Put+ put (WithBinary (CommandId i)) = putWord8 i++ get :: Get (WithBinary CommandId)+ get = WithBinary . CommandId <$> getWord8++--------------------------------------------------------------------------------+-- Command+--------------------------------------------------------------------------------++{- |+The type of control command messages.++Commands are opaque and can only be obtained using `userCommand` or as builtin+commands `startHeapProfiling`, `stopHeapProfiling`, and `requestHeapCensus`.++@since 0.1.0.0+-}+data Command = Command !Namespace !CommandId+ deriving (Eq, Show)++{- |+Construct a custom control command message.++@since 0.1.0.0+-}+userCommand :: Namespace -> CommandId -> Command+userCommand namespace commandId = Command namespace commandId++{- |+Encode a custom control command message to a lazy t`BSL.ByteString`.++@since 0.1.0.0+-}+encodeLazy :: Command -> BSL.ByteString+encodeLazy = B.encode++{- |+Encode a custom control command message to a strict t`BS.ByteString`.++@since 0.1.0.0+-}+encodeStrict :: Command -> BS.ByteString+encodeStrict = BSL.toStrict . encodeLazy++instance Binary Command where+ put :: Command -> Put+ put (Command namespace commandId) = do+ put $ WithBinary Magic+ put $ WithBinary protocolVersion+ put $ WithBinary namespace+ put $ WithBinary commandId++ get :: Get Command+ get = do+ WithBinary Magic <- get+ WithBinary commandProtocolVersion <- get+ unless (isProtocolVersionSupported commandProtocolVersion) $+ throw $+ ProtocolVersionNotSupportedError commandProtocolVersion+ WithBinary namespace <- get+ WithBinary commandId <- get+ pure $ Command namespace commandId++--------------------------------------------------------------------------------+-- Builtin Commands+--------------------------------------------------------------------------------++{- |+The builtin control command message that starts heap profiling.++See `GHC.Profiling.startHeapProfTimer`.++@since 0.1.0.0+-}+startHeapProfiling :: Command+startHeapProfiling = Command eventlogSocketNamespace (CommandId 3)++{- |+The builtin control command message that stops heap profiling.++See `GHC.Profiling.stopHeapProfTimer`.++@since 0.1.0.0+-}+stopHeapProfiling :: Command+stopHeapProfiling = Command eventlogSocketNamespace (CommandId 4)++{- |+The builtin control command message that requests a heap census.++See `GHC.Profiling.requestHeapCensus`.++@since 0.1.0.0+-}+requestHeapCensus :: Command+requestHeapCensus = Command eventlogSocketNamespace (CommandId 5)++--------------------------------------------------------------------------------+-- Internal helpers+--------------------------------------------------------------------------------++{- |+Internal helper.++This wrapper hides `Binary` instances from the public API.+-}+newtype WithBinary a = WithBinary a