diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,5 @@ +## [_Unreleased_](https://github.com/freckle/cloudevents-haskell/compare/v0.1.0.0...main) + +## [v0.1.0.0](https://github.com/freckle/cloudevents-haskell/tree/v0.1.0.0) + +First tagged release. diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,21 @@ +The MIT License (MIT) + +Copyright (c) 2025 Renaissance Learning Inc + +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/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,363 @@ +# CloudEvents Haskell SDK + +An unofficial Haskell SDK for the [CloudEvents](https://cloudevents.io/) specification, particularly for version 1.0.2 of the spec. ([JSON Schema](https://github.com/cloudevents/spec/blob/v1.0.2/cloudevents/formats/cloudevents.json)) + +## Overview + +CloudEvents is a vendor-neutral specification for defining the format of event data. This SDK provides a type-safe and idiomatic way to work with CloudEvents in Haskell, making it easier to produce and consume CloudEvents across different services and platforms. + +The CloudEvents Haskell SDK allows you to: + +- Create CloudEvents with strongly typed event data and extensions +- Validate CloudEvents against the specification +- Encode and decode CloudEvents in JSON format +- Integrate with message brokers like Apache Kafka + +## Installation + +Add the package to your project's dependencies: + +### Using Cabal + +``` +# In your .cabal file +build-depends: cloudevents-haskell +``` + +### Using Stack + +```yaml +# In your package.yaml file +dependencies: + - cloudevents-haskell +``` + +## Key Features + +- **Type-safe CloudEvent representation** - Events modeled as native Haskell types with proper validation +- **Flexible event data** - Support for arbitrary event data types via polymorphism +- **Extension mechanism** - Define and use custom extension attributes +- **Protocol bindings** - Integration with Apache Kafka (binary and structured modes) +- **JSON encoding/decoding** - Automatic serialization with Aeson via Autodocodec +- **Lenses** - Convenient access and modification of CloudEvent fields +- **Validation** - Validate CloudEvents against the JSON schema + +## Quick Start Examples + +### Creating a Simple CloudEvent + +```haskell +import CloudEvent.V1.Event.Data +import Data.Text (Text) + +-- Create a CloudEvent with Text payload and no extensions +simpleEvent :: CloudEvent EmptyExtension Text +simpleEvent = + mkCloudEvent + MkCloudEventArg + { ceId = "1234-1234-1234" + , ceSource = -- ... (Iri value) + , ceEventType = "com.example.event.created" + , ceDataContentType = Just "text/plain" + , ceDataSchema = Nothing + , ceSubject = Just "resource123" + , ceTime = -- ... (UTCTime value) + } + "This is the event payload as plain text" + EmptyExtension -- No extensions +``` + +### Working with Structured Data + +```haskell +import CloudEvent.V1.Event.Data +import Data.Aeson (FromJSON, ToJSON) +import Data.Text (Text) +import GHC.Generics (Generic) +import Autodocodec + +-- Define custom event data type +data UserCreatedEvent = UserCreatedEvent + { userId :: Text + , username :: Text + , email :: Text + } + deriving stock (Eq, Show, Generic) + deriving (FromJSON, ToJSON) via (Autodocodec UserCreatedEvent) + +instance HasCodec UserCreatedEvent where + codec = + object "UserCreatedEvent" $ + UserCreatedEvent + <$> requiredField' "userId" .= (.userId) + <*> requiredField' "username" .= (.username) + <*> requiredField' "email" .= (.email) + +-- Create an event with structured data +userCreatedEvent :: CloudEvent EmptyExtension UserCreatedEvent +userCreatedEvent = + mkCloudEvent + MkCloudEventArg + { ceId = "user-123-456" + , ceSource = -- ... (Iri value) + , ceEventType = "com.example.user.created" + , ceDataContentType = Just "application/json" + , ceDataSchema = Nothing + , ceSubject = Just "resource123" + , ceTime = -- ... (UTCTime value) + } + UserCreatedEvent + { userId = "123" + , username = "johndoe" + , email = "john@example.com" + } + EmptyExtension +``` + +### Using Custom Extensions + +```haskell +import CloudEvent.V1.Event.Data +import Data.Aeson (FromJSON, ToJSON) +import Data.Text (Text) +import GHC.Generics (Generic) +import Autodocodec + +-- Define custom extension attributes +data TraceExtension = TraceExtension + { traceId :: Text + , spanId :: Text + } + deriving stock (Eq, Show, Generic) + deriving (FromJSON, ToJSON) via (Autodocodec TraceExtension) + +instance HasCodec TraceExtension where + codec = object "TraceExtension" objectCodec + +-- This is required +instance HasObjectCodec TraceExtension where + objectCodec = + TraceExtension + <$> requiredField' "traceId" .= (.traceId) + <*> requiredField' "spanId" .= (.spanId) + +-- Create an event with custom extensions +eventWithTracing :: CloudEvent TraceExtension Text +eventWithTracing = + mkCloudEvent + MkCloudEventArg + { ceId = "evt-789-abc" + , ceSource = -- ... (Iri value) + , ceEventType = "com.example.order.processed" + , ceDataContentType = Just "text/plain" + , ceDataSchema = Nothing + , ceSubject = Just "order/456" + , ceTime = -- ... (UTCTime value) + } + "Order 456 has been processed successfully" + TraceExtension + { traceId = "trace-123456789" + , spanId = "span-abcdef" + } +``` + +## Validating CloudEvents + +The SDK provides functionality to validate CloudEvents against the specification: + +```haskell +import CloudEvent.V1.Event.Data +import CloudEvent.V1.Event.Validation +import Data.Aeson (Value, toJSON) + +-- Validate a CloudEvent JSON representation +validateJsonCloudEvent :: Value -> Bool +validateJsonCloudEvent jsonValue = + isValidCloudEvent @MyEventData @MyExtensions jsonValue + +-- Example usage: +-- let eventJson = toJSON myCloudEvent +-- if validateJsonCloudEvent eventJson +-- then putStrLn "Valid CloudEvent" +-- else putStrLn "Invalid CloudEvent" +``` + +## Kafka Integration + +The SDK provides integration with Apache Kafka through the `CloudEvent.V1.Bindings.Kafka` module: + +```haskell +import CloudEvent.V1.Bindings.Kafka +import CloudEvent.V1.Event.Data +import Data.Text (Text) +import Kafka.Producer (TopicName) + +-- Create a CloudEvent with Kafka extension +kafkaEvent :: CloudEvent KafkaCloudEventExtAttributes Text +kafkaEvent = + mkCloudEvent + MkCloudEventArg + { ceId = "evt-kafka-123" + , ceSource = -- ... (Iri value) + , ceEventType = "com.example.inventory.updated" + , ceDataContentType = Just "text/plain" + , ceDataSchema = Nothing + , ceSubject = Just "product/123" + , ceTime = -- ... (UTCTime value) + } + "Product 123 inventory updated to 42 units" + KafkaCloudEventExtAttributes{partitionKey = "product-123"} + +-- Send using binary content mode +sendBinary :: TopicName -> CloudEvent KafkaCloudEventExtAttributes Text -> ProducerRecord +sendBinary topic event = toBinaryKafkaMessage topic event +-- Use with Kafka producer: producerSend producer producerRecord + +-- Send using structured content mode +sendStructured :: TopicName -> CloudEvent KafkaCloudEventExtAttributes Text -> ProducerRecord +sendStructured topic event = toStructuredKafkaMessage topic event +-- Use with Kafka producer: producerSend producer producerRecord +``` + +## Using Lenses + +The SDK provides lenses for convenient access and modification of CloudEvent fields: + +```haskell +import CloudEvent.V1.Event.Data +import CloudEvent.V1.Event.Lens +import Control.Lens +import Data.Text (Text) + +-- Access fields using lenses +getEventId :: CloudEvent ext eventData -> Text +getEventId event = event ^. ceId + +-- Modify a CloudEvent using lenses +updateSubject :: Text -> CloudEvent ext eventData -> CloudEvent ext eventData +updateSubject newSubject event = + event & ceSubject .~ Just newSubject +``` + +## Complete Example + +Here's a more complete example showing how to create, validate, and send a CloudEvent to Kafka: + +```haskell +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE OverloadedRecordDot #-} + +module Example where + +import Autodocodec +import CloudEvent.V1.Bindings.Kafka +import CloudEvent.V1.Event.Data +import CloudEvent.V1.Event.Lens +import CloudEvent.V1.Event.Validation +import Control.Lens +import Data.Aeson (FromJSON, ToJSON, toJSON) +import Data.Text (Text) +import GHC.Generics (Generic) +import Kafka.Producer + +-- Define our event data type +data OrderCreatedEvent = OrderCreatedEvent + { orderId :: Text + , customerId :: Text + , amount :: Double + , items :: [Text] + } + deriving stock (Eq, Show, Generic) + deriving (FromJSON, ToJSON) via (Autodocodec OrderCreatedEvent) + +instance HasCodec OrderCreatedEvent where + codec = + object "OrderCreatedEvent" $ + OrderCreatedEvent + <$> requiredField' "orderId" .= (.orderId) + <*> requiredField' "customerId" .= (.customerId) + <*> requiredField' "amount" .= (.amount) + <*> requiredField' "items" .= (.items) + +-- Define our Kafka-compatible extension +data OrderExtension = OrderExtension + { partitionKey :: Text -- For Kafka routing + , region :: Text -- Custom extension field + } + deriving stock (Eq, Show, Generic) + +instance HasCodec OrderExtension where + codec = object "OrderExtension" objectCodec + +instance HasObjectCodec OrderExtension where + objectCodec = + OrderExtension + <$> requiredField' "partitionKey" .= (.partitionKey) + <*> requiredField' "region" .= (.region) + +-- Create our CloudEvent +createOrderEvent :: Text -> OrderCreatedEvent -> OrderExtension -> CloudEvent OrderExtension OrderCreatedEvent +createOrderEvent orderId orderData ext = + mkCloudEvent + MkCloudEventArg + { ceId = "order-" <> orderId + , ceSource = -- ... (Iri value) + , ceEventType = "com.example.order.created" + , ceDataContentType = Just "application/json" + , ceDataSchema = Nothing + , ceSubject = Just ("order/" <> orderId) + , ceTime = -- ... (UTCTime value) + } + orderData + ext + +-- Example usage in a function that processes and sends an order event +processOrder :: Text -> Text -> Double -> [Text] -> Text -> IO () +processOrder orderId customerId amount items region = do + -- Create the order data + let orderData = OrderCreatedEvent + { orderId = orderId + , customerId = customerId + , amount = amount + , items = items + } + + -- Create extension with Kafka partition key and region + extension = OrderExtension + { partitionKey = orderId -- Use orderId as partition key + , region = region + } + + -- Create the CloudEvent + event = createOrderEvent orderId orderData extension + + -- Define Kafka topic + topic = "orders" + + -- Create Kafka producer record in binary mode + producerRecord = toBinaryKafkaMessage topic event + + -- Validate the event before sending + -- In real code, you would decode the JSON first + let isValid = isValidCloudEvent @OrderCreatedEvent @OrderExtension (toJSON event) + + if isValid + then do + putStrLn "Event is valid, sending to Kafka..." + -- In a real application, you would send to Kafka: + -- producer <- newProducer producerProperties + -- sendMessageBatch producer [producerRecord] + -- closeProducer producer + pure () + else + putStrLn "Event validation failed!" +``` + +## Contributing + +Contributions are welcome! Please feel free to submit a Pull Request. + +## License + +This project is licensed under the BSD-3-Clause License - see the [LICENSE](LICENSE) file for details. diff --git a/cloudevents-haskell.cabal b/cloudevents-haskell.cabal new file mode 100644 --- /dev/null +++ b/cloudevents-haskell.cabal @@ -0,0 +1,75 @@ +cabal-version: 2.2 +name: cloudevents-haskell +version: 0.1.0.0 +license: BSD-3-Clause +license-file: LICENSE +maintainer: Freckle Education +homepage: https://github.com/freckle/cloudevents-haskell#readme +bug-reports: https://github.com/freckle/cloudevents-haskell/issues +synopsis: Unofficial Haskell SDK for the CloudEvents specification +description: + See the README on GitHub at + +category: Utils +build-type: Simple +extra-source-files: package.yaml +extra-doc-files: + README.md + CHANGELOG.md + +source-repository head + type: git + location: https://github.com/freckle/cloudevents-haskell + +library + exposed-modules: + CloudEvent.V1.Bindings.Kafka + CloudEvent.V1.Event.Data + CloudEvent.V1.Event.Internal.Data + CloudEvent.V1.Event.Internal.Orphans + CloudEvent.V1.Event.Lens + CloudEvent.V1.Event.Validation + + hs-source-dirs: src + other-modules: Paths_cloudevents_haskell + autogen-modules: Paths_cloudevents_haskell + default-language: GHC2021 + default-extensions: + ApplicativeDo DataKinds DeriveAnyClass DerivingStrategies + DerivingVia DuplicateRecordFields GADTs LambdaCase NoFieldSelectors + NoImplicitPrelude NoMonomorphismRestriction NoPostfixOperators + OverloadedRecordDot OverloadedStrings QuasiQuotes TypeFamilies + + ghc-options: + -Weverything -Wno-all-missed-specialisations + -Wno-missed-specialisations -Wno-missing-exported-signatures + -Wno-missing-import-lists -Wno-missing-local-signatures + -Wno-monomorphism-restriction -Wno-safe -Wno-unsafe + + build-depends: + aeson >=2.0.3.0, + autodocodec >=0.4.2.2, + autodocodec-schema >=0.2.0.1, + base >=4.16.4.0 && <5, + binary >=0.8.9.0, + binary-instances >=1.0.4, + bytestring >=0.11.4.0, + hw-kafka-client >=5.3.0, + iri >=0.5.1.1, + lens >=5.1.1, + text >=2.0.2, + time >=1.12.2 + + if impl(ghc >=9.8) + ghc-options: + -Wno-missing-role-annotations -Wno-missing-poly-kind-signatures + + if impl(ghc >=9.2) + ghc-options: -Wno-missing-kind-signatures + + if impl(ghc >=8.10) + ghc-options: + -Wno-missing-safe-haskell-mode -Wno-prepositive-qualified-module + + if impl(ghc >=8.8) + ghc-options: -fwrite-ide-info diff --git a/package.yaml b/package.yaml new file mode 100644 --- /dev/null +++ b/package.yaml @@ -0,0 +1,89 @@ +name: cloudevents-haskell +version: 0.1.0.0 +maintainer: Freckle Education +category: Utils +github: freckle/cloudevents-haskell +license: BSD-3-Clause +synopsis: Unofficial Haskell SDK for the CloudEvents specification +description: See the README on GitHub at + +extra-doc-files: + - README.md + - CHANGELOG.md + +extra-source-files: + - package.yaml + +language: GHC2021 + +dependencies: + - base < 5 + +ghc-options: + - -Weverything + - -Wno-all-missed-specialisations + - -Wno-missed-specialisations + - -Wno-missing-exported-signatures # re-enables missing-signatures + - -Wno-missing-import-lists + - -Wno-missing-local-signatures + - -Wno-monomorphism-restriction + - -Wno-safe + - -Wno-unsafe + +when: + - condition: "impl(ghc >= 9.8)" + ghc-options: + - -Wno-missing-role-annotations + - -Wno-missing-poly-kind-signatures + - condition: "impl(ghc >= 9.2)" + ghc-options: + - -Wno-missing-kind-signatures + - condition: "impl(ghc >= 8.10)" + ghc-options: + - -Wno-missing-safe-haskell-mode + - -Wno-prepositive-qualified-module + - condition: "impl(ghc >= 8.8)" + ghc-options: + - -fwrite-ide-info + +default-extensions: + - ApplicativeDo + - DataKinds + - DeriveAnyClass + - DerivingStrategies + - DerivingVia + - DuplicateRecordFields + - GADTs + - LambdaCase + - NoFieldSelectors + - NoImplicitPrelude + - NoMonomorphismRestriction + - NoPostfixOperators + - OverloadedRecordDot + - OverloadedStrings + - QuasiQuotes + - TypeFamilies + +library: + source-dirs: src + dependencies: + - aeson + - autodocodec + - autodocodec-schema + - binary + - binary-instances + - bytestring + - hw-kafka-client + - iri + - lens + - text + - time +# tests: +# spec: +# main: Spec.hs +# source-dirs: test +# ghc-options: -threaded -rtsopts "-with-rtsopts=-N" +# dependencies: +# - cloudevents-haskell +# - hspec +# - hspec-junit-formatter diff --git a/src/CloudEvent/V1/Bindings/Kafka.hs b/src/CloudEvent/V1/Bindings/Kafka.hs new file mode 100644 --- /dev/null +++ b/src/CloudEvent/V1/Bindings/Kafka.hs @@ -0,0 +1,144 @@ +-- | Provides functionality for integrating CloudEvents with Apache Kafka. +-- This module implements the CloudEvents Kafka Protocol Binding specification v1.0.2 +-- which defines how CloudEvents are mapped to Kafka messages. +-- +-- The binding supports two content modes: +-- +-- * Binary mode: The CloudEvent's data is placed directly in the Kafka message value, +-- with all other attributes being placed in the message headers with a 'ce_' prefix. +-- +-- * Structured mode: The entire CloudEvent, including its data, is serialized into a +-- single message value using the JSON event format. +-- +-- See: +module CloudEvent.V1.Bindings.Kafka + ( KafkaCloudEventExtAttributes (..) + , toBinaryKafkaMessage + , toStructuredKafkaMessage + ) where + +import Prelude + +import Autodocodec + ( Autodocodec (..) + , HasCodec (..) + , HasObjectCodec (..) + , object + , requiredField' + , (.=) + ) +import CloudEvent.V1.Event.Internal.Data (CloudEvent (..)) +import Data.Aeson (FromJSON, ToJSON, encode) +import Data.Binary (Binary) +import Data.ByteString (ByteString) +import Data.ByteString.Lazy qualified as BSL +import Data.Maybe (catMaybes) +import Data.String (IsString (..)) +import Data.Text (Text) +import Data.Text.Encoding (encodeUtf8) +import GHC.Generics (Generic) +import GHC.Records (HasField) +import Iri.Rendering.Text (iri) +import Kafka.Producer + ( ProducePartition (UnassignedPartition) + , ProducerRecord (..) + , TopicName + , headersFromList + ) + +-- | Extension attributes specific to Kafka CloudEvents. +-- This follows the CloudEvents Kafka Protocol Binding specification which +-- recommends mapping a partition key attribute to the Kafka record key. +newtype KafkaCloudEventExtAttributes = KafkaCloudEventExtAttributes + { partitionKey :: Text + -- ^ The partition key used to determine which partition a message should be sent to. + -- This corresponds to the 'partitionkey' attribute in the CloudEvents Partitioning extension. + -- This will be used as the Kafka message key when sending events. + } + deriving stock (Eq, Generic, Show) + deriving (FromJSON, ToJSON) via (Autodocodec KafkaCloudEventExtAttributes) + deriving anyclass (Binary) + +instance HasCodec KafkaCloudEventExtAttributes where + codec = object "KafkaCloudEventExtAttributes" objectCodec + +instance HasObjectCodec KafkaCloudEventExtAttributes where + objectCodec = + KafkaCloudEventExtAttributes + <$> requiredField' "partitionKey" .= (.partitionKey) + +-- | Converts a CloudEvent to a Kafka message in binary content mode. +-- +-- In binary mode: +-- * The CloudEvent data is serialized as JSON and placed in the Kafka message value +-- * CloudEvent attributes are mapped to Kafka headers with 'ce_' prefix +-- * The content type header indicates the data format +-- * The partition key extension attribute is mapped to the Kafka message key +-- +-- As specified in the Kafka Protocol Binding section 3.2: +-- +toBinaryKafkaMessage + :: forall ext eventData + . (HasField "partitionKey" ext Text, ToJSON eventData) + => TopicName + -- ^ The Kafka topic to publish to + -> CloudEvent ext eventData + -- ^ The CloudEvent to convert + -> ProducerRecord + -- ^ Resulting Kafka producer record +toBinaryKafkaMessage topicName cloudEvent = + let + partitionKey = cloudEvent.extensionAttributes.partitionKey + kafkaHeadersMapping :: [(ByteString, ByteString)] = + catMaybes + [ Just ("ce_id", encodeUtf8 cloudEvent.ceId) + , Just ("ce_type", encodeUtf8 cloudEvent.ceType) + , Just ("ce_source", encodeUtf8 $ iri $ cloudEvent.ceSource) + , Just ("ce_specversion", encodeUtf8 cloudEvent.ceSpecVersion) + , Just ("ce_time", fromString $ show $ cloudEvent.ceTime) + , ("ce_subject",) . encodeUtf8 <$> cloudEvent.ceSubject + , ("content-type",) . encodeUtf8 <$> cloudEvent.ceDataContentType + , ("ce_dataschema",) . encodeUtf8 . iri <$> cloudEvent.ceDataSchema + ] + in + ProducerRecord + { prValue = Just $ BSL.toStrict $ encode cloudEvent.ceData + , prTopic = topicName + , prPartition = UnassignedPartition + , prKey = Just $ encodeUtf8 partitionKey + , prHeaders = headersFromList kafkaHeadersMapping + } + +-- | Converts a CloudEvent to a Kafka message in structured content mode AKA JSON. +-- +-- In structured mode: +-- * The entire CloudEvent (attributes and data) is serialized as JSON and placed in the Kafka message value +-- * A 'content-type' header with value 'application/cloudevents+json; charset=utf-8' is added +-- * The partition key extension attribute is mapped to the Kafka message key +-- +-- This format allows for simple forwarding of the same event across multiple +-- routing hops and protocols without requiring knowledge of the CloudEvent format. +-- +-- As specified in the Kafka Protocol Binding section 3.3: +-- +toStructuredKafkaMessage + :: (HasCodec eventData, HasField "partitionKey" ext Text, HasObjectCodec ext) + => TopicName + -- ^ The Kafka topic to publish to + -> CloudEvent ext eventData + -- ^ The CloudEvent to convert + -> ProducerRecord + -- ^ Resulting Kafka producer record +toStructuredKafkaMessage topicName cloudEvent = + let + partitionKey = cloudEvent.extensionAttributes.partitionKey + kafkaHeadersMapping :: [(ByteString, ByteString)] = + [("content-type", "application/cloudevents+json; charset=utf-8")] + in + ProducerRecord + { prValue = Just $ BSL.toStrict $ encode cloudEvent + , prTopic = topicName + , prPartition = UnassignedPartition + , prKey = Just $ encodeUtf8 partitionKey + , prHeaders = headersFromList kafkaHeadersMapping + } diff --git a/src/CloudEvent/V1/Event/Data.hs b/src/CloudEvent/V1/Event/Data.hs new file mode 100644 --- /dev/null +++ b/src/CloudEvent/V1/Event/Data.hs @@ -0,0 +1,83 @@ +module CloudEvent.V1.Event.Data + ( CloudEvent + , MkCloudEventArg (..) + , mkCloudEvent + , EmptyExtension (..) + ) where + +import Prelude + +import Autodocodec + ( Autodocodec (..) + , HasCodec (..) + , HasObjectCodec (objectCodec) + , object + ) +import CloudEvent.V1.Event.Internal.Data (CloudEvent (..)) +import Data.Aeson (FromJSON, ToJSON) +import Data.Binary (Binary) +import Data.Text (Text) +import Data.Time (UTCTime) +import GHC.Generics (Generic) +import Iri.Data (Iri) + +-- | Arguments for creating a CloudEvent +data MkCloudEventArg = MkCloudEventArg + { ceId :: Text + -- ^ Unique identifier for the event + , ceSource :: Iri + -- ^ Identifies the context where the event occurred + , ceEventType :: Text + -- ^ Describes the type of event + , ceDataContentType :: Maybe Text + -- ^ Content type of the event data (e.g., application/json) + , ceDataSchema :: Maybe Iri + -- ^ Schema that the event data adheres to + , ceSubject :: Maybe Text + -- ^ Subject of the event within the context + , ceTime :: UTCTime + -- ^ Timestamp when the event occurred + } + +mkCloudEvent + :: MkCloudEventArg + -> eventData + -> extensionAttributeRecord + -> CloudEvent extensionAttributeRecord eventData +mkCloudEvent x eventData ext = + CloudEvent + { ceId = x.ceId + , ceSource = x.ceSource + , ceSpecVersion = "1.0" + , ceType = x.ceEventType + , ceDataContentType = x.ceDataContentType + , ceDataSchema = x.ceDataSchema + , ceSubject = x.ceSubject + , ceTime = x.ceTime + , ceData = eventData + , ceDatabase64 = Nothing + , extensionAttributes = ext + } + +-- | A placeholder type representing an empty set of extension attributes. +-- +-- This type is useful when you need to create a CloudEvent with no extension +-- attributes but require a concrete type parameter for the extension. +-- It encodes and decodes to an empty JSON object. +-- +-- Example usage: +-- +-- @ +-- myEvent :: CloudEvent EmptyExtension MyDataType +-- myEvent = mkCloudEvent args myData EmptyExtension +-- @ +data EmptyExtension = EmptyExtension + deriving stock (Eq, Generic, Show) + deriving anyclass (Binary) + deriving (FromJSON, ToJSON) via (Autodocodec EmptyExtension) + +instance HasCodec EmptyExtension where + codec = object "EmptyExtension" objectCodec + +instance HasObjectCodec EmptyExtension where + objectCodec = pure EmptyExtension diff --git a/src/CloudEvent/V1/Event/Internal/Data.hs b/src/CloudEvent/V1/Event/Internal/Data.hs new file mode 100644 --- /dev/null +++ b/src/CloudEvent/V1/Event/Internal/Data.hs @@ -0,0 +1,124 @@ +module CloudEvent.V1.Event.Internal.Data + ( CloudEvent (..) + ) where + +import Prelude + +import Autodocodec + ( Autodocodec (..) + , HasCodec (..) + , HasObjectCodec (objectCodec) + , object + , optionalField' + , requiredField' + , (.=) + ) +import CloudEvent.V1.Event.Internal.Orphans () +import Data.Aeson (FromJSON, ToJSON) +import Data.Binary (Binary) +import Data.Text (Text) +import Data.Time (UTCTime) +import GHC.Generics (Generic) +import Iri.Data (Iri) + +-- | A CloudEvent represents the standardized format for describing event data. +-- This implementation follows the CloudEvents specification version 1.0. +-- CloudEvents are designed to provide interoperability across services, +-- platforms and systems. +data CloudEvent extension eventData = CloudEvent + { ceId :: Text + -- ^ Identifies the event. Producers must ensure that 'source' + 'id' is unique + -- for each distinct event. If a duplicate event is re-sent (e.g. due to a network error) + -- it may have the same 'id'. Consumers may assume that events with identical + -- 'source' and 'id' are duplicates. + -- + -- Examples: + -- * An event counter maintained by the producer + -- * A UUID + , ceSource :: Iri + -- ^ Identifies the context in which an event happened. Often this will include + -- information such as the type of the event source, the organization publishing the event, + -- or the process that produced the event. + -- + -- Examples: + -- * https://github.com/cloudevents + -- * mailto:cncf-wg-serverless@lists.cncf.io + -- * urn:uuid:6e8bc430-9c3a-11d9-9669-0800200c9a66 + -- * /sensors/tn-1234567/alerts + , ceSpecVersion :: Text + -- ^ The version of the CloudEvents specification which the event uses. + -- This enables the interpretation of the context. + -- For CloudEvents Spec v1.0, this is always "1.0". + , ceType :: Text + -- ^ This attribute contains a value describing the type of event related to the + -- originating occurrence. Often this attribute is used for routing, observability, + -- policy enforcement, etc. + -- + -- Examples: + -- * com.github.pull_request.opened + -- * com.example.object.deleted.v2 + , ceDataContentType :: Maybe Text + -- ^ Content type of the data value. This attribute enables data to carry any + -- type of content, whereby format and encoding might differ from that of the chosen + -- event format. For example, an event rendered using the JSON format might carry an + -- XML payload in data. + -- + -- Examples: + -- * text/xml + -- * application/json + -- * image/png + -- * application/octet-stream + , ceDataSchema :: Maybe Iri + -- ^ Identifies the schema that data adheres to. Incompatible changes to the schema + -- should be reflected by a different URI. + , ceSubject :: Maybe Text + -- ^ This describes the subject of the event in the context of the event producer. + -- In publish-subscribe scenarios, a subscriber will typically subscribe to events + -- emitted by a source, but the source identifier alone might not be sufficient as + -- a qualifier for any specific event if the source context has internal sub-structure. + -- + -- Example: + -- * A storage system might have an event source (storage container) but include the name + -- of the modified file in the subject: "mynewfile.jpg" + , ceTime :: UTCTime + -- ^ Timestamp of when the occurrence happened. If the time of the occurrence + -- cannot be determined then this attribute may be set to some other time + -- (such as the current time) by the CloudEvents producer. + -- + -- Example: + -- * 2018-04-05T17:31:00Z + , ceData :: eventData + -- ^ The actual event data. This may be structured data formatted according to + -- the 'datacontenttype' attribute. This specification does not place any restriction + -- on the type of this information. + , ceDatabase64 :: Maybe Text + -- ^ Base64 encoded event payload. Must adhere to RFC4648. + -- This is used for data that is binary in nature and can't be directly included + -- in standard formats like JSON. + , extensionAttributes :: extension + -- ^ User-defined extension attributes to the CloudEvent. Extension attributes + -- have no defined meaning in the core CloudEvent specification. + -- They allow external systems to attach metadata to an event. + } + deriving stock (Eq, Generic, Show) + deriving (FromJSON, ToJSON) via (Autodocodec (CloudEvent extension eventData)) + deriving anyclass (Binary) + +instance + (HasCodec eventData, HasObjectCodec extension) + => HasCodec (CloudEvent extension eventData) + where + codec = + object "CloudEvent" + $ CloudEvent + <$> requiredField' "id" .= (.ceId) + <*> requiredField' "source" .= (.ceSource) + <*> requiredField' "specversion" .= (.ceSpecVersion) + <*> requiredField' "type" .= (.ceType) + <*> optionalField' "datacontenttype" .= (.ceDataContentType) + <*> optionalField' "dataschema" .= (.ceDataSchema) + <*> optionalField' "subject" .= (.ceSubject) + <*> requiredField' "time" .= (.ceTime) + <*> requiredField' "data" .= (.ceData) + <*> optionalField' "data_base64" .= (.ceDatabase64) + <*> objectCodec @extension .= (.extensionAttributes) diff --git a/src/CloudEvent/V1/Event/Internal/Orphans.hs b/src/CloudEvent/V1/Event/Internal/Orphans.hs new file mode 100644 --- /dev/null +++ b/src/CloudEvent/V1/Event/Internal/Orphans.hs @@ -0,0 +1,32 @@ +{-# OPTIONS_GHC -Wno-missing-export-lists #-} +{-# OPTIONS_GHC -Wno-orphans #-} + +module CloudEvent.V1.Event.Internal.Orphans where + +import Prelude + +import Autodocodec (Autodocodec (..), HasCodec (codec), bimapCodec) +import Data.Aeson (FromJSON, ToJSON) +import Data.Bifunctor (first) +import Data.Binary (Binary (..)) +import Data.Binary.Instances () +import Data.Text (Text) +import Data.Text qualified as T +import Iri.Data (Iri) +import Iri.Parsing.Text qualified +import Iri.Rendering.Text qualified + +instance HasCodec Iri where + codec = + bimapCodec + (first T.unpack . Iri.Parsing.Text.iri) + Iri.Rendering.Text.iri + (codec @Text) + +deriving via Autodocodec Iri instance FromJSON Iri + +deriving via Autodocodec Iri instance ToJSON Iri + +instance Binary Iri where + put r = put @Text $ Iri.Rendering.Text.iri r + get = get @Text >>= either (fail . T.unpack) pure . Iri.Parsing.Text.iri diff --git a/src/CloudEvent/V1/Event/Lens.hs b/src/CloudEvent/V1/Event/Lens.hs new file mode 100644 --- /dev/null +++ b/src/CloudEvent/V1/Event/Lens.hs @@ -0,0 +1,22 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# OPTIONS_GHC -Wno-missing-export-lists #-} + +module CloudEvent.V1.Event.Lens where + +import CloudEvent.V1.Event.Data (CloudEvent) +import Control.Lens (makeLensesFor) + +makeLensesFor + [ ("ceId", "_ceId") + , ("ceSource", "_ceSource") + , ("ceSpecversion", "_ceSpecversion") + , ("ceType", "_ceType") + , ("ceDatacontenttype", "_ceDatacontenttype") + , ("ceDataschema", "_ceDataschema") + , ("ceSubject", "_ceSubject") + , ("ceTime", "_ceTime") + , ("ceData", "_ceData") + , ("ceData_base64", "_ceData_base64") + , ("extensionAttributes", "_extensionAttributes") + ] + ''CloudEvent diff --git a/src/CloudEvent/V1/Event/Validation.hs b/src/CloudEvent/V1/Event/Validation.hs new file mode 100644 --- /dev/null +++ b/src/CloudEvent/V1/Event/Validation.hs @@ -0,0 +1,34 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} + +module CloudEvent.V1.Event.Validation + ( isValidCloudEvent + ) where + +import Prelude + +import Autodocodec (HasCodec, HasObjectCodec) +import Autodocodec.Schema (jsonSchemaViaCodec, validateAccordingTo) +import CloudEvent.V1.Event.Data (CloudEvent) +import Data.Aeson (Value) +import Data.Kind (Type) + +-- | Validates that a JSON value conforms to a specific CloudEvents specification. +-- Requires the event data type and extension attributes to be specified as type applications with the event data type first. +-- +-- Example usage: +-- +-- @ +-- let jsonValue = ... -- Some JSON representation of a CloudEvent +-- if isValidCloudEvent \@MyEventData \@MyExtensions jsonValue +-- then handleValidEvent jsonValue +-- else handleInvalidEvent +-- @ +isValidCloudEvent + :: forall (eventData :: Type) (extensionAttributes :: Type) + . (HasCodec eventData, HasObjectCodec extensionAttributes) => Value -> Bool +isValidCloudEvent = + flip + validateAccordingTo + ( jsonSchemaViaCodec + @(CloudEvent extensionAttributes eventData) + )