diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,5 @@ +# Revision history for eventlog-socket-command + +## 0.1.0.0 -- 2026-03-04 + +* First version. Released on an unsuspecting world. diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/eventlog-socket-control.cabal b/eventlog-socket-control.cabal new file mode 100644 --- /dev/null +++ b/eventlog-socket-control.cabal @@ -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 diff --git a/src/GHC/Eventlog/Socket/Control.hs b/src/GHC/Eventlog/Socket/Control.hs new file mode 100644 --- /dev/null +++ b/src/GHC/Eventlog/Socket/Control.hs @@ -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