├── .envrc ├── cabal.project ├── Setup.hs ├── tests ├── Spec.hs └── Kafka │ └── Consumer │ ├── ConsumerRecordMapSpec.hs │ └── ConsumerRecordTraverseSpec.hs ├── tests-it ├── Spec.hs └── Kafka │ ├── TestEnv.hs │ └── IntegrationSpec.hs ├── .vscode ├── settings.json └── tasks.json ├── default.nix ├── example ├── Main.hs ├── ConsumerExample.hs └── ProducerExample.hs ├── scripts ├── build-docs.sh └── build-librdkafka ├── shell.nix ├── nix ├── nixpkgs.nix ├── overrides.nix ├── sources.json └── sources.nix ├── src └── Kafka │ ├── Topic │ └── Types.hs │ ├── Producer │ ├── Convert.hs │ ├── Types.hs │ ├── Callbacks.hs │ └── ProducerProperties.hs │ ├── Callbacks.hs │ ├── Consumer │ ├── Subscription.hs │ ├── Callbacks.hs │ ├── ConsumerProperties.hs │ ├── Convert.hs │ └── Types.hs │ ├── Dump.hs │ ├── Internal │ ├── Setup.hs │ └── Shared.hs │ ├── Transaction.hs │ ├── Topic.hs │ ├── Types.hs │ ├── Producer.hs │ ├── Metadata.hs │ └── Consumer.hs ├── LICENSE ├── .gitignore ├── project.sh ├── docker-compose.yml ├── hw-kafka-client.cabal ├── .github └── workflows │ └── haskell.yml ├── .stylish-haskell.yaml └── README.md /.envrc: -------------------------------------------------------------------------------- 1 | use nix 2 | -------------------------------------------------------------------------------- /cabal.project: -------------------------------------------------------------------------------- 1 | packages: . 2 | -------------------------------------------------------------------------------- /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /tests/Spec.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -F -pgmF hspec-discover #-} 2 | -------------------------------------------------------------------------------- /tests-it/Spec.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -F -pgmF hspec-discover #-} 2 | -------------------------------------------------------------------------------- /.vscode/settings.json: -------------------------------------------------------------------------------- 1 | { 2 | "nixEnvSelector.nixFile": "${workspaceRoot}/shell.nix" 3 | } 4 | -------------------------------------------------------------------------------- /default.nix: -------------------------------------------------------------------------------- 1 | { compiler ? "ghc843" }: 2 | 3 | with rec { 4 | pkgs = (import ./nix/nixpkgs.nix { 5 | inherit compiler; 6 | }); 7 | drv = pkgs.haskellPackages.hw-kafka-client; 8 | }; 9 | 10 | drv 11 | -------------------------------------------------------------------------------- /example/Main.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import ConsumerExample 4 | import ProducerExample 5 | 6 | main :: IO () 7 | main = do 8 | putStrLn "Running producer example..." 9 | runProducerExample 10 | 11 | putStrLn "Running consumer example..." 12 | runConsumerExample 13 | 14 | putStrLn "Ok." 15 | -------------------------------------------------------------------------------- /scripts/build-docs.sh: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | set -e 3 | 4 | dir=$(mktemp -d dist-docs.XXXXXX) 5 | trap 'rm -r "$dir"' EXIT 6 | 7 | cabal v2-haddock --builddir="$dir" --haddock-for-hackage --haddock-option=--hyperlinked-source 8 | # Starting with cabal 2.0, `--publish` is needed for uploading to non-candidate releases 9 | cabal upload -d $dir/*-docs.tar.gz --publish 10 | -------------------------------------------------------------------------------- /shell.nix: -------------------------------------------------------------------------------- 1 | with import {}; 2 | 3 | pkgs.mkShell { 4 | buildInputs = with pkgs; [ 5 | zlib 6 | rdkafka 7 | # nettools 8 | gmp 9 | ]; 10 | 11 | shellHook = '' 12 | PATH=~/.cabal/bin:$PATH 13 | LD_LIBRARY_PATH=${pkgs.zlib}/lib:$LD_LIBRARY_PATH 14 | export LIBRARY_PATH=${pkgs.rdkafka}/lib 15 | export C_INCLUDE_PATH=${pkgs.rdkafka}/include 16 | 17 | export KAFKA_TEST_BROKER=$(ifconfig | sed -En 's/127.0.0.1//;s/.*inet (addr:)?(([0-9]*\.){3}[0-9]*).*/\2/p' | head -n 1) 18 | ''; 19 | } 20 | -------------------------------------------------------------------------------- /nix/nixpkgs.nix: -------------------------------------------------------------------------------- 1 | { compiler ? "ghc843" }: 2 | 3 | with rec { 4 | sources = import ./sources.nix; 5 | nivOverlay = _: pkgs: 6 | { niv = (import sources.niv {}).niv; # use the sources :) 7 | }; 8 | }; 9 | 10 | import sources.nixpkgs { 11 | config = { 12 | packageOverrides = super: let self = super.pkgs; in { 13 | haskellPackages = super.haskell.packages.${compiler}.override { 14 | overrides = import ./overrides.nix { pkgs = self; }; 15 | }; 16 | 17 | }; 18 | }; 19 | overlays = [nivOverlay]; 20 | } 21 | -------------------------------------------------------------------------------- /src/Kafka/Topic/Types.hs: -------------------------------------------------------------------------------- 1 | module Kafka.Topic.Types ( 2 | PartitionCount (..) 3 | , ReplicationFactor (..) 4 | , NewTopic (..) 5 | ) where 6 | 7 | import Data.Map 8 | 9 | import Kafka.Types 10 | 11 | newtype PartitionCount = PartitionCount { unPartitionCount :: Int } deriving (Show, Eq) 12 | newtype ReplicationFactor = ReplicationFactor { unReplicationFactor :: Int } deriving (Show, Eq) 13 | 14 | data NewTopic = NewTopic { 15 | topicName :: TopicName 16 | , topicPartitionCount :: PartitionCount 17 | , topicReplicationFactor :: ReplicationFactor 18 | , topicConfig :: Map String String 19 | } deriving (Show) 20 | -------------------------------------------------------------------------------- /nix/overrides.nix: -------------------------------------------------------------------------------- 1 | { pkgs }: 2 | 3 | self: super: 4 | 5 | with { inherit (pkgs.stdenv) lib; }; 6 | 7 | with pkgs.haskell.lib; 8 | 9 | { 10 | hw-kafka-client = ( 11 | with rec { 12 | hw-kafka-clientSource = pkgs.lib.cleanSource ../.; 13 | hw-kafka-clientBasic = self.callCabal2nix "hw-kafka-client" hw-kafka-clientSource {}; 14 | }; 15 | overrideCabal hw-kafka-clientBasic (old: { 16 | enableLibraryProfiling = false; 17 | preConfigure = "sed -i -e /extra-lib-dirs/d -e /include-dirs/d -e /librdkafka/d hw-kafka-client.cabal"; 18 | configureFlags = '' 19 | --extra-include-dirs=${pkgs.rdkafka}/include/librdkafka 20 | 21 | --extra-prog-path=${pkgs.rdkafka}/lib 22 | 23 | --extra-lib-dirs=${pkgs.rdkafka}/lib 24 | ''; 25 | }) 26 | ); 27 | } 28 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2016 Alexey Raga 2 | 3 | Permission is hereby granted, free of charge, to any person obtaining 4 | a copy of this software and associated documentation files (the 5 | "Software"), to deal in the Software without restriction, including 6 | without limitation the rights to use, copy, modify, merge, publish, 7 | distribute, sublicense, and/or sell copies of the Software, and to 8 | permit persons to whom the Software is furnished to do so, subject to 9 | the following conditions: 10 | 11 | The above copyright notice and this permission notice shall be included 12 | in all copies or substantial portions of the Software. 13 | 14 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, 15 | EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF 16 | MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. 17 | IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY 18 | CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, 19 | TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE 20 | SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. 21 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | # Created by http://www.gitignore.io 2 | 3 | .librdkafka/* 4 | 5 | ### OSX ### 6 | .DS_Store 7 | .AppleDouble 8 | .LSOverride 9 | 10 | # Icon must ends with two \r. 11 | Icon 12 | 13 | 14 | # Thumbnails 15 | ._* 16 | 17 | # Files that might appear on external disk 18 | .Spotlight-V100 19 | .Trashes 20 | 21 | .librdkafka/* 22 | 23 | ### Haskell ### 24 | dist 25 | dist-newstyle 26 | dist-docs* 27 | cabal-dev 28 | *.o 29 | *.hi 30 | *.chi 31 | *.chs.h 32 | .virthualenv 33 | .hsenv 34 | .cabal-sandbox/ 35 | cabal.sandbox.config 36 | cabal.config 37 | cabal.project.local 38 | .stack-work/ 39 | *.cabal 40 | *.ghc* 41 | 42 | ### Nix ### 43 | result* 44 | 45 | ### Emacs ### 46 | # -*- mode: gitignore; -*- 47 | *~ 48 | \#*\# 49 | /.emacs.desktop 50 | /.emacs.desktop.lock 51 | *.elc 52 | auto-save-list 53 | tramp 54 | .\#* 55 | 56 | # Org-mode 57 | .org-id-locations 58 | *_archive 59 | 60 | # flymake-mode 61 | *_flymake.* 62 | 63 | # eshell files 64 | /eshell/history 65 | /eshell/lastdir 66 | 67 | # elpa packages 68 | /elpa/ 69 | TAGS 70 | 71 | ### Haddock 72 | src/highlight.js 73 | src/style.css 74 | 75 | # Direnv 76 | .direnv 77 | -------------------------------------------------------------------------------- /nix/sources.json: -------------------------------------------------------------------------------- 1 | { 2 | "niv": { 3 | "branch": "master", 4 | "description": "Easy dependency management for Nix projects", 5 | "homepage": "https://github.com/nmattia/niv", 6 | "owner": "nmattia", 7 | "repo": "niv", 8 | "rev": "65a61b147f307d24bfd0a5cd56ce7d7b7cc61d2e", 9 | "sha256": "17mirpsx5wyw262fpsd6n6m47jcgw8k2bwcp1iwdnrlzy4dhcgqh", 10 | "type": "tarball", 11 | "url": "https://github.com/nmattia/niv/archive/65a61b147f307d24bfd0a5cd56ce7d7b7cc61d2e.tar.gz", 12 | "url_template": "https://github.com///archive/.tar.gz" 13 | }, 14 | "nixpkgs": { 15 | "branch": "nixos-21.05", 16 | "description": "Nix Packages collection", 17 | "homepage": "", 18 | "owner": "NixOS", 19 | "repo": "nixpkgs", 20 | "rev": "ce7a1190a0fa4ba3465b5f5471b08567060ca14c", 21 | "sha256": "1zr1s9gp0h5g4arlba1bpb9yqfaaby5195ydm6a2psaxhm748li9", 22 | "type": "tarball", 23 | "url": "https://github.com/NixOS/nixpkgs/archive/ce7a1190a0fa4ba3465b5f5471b08567060ca14c.tar.gz", 24 | "url_template": "https://github.com///archive/.tar.gz" 25 | } 26 | } 27 | -------------------------------------------------------------------------------- /tests/Kafka/Consumer/ConsumerRecordMapSpec.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | module Kafka.Consumer.ConsumerRecordMapSpec 3 | ( spec 4 | ) where 5 | 6 | import Data.Bitraversable 7 | import Data.Text 8 | import Kafka.Consumer.Types 9 | import Kafka.Types 10 | import Test.Hspec 11 | 12 | testKey, testValue :: Text 13 | testKey = "some-key" 14 | testValue = "some-value" 15 | 16 | testRecord :: ConsumerRecord (Maybe Text) (Maybe Text) 17 | testRecord = ConsumerRecord 18 | { crTopic = "some-topic" 19 | , crPartition = PartitionId 0 20 | , crOffset = Offset 5 21 | , crTimestamp = NoTimestamp 22 | , crHeaders = mempty 23 | , crKey = Just testKey 24 | , crValue = Just testValue 25 | } 26 | 27 | spec :: Spec 28 | spec = describe "Kafka.Consumer.ConsumerRecordSpec" $ do 29 | it "should exract key" $ 30 | bitraverse id pure testRecord `shouldBe` Just (crMapKey (const testKey) testRecord) 31 | 32 | it "should extract value" $ 33 | sequence testRecord `shouldBe` Just (crMapValue (const testValue) testRecord) 34 | 35 | it "should extract both key and value" $ 36 | bisequence testRecord `shouldBe` Just (crMapKV (const testKey) (const testValue) testRecord) 37 | -------------------------------------------------------------------------------- /scripts/build-librdkafka: -------------------------------------------------------------------------------- 1 | #!/bin/bash 2 | 3 | RDKAFKA_VER="1a722553638bba85dbda5050455f7b9a5ef302de" 4 | 5 | PRJ=$PWD 6 | DST="$PRJ/.librdkafka" 7 | VERSION_FILE="$DST/version.txt" 8 | 9 | OS=`echo $(uname) | tr '[:upper:]' '[:lower:]'` 10 | if [ "$OS" = "linux" ]; then 11 | GUESS_INSTALL_DIR=/usr 12 | else 13 | GUESS_INSTALL_DIR=/usr/local 14 | fi; 15 | 16 | INSTALL_DIR=${INSTALL_DIR:-$GUESS_INSTALL_DIR} 17 | 18 | if [ -f $VERSION_FILE ]; then 19 | echo "Found librdkafka: $(cat $VERSION_FILE), expected: $RDKAFKA_VER" 20 | else 21 | echo "librdkafka not found in $DST" 22 | fi 23 | 24 | if [ -f $VERSION_FILE ] && [ "$(cat $VERSION_FILE)" == $RDKAFKA_VER ]; then 25 | echo "Required version found, using it" 26 | sudo cp -r $DST/* $INSTALL_DIR/ 27 | exit 0 28 | fi 29 | 30 | echo "Making librdkafka ($RDKAFKA_VER)" 31 | SRC=`mktemp -d 2>/dev/null || mktemp -d -t 'rdkafka'` 32 | git clone https://github.com/edenhill/librdkafka "$SRC" 33 | cd $SRC 34 | git reset $RDKAFKA_VER --hard 35 | 36 | ./configure --prefix $DST 37 | cd src 38 | make && make install 39 | find $DST/lib -type f -executable | xargs strip 40 | 41 | sudo cp -r $DST/* $INSTALL_DIR/ 42 | 43 | echo "Writing version file to $VERSION_FILE" 44 | echo $RDKAFKA_VER > $VERSION_FILE 45 | -------------------------------------------------------------------------------- /project.sh: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env bash 2 | 3 | CABAL_FLAGS="-j8" 4 | 5 | cmd="$1" 6 | 7 | shift 8 | 9 | cabal-install() { 10 | cabal v2-install \ 11 | -j8 \ 12 | --installdir="$HOME/.local/bin" \ 13 | --overwrite-policy=always \ 14 | --disable-documentation \ 15 | $CABAL_FLAGS "$@" 16 | } 17 | 18 | cabal-build() { 19 | cabal v2-build \ 20 | --enable-tests \ 21 | --write-ghc-environment-files=ghc8.4.4+ \ 22 | $CABAL_FLAGS "$@" 23 | } 24 | 25 | cabal-test() { 26 | cabal v2-test \ 27 | --enable-tests \ 28 | --test-show-details=direct \ 29 | --test-options='+RTS -g1' \ 30 | $CABAL_FLAGS "$@" 31 | } 32 | 33 | cabal-exec() { 34 | cabal v2-exec "$(echo *.cabal | cut -d . -f 1)" "$@" 35 | } 36 | 37 | cabal-bench() { 38 | cabal v2-bench -j8 \ 39 | $CABAL_FLAGS "$@" 40 | } 41 | 42 | cabal-repl() { 43 | cabal v2-repl \ 44 | $CABAL_FLAGS "$@" 45 | } 46 | 47 | cabal-clean() { 48 | cabal v2-clean 49 | } 50 | 51 | case "$cmd" in 52 | install) 53 | cabal-install 54 | ;; 55 | 56 | build) 57 | cabal-build 58 | ;; 59 | 60 | exec) 61 | cabal-exec 62 | ;; 63 | 64 | test) 65 | cabal-build 66 | cabal-test 67 | ;; 68 | 69 | bench) 70 | cabal-bench 71 | ;; 72 | 73 | repl) 74 | cabal-repl 75 | ;; 76 | 77 | clean) 78 | cabal-clean 79 | ;; 80 | 81 | *) 82 | echo "Unrecognised command: $cmd" 83 | exit 1 84 | esac 85 | -------------------------------------------------------------------------------- /docker-compose.yml: -------------------------------------------------------------------------------- 1 | version: '3.7' 2 | services: 3 | # Redpanda cluster 4 | redpanda-1: 5 | image: docker.redpanda.com/redpandadata/redpanda:v23.1.1 6 | container_name: redpanda-1 7 | command: 8 | - redpanda 9 | - start 10 | - --smp 11 | - '1' 12 | - --reserve-memory 13 | - 0M 14 | - --overprovisioned 15 | - --node-id 16 | - '1' 17 | - --kafka-addr 18 | - PLAINTEXT://0.0.0.0:29092,OUTSIDE://0.0.0.0:9092 19 | - --advertise-kafka-addr 20 | - PLAINTEXT://redpanda-1:29092,OUTSIDE://localhost:9092 21 | - --pandaproxy-addr 22 | - PLAINTEXT://0.0.0.0:28082,OUTSIDE://0.0.0.0:8082 23 | - --advertise-pandaproxy-addr 24 | - PLAINTEXT://redpanda-1:28082,OUTSIDE://localhost:8082 25 | - --rpc-addr 26 | - 0.0.0.0:33145 27 | - --advertise-rpc-addr 28 | - redpanda-1:33145 29 | ports: 30 | - 8082:8082 31 | - 9092:9092 32 | - 9644:9644 33 | - 28082:28082 34 | - 29092:29092 35 | 36 | redpanda-console: 37 | image: docker.redpanda.com/redpandadata/console:v2.2.2 38 | container_name: redpanda-console 39 | entrypoint: /bin/sh 40 | command: -c "echo \"$$CONSOLE_CONFIG_FILE\" > /tmp/config.yml; /app/console" 41 | environment: 42 | CONFIG_FILEPATH: /tmp/config.yml 43 | CONSOLE_CONFIG_FILE: | 44 | kafka: 45 | brokers: ["redpanda-1:29092"] 46 | schemaRegistry: 47 | enabled: false 48 | redpanda: 49 | adminApi: 50 | enabled: true 51 | urls: ["http://redpanda-1:9644"] 52 | connect: 53 | enabled: false 54 | ports: 55 | - 8080:8080 56 | depends_on: 57 | - redpanda-1 58 | -------------------------------------------------------------------------------- /src/Kafka/Producer/Convert.hs: -------------------------------------------------------------------------------- 1 | module Kafka.Producer.Convert 2 | ( copyMsgFlags 3 | , producePartitionInt 4 | , producePartitionCInt 5 | , handleProduceErr 6 | , handleProduceErr' 7 | , handleProduceErrT 8 | ) 9 | where 10 | 11 | import Foreign.C.Error (getErrno) 12 | import Foreign.C.Types (CInt) 13 | import Kafka.Internal.RdKafka (RdKafkaRespErrT(..), rdKafkaMsgFlagCopy) 14 | import Kafka.Internal.Shared (kafkaRespErr) 15 | import Kafka.Types (KafkaError(..)) 16 | import Kafka.Producer.Types (ProducePartition(..)) 17 | 18 | copyMsgFlags :: Int 19 | copyMsgFlags = rdKafkaMsgFlagCopy 20 | {-# INLINE copyMsgFlags #-} 21 | 22 | producePartitionInt :: ProducePartition -> Int 23 | producePartitionInt UnassignedPartition = -1 24 | producePartitionInt (SpecifiedPartition n) = n 25 | {-# INLINE producePartitionInt #-} 26 | 27 | producePartitionCInt :: ProducePartition -> CInt 28 | producePartitionCInt = fromIntegral . producePartitionInt 29 | {-# INLINE producePartitionCInt #-} 30 | 31 | handleProduceErr :: Int -> IO (Maybe KafkaError) 32 | handleProduceErr (- 1) = Just . kafkaRespErr <$> getErrno 33 | handleProduceErr 0 = return Nothing 34 | handleProduceErr _ = return $ Just KafkaInvalidReturnValue 35 | {-# INLINE handleProduceErr #-} 36 | 37 | handleProduceErrT :: RdKafkaRespErrT -> IO (Maybe KafkaError) 38 | handleProduceErrT RdKafkaRespErrUnknown = Just . kafkaRespErr <$> getErrno 39 | handleProduceErrT RdKafkaRespErrNoError = return Nothing 40 | handleProduceErrT e = return $ Just (KafkaResponseError e) 41 | {-# INLINE handleProduceErrT #-} 42 | 43 | handleProduceErr' :: Int -> IO (Either KafkaError ()) 44 | handleProduceErr' (- 1) = Left . kafkaRespErr <$> getErrno 45 | handleProduceErr' 0 = return (Right ()) 46 | handleProduceErr' _ = return $ Left KafkaInvalidReturnValue 47 | {-# INLINE handleProduceErr' #-} 48 | -------------------------------------------------------------------------------- /tests/Kafka/Consumer/ConsumerRecordTraverseSpec.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | module Kafka.Consumer.ConsumerRecordTraverseSpec 4 | ( spec 5 | ) where 6 | 7 | import Data.Bifunctor 8 | import Data.Bitraversable 9 | import Data.Text 10 | import Kafka.Consumer.Types 11 | import Kafka.Types 12 | import Test.Hspec 13 | 14 | testKey, testValue :: Text 15 | testKey = "some-key" 16 | testValue = "some-value" 17 | 18 | testRecord :: ConsumerRecord Text Text 19 | testRecord = ConsumerRecord 20 | { crTopic = "some-topic" 21 | , crPartition = PartitionId 0 22 | , crOffset = Offset 5 23 | , crTimestamp = NoTimestamp 24 | , crHeaders = mempty 25 | , crKey = testKey 26 | , crValue = testValue 27 | } 28 | 29 | liftValue :: a -> Maybe a 30 | liftValue = Just 31 | 32 | liftNothing :: a -> Maybe a 33 | liftNothing _ = Nothing 34 | 35 | spec :: Spec 36 | spec = describe "Kafka.Consumer.ConsumerRecordTraverseSpec" $ do 37 | it "should sequence" $ do 38 | sequence (liftValue <$> testRecord) `shouldBe` Just testRecord 39 | sequenceA (liftValue <$> testRecord) `shouldBe` Just testRecord 40 | sequence (liftNothing <$> testRecord) `shouldBe` Nothing 41 | 42 | it "should traverse" $ do 43 | traverse liftValue testRecord `shouldBe` Just testRecord 44 | traverse liftNothing testRecord `shouldBe` Nothing 45 | 46 | it "should bisequence" $ do 47 | bisequence (bimap liftValue liftValue testRecord) `shouldBe` Just testRecord 48 | bisequence (bimap liftNothing liftValue testRecord) `shouldBe` Nothing 49 | bisequence (bimap liftValue liftNothing testRecord) `shouldBe` Nothing 50 | bisequenceA (bimap liftValue liftValue testRecord) `shouldBe` Just testRecord 51 | bisequenceA (bimap liftNothing liftValue testRecord) `shouldBe` Nothing 52 | bisequenceA (bimap liftValue liftNothing testRecord) `shouldBe` Nothing 53 | 54 | it "should bitraverse" $ do 55 | bitraverse liftValue liftValue testRecord `shouldBe` Just testRecord 56 | bitraverse liftNothing liftValue testRecord `shouldBe` Nothing 57 | bitraverse liftValue liftNothing testRecord `shouldBe` Nothing 58 | 59 | -------------------------------------------------------------------------------- /src/Kafka/Callbacks.hs: -------------------------------------------------------------------------------- 1 | module Kafka.Callbacks 2 | ( errorCallback 3 | , logCallback 4 | , statsCallback 5 | , Callback 6 | ) 7 | where 8 | 9 | import Data.ByteString (ByteString) 10 | import Kafka.Internal.RdKafka (rdKafkaConfSetErrorCb, rdKafkaConfSetLogCb, rdKafkaConfSetStatsCb) 11 | import Kafka.Internal.Setup (getRdKafkaConf, Callback(..)) 12 | import Kafka.Types (KafkaError(..), KafkaLogLevel(..)) 13 | 14 | -- | Add a callback for errors. 15 | -- 16 | -- ==== __Examples__ 17 | -- 18 | -- Basic usage: 19 | -- 20 | -- > 'setCallback' ('errorCallback' myErrorCallback) 21 | -- > 22 | -- > myErrorCallback :: 'KafkaError' -> String -> IO () 23 | -- > myErrorCallback kafkaError message = print $ show kafkaError <> "|" <> message 24 | errorCallback :: (KafkaError -> String -> IO ()) -> Callback 25 | errorCallback callback = 26 | let realCb _ err = callback (KafkaResponseError err) 27 | in Callback $ \k -> rdKafkaConfSetErrorCb (getRdKafkaConf k) realCb 28 | 29 | -- | Add a callback for logs. 30 | -- 31 | -- ==== __Examples__ 32 | -- 33 | -- Basic usage: 34 | -- 35 | -- > 'setCallback' ('logCallback' myLogCallback) 36 | -- > 37 | -- > myLogCallback :: 'KafkaLogLevel' -> String -> String -> IO () 38 | -- > myLogCallback level facility message = print $ show level <> "|" <> facility <> "|" <> message 39 | logCallback :: (KafkaLogLevel -> String -> String -> IO ()) -> Callback 40 | logCallback callback = 41 | let realCb _ = callback . toEnum 42 | in Callback $ \k -> rdKafkaConfSetLogCb (getRdKafkaConf k) realCb 43 | 44 | -- | Add a callback for stats. The passed ByteString contains an UTF-8 encoded JSON document and can e.g. be parsed using Data.Aeson.decodeStrict. For more information about the content of the JSON document see . 45 | -- 46 | -- ==== __Examples__ 47 | -- 48 | -- Basic usage: 49 | -- 50 | -- > 'setCallback' ('statsCallback' myStatsCallback) 51 | -- > 52 | -- > myStatsCallback :: String -> IO () 53 | -- > myStatsCallback stats = print $ show stats 54 | statsCallback :: (ByteString -> IO ()) -> Callback 55 | statsCallback callback = 56 | let realCb _ = callback 57 | in Callback $ \k -> rdKafkaConfSetStatsCb (getRdKafkaConf k) realCb 58 | -------------------------------------------------------------------------------- /.vscode/tasks.json: -------------------------------------------------------------------------------- 1 | { 2 | "version": "2.0.0", 3 | "tasks": [ 4 | { 5 | "label": "Build", 6 | "type": "shell", 7 | "command": "bash", 8 | "args": ["-lc", "cabal new-build && echo 'Done'"], 9 | "group": { 10 | "kind": "build", 11 | "isDefault": true 12 | }, 13 | "problemMatcher": { 14 | "owner": "haskell", 15 | "fileLocation": "relative", 16 | "pattern": [ 17 | { 18 | "regexp": "^(.+?):(\\d+):(\\d+):\\s+(error|warning|info):.*$", 19 | "file": 1, "line": 2, "column": 3, "severity": 4 20 | }, 21 | { 22 | "regexp": "\\s*(.*)$", 23 | "message": 1 24 | } 25 | ] 26 | }, 27 | "presentation": { 28 | "echo": false, 29 | "reveal": "always", 30 | "focus": false, 31 | "panel": "shared", 32 | "showReuseMessage": false, 33 | "clear": true 34 | } 35 | }, 36 | { 37 | "label": "Test", 38 | "type": "shell", 39 | "command": "bash", 40 | "args": ["-lc", "cabal new-test && echo 'Done'"], 41 | "group": { 42 | "kind": "test", 43 | "isDefault": true 44 | }, 45 | "problemMatcher": { 46 | "owner": "haskell", 47 | "fileLocation": "relative", 48 | "pattern": [ 49 | { 50 | "regexp": "^(.+?):(\\d+):(\\d+):.*$", 51 | "file": 1, "line": 2, "column": 3, "severity": 4 52 | }, 53 | { 54 | "regexp": "\\s*(\\d\\)\\s)?(.*)$", 55 | "message": 2 56 | } 57 | ] 58 | }, 59 | "presentation": { 60 | "echo": false, 61 | "reveal": "always", 62 | "focus": false, 63 | "panel": "shared", 64 | "showReuseMessage": false, 65 | "clear": true 66 | } 67 | } 68 | ] 69 | } 70 | -------------------------------------------------------------------------------- /src/Kafka/Consumer/Subscription.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | ----------------------------------------------------------------------------- 4 | -- | 5 | -- Module with subscription types and functions. 6 | ----------------------------------------------------------------------------- 7 | module Kafka.Consumer.Subscription 8 | ( Subscription(..) 9 | , topics 10 | , offsetReset 11 | , extraSubscriptionProps 12 | ) 13 | where 14 | 15 | import Data.Map (Map) 16 | import qualified Data.Map as M 17 | import Data.Semigroup as Sem 18 | import Data.Set (Set) 19 | import qualified Data.Set as Set 20 | import Data.Text (Text) 21 | import Kafka.Consumer.Types (OffsetReset (..)) 22 | import Kafka.Types (TopicName (..)) 23 | 24 | -- | A consumer subscription to a topic. 25 | -- 26 | -- ==== __Examples__ 27 | -- 28 | -- Typically you don't call the constructor directly, but combine settings: 29 | -- 30 | -- @ 31 | -- consumerSub :: 'Subscription' 32 | -- consumerSub = 'topics' ['TopicName' "kafka-client-example-topic"] 33 | -- <> 'offsetReset' 'Earliest' 34 | -- <> 'extraSubscriptionProps' (fromList [("prop1", "value 1"), ("prop2", "value 2")]) 35 | -- @ 36 | data Subscription = Subscription (Set TopicName) (Map Text Text) 37 | 38 | instance Sem.Semigroup Subscription where 39 | (Subscription ts1 m1) <> (Subscription ts2 m2) = 40 | let ts' = Set.union ts1 ts2 41 | ps' = M.union m1 m2 42 | in Subscription ts' ps' 43 | {-# INLINE (<>) #-} 44 | 45 | instance Monoid Subscription where 46 | mempty = Subscription Set.empty M.empty 47 | {-# INLINE mempty #-} 48 | mappend = (Sem.<>) 49 | {-# INLINE mappend #-} 50 | 51 | -- | Build a subscription by giving the list of topic names only 52 | topics :: [TopicName] -> Subscription 53 | topics ts = Subscription (Set.fromList ts) M.empty 54 | 55 | -- | Build a subscription by giving the offset reset parameter only 56 | offsetReset :: OffsetReset -> Subscription 57 | offsetReset o = 58 | let o' = case o of 59 | Earliest -> "earliest" 60 | Latest -> "latest" 61 | in Subscription Set.empty (M.fromList [("auto.offset.reset", o')]) 62 | 63 | -- | Build a subscription by giving extra properties only 64 | extraSubscriptionProps :: Map Text Text -> Subscription 65 | extraSubscriptionProps = Subscription Set.empty 66 | -------------------------------------------------------------------------------- /example/ConsumerExample.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | {-# LANGUAGE ScopedTypeVariables #-} 3 | module ConsumerExample 4 | 5 | where 6 | 7 | import Control.Arrow ((&&&)) 8 | import Control.Exception (bracket) 9 | import Kafka.Consumer 10 | import Data.Text (Text) 11 | 12 | -- Global consumer properties 13 | consumerProps :: ConsumerProperties 14 | consumerProps = brokersList ["localhost:9092"] 15 | <> groupId "consumer_example_group" 16 | <> noAutoCommit 17 | <> setCallback (rebalanceCallback printingRebalanceCallback) 18 | <> setCallback (offsetCommitCallback printingOffsetCallback) 19 | <> logLevel KafkaLogInfo 20 | 21 | -- Subscription to topics 22 | consumerSub :: Subscription 23 | consumerSub = topics ["kafka-client-example-topic"] 24 | <> offsetReset Earliest 25 | 26 | -- Running an example 27 | runConsumerExample :: IO () 28 | runConsumerExample = do 29 | print $ cpLogLevel consumerProps 30 | res <- bracket mkConsumer clConsumer runHandler 31 | print res 32 | where 33 | mkConsumer = newConsumer consumerProps consumerSub 34 | clConsumer (Left err) = return (Left err) 35 | clConsumer (Right kc) = maybe (Right ()) Left <$> closeConsumer kc 36 | runHandler (Left err) = return (Left err) 37 | runHandler (Right kc) = processMessages kc 38 | 39 | ------------------------------------------------------------------- 40 | processMessages :: KafkaConsumer -> IO (Either KafkaError ()) 41 | processMessages kafka = do 42 | mapM_ (\_ -> do 43 | msg1 <- pollMessage kafka (Timeout 1000) 44 | putStrLn $ "Message: " <> show msg1 45 | err <- commitAllOffsets OffsetCommit kafka 46 | putStrLn $ "Offsets: " <> maybe "Committed." show err 47 | ) [0 :: Integer .. 10] 48 | return $ Right () 49 | 50 | printingRebalanceCallback :: KafkaConsumer -> RebalanceEvent -> IO () 51 | printingRebalanceCallback _ e = case e of 52 | RebalanceBeforeAssign ps -> 53 | putStrLn $ "[Rebalance] About to assign partitions: " <> show ps 54 | RebalanceAssign ps -> 55 | putStrLn $ "[Rebalance] Assign partitions: " <> show ps 56 | RebalanceBeforeRevoke ps -> 57 | putStrLn $ "[Rebalance] About to revoke partitions: " <> show ps 58 | RebalanceRevoke ps -> 59 | putStrLn $ "[Rebalance] Revoke partitions: " <> show ps 60 | 61 | printingOffsetCallback :: KafkaConsumer -> KafkaError -> [TopicPartition] -> IO () 62 | printingOffsetCallback _ e ps = do 63 | print ("Offsets callback:" ++ show e) 64 | mapM_ (print . (tpTopicName &&& tpPartition &&& tpOffset)) ps 65 | -------------------------------------------------------------------------------- /src/Kafka/Dump.hs: -------------------------------------------------------------------------------- 1 | ----------------------------------------------------------------------------- 2 | -- | 3 | -- Module providing various functions to dump information. These may be useful for 4 | -- debug/investigation but should probably not be used on production applications. 5 | ----------------------------------------------------------------------------- 6 | module Kafka.Dump 7 | ( hPrintSupportedKafkaConf 8 | , hPrintKafka 9 | , dumpKafkaConf 10 | , dumpTopicConf 11 | ) 12 | where 13 | 14 | import Kafka.Internal.RdKafka 15 | ( CSizePtr 16 | , rdKafkaConfDumpFree 17 | , peekCText 18 | , rdKafkaConfDump 19 | , rdKafkaTopicConfDump 20 | , rdKafkaDump 21 | , handleToCFile 22 | , rdKafkaConfPropertiesShow 23 | ) 24 | import Kafka.Internal.Setup 25 | ( HasKafka(..) 26 | , HasTopicConf(..) 27 | , HasKafkaConf(..) 28 | , getRdKafka 29 | , getRdTopicConf 30 | , getRdKafkaConf 31 | ) 32 | 33 | import Control.Monad ((<=<)) 34 | import Control.Monad.IO.Class (MonadIO(liftIO)) 35 | import Data.Map.Strict (Map) 36 | import qualified Data.Map.Strict as Map 37 | import Foreign (Ptr, alloca, Storable(peek, peekElemOff)) 38 | import Foreign.C.String (CString) 39 | import System.IO (Handle) 40 | import Data.Text (Text) 41 | 42 | -- | Prints out all supported Kafka conf properties to a handle 43 | hPrintSupportedKafkaConf :: MonadIO m => Handle -> m () 44 | hPrintSupportedKafkaConf h = liftIO $ handleToCFile h "w" >>= rdKafkaConfPropertiesShow 45 | 46 | -- | Prints out all data associated with a specific kafka object to a handle 47 | hPrintKafka :: (MonadIO m, HasKafka k) => Handle -> k -> m () 48 | hPrintKafka h k = liftIO $ handleToCFile h "w" >>= \f -> rdKafkaDump f (getRdKafka k) 49 | 50 | -- | Returns a map of the current topic configuration 51 | dumpTopicConf :: (MonadIO m, HasTopicConf t) => t -> m (Map Text Text) 52 | dumpTopicConf t = liftIO $ parseDump (rdKafkaTopicConfDump (getRdTopicConf t)) 53 | 54 | -- | Returns a map of the current kafka configuration 55 | dumpKafkaConf :: (MonadIO m, HasKafkaConf k) => k -> m (Map Text Text) 56 | dumpKafkaConf k = liftIO $ parseDump (rdKafkaConfDump (getRdKafkaConf k)) 57 | 58 | parseDump :: (CSizePtr -> IO (Ptr CString)) -> IO (Map Text Text) 59 | parseDump cstr = alloca $ \sizeptr -> do 60 | strPtr <- cstr sizeptr 61 | size <- peek sizeptr 62 | 63 | keysAndValues <- mapM (peekCText <=< peekElemOff strPtr) [0..(fromIntegral size - 1)] 64 | 65 | let ret = Map.fromList $ listToTuple keysAndValues 66 | rdKafkaConfDumpFree strPtr size 67 | return ret 68 | 69 | listToTuple :: [Text] -> [(Text, Text)] 70 | listToTuple [] = [] 71 | listToTuple (k:v:ts) = (k, v) : listToTuple ts 72 | listToTuple _ = error "list to tuple can only be called on even length lists" 73 | -------------------------------------------------------------------------------- /src/Kafka/Producer/Types.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveDataTypeable #-} 2 | {-# LANGUAGE DeriveGeneric #-} 3 | {-# LANGUAGE DerivingStrategies #-} 4 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 5 | 6 | ----------------------------------------------------------------------------- 7 | -- | 8 | -- Module holding producer types. 9 | ----------------------------------------------------------------------------- 10 | module Kafka.Producer.Types 11 | ( KafkaProducer(..) 12 | , ProducerRecord(..) 13 | , ProducePartition(..) 14 | , DeliveryReport(..) 15 | , ImmediateError(..) 16 | ) 17 | where 18 | 19 | import Data.ByteString 20 | import Data.Typeable (Typeable) 21 | import GHC.Generics (Generic) 22 | import Kafka.Consumer.Types (Offset (..)) 23 | import Kafka.Internal.Setup (HasKafka (..), HasKafkaConf (..), HasTopicConf (..), Kafka (..), KafkaConf (..), TopicConf (..)) 24 | import Kafka.Types (KafkaError (..), TopicName (..), Headers) 25 | 26 | -- | The main type for Kafka message production, used e.g. to send messages. 27 | -- 28 | -- Its constructor is intentionally not exposed, instead, one should used 'Kafka.Producer.newProducer' to acquire such a value. 29 | data KafkaProducer = KafkaProducer 30 | { kpKafkaPtr :: !Kafka 31 | , kpKafkaConf :: !KafkaConf 32 | , kpTopicConf :: !TopicConf 33 | } 34 | 35 | instance HasKafka KafkaProducer where 36 | getKafka = kpKafkaPtr 37 | {-# INLINE getKafka #-} 38 | 39 | instance HasKafkaConf KafkaProducer where 40 | getKafkaConf = kpKafkaConf 41 | {-# INLINE getKafkaConf #-} 42 | 43 | instance HasTopicConf KafkaProducer where 44 | getTopicConf = kpTopicConf 45 | {-# INLINE getTopicConf #-} 46 | 47 | -- | Represents messages /to be enqueued/ onto a Kafka broker (i.e. used for a producer) 48 | data ProducerRecord = ProducerRecord 49 | { prTopic :: !TopicName 50 | , prPartition :: !ProducePartition 51 | , prKey :: Maybe ByteString 52 | , prValue :: Maybe ByteString 53 | , prHeaders :: !Headers 54 | } deriving (Eq, Show, Typeable, Generic) 55 | 56 | -- | 57 | data ProducePartition = 58 | -- | The partition number of the topic 59 | SpecifiedPartition {-# UNPACK #-} !Int 60 | -- | Let the Kafka broker decide the partition 61 | | UnassignedPartition 62 | deriving (Show, Eq, Ord, Typeable, Generic) 63 | 64 | -- | Data type representing an error that is caused by pre-flight conditions not being met 65 | newtype ImmediateError = ImmediateError KafkaError 66 | deriving newtype (Eq, Show) 67 | 68 | -- | The result of sending a message to the broker, useful for callbacks 69 | data DeliveryReport 70 | -- | The message was successfully sent at this offset 71 | = DeliverySuccess ProducerRecord Offset 72 | -- | The message could not be sent 73 | | DeliveryFailure ProducerRecord KafkaError 74 | -- | An error occurred, but /librdkafka/ did not attach any sent message 75 | | NoMessageError KafkaError 76 | deriving (Show, Eq, Generic) 77 | -------------------------------------------------------------------------------- /src/Kafka/Producer/Callbacks.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TypeApplications #-} 2 | {-# LANGUAGE LambdaCase #-} 3 | module Kafka.Producer.Callbacks 4 | ( deliveryCallback 5 | , module X 6 | ) 7 | where 8 | 9 | import Control.Monad (void) 10 | import Control.Exception (bracket) 11 | import Control.Concurrent (forkIO) 12 | import Foreign.C.Error (getErrno) 13 | import Foreign.Ptr (Ptr, nullPtr) 14 | import Foreign.Storable (Storable(peek)) 15 | import Foreign.StablePtr (castPtrToStablePtr, deRefStablePtr, freeStablePtr) 16 | import Kafka.Callbacks as X 17 | import Kafka.Consumer.Types (Offset(..)) 18 | import Kafka.Internal.RdKafka (RdKafkaMessageT(..), RdKafkaRespErrT(..), rdKafkaConfSetDrMsgCb) 19 | import Kafka.Internal.Setup (getRdKafkaConf, Callback(..)) 20 | import Kafka.Internal.Shared (kafkaRespErr, readTopic, readKey, readPayload, readHeaders) 21 | import Kafka.Producer.Types (ProducerRecord(..), DeliveryReport(..), ProducePartition(..)) 22 | import Kafka.Types (KafkaError(..), TopicName(..)) 23 | import Data.Either (fromRight) 24 | 25 | -- | Sets the callback for delivery reports. 26 | -- 27 | -- /Note: A callback should not be a long-running process as it blocks 28 | -- librdkafka from continuing on the thread that handles the delivery 29 | -- callbacks. For callbacks to individual messsages see 30 | -- 'Kafka.Producer.produceMessage\''./ 31 | -- 32 | deliveryCallback :: (DeliveryReport -> IO ()) -> Callback 33 | deliveryCallback callback = Callback $ \kc -> rdKafkaConfSetDrMsgCb (getRdKafkaConf kc) realCb 34 | where 35 | realCb :: t -> Ptr RdKafkaMessageT -> IO () 36 | realCb _ mptr = 37 | if mptr == nullPtr 38 | then getErrno >>= (callback . NoMessageError . kafkaRespErr) 39 | else do 40 | s <- peek mptr 41 | prodRec <- mkProdRec mptr 42 | let cbPtr = opaque'RdKafkaMessageT s 43 | callbacks cbPtr $ 44 | if err'RdKafkaMessageT s /= RdKafkaRespErrNoError 45 | then mkErrorReport s prodRec 46 | else mkSuccessReport s prodRec 47 | 48 | callbacks cbPtr rep = do 49 | callback rep 50 | if cbPtr == nullPtr then 51 | pure () 52 | else bracket (pure $ castPtrToStablePtr cbPtr) freeStablePtr $ \stablePtr -> do 53 | msgCb <- deRefStablePtr @(DeliveryReport -> IO ()) stablePtr 54 | -- Here we fork the callback since it might be a longer action and 55 | -- blocking here would block librdkafka from continuing its execution 56 | void . forkIO $ msgCb rep 57 | 58 | mkErrorReport :: RdKafkaMessageT -> ProducerRecord -> DeliveryReport 59 | mkErrorReport msg prodRec = DeliveryFailure prodRec (KafkaResponseError (err'RdKafkaMessageT msg)) 60 | 61 | mkSuccessReport :: RdKafkaMessageT -> ProducerRecord -> DeliveryReport 62 | mkSuccessReport msg prodRec = DeliverySuccess prodRec (Offset $ offset'RdKafkaMessageT msg) 63 | 64 | mkProdRec :: Ptr RdKafkaMessageT -> IO ProducerRecord 65 | mkProdRec pmsg = do 66 | msg <- peek pmsg 67 | topic <- readTopic msg 68 | key <- readKey msg 69 | payload <- readPayload msg 70 | flip fmap (fromRight mempty <$> readHeaders pmsg) $ \headers -> 71 | ProducerRecord 72 | { prTopic = TopicName topic 73 | , prPartition = SpecifiedPartition (partition'RdKafkaMessageT msg) 74 | , prKey = key 75 | , prValue = payload 76 | , prHeaders = headers 77 | } 78 | -------------------------------------------------------------------------------- /example/ProducerExample.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | {-# LANGUAGE LambdaCase #-} 3 | 4 | module ProducerExample 5 | where 6 | 7 | import Control.Concurrent.MVar (newEmptyMVar, putMVar, takeMVar) 8 | import Control.Exception (bracket) 9 | import Control.Monad (forM_) 10 | import Control.Monad.IO.Class (MonadIO(..)) 11 | import Data.ByteString (ByteString) 12 | import Data.ByteString.Char8 (pack) 13 | import Kafka.Consumer (Offset) 14 | import Kafka.Producer 15 | import Data.Text (Text) 16 | 17 | -- Global producer properties 18 | producerProps :: ProducerProperties 19 | producerProps = brokersList ["localhost:9092"] 20 | <> sendTimeout (Timeout 10000) 21 | <> setCallback (deliveryCallback print) 22 | <> logLevel KafkaLogDebug 23 | 24 | -- Topic to send messages to 25 | targetTopic :: TopicName 26 | targetTopic = "kafka-client-example-topic" 27 | 28 | mkMessage :: Maybe ByteString -> Maybe ByteString -> ProducerRecord 29 | mkMessage k v = ProducerRecord 30 | { prTopic = targetTopic 31 | , prPartition = UnassignedPartition 32 | , prKey = k 33 | , prValue = v 34 | , prHeaders = mempty 35 | } 36 | 37 | -- Run an example 38 | runProducerExample :: IO () 39 | runProducerExample = 40 | bracket mkProducer clProducer runHandler >>= print 41 | where 42 | mkProducer = newProducer producerProps 43 | clProducer (Left _) = return () 44 | clProducer (Right prod) = closeProducer prod 45 | runHandler (Left err) = return $ Left err 46 | runHandler (Right prod) = sendMessages prod 47 | 48 | sendMessages :: KafkaProducer -> IO (Either KafkaError ()) 49 | sendMessages prod = do 50 | putStrLn "Producer is ready, send your messages!" 51 | msg1 <- getLine 52 | 53 | err1 <- produceMessage prod (mkMessage (Just "zero") (Just $ pack msg1)) 54 | forM_ err1 print 55 | 56 | putStrLn "One more time!" 57 | msg2 <- getLine 58 | 59 | err2 <- produceMessage prod (mkMessage (Just "key") (Just $ pack msg2)) 60 | forM_ err2 print 61 | 62 | putStrLn "And the last one..." 63 | msg3 <- getLine 64 | err3 <- produceMessage prod (mkMessage (Just "key3") (Just $ pack msg3)) 65 | 66 | err4 <- produceMessage prod ((mkMessage (Just "key4") (Just $ pack msg3)) { prHeaders = headersFromList [("fancy", "header")]}) 67 | 68 | -- forM_ errs (print . snd) 69 | 70 | putStrLn "Thank you." 71 | return $ Right () 72 | 73 | -- | An example for sending messages synchronously using the 'produceMessage'' 74 | -- function 75 | -- 76 | sendMessageSync :: MonadIO m 77 | => KafkaProducer 78 | -> ProducerRecord 79 | -> m (Either KafkaError Offset) 80 | sendMessageSync producer record = liftIO $ do 81 | -- Create an empty MVar: 82 | var <- newEmptyMVar 83 | 84 | -- Produce the message and use the callback to put the delivery report in the 85 | -- MVar: 86 | res <- produceMessage' producer record (putMVar var) 87 | 88 | case res of 89 | Left (ImmediateError err) -> 90 | pure (Left err) 91 | Right () -> do 92 | -- Flush producer queue to make sure you don't get stuck waiting for the 93 | -- message to send: 94 | flushProducer producer 95 | 96 | -- Wait for the message's delivery report and map accordingly: 97 | takeMVar var >>= return . \case 98 | DeliverySuccess _ offset -> Right offset 99 | DeliveryFailure _ err -> Left err 100 | NoMessageError err -> Left err 101 | -------------------------------------------------------------------------------- /tests-it/Kafka/TestEnv.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | {-# LANGUAGE ScopedTypeVariables #-} 3 | 4 | module Kafka.TestEnv where 5 | 6 | import Control.Exception 7 | import Control.Monad (void) 8 | import Data.Monoid ((<>)) 9 | import qualified Data.Text as Text 10 | import System.Environment 11 | import System.IO.Unsafe 12 | 13 | import qualified System.Random as Rnd 14 | 15 | import Control.Concurrent 16 | import Kafka.Consumer as C 17 | import Kafka.Producer as P 18 | 19 | import Test.Hspec 20 | 21 | testPrefix :: String 22 | testPrefix = unsafePerformIO $ take 10 . Rnd.randomRs ('a','z') <$> Rnd.newStdGen 23 | {-# NOINLINE testPrefix #-} 24 | 25 | brokerAddress :: BrokerAddress 26 | brokerAddress = unsafePerformIO $ 27 | BrokerAddress . Text.pack <$> getEnv "KAFKA_TEST_BROKER" `catch` \(_ :: SomeException) -> return "localhost:9092" 28 | {-# NOINLINE brokerAddress #-} 29 | 30 | testTopic :: TopicName 31 | testTopic = unsafePerformIO $ 32 | TopicName . Text.pack <$> getEnv "KAFKA_TEST_TOPIC" `catch` \(_ :: SomeException) -> return $ testPrefix <> "-topic" 33 | {-# NOINLINE testTopic #-} 34 | 35 | testGroupId :: ConsumerGroupId 36 | testGroupId = ConsumerGroupId (Text.pack testPrefix) 37 | 38 | makeGroupId :: String -> ConsumerGroupId 39 | makeGroupId suffix = 40 | ConsumerGroupId . Text.pack $ testPrefix <> "-" <> suffix 41 | 42 | isTestGroupId :: ConsumerGroupId -> Bool 43 | isTestGroupId (ConsumerGroupId group) = Text.pack testPrefix `Text.isPrefixOf` group 44 | 45 | consumerProps :: ConsumerProperties 46 | consumerProps = C.brokersList [brokerAddress] 47 | <> groupId testGroupId 48 | <> C.setCallback (logCallback (\l s1 s2 -> print $ "[Consumer] " <> show l <> ": " <> s1 <> ", " <> s2)) 49 | <> C.setCallback (errorCallback (\e r -> print $ "[Consumer] " <> show e <> ": " <> r)) 50 | <> noAutoCommit 51 | 52 | consumerPropsNoStore :: ConsumerProperties 53 | consumerPropsNoStore = consumerProps <> noAutoOffsetStore 54 | 55 | producerProps :: ProducerProperties 56 | producerProps = P.brokersList [brokerAddress] 57 | <> P.setCallback (logCallback (\l s1 s2 -> print $ "[Producer] " <> show l <> ": " <> s1 <> ", " <> s2)) 58 | <> P.setCallback (errorCallback (\e r -> print $ "[Producer] " <> show e <> ": " <> r)) 59 | 60 | testSubscription :: TopicName -> Subscription 61 | testSubscription t = topics [t] 62 | <> offsetReset Earliest 63 | 64 | mkProducer :: IO KafkaProducer 65 | mkProducer = newProducer producerProps >>= \(Right p) -> pure p 66 | 67 | mkConsumerWith :: ConsumerProperties -> IO KafkaConsumer 68 | mkConsumerWith props = do 69 | waitVar <- newEmptyMVar 70 | let props' = props <> C.setCallback (rebalanceCallback (\_ -> rebCallback waitVar)) 71 | (Right c) <- newConsumer props' (testSubscription testTopic) 72 | _ <- readMVar waitVar 73 | return c 74 | where 75 | rebCallback var evt = case evt of 76 | (RebalanceAssign _) -> putMVar var True 77 | _ -> pure () 78 | 79 | specWithConsumer :: String -> ConsumerProperties -> SpecWith KafkaConsumer -> Spec 80 | specWithConsumer s p f = 81 | beforeAll (mkConsumerWith p) 82 | $ afterAll (void . closeConsumer) 83 | $ describe s f 84 | 85 | specWithProducer :: String -> SpecWith KafkaProducer -> Spec 86 | specWithProducer s f = beforeAll mkProducer $ afterAll (void . closeProducer) $ describe s f 87 | 88 | specWithKafka :: String -> ConsumerProperties -> SpecWith (KafkaConsumer, KafkaProducer) -> Spec 89 | specWithKafka s p f = 90 | beforeAll ((,) <$> mkConsumerWith p <*> mkProducer) 91 | $ afterAll (\(consumer, producer) -> void $ closeProducer producer >> closeConsumer consumer) 92 | $ describe s f 93 | -------------------------------------------------------------------------------- /src/Kafka/Consumer/Callbacks.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE BangPatterns #-} 2 | module Kafka.Consumer.Callbacks 3 | ( rebalanceCallback 4 | , offsetCommitCallback 5 | , module X 6 | ) 7 | where 8 | 9 | import Control.Arrow ((&&&)) 10 | import Control.Monad (forM_, void) 11 | import Foreign.ForeignPtr (newForeignPtr_) 12 | import Foreign.Ptr (nullPtr) 13 | import Kafka.Callbacks as X 14 | import Kafka.Consumer.Convert (fromNativeTopicPartitionList', fromNativeTopicPartitionList'') 15 | import Kafka.Consumer.Types (KafkaConsumer (..), RebalanceEvent (..), TopicPartition (..)) 16 | import Kafka.Internal.RdKafka 17 | import Kafka.Internal.Setup (HasKafka (..), HasKafkaConf (..), Kafka (..), KafkaConf (..), getRdMsgQueue, Callback (..)) 18 | import Kafka.Types (KafkaError (..), PartitionId (..), TopicName (..)) 19 | 20 | import qualified Data.Text as Text 21 | 22 | -- | Sets a callback that is called when rebalance is needed. 23 | rebalanceCallback :: (KafkaConsumer -> RebalanceEvent -> IO ()) -> Callback 24 | rebalanceCallback callback = 25 | Callback $ \kc@(KafkaConf con _ _) -> rdKafkaConfSetRebalanceCb con (realCb kc) 26 | where 27 | realCb kc k err pl = do 28 | k' <- newForeignPtr_ k 29 | pls <- newForeignPtr_ pl 30 | setRebalanceCallback callback (KafkaConsumer (Kafka k') kc) (KafkaResponseError err) pls 31 | 32 | -- | Sets a callback that is called when rebalance is needed. 33 | -- 34 | -- The results of automatic or manual offset commits will be scheduled 35 | -- for this callback and is served by 'Kafka.Consumer.pollMessage'. 36 | -- 37 | -- If no partitions had valid offsets to commit this callback will be called 38 | -- with 'KafkaResponseError' 'RdKafkaRespErrNoOffset' which is not to be considered 39 | -- an error. 40 | offsetCommitCallback :: (KafkaConsumer -> KafkaError -> [TopicPartition] -> IO ()) -> Callback 41 | offsetCommitCallback callback = 42 | Callback $ \kc@(KafkaConf conf _ _) -> rdKafkaConfSetOffsetCommitCb conf (realCb kc) 43 | where 44 | realCb kc k err pl = do 45 | k' <- newForeignPtr_ k 46 | pls <- fromNativeTopicPartitionList' pl 47 | callback (KafkaConsumer (Kafka k') kc) (KafkaResponseError err) pls 48 | 49 | ------------------------------------------------------------------------------- 50 | redirectPartitionQueue :: Kafka -> TopicName -> PartitionId -> RdKafkaQueueTPtr -> IO () 51 | redirectPartitionQueue (Kafka k) (TopicName t) (PartitionId p) q = do 52 | mpq <- rdKafkaQueueGetPartition k (Text.unpack t) p 53 | case mpq of 54 | Nothing -> return () 55 | Just pq -> rdKafkaQueueForward pq q 56 | 57 | setRebalanceCallback :: (KafkaConsumer -> RebalanceEvent -> IO ()) 58 | -> KafkaConsumer 59 | -> KafkaError 60 | -> RdKafkaTopicPartitionListTPtr -> IO () 61 | setRebalanceCallback f k e pls = do 62 | ps <- fromNativeTopicPartitionList'' pls 63 | let assignment = (tpTopicName &&& tpPartition) <$> ps 64 | let (Kafka kptr) = getKafka k 65 | 66 | case e of 67 | KafkaResponseError RdKafkaRespErrAssignPartitions -> do 68 | f k (RebalanceBeforeAssign assignment) 69 | protocol <- rdKafkaRebalanceProtocol kptr 70 | if protocol == "COOPERATIVE" 71 | then void $ rdKafkaIncrementalAssign kptr pls 72 | else void $ rdKafkaAssign kptr pls 73 | 74 | mbq <- getRdMsgQueue $ getKafkaConf k 75 | case mbq of 76 | Nothing -> pure () 77 | Just mq -> do 78 | {- Magnus Edenhill: 79 | If you redirect after assign() it means some messages may be forwarded to the single consumer queue, 80 | so either do it before assign() or do: assign(); pause(); redirect; resume() 81 | -} 82 | void $ rdKafkaPausePartitions kptr pls 83 | forM_ ps (\tp -> redirectPartitionQueue (getKafka k) (tpTopicName tp) (tpPartition tp) mq) 84 | void $ rdKafkaResumePartitions kptr pls 85 | 86 | f k (RebalanceAssign assignment) 87 | 88 | KafkaResponseError RdKafkaRespErrRevokePartitions -> do 89 | f k (RebalanceBeforeRevoke assignment) 90 | protocol <- rdKafkaRebalanceProtocol kptr 91 | if protocol == "COOPERATIVE" 92 | then void $ rdKafkaIncrementalUnassign kptr pls 93 | else void $ newForeignPtr_ nullPtr >>= rdKafkaAssign kptr 94 | f k (RebalanceRevoke assignment) 95 | x -> error $ "Rebalance: UNKNOWN response: " <> show x 96 | -------------------------------------------------------------------------------- /hw-kafka-client.cabal: -------------------------------------------------------------------------------- 1 | cabal-version: 2.2 2 | 3 | name: hw-kafka-client 4 | version: 5.3.0 5 | synopsis: Kafka bindings for Haskell 6 | description: Apache Kafka bindings backed by the librdkafka C library. 7 | . 8 | Features include: 9 | . 10 | * Consumer groups: auto-rebalancing consumers 11 | . 12 | * Keyed and keyless messages producing/consuming 13 | . 14 | * Batch producing messages 15 | category: Database 16 | homepage: https://github.com/haskell-works/hw-kafka-client 17 | bug-reports: https://github.com/haskell-works/hw-kafka-client/issues 18 | author: Alexey Raga 19 | maintainer: Alexey Raga 20 | license: MIT 21 | license-file: LICENSE 22 | tested-with: GHC == 8.10.2, GHC == 8.8.3, GHC == 8.6.5, GHC == 8.4.4, GHC == 9.10.1 23 | build-type: Simple 24 | extra-source-files: README.md 25 | 26 | source-repository head 27 | type: git 28 | location: https://github.com/haskell-works/hw-kafka-client.git 29 | 30 | flag examples 31 | description: Also compile examples 32 | manual: True 33 | default: False 34 | 35 | flag it 36 | description: Run integration tests 37 | manual: True 38 | default: False 39 | 40 | library 41 | hs-source-dirs: src 42 | ghc-options: -Wall 43 | -Wcompat 44 | -Wincomplete-record-updates 45 | -Wincomplete-uni-patterns 46 | -Wredundant-constraints 47 | extra-libraries: rdkafka 48 | build-depends: base >=4.6 && <5 49 | , bifunctors 50 | , bytestring 51 | , containers 52 | , text 53 | , transformers 54 | , unix 55 | build-tool-depends: c2hs:c2hs 56 | if impl(ghc <8.0) 57 | build-depends: semigroups 58 | exposed-modules: Kafka.Topic 59 | Kafka.Topic.Types 60 | Kafka.Consumer 61 | Kafka.Consumer.ConsumerProperties 62 | Kafka.Consumer.Subscription 63 | Kafka.Consumer.Types 64 | Kafka.Dump 65 | Kafka.Metadata 66 | Kafka.Producer 67 | Kafka.Producer.ProducerProperties 68 | Kafka.Producer.Types 69 | Kafka.Transaction 70 | Kafka.Types 71 | other-modules: Kafka.Callbacks 72 | Kafka.Consumer.Callbacks 73 | Kafka.Consumer.Convert 74 | Kafka.Internal.RdKafka 75 | Kafka.Internal.Setup 76 | Kafka.Internal.Shared 77 | Kafka.Producer.Callbacks 78 | Kafka.Producer.Convert 79 | default-language: Haskell2010 80 | 81 | executable kafka-client-example 82 | main-is: Main.hs 83 | hs-source-dirs: example 84 | ghc-options: -threaded -rtsopts 85 | build-depends: base >=4.6 && <5 86 | , bytestring 87 | , hw-kafka-client 88 | , text 89 | if !(flag(examples)) 90 | buildable: False 91 | other-modules: 92 | ConsumerExample 93 | ProducerExample 94 | default-language: Haskell2010 95 | 96 | test-suite integration-tests 97 | type: exitcode-stdio-1.0 98 | ghc-options: -threaded -rtsopts -with-rtsopts=-N 99 | main-is: Spec.hs 100 | hs-source-dirs: tests-it 101 | ghc-options: -Wall -threaded 102 | build-depends: base >=4.6 && <5 103 | , bifunctors 104 | , bytestring 105 | , containers 106 | , either 107 | , hspec 108 | , hw-kafka-client 109 | , monad-loops 110 | , random 111 | , text 112 | , transformers 113 | build-tool-depends: hspec-discover:hspec-discover 114 | if !(flag(it)) 115 | buildable: False 116 | other-modules: Kafka.IntegrationSpec 117 | Kafka.TestEnv 118 | default-language: Haskell2010 119 | 120 | test-suite tests 121 | type: exitcode-stdio-1.0 122 | ghc-options: -threaded -rtsopts -with-rtsopts=-N 123 | main-is: Spec.hs 124 | hs-source-dirs: tests 125 | ghc-options: -Wall -threaded 126 | build-depends: base >=4.6 && <5 127 | , bifunctors 128 | , bytestring 129 | , containers 130 | , either 131 | , hspec 132 | , hw-kafka-client 133 | , text 134 | , monad-loops 135 | build-tool-depends: hspec-discover:hspec-discover 136 | other-modules: Kafka.Consumer.ConsumerRecordMapSpec 137 | Kafka.Consumer.ConsumerRecordTraverseSpec 138 | default-language: Haskell2010 139 | -------------------------------------------------------------------------------- /src/Kafka/Internal/Setup.hs: -------------------------------------------------------------------------------- 1 | module Kafka.Internal.Setup 2 | ( KafkaProps(..) 3 | , TopicProps(..) 4 | , Kafka(..) 5 | , KafkaConf(..) 6 | , TopicConf(..) 7 | , HasKafka(..) 8 | , HasKafkaConf(..) 9 | , HasTopicConf(..) 10 | , Callback(..) 11 | , CallbackPollStatus(..) 12 | , getRdKafka 13 | , getRdKafkaConf 14 | , getRdMsgQueue 15 | , getRdTopicConf 16 | , newTopicConf 17 | , newKafkaConf 18 | , kafkaConf 19 | , topicConf 20 | , checkConfSetValue 21 | , setKafkaConfValue 22 | , setAllKafkaConfValues 23 | , setTopicConfValue 24 | , setAllTopicConfValues 25 | ) 26 | where 27 | 28 | import Kafka.Internal.RdKafka (CCharBufPointer, RdKafkaConfResT (..), RdKafkaConfTPtr, RdKafkaQueueTPtr, RdKafkaTPtr, RdKafkaTopicConfTPtr, nErrorBytes, newRdKafkaConfT, newRdKafkaTopicConfT, rdKafkaConfSet, rdKafkaTopicConfSet) 29 | import Kafka.Types (KafkaError (..)) 30 | 31 | import Control.Concurrent.MVar (MVar, newMVar) 32 | import Control.Exception (throw) 33 | import Data.IORef (IORef, newIORef, readIORef) 34 | import Data.Map (Map) 35 | import Data.Text (Text) 36 | import Foreign.C.String (peekCString) 37 | import Foreign.Marshal.Alloc (allocaBytes) 38 | 39 | import qualified Data.Map as Map 40 | import qualified Data.Text as Text 41 | 42 | -- 43 | -- Configuration 44 | -- 45 | newtype KafkaProps = KafkaProps (Map Text Text) deriving (Show, Eq) 46 | newtype TopicProps = TopicProps (Map Text Text) deriving (Show, Eq) 47 | newtype Kafka = Kafka RdKafkaTPtr deriving Show 48 | newtype TopicConf = TopicConf RdKafkaTopicConfTPtr deriving Show 49 | 50 | -- | Callbacks allow retrieving various information like error occurences, statistics 51 | -- and log messages. 52 | -- See `Kafka.Consumer.setCallback` (Consumer) and `Kafka.Producer.setCallback` (Producer) for more details. 53 | newtype Callback = Callback (KafkaConf -> IO ()) 54 | 55 | data CallbackPollStatus = CallbackPollEnabled | CallbackPollDisabled deriving (Show, Eq) 56 | 57 | data KafkaConf = KafkaConf 58 | { kcfgKafkaConfPtr :: RdKafkaConfTPtr 59 | -- ^ A pointer to a native Kafka configuration 60 | 61 | , kcfgMessagesQueue :: IORef (Maybe RdKafkaQueueTPtr) 62 | -- ^ A queue for messages 63 | 64 | , kcfgCallbackPollStatus :: MVar CallbackPollStatus 65 | -- ^ A mutex to prevent handling callbacks from multiple threads 66 | -- which can be dangerous in some cases. 67 | } 68 | 69 | class HasKafka a where 70 | getKafka :: a -> Kafka 71 | 72 | class HasKafkaConf a where 73 | getKafkaConf :: a -> KafkaConf 74 | 75 | class HasTopicConf a where 76 | getTopicConf :: a -> TopicConf 77 | 78 | instance HasKafkaConf KafkaConf where 79 | getKafkaConf = id 80 | {-# INLINE getKafkaConf #-} 81 | 82 | instance HasKafka Kafka where 83 | getKafka = id 84 | {-# INLINE getKafka #-} 85 | 86 | instance HasTopicConf TopicConf where 87 | getTopicConf = id 88 | {-# INLINE getTopicConf #-} 89 | 90 | getRdKafka :: HasKafka k => k -> RdKafkaTPtr 91 | getRdKafka k = let (Kafka k') = getKafka k in k' 92 | {-# INLINE getRdKafka #-} 93 | 94 | getRdKafkaConf :: HasKafkaConf k => k -> RdKafkaConfTPtr 95 | getRdKafkaConf k = let (KafkaConf k' _ _) = getKafkaConf k in k' 96 | {-# INLINE getRdKafkaConf #-} 97 | 98 | getRdMsgQueue :: HasKafkaConf k => k -> IO (Maybe RdKafkaQueueTPtr) 99 | getRdMsgQueue k = 100 | let (KafkaConf _ rq _) = getKafkaConf k 101 | in readIORef rq 102 | 103 | getRdTopicConf :: HasTopicConf t => t -> RdKafkaTopicConfTPtr 104 | getRdTopicConf t = let (TopicConf t') = getTopicConf t in t' 105 | {-# INLINE getRdTopicConf #-} 106 | 107 | newTopicConf :: IO TopicConf 108 | newTopicConf = TopicConf <$> newRdKafkaTopicConfT 109 | 110 | newKafkaConf :: IO KafkaConf 111 | newKafkaConf = KafkaConf <$> newRdKafkaConfT <*> newIORef Nothing <*> newMVar CallbackPollEnabled 112 | 113 | kafkaConf :: KafkaProps -> IO KafkaConf 114 | kafkaConf overrides = do 115 | conf <- newKafkaConf 116 | setAllKafkaConfValues conf overrides 117 | return conf 118 | 119 | topicConf :: TopicProps -> IO TopicConf 120 | topicConf overrides = do 121 | conf <- newTopicConf 122 | setAllTopicConfValues conf overrides 123 | return conf 124 | 125 | checkConfSetValue :: RdKafkaConfResT -> CCharBufPointer -> IO () 126 | checkConfSetValue err charPtr = case err of 127 | RdKafkaConfOk -> return () 128 | RdKafkaConfInvalid -> do 129 | str <- peekCString charPtr 130 | throw $ KafkaInvalidConfigurationValue (Text.pack str) 131 | RdKafkaConfUnknown -> do 132 | str <- peekCString charPtr 133 | throw $ KafkaUnknownConfigurationKey (Text.pack str) 134 | 135 | setKafkaConfValue :: KafkaConf -> Text -> Text -> IO () 136 | setKafkaConfValue (KafkaConf confPtr _ _) key value = 137 | allocaBytes nErrorBytes $ \charPtr -> do 138 | err <- rdKafkaConfSet confPtr (Text.unpack key) (Text.unpack value) charPtr (fromIntegral nErrorBytes) 139 | checkConfSetValue err charPtr 140 | 141 | setAllKafkaConfValues :: KafkaConf -> KafkaProps -> IO () 142 | setAllKafkaConfValues conf (KafkaProps props) = Map.foldMapWithKey (setKafkaConfValue conf) props --forM_ props $ uncurry (setKafkaConfValue conf) 143 | 144 | setTopicConfValue :: TopicConf -> Text -> Text -> IO () 145 | setTopicConfValue (TopicConf confPtr) key value = 146 | allocaBytes nErrorBytes $ \charPtr -> do 147 | err <- rdKafkaTopicConfSet confPtr (Text.unpack key) (Text.unpack value) charPtr (fromIntegral nErrorBytes) 148 | checkConfSetValue err charPtr 149 | 150 | setAllTopicConfValues :: TopicConf -> TopicProps -> IO () 151 | setAllTopicConfValues conf (TopicProps props) = Map.foldMapWithKey (setTopicConfValue conf) props --forM_ props $ uncurry (setTopicConfValue conf) 152 | -------------------------------------------------------------------------------- /src/Kafka/Internal/Shared.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE LambdaCase #-} 2 | 3 | module Kafka.Internal.Shared 4 | ( pollEvents 5 | , word8PtrToBS 6 | , kafkaRespErr 7 | , throwOnError 8 | , hasError 9 | , rdKafkaErrorToEither 10 | , kafkaErrorToEither 11 | , kafkaErrorToMaybe 12 | , maybeToLeft 13 | , readHeaders 14 | , readPayload 15 | , readTopic 16 | , readKey 17 | , readTimestamp 18 | , readBS 19 | ) 20 | where 21 | 22 | import Control.Exception (throw) 23 | import Control.Monad (void) 24 | import qualified Data.ByteString as BS 25 | import qualified Data.ByteString.Internal as BSI 26 | import Data.Text (Text) 27 | import qualified Data.Text as Text 28 | import Data.Word (Word8) 29 | import Foreign.C.Error (Errno (..)) 30 | import Foreign.ForeignPtr (newForeignPtr_) 31 | import Foreign.Marshal.Alloc (alloca) 32 | import Foreign.Ptr (Ptr, nullPtr) 33 | import Foreign.Storable (Storable (peek)) 34 | import Kafka.Consumer.Types (Timestamp (..)) 35 | import Kafka.Internal.RdKafka (RdKafkaMessageT (..), RdKafkaMessageTPtr, RdKafkaRespErrT (..), RdKafkaTimestampTypeT (..), Word8Ptr, rdKafkaErrno2err, rdKafkaMessageTimestamp, rdKafkaPoll, rdKafkaTopicName, rdKafkaHeaderGetAll, rdKafkaMessageHeaders) 36 | import Kafka.Internal.Setup (HasKafka (..), Kafka (..)) 37 | import Kafka.Types (KafkaError (..), Millis (..), Timeout (..), Headers, headersFromList) 38 | 39 | pollEvents :: HasKafka a => a -> Maybe Timeout -> IO () 40 | pollEvents a tm = 41 | let timeout = maybe 0 unTimeout tm 42 | Kafka k = getKafka a 43 | in void (rdKafkaPoll k timeout) 44 | 45 | word8PtrToBS :: Int -> Word8Ptr -> IO BS.ByteString 46 | word8PtrToBS len ptr = BSI.create len $ \bsptr -> 47 | BSI.memcpy bsptr ptr len 48 | 49 | kafkaRespErr :: Errno -> KafkaError 50 | kafkaRespErr (Errno num) = KafkaResponseError $ rdKafkaErrno2err (fromIntegral num) 51 | {-# INLINE kafkaRespErr #-} 52 | 53 | throwOnError :: IO (Maybe Text) -> IO () 54 | throwOnError action = do 55 | m <- action 56 | case m of 57 | Just e -> throw $ KafkaError e 58 | Nothing -> return () 59 | 60 | hasError :: KafkaError -> Bool 61 | hasError err = case err of 62 | KafkaResponseError RdKafkaRespErrNoError -> False 63 | _ -> True 64 | {-# INLINE hasError #-} 65 | 66 | rdKafkaErrorToEither :: RdKafkaRespErrT -> Either KafkaError () 67 | rdKafkaErrorToEither err = case err of 68 | RdKafkaRespErrNoError -> Right () 69 | _ -> Left (KafkaResponseError err) 70 | {-# INLINE rdKafkaErrorToEither #-} 71 | 72 | kafkaErrorToEither :: KafkaError -> Either KafkaError () 73 | kafkaErrorToEither err = case err of 74 | KafkaResponseError RdKafkaRespErrNoError -> Right () 75 | _ -> Left err 76 | {-# INLINE kafkaErrorToEither #-} 77 | 78 | kafkaErrorToMaybe :: KafkaError -> Maybe KafkaError 79 | kafkaErrorToMaybe err = case err of 80 | KafkaResponseError RdKafkaRespErrNoError -> Nothing 81 | _ -> Just err 82 | {-# INLINE kafkaErrorToMaybe #-} 83 | 84 | maybeToLeft :: Maybe a -> Either a () 85 | maybeToLeft = maybe (Right ()) Left 86 | {-# INLINE maybeToLeft #-} 87 | 88 | readPayload :: RdKafkaMessageT -> IO (Maybe BS.ByteString) 89 | readPayload = readBS len'RdKafkaMessageT payload'RdKafkaMessageT 90 | 91 | readTopic :: RdKafkaMessageT -> IO Text 92 | readTopic msg = newForeignPtr_ (topic'RdKafkaMessageT msg) >>= (fmap Text.pack . rdKafkaTopicName) 93 | 94 | readKey :: RdKafkaMessageT -> IO (Maybe BSI.ByteString) 95 | readKey = readBS keyLen'RdKafkaMessageT key'RdKafkaMessageT 96 | 97 | readTimestamp :: RdKafkaMessageTPtr -> IO Timestamp 98 | readTimestamp msg = 99 | alloca $ \p -> do 100 | typeP <- newForeignPtr_ p 101 | ts <- fromIntegral <$> rdKafkaMessageTimestamp msg typeP 102 | tsType <- peek p 103 | return $ case tsType of 104 | RdKafkaTimestampCreateTime -> CreateTime (Millis ts) 105 | RdKafkaTimestampLogAppendTime -> LogAppendTime (Millis ts) 106 | RdKafkaTimestampNotAvailable -> NoTimestamp 107 | 108 | 109 | readHeaders :: Ptr RdKafkaMessageT -> IO (Either RdKafkaRespErrT Headers) 110 | readHeaders msg = do 111 | (err, headersPtr) <- rdKafkaMessageHeaders msg 112 | case err of 113 | RdKafkaRespErrNoent -> return $ Right mempty 114 | RdKafkaRespErrNoError -> fmap headersFromList <$> extractHeaders headersPtr 115 | e -> return . Left $ e 116 | where extractHeaders ptHeaders = 117 | alloca $ \nptr -> 118 | alloca $ \vptr -> 119 | alloca $ \szptr -> 120 | let go acc idx = rdKafkaHeaderGetAll ptHeaders idx nptr vptr szptr >>= \case 121 | RdKafkaRespErrNoent -> return $ Right acc 122 | RdKafkaRespErrNoError -> do 123 | cstr <- peek nptr 124 | wptr <- peek vptr 125 | csize <- peek szptr 126 | hn <- BS.packCString cstr 127 | hv <- word8PtrToBS (fromIntegral csize) wptr 128 | go ((hn, hv) : acc) (idx + 1) 129 | _ -> error "Unexpected error code while extracting headers" 130 | in go [] 0 131 | 132 | readBS :: (t -> Int) -> (t -> Ptr Word8) -> t -> IO (Maybe BS.ByteString) 133 | readBS flen fdata s = if fdata s == nullPtr 134 | then return Nothing 135 | else Just <$> word8PtrToBS (flen s) (fdata s) 136 | -------------------------------------------------------------------------------- /src/Kafka/Producer/ProducerProperties.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | ----------------------------------------------------------------------------- 4 | -- | 5 | -- Module with producer properties types and functions. 6 | ----------------------------------------------------------------------------- 7 | module Kafka.Producer.ProducerProperties 8 | ( ProducerProperties(..) 9 | , brokersList 10 | , setCallback 11 | , logLevel 12 | , compression 13 | , topicCompression 14 | , sendTimeout 15 | , statisticsInterval 16 | , extraProps 17 | , extraProp 18 | , suppressDisconnectLogs 19 | , extraTopicProps 20 | , debugOptions 21 | , module Kafka.Producer.Callbacks 22 | ) 23 | where 24 | 25 | import Data.Text (Text) 26 | import qualified Data.Text as Text 27 | import Control.Monad (MonadPlus(mplus)) 28 | import Data.Map (Map) 29 | import qualified Data.Map as M 30 | import Data.Semigroup as Sem 31 | import Kafka.Types (KafkaDebug(..), Timeout(..), KafkaCompressionCodec(..), KafkaLogLevel(..), BrokerAddress(..), kafkaDebugToText, kafkaCompressionCodecToText, Millis(..)) 32 | 33 | import Kafka.Producer.Callbacks 34 | 35 | -- | Properties to create 'Kafka.Producer.Types.KafkaProducer'. 36 | data ProducerProperties = ProducerProperties 37 | { ppKafkaProps :: Map Text Text 38 | , ppTopicProps :: Map Text Text 39 | , ppLogLevel :: Maybe KafkaLogLevel 40 | , ppCallbacks :: [Callback] 41 | } 42 | 43 | instance Sem.Semigroup ProducerProperties where 44 | (ProducerProperties k1 t1 ll1 cb1) <> (ProducerProperties k2 t2 ll2 cb2) = 45 | ProducerProperties (M.union k2 k1) (M.union t2 t1) (ll2 `mplus` ll1) (cb1 `mplus` cb2) 46 | {-# INLINE (<>) #-} 47 | 48 | -- | /Right biased/ so we prefer newer properties over older ones. 49 | instance Monoid ProducerProperties where 50 | mempty = ProducerProperties 51 | { ppKafkaProps = M.empty 52 | , ppTopicProps = M.empty 53 | , ppLogLevel = Nothing 54 | , ppCallbacks = [] 55 | } 56 | {-# INLINE mempty #-} 57 | mappend = (Sem.<>) 58 | {-# INLINE mappend #-} 59 | 60 | -- | Set the to contact to connect to the Kafka cluster. 61 | brokersList :: [BrokerAddress] -> ProducerProperties 62 | brokersList bs = 63 | let bs' = Text.intercalate "," (unBrokerAddress <$> bs) 64 | in extraProps $ M.fromList [("bootstrap.servers", bs')] 65 | 66 | -- | Set the producer callback. 67 | -- 68 | -- For examples of use, see: 69 | -- 70 | -- * 'errorCallback' 71 | -- * 'logCallback' 72 | -- * 'statsCallback' 73 | setCallback :: Callback -> ProducerProperties 74 | setCallback cb = mempty { ppCallbacks = [cb] } 75 | 76 | -- | Sets the logging level. 77 | -- Usually is used with 'debugOptions' to configure which logs are needed. 78 | logLevel :: KafkaLogLevel -> ProducerProperties 79 | logLevel ll = mempty { ppLogLevel = Just ll } 80 | 81 | -- | Set the for the producer. 82 | compression :: KafkaCompressionCodec -> ProducerProperties 83 | compression c = 84 | extraProps $ M.singleton "compression.codec" (kafkaCompressionCodecToText c) 85 | 86 | -- | Set the for the topic. 87 | topicCompression :: KafkaCompressionCodec -> ProducerProperties 88 | topicCompression c = 89 | extraTopicProps $ M.singleton "compression.codec" (kafkaCompressionCodecToText c) 90 | 91 | -- | Set the . 92 | sendTimeout :: Timeout -> ProducerProperties 93 | sendTimeout (Timeout t) = 94 | extraTopicProps $ M.singleton "message.timeout.ms" (Text.pack $ show t) 95 | 96 | -- | Set the for the producer. 97 | statisticsInterval :: Millis -> ProducerProperties 98 | statisticsInterval (Millis t) = 99 | extraProps $ M.singleton "statistics.interval.ms" (Text.pack $ show t) 100 | 101 | -- | Any configuration options that are supported by /librdkafka/. 102 | -- The full list can be found 103 | extraProps :: Map Text Text -> ProducerProperties 104 | extraProps m = mempty { ppKafkaProps = m } 105 | 106 | -- | Any configuration options that are supported by /librdkafka/. 107 | -- The full list can be found 108 | extraProp :: Text -> Text -> ProducerProperties 109 | extraProp k v = mempty { ppKafkaProps = M.singleton k v } 110 | {-# INLINE extraProp #-} 111 | 112 | -- | Suppresses producer disconnects logs. 113 | -- 114 | -- It might be useful to turn this off when interacting with brokers 115 | -- with an aggressive connection.max.idle.ms value. 116 | suppressDisconnectLogs :: ProducerProperties 117 | suppressDisconnectLogs = 118 | extraProps $ M.fromList [("log.connection.close", "false")] 119 | 120 | -- | Any *topic* configuration options that are supported by /librdkafka/. 121 | -- The full list can be found 122 | extraTopicProps :: Map Text Text -> ProducerProperties 123 | extraTopicProps m = mempty { ppTopicProps = m } 124 | 125 | -- | Sets features for the producer 126 | -- Usually is used with 'logLevel'. 127 | debugOptions :: [KafkaDebug] -> ProducerProperties 128 | debugOptions [] = extraProps M.empty 129 | debugOptions d = 130 | let points = Text.intercalate "," (kafkaDebugToText <$> d) 131 | in extraProps $ M.fromList [("debug", points)] 132 | -------------------------------------------------------------------------------- /src/Kafka/Transaction.hs: -------------------------------------------------------------------------------- 1 | ----------------------------------------------------------------------------- 2 | -- | 3 | -- Module to work wih Kafkas transactional producers. 4 | -- 5 | ----------------------------------------------------------------------------- 6 | module Kafka.Transaction 7 | ( initTransactions 8 | , beginTransaction 9 | , commitTransaction 10 | , abortTransaction 11 | 12 | , commitOffsetMessageTransaction 13 | -- , commitTransactionWithOffsets 14 | 15 | , TxError 16 | , getKafkaError 17 | , kafkaErrorIsFatal 18 | , kafkaErrorIsRetriable 19 | , kafkaErrorTxnRequiresAbort 20 | ) 21 | where 22 | 23 | import Control.Monad.IO.Class (MonadIO (liftIO)) 24 | import Kafka.Internal.RdKafka (RdKafkaErrorTPtr, rdKafkaErrorDestroy, rdKafkaErrorIsFatal, rdKafkaErrorIsRetriable, rdKafkaErrorTxnRequiresAbort, rdKafkaErrorCode, rdKafkaInitTransactions, rdKafkaBeginTransaction, rdKafkaCommitTransaction, rdKafkaAbortTransaction, rdKafkaSendOffsetsToTransaction) 25 | import Kafka.Internal.Setup (getRdKafka) 26 | import Kafka.Producer.Convert (handleProduceErrT) 27 | import Kafka.Producer 28 | import Kafka.Consumer.Convert (toNativeTopicPartitionList, topicPartitionFromMessageForCommit) 29 | import Kafka.Consumer 30 | 31 | ------------------------------------------------------------------------------------- 32 | -- Tx API 33 | 34 | data TxError = TxError 35 | { txErrorKafka :: !KafkaError 36 | , txErrorFatal :: !Bool 37 | , txErrorRetriable :: !Bool 38 | , txErrorTxnReqAbort :: !Bool 39 | } 40 | 41 | -- | Initialises Kafka for transactions 42 | initTransactions :: MonadIO m 43 | => KafkaProducer 44 | -> Timeout 45 | -> m (Maybe KafkaError) 46 | initTransactions p (Timeout to) 47 | = liftIO $ rdKafkaInitTransactions (getRdKafka p) to >>= rdKafkaErrorCode >>= handleProduceErrT 48 | 49 | -- | Begins a new transaction 50 | beginTransaction :: MonadIO m 51 | => KafkaProducer 52 | -> m (Maybe KafkaError) 53 | beginTransaction p 54 | = liftIO $ rdKafkaBeginTransaction (getRdKafka p) >>= rdKafkaErrorCode >>= handleProduceErrT 55 | 56 | -- | Commits an existing transaction 57 | -- Pre-condition: there exists an open transaction, created with beginTransaction 58 | commitTransaction :: MonadIO m 59 | => KafkaProducer 60 | -> Timeout 61 | -> m (Maybe TxError) 62 | commitTransaction p (Timeout to) = liftIO $ rdKafkaCommitTransaction (getRdKafka p) to >>= toTxError 63 | 64 | -- | Aborts an existing transaction 65 | -- Pre-condition: there exists an open transaction, created with beginTransaction 66 | abortTransaction :: MonadIO m 67 | => KafkaProducer 68 | -> Timeout 69 | -> m (Maybe KafkaError) 70 | abortTransaction p (Timeout to) 71 | = liftIO $ do rdKafkaAbortTransaction (getRdKafka p) to >>= rdKafkaErrorCode >>= handleProduceErrT 72 | 73 | -- | Commits the message's offset in the current transaction 74 | -- Similar to Kafka.Consumer.commitOffsetMessage but within a transactional context 75 | -- Pre-condition: there exists an open transaction, created with beginTransaction 76 | commitOffsetMessageTransaction :: MonadIO m 77 | => KafkaProducer 78 | -> KafkaConsumer 79 | -> ConsumerRecord k v 80 | -> Timeout 81 | -> m (Maybe TxError) 82 | commitOffsetMessageTransaction p c m (Timeout to) = liftIO $ do 83 | tps <- toNativeTopicPartitionList [topicPartitionFromMessageForCommit m] 84 | rdKafkaSendOffsetsToTransaction (getRdKafka p) (getRdKafka c) tps to >>= toTxError 85 | 86 | -- -- | Commit offsets for all currently assigned partitions in the current transaction 87 | -- -- Similar to Kafka.Consumer.commitAllOffsets but within a transactional context 88 | -- -- Pre-condition: there exists an open transaction, created with beginTransaction 89 | -- commitAllOffsetsTransaction :: MonadIO m 90 | -- => KafkaProducer 91 | -- -> KafkaConsumer 92 | -- -> Timeout 93 | -- -> m (Maybe TxError) 94 | -- commitAllOffsetsTransaction p c (Timeout to) = liftIO $ do 95 | -- -- TODO: this can't be right... 96 | -- tps <- newForeignPtr_ nullPtr 97 | -- rdKafkaSendOffsetsToTransaction (getRdKafka p) (getRdKafka c) tps to >>= toTxError 98 | 99 | getKafkaError :: TxError -> KafkaError 100 | getKafkaError = txErrorKafka 101 | 102 | kafkaErrorIsFatal :: TxError -> Bool 103 | kafkaErrorIsFatal = txErrorFatal 104 | 105 | kafkaErrorIsRetriable :: TxError -> Bool 106 | kafkaErrorIsRetriable = txErrorRetriable 107 | 108 | kafkaErrorTxnRequiresAbort :: TxError -> Bool 109 | kafkaErrorTxnRequiresAbort = txErrorTxnReqAbort 110 | 111 | ---------------------------------------------------------------------------------------------------- 112 | -- Implementation detail, used internally 113 | toTxError :: RdKafkaErrorTPtr -> IO (Maybe TxError) 114 | toTxError errPtr = do 115 | ret <- rdKafkaErrorCode errPtr >>= handleProduceErrT 116 | case ret of 117 | Nothing -> do 118 | -- NOTE: don't forget to free error structure, otherwise we are leaking memory! 119 | rdKafkaErrorDestroy errPtr 120 | pure Nothing 121 | Just ke -> do 122 | fatal <- rdKafkaErrorIsFatal errPtr 123 | retriable <- rdKafkaErrorIsRetriable errPtr 124 | reqAbort <- rdKafkaErrorTxnRequiresAbort errPtr 125 | -- NOTE: don't forget to free error structure, otherwise we are leaking memory! 126 | rdKafkaErrorDestroy errPtr 127 | pure $ Just $ TxError 128 | { txErrorKafka = ke 129 | , txErrorFatal = fatal 130 | , txErrorRetriable = retriable 131 | , txErrorTxnReqAbort = reqAbort 132 | } 133 | -------------------------------------------------------------------------------- /nix/sources.nix: -------------------------------------------------------------------------------- 1 | # This file has been generated by Niv. 2 | 3 | let 4 | 5 | # 6 | # The fetchers. fetch_ fetches specs of type . 7 | # 8 | 9 | fetch_file = pkgs: spec: 10 | if spec.builtin or true then 11 | builtins_fetchurl { inherit (spec) url sha256; } 12 | else 13 | pkgs.fetchurl { inherit (spec) url sha256; }; 14 | 15 | fetch_tarball = pkgs: name: spec: 16 | let 17 | ok = str: ! builtins.isNull (builtins.match "[a-zA-Z0-9+-._?=]" str); 18 | # sanitize the name, though nix will still fail if name starts with period 19 | name' = stringAsChars (x: if ! ok x then "-" else x) "${name}-src"; 20 | in 21 | if spec.builtin or true then 22 | builtins_fetchTarball { name = name'; inherit (spec) url sha256; } 23 | else 24 | pkgs.fetchzip { name = name'; inherit (spec) url sha256; }; 25 | 26 | fetch_git = spec: 27 | builtins.fetchGit { url = spec.repo; inherit (spec) rev ref; }; 28 | 29 | fetch_local = spec: spec.path; 30 | 31 | fetch_builtin-tarball = name: throw 32 | ''[${name}] The niv type "builtin-tarball" is deprecated. You should instead use `builtin = true`. 33 | $ niv modify ${name} -a type=tarball -a builtin=true''; 34 | 35 | fetch_builtin-url = name: throw 36 | ''[${name}] The niv type "builtin-url" will soon be deprecated. You should instead use `builtin = true`. 37 | $ niv modify ${name} -a type=file -a builtin=true''; 38 | 39 | # 40 | # Various helpers 41 | # 42 | 43 | # The set of packages used when specs are fetched using non-builtins. 44 | mkPkgs = sources: 45 | let 46 | sourcesNixpkgs = 47 | import (builtins_fetchTarball { inherit (sources.nixpkgs) url sha256; }) {}; 48 | hasNixpkgsPath = builtins.any (x: x.prefix == "nixpkgs") builtins.nixPath; 49 | hasThisAsNixpkgsPath = == ./.; 50 | in 51 | if builtins.hasAttr "nixpkgs" sources 52 | then sourcesNixpkgs 53 | else if hasNixpkgsPath && ! hasThisAsNixpkgsPath then 54 | import {} 55 | else 56 | abort 57 | '' 58 | Please specify either (through -I or NIX_PATH=nixpkgs=...) or 59 | add a package called "nixpkgs" to your sources.json. 60 | ''; 61 | 62 | # The actual fetching function. 63 | fetch = pkgs: name: spec: 64 | 65 | if ! builtins.hasAttr "type" spec then 66 | abort "ERROR: niv spec ${name} does not have a 'type' attribute" 67 | else if spec.type == "file" then fetch_file pkgs spec 68 | else if spec.type == "tarball" then fetch_tarball pkgs name spec 69 | else if spec.type == "git" then fetch_git spec 70 | else if spec.type == "local" then fetch_local spec 71 | else if spec.type == "builtin-tarball" then fetch_builtin-tarball name 72 | else if spec.type == "builtin-url" then fetch_builtin-url name 73 | else 74 | abort "ERROR: niv spec ${name} has unknown type ${builtins.toJSON spec.type}"; 75 | 76 | # If the environment variable NIV_OVERRIDE_${name} is set, then use 77 | # the path directly as opposed to the fetched source. 78 | replace = name: drv: 79 | let 80 | saneName = stringAsChars (c: if isNull (builtins.match "[a-zA-Z0-9]" c) then "_" else c) name; 81 | ersatz = builtins.getEnv "NIV_OVERRIDE_${saneName}"; 82 | in 83 | if ersatz == "" then drv else ersatz; 84 | 85 | # Ports of functions for older nix versions 86 | 87 | # a Nix version of mapAttrs if the built-in doesn't exist 88 | mapAttrs = builtins.mapAttrs or ( 89 | f: set: with builtins; 90 | listToAttrs (map (attr: { name = attr; value = f attr set.${attr}; }) (attrNames set)) 91 | ); 92 | 93 | # https://github.com/NixOS/nixpkgs/blob/0258808f5744ca980b9a1f24fe0b1e6f0fecee9c/lib/lists.nix#L295 94 | range = first: last: if first > last then [] else builtins.genList (n: first + n) (last - first + 1); 95 | 96 | # https://github.com/NixOS/nixpkgs/blob/0258808f5744ca980b9a1f24fe0b1e6f0fecee9c/lib/strings.nix#L257 97 | stringToCharacters = s: map (p: builtins.substring p 1 s) (range 0 (builtins.stringLength s - 1)); 98 | 99 | # https://github.com/NixOS/nixpkgs/blob/0258808f5744ca980b9a1f24fe0b1e6f0fecee9c/lib/strings.nix#L269 100 | stringAsChars = f: s: concatStrings (map f (stringToCharacters s)); 101 | concatStrings = builtins.concatStringsSep ""; 102 | 103 | # fetchTarball version that is compatible between all the versions of Nix 104 | builtins_fetchTarball = { url, name, sha256 }@attrs: 105 | let 106 | inherit (builtins) lessThan nixVersion fetchTarball; 107 | in 108 | if lessThan nixVersion "1.12" then 109 | fetchTarball { inherit name url; } 110 | else 111 | fetchTarball attrs; 112 | 113 | # fetchurl version that is compatible between all the versions of Nix 114 | builtins_fetchurl = { url, sha256 }@attrs: 115 | let 116 | inherit (builtins) lessThan nixVersion fetchurl; 117 | in 118 | if lessThan nixVersion "1.12" then 119 | fetchurl { inherit url; } 120 | else 121 | fetchurl attrs; 122 | 123 | # Create the final "sources" from the config 124 | mkSources = config: 125 | mapAttrs ( 126 | name: spec: 127 | if builtins.hasAttr "outPath" spec 128 | then abort 129 | "The values in sources.json should not have an 'outPath' attribute" 130 | else 131 | spec // { outPath = replace name (fetch config.pkgs name spec); } 132 | ) config.sources; 133 | 134 | # The "config" used by the fetchers 135 | mkConfig = 136 | { sourcesFile ? if builtins.pathExists ./sources.json then ./sources.json else null 137 | , sources ? if isNull sourcesFile then {} else builtins.fromJSON (builtins.readFile sourcesFile) 138 | , pkgs ? mkPkgs sources 139 | }: rec { 140 | # The sources, i.e. the attribute set of spec name to spec 141 | inherit sources; 142 | 143 | # The "pkgs" (evaluated nixpkgs) to use for e.g. non-builtin fetchers 144 | inherit pkgs; 145 | }; 146 | 147 | in 148 | mkSources (mkConfig {}) // { __functor = _: settings: mkSources (mkConfig settings); } 149 | -------------------------------------------------------------------------------- /.github/workflows/haskell.yml: -------------------------------------------------------------------------------- 1 | name: Binaries 2 | 3 | defaults: 4 | run: 5 | shell: bash 6 | 7 | on: 8 | push: 9 | branches: 10 | - main 11 | pull_request: 12 | 13 | jobs: 14 | build: 15 | runs-on: ${{ matrix.os }} 16 | 17 | strategy: 18 | fail-fast: false 19 | matrix: 20 | ghc: ["9.4.2", "9.2.4", "9.0.2", "8.10.7", "8.8.4", "8.6.5", "9.10.1"] 21 | os: [ubuntu-latest] 22 | 23 | steps: 24 | - uses: actions/checkout@v4 25 | 26 | - uses: actions/cache@v3 27 | name: Cache librdkafka 28 | with: 29 | path: .librdkafka 30 | key: librdkafka-cache--${{ runner.os }}-${{ matrix.ghc }} 31 | 32 | - name: Build librdkafka 33 | run: ./scripts/build-librdkafka 34 | 35 | - uses: haskell-actions/setup@v2 36 | id: setup-haskell 37 | with: 38 | ghc-version: ${{ matrix.ghc }} 39 | cabal-version: 3.4.0.0 40 | 41 | - name: Set some window specific things 42 | if: matrix.os == 'windows-latest' 43 | run: echo 'EXE_EXT=.exe' >> $GITHUB_ENV 44 | 45 | - name: Configure project 46 | run: cabal configure --enable-tests --enable-benchmarks --write-ghc-environment-files=ghc8.4.4+ 47 | 48 | - name: Cache ~/.cabal/packages, ~/.cabal/store and dist-newstyle 49 | uses: actions/cache@v4 50 | with: 51 | path: | 52 | ~/.cabal/packages 53 | ~/.cabal/store 54 | dist-newstyle 55 | key: ${{ runner.os }}-${{ matrix.ghc }}-${{ hashFiles('**/*.cabal', '**/cabal.project', '**/cabal.project.freeze') }} 56 | restore-keys: ${{ runner.os }}-${{ matrix.ghc }}- 57 | 58 | - name: Build 59 | # Try building it twice in case of flakey builds on Windows 60 | run: | 61 | cabal build all --enable-tests --enable-benchmarks --write-ghc-environment-files=ghc8.4.4+ || \ 62 | cabal build all --enable-tests --enable-benchmarks --write-ghc-environment-files=ghc8.4.4+ -j1 63 | 64 | - name: Test 65 | run: | 66 | cabal test all --enable-tests --enable-benchmarks --write-ghc-environment-files=ghc8.4.4+ 67 | 68 | check: 69 | needs: build 70 | runs-on: ubuntu-latest 71 | outputs: 72 | tag: ${{ steps.tag.outputs.tag }} 73 | 74 | steps: 75 | - uses: actions/checkout@v4 76 | 77 | - name: Check if cabal project is sane 78 | run: | 79 | PROJECT_DIR=$PWD 80 | mkdir -p $PROJECT_DIR/build/sdist 81 | for i in $(git ls-files | grep '\.cabal'); do 82 | cd $PROJECT_DIR && cd `dirname $i` 83 | cabal check 84 | done 85 | 86 | - name: Tag new version 87 | id: tag 88 | if: ${{ github.ref == 'refs/heads/main' }} 89 | env: 90 | server: http://hackage.haskell.org 91 | username: ${{ secrets.HACKAGE_USER }} 92 | password: ${{ secrets.HACKAGE_PASS }} 93 | run: | 94 | package_version="$(cat *.cabal | grep '^version:' | cut -d : -f 2 | xargs)" 95 | 96 | echo "Package version is v$package_version" 97 | 98 | git fetch --unshallow origin 99 | 100 | if git tag "v$package_version"; then 101 | echo "Tagging with new version "v$package_version"" 102 | 103 | if git push origin "v$package_version"; then 104 | echo "Tagged with new version "v$package_version"" 105 | 106 | echo "tag=v$package_version" >> $GITHUB_OUTPUT 107 | 108 | fi 109 | fi 110 | 111 | release: 112 | needs: [build, check] 113 | runs-on: ubuntu-latest 114 | if: ${{ needs.check.outputs.tag != '' }} 115 | outputs: 116 | upload_url: ${{ steps.create_release.outputs.upload_url }} 117 | 118 | steps: 119 | - uses: actions/checkout@v4 120 | 121 | - name: Create source distribution 122 | run: | 123 | PROJECT_DIR=$PWD 124 | mkdir -p $PROJECT_DIR/build/sdist 125 | for i in $(git ls-files | grep '\.cabal'); do 126 | cd $PROJECT_DIR && cd `dirname $i` 127 | cabal v2-sdist -o $PROJECT_DIR/build/sdist 128 | done; 129 | 130 | - name: Publish to hackage 131 | env: 132 | server: http://hackage.haskell.org 133 | username: ${{ secrets.HACKAGE_USER }} 134 | password: ${{ secrets.HACKAGE_PASS }} 135 | candidate: false 136 | run: | 137 | package_version="$(cat *.cabal | grep '^version:' | cut -d : -f 2 | xargs)" 138 | 139 | for PACKAGE_TARBALL in $(find ./build/sdist/ -name "*.tar.gz"); do 140 | PACKAGE_NAME=$(basename ${PACKAGE_TARBALL%.*.*}) 141 | 142 | if ${{ env.candidate }}; then 143 | TARGET_URL="${{ env.server }}/packages/candidates"; 144 | DOCS_URL="${{ env.server }}/package/$PACKAGE_NAME/candidate/docs" 145 | else 146 | TARGET_URL="${{ env.server }}/packages/upload"; 147 | DOCS_URL="${{ env.server }}/package/$PACKAGE_NAME/docs" 148 | fi 149 | 150 | HACKAGE_STATUS=$(curl --silent --head -w %{http_code} -XGET --anyauth --user "${{ env.username }}:${{ env.password }}" ${{ env.server }}/package/$PACKAGE_NAME -o /dev/null) 151 | 152 | if [ "$HACKAGE_STATUS" = "404" ]; then 153 | echo "Uploading $PACKAGE_NAME to $TARGET_URL" 154 | 155 | curl -X POST -f --user "${{ env.username }}:${{ env.password }}" $TARGET_URL -F "package=@$PACKAGE_TARBALL" 156 | echo "Uploaded $PACKAGE_NAME" 157 | else 158 | echo "Package $PACKAGE_NAME" already exists on Hackage. 159 | fi 160 | done 161 | 162 | - name: Create Release 163 | id: create_release 164 | uses: actions/create-release@v1 165 | env: 166 | GITHUB_TOKEN: ${{ secrets.GITHUB_TOKEN }} # This token is provided by Actions, you do not need to create your own token 167 | with: 168 | tag_name: ${{ github.ref }} 169 | release_name: Release ${{ github.ref }} 170 | body: Undocumented 171 | draft: true 172 | prerelease: false 173 | 174 | -------------------------------------------------------------------------------- /src/Kafka/Topic.hs: -------------------------------------------------------------------------------- 1 | module Kafka.Topic( 2 | module X 3 | , createTopic 4 | , deleteTopic 5 | ) where 6 | 7 | import Control.Exception 8 | import Control.Monad.IO.Class 9 | import Control.Monad.Trans.Class 10 | import Control.Monad.Trans.Except 11 | import Control.Monad.Trans.Maybe 12 | import Data.Bifunctor 13 | import Data.Foldable 14 | import Data.List.NonEmpty 15 | import qualified Data.List.NonEmpty as NEL 16 | import qualified Data.Map as M 17 | import Data.Maybe 18 | import qualified Data.Set as S 19 | import qualified Data.Text as T 20 | import Kafka.Internal.RdKafka 21 | import Kafka.Internal.Setup 22 | 23 | import Kafka.Topic.Types as X 24 | import Kafka.Types as X 25 | 26 | --- CREATE TOPIC --- 27 | createTopic :: HasKafka k => k -> NewTopic -> IO (Either KafkaError TopicName) 28 | createTopic k topic = do 29 | let kafkaPtr = getRdKafka k 30 | queue <- newRdKafkaQueue kafkaPtr 31 | opts <- newRdKAdminOptions kafkaPtr RdKafkaAdminOpAny 32 | 33 | topicRes <- withNewTopic topic $ \topic' -> rdKafkaCreateTopic kafkaPtr topic' opts queue 34 | 35 | case topicRes of 36 | Left err -> do 37 | pure $ Left (NEL.head err) 38 | Right _ -> do 39 | res <- waitForResponse (topicName topic) rdKafkaEventCreateTopicsResult rdKafkaCreateTopicsResultTopics queue 40 | case listToMaybe res of 41 | Nothing -> pure $ Left KafkaInvalidReturnValue 42 | Just result -> pure $ case result of 43 | Left (_, e, _) -> Left e 44 | Right tName -> Right tName 45 | 46 | --- DELETE TOPIC --- 47 | deleteTopic :: HasKafka k 48 | => k 49 | -> TopicName 50 | -> IO (Either KafkaError TopicName) 51 | deleteTopic k topic = liftIO $ do 52 | let kafkaPtr = getRdKafka k 53 | queue <- newRdKafkaQueue kafkaPtr 54 | opts <- newRdKAdminOptions kafkaPtr RdKafkaAdminOpAny 55 | 56 | topicRes <- withOldTopic topic $ \topic' -> rdKafkaDeleteTopics kafkaPtr [topic'] opts queue 57 | case topicRes of 58 | Left err -> do 59 | pure $ Left (NEL.head err) 60 | Right _ -> do 61 | res <- waitForResponse topic rdKafkaEventDeleteTopicsResult rdKafkaDeleteTopicsResultTopics queue 62 | case listToMaybe res of 63 | Nothing -> pure $ Left KafkaInvalidReturnValue 64 | Just result -> pure $ case result of 65 | Left (_, e, _) -> Left e 66 | Right tName -> Right tName 67 | 68 | withNewTopic :: NewTopic 69 | -> (RdKafkaNewTopicTPtr -> IO a) 70 | -> IO (Either (NonEmpty KafkaError) a) 71 | withNewTopic t = withUnsafeOne t mkNewTopicUnsafe rdKafkaNewTopicDestroy 72 | 73 | withOldTopic :: TopicName 74 | -> (RdKafkaDeleteTopicTPtr -> IO a) 75 | -> IO (Either (NonEmpty KafkaError) a) 76 | withOldTopic tName transform = do 77 | rmOldTopicRes <- rmOldTopic tName oldTopicPtr 78 | case rmOldTopicRes of 79 | Left err -> do 80 | return $ Left err 81 | Right topic -> do 82 | res <- transform topic 83 | return $ Right res 84 | 85 | oldTopicPtr :: TopicName -> IO (Either KafkaError RdKafkaDeleteTopicTPtr) 86 | oldTopicPtr tName = do 87 | res <- newRdKafkaDeleteTopic $ T.unpack . unTopicName $ tName 88 | case res of 89 | Left str -> pure $ Left (KafkaError $ T.pack str) 90 | Right ptr -> pure $ Right ptr 91 | 92 | mkNewTopicUnsafe :: NewTopic -> IO (Either KafkaError RdKafkaNewTopicTPtr) 93 | mkNewTopicUnsafe topic = runExceptT $ do 94 | topic' <- withErrStr $ newRdKafkaNewTopicUnsafe (T.unpack $ unTopicName $ topicName topic) (unPartitionCount $ topicPartitionCount topic) (unReplicationFactor $ topicReplicationFactor topic) 95 | _ <- withErrKafka $ whileRight (uncurry $ rdKafkaNewTopicSetConfig undefined) (M.toList $ topicConfig topic) 96 | pure topic' 97 | where 98 | withErrStr = withExceptT (KafkaError . T.pack) . ExceptT 99 | withErrKafka = withExceptT KafkaResponseError . ExceptT 100 | 101 | rmOldTopic :: TopicName 102 | -> (TopicName -> IO (Either KafkaError a)) 103 | -> IO (Either (NonEmpty KafkaError) a) 104 | rmOldTopic tName remove = do 105 | res <- remove tName 106 | case res of 107 | Left err -> pure $ Left (singletonList err) 108 | Right resource -> pure $ Right resource 109 | 110 | withUnsafeOne :: a -- ^ Item to handle 111 | -> (a -> IO (Either KafkaError b)) -- ^ Create an unsafe element 112 | -> (b -> IO ()) -- ^ Destroy the unsafe element 113 | -> (b -> IO c) -- ^ Handler 114 | -> IO (Either (NonEmpty KafkaError) c) 115 | withUnsafeOne a mkOne cleanup f = 116 | bracket (mkOne a) cleanupOne processOne 117 | where 118 | cleanupOne (Right b) = cleanup b 119 | cleanupOne (Left _) = pure () -- no resource to clean if creation failed 120 | 121 | processOne (Right b) = Right <$> f b 122 | processOne (Left e) = pure (Left (singletonList e)) 123 | 124 | whileRight :: Monad m 125 | => (a -> m (Either e ())) 126 | -> [a] 127 | -> m (Either e ()) 128 | whileRight f as = runExceptT $ traverse_ (ExceptT . f) as 129 | 130 | waitForResponse :: TopicName 131 | -> (RdKafkaEventTPtr -> IO (Maybe a)) 132 | -> (a -> IO [Either (String, RdKafkaRespErrT, String) String]) 133 | -> RdKafkaQueueTPtr 134 | -> IO [Either (TopicName, KafkaError, String) TopicName] 135 | waitForResponse topic fromEvent toResults q = 136 | fromMaybe [] <$> runMaybeT (go []) 137 | where 138 | awaited = S.singleton topic 139 | 140 | go accRes = do 141 | qRes <- MaybeT $ rdKafkaQueuePoll q 1000 142 | eRes <- MaybeT $ fromEvent qRes 143 | tRes <- lift $ toResults eRes 144 | let results = wrapTopicName <$> tRes 145 | let topics = S.fromList $ getTopicName <$> results 146 | let newRes = results <> accRes 147 | let remaining = S.difference awaited topics 148 | if S.null remaining 149 | then pure newRes 150 | else go newRes 151 | 152 | getTopicName = either (\(t,_,_) -> t) id 153 | wrapTopicName = bimap (\(t,e,s) -> (TopicName (T.pack t), KafkaResponseError e, s)) 154 | (TopicName . T.pack) 155 | 156 | singletonList :: a -> NonEmpty a 157 | singletonList x = x :| [] 158 | 159 | -------------------------------------------------------------------------------- /src/Kafka/Types.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveDataTypeable #-} 2 | {-# LANGUAGE DeriveGeneric #-} 3 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 4 | {-# LANGUAGE OverloadedStrings #-} 5 | 6 | ----------------------------------------------------------------------------- 7 | -- | 8 | -- Module holding types shared by consumer and producer modules. 9 | ----------------------------------------------------------------------------- 10 | module Kafka.Types 11 | ( BrokerId(..) 12 | , PartitionId(..) 13 | , Millis(..) 14 | , ClientId(..) 15 | , BatchSize(..) 16 | , TopicName(..) 17 | , BrokerAddress(..) 18 | , Timeout(..) 19 | , KafkaLogLevel(..) 20 | , KafkaError(..) 21 | , KafkaDebug(..) 22 | , KafkaCompressionCodec(..) 23 | , TopicType(..) 24 | , Headers, headersFromList, headersToList 25 | , topicType 26 | , kafkaDebugToText 27 | , kafkaCompressionCodecToText 28 | ) 29 | where 30 | 31 | import Control.Exception (Exception (..)) 32 | import Data.Int (Int64) 33 | import Data.String (IsString) 34 | import Data.Text (Text, isPrefixOf) 35 | import Data.Typeable (Typeable) 36 | import GHC.Generics (Generic) 37 | import Kafka.Internal.RdKafka (RdKafkaRespErrT, rdKafkaErr2name, rdKafkaErr2str) 38 | import qualified Data.ByteString as BS 39 | 40 | -- | Kafka broker ID 41 | newtype BrokerId = BrokerId { unBrokerId :: Int } deriving (Show, Eq, Ord, Read, Generic) 42 | 43 | -- | Topic partition ID 44 | newtype PartitionId = PartitionId { unPartitionId :: Int } deriving (Show, Eq, Read, Ord, Enum, Generic) 45 | 46 | -- | A number of milliseconds, used to represent durations and timestamps 47 | newtype Millis = Millis { unMillis :: Int64 } deriving (Show, Read, Eq, Ord, Num, Generic) 48 | 49 | -- | Client ID used by Kafka to better track requests 50 | -- 51 | -- See 52 | newtype ClientId = ClientId 53 | { unClientId :: Text 54 | } deriving (Show, Eq, IsString, Ord, Generic) 55 | 56 | -- | Batch size used for polling 57 | newtype BatchSize = BatchSize { unBatchSize :: Int } deriving (Show, Read, Eq, Ord, Num, Generic) 58 | 59 | -- | Whether the topic is created by a user or by the system 60 | data TopicType = 61 | User -- ^ Normal topics that are created by user. 62 | | System -- ^ Topics starting with a double underscore "\__" (@__consumer_offsets@, @__confluent.support.metrics@, etc.) are considered "system" topics 63 | deriving (Show, Read, Eq, Ord, Generic) 64 | 65 | -- | Topic name to consume/produce messages 66 | -- 67 | -- Wildcard (regex) topics are supported by the /librdkafka/ assignor: 68 | -- any topic name in the topics list that is prefixed with @^@ will 69 | -- be regex-matched to the full list of topics in the cluster and matching 70 | -- topics will be added to the subscription list. 71 | newtype TopicName = TopicName 72 | { unTopicName :: Text -- ^ a simple topic name or a regex if started with @^@ 73 | } deriving (Show, Eq, Ord, IsString, Read, Generic) 74 | 75 | -- | Deduce the type of a topic from its name, by checking if it starts with a double underscore "\__" 76 | topicType :: TopicName -> TopicType 77 | topicType (TopicName tn) = 78 | if "__" `isPrefixOf` tn then System else User 79 | {-# INLINE topicType #-} 80 | 81 | -- | Kafka broker address string (e.g. @broker1:9092@) 82 | newtype BrokerAddress = BrokerAddress 83 | { unBrokerAddress :: Text 84 | } deriving (Show, Eq, IsString, Generic) 85 | 86 | -- | Timeout in milliseconds 87 | newtype Timeout = Timeout { unTimeout :: Int } deriving (Show, Eq, Read, Generic) 88 | 89 | -- | Log levels for /librdkafka/. 90 | data KafkaLogLevel = 91 | KafkaLogEmerg | KafkaLogAlert | KafkaLogCrit | KafkaLogErr | KafkaLogWarning | 92 | KafkaLogNotice | KafkaLogInfo | KafkaLogDebug 93 | deriving (Show, Enum, Eq) 94 | 95 | -- | All possible Kafka errors 96 | data KafkaError = 97 | KafkaError Text 98 | | KafkaInvalidReturnValue 99 | | KafkaBadSpecification Text 100 | | KafkaResponseError RdKafkaRespErrT 101 | | KafkaInvalidConfigurationValue Text 102 | | KafkaUnknownConfigurationKey Text 103 | | KafkaBadConfiguration 104 | deriving (Eq, Show, Typeable, Generic) 105 | 106 | instance Exception KafkaError where 107 | displayException (KafkaResponseError err) = 108 | "[" ++ rdKafkaErr2name err ++ "] " ++ rdKafkaErr2str err 109 | displayException err = show err 110 | 111 | -- | Available /librdkafka/ debug contexts 112 | data KafkaDebug = 113 | DebugGeneric 114 | | DebugBroker 115 | | DebugTopic 116 | | DebugMetadata 117 | | DebugQueue 118 | | DebugMsg 119 | | DebugProtocol 120 | | DebugCgrp 121 | | DebugSecurity 122 | | DebugFetch 123 | | DebugFeature 124 | | DebugAll 125 | deriving (Eq, Show, Typeable, Generic) 126 | 127 | -- | Convert a 'KafkaDebug' into its /librdkafka/ string equivalent. 128 | -- 129 | -- This is used internally by the library but may be useful to some developers. 130 | kafkaDebugToText :: KafkaDebug -> Text 131 | kafkaDebugToText d = case d of 132 | DebugGeneric -> "generic" 133 | DebugBroker -> "broker" 134 | DebugTopic -> "topic" 135 | DebugMetadata -> "metadata" 136 | DebugQueue -> "queue" 137 | DebugMsg -> "msg" 138 | DebugProtocol -> "protocol" 139 | DebugCgrp -> "cgrp" 140 | DebugSecurity -> "security" 141 | DebugFetch -> "fetch" 142 | DebugFeature -> "feature" 143 | DebugAll -> "all" 144 | 145 | -- | Compression codec used by a topic 146 | -- 147 | -- See 148 | data KafkaCompressionCodec = 149 | NoCompression 150 | | Gzip 151 | | Snappy 152 | | Lz4 153 | | Zstd 154 | deriving (Eq, Show, Typeable, Generic) 155 | 156 | -- | Convert a 'KafkaCompressionCodec' into its /librdkafka/ string equivalent. 157 | -- 158 | -- This is used internally by the library but may be useful to some developers. 159 | kafkaCompressionCodecToText :: KafkaCompressionCodec -> Text 160 | kafkaCompressionCodecToText c = case c of 161 | NoCompression -> "none" 162 | Gzip -> "gzip" 163 | Snappy -> "snappy" 164 | Lz4 -> "lz4" 165 | Zstd -> "zstd" 166 | 167 | -- | Headers that might be passed along with a record 168 | newtype Headers = Headers { unHeaders :: [(BS.ByteString, BS.ByteString)] } 169 | deriving (Eq, Show, Semigroup, Monoid, Read, Typeable, Generic) 170 | 171 | headersFromList :: [(BS.ByteString, BS.ByteString)] -> Headers 172 | headersFromList = Headers 173 | 174 | headersToList :: Headers -> [(BS.ByteString, BS.ByteString)] 175 | headersToList = unHeaders -------------------------------------------------------------------------------- /.stylish-haskell.yaml: -------------------------------------------------------------------------------- 1 | # stylish-haskell configuration file 2 | # ================================== 3 | 4 | # The stylish-haskell tool is mainly configured by specifying steps. These steps 5 | # are a list, so they have an order, and one specific step may appear more than 6 | # once (if needed). Each file is processed by these steps in the given order. 7 | steps: 8 | # Convert some ASCII sequences to their Unicode equivalents. This is disabled 9 | # by default. 10 | # - unicode_syntax: 11 | # # In order to make this work, we also need to insert the UnicodeSyntax 12 | # # language pragma. If this flag is set to true, we insert it when it's 13 | # # not already present. You may want to disable it if you configure 14 | # # language extensions using some other method than pragmas. Default: 15 | # # true. 16 | # add_language_pragma: true 17 | 18 | # Align the right hand side of some elements. This is quite conservative 19 | # and only applies to statements where each element occupies a single 20 | # line. 21 | - simple_align: 22 | cases: true 23 | top_level_patterns: true 24 | records: true 25 | 26 | # Import cleanup 27 | - imports: 28 | # There are different ways we can align names and lists. 29 | # 30 | # - global: Align the import names and import list throughout the entire 31 | # file. 32 | # 33 | # - file: Like global, but don't add padding when there are no qualified 34 | # imports in the file. 35 | # 36 | # - group: Only align the imports per group (a group is formed by adjacent 37 | # import lines). 38 | # 39 | # - none: Do not perform any alignment. 40 | # 41 | # Default: global. 42 | align: group 43 | 44 | # Folowing options affect only import list alignment. 45 | # 46 | # List align has following options: 47 | # 48 | # - after_alias: Import list is aligned with end of import including 49 | # 'as' and 'hiding' keywords. 50 | # 51 | # > import qualified Data.List as List (concat, foldl, foldr, head, 52 | # > init, last, length) 53 | # 54 | # - with_alias: Import list is aligned with start of alias or hiding. 55 | # 56 | # > import qualified Data.List as List (concat, foldl, foldr, head, 57 | # > init, last, length) 58 | # 59 | # - new_line: Import list starts always on new line. 60 | # 61 | # > import qualified Data.List as List 62 | # > (concat, foldl, foldr, head, init, last, length) 63 | # 64 | # Default: after_alias 65 | list_align: after_alias 66 | 67 | # Long list align style takes effect when import is too long. This is 68 | # determined by 'columns' setting. 69 | # 70 | # - inline: This option will put as much specs on same line as possible. 71 | # 72 | # - new_line: Import list will start on new line. 73 | # 74 | # - new_line_multiline: Import list will start on new line when it's 75 | # short enough to fit to single line. Otherwise it'll be multiline. 76 | # 77 | # - multiline: One line per import list entry. 78 | # Type with contructor list acts like single import. 79 | # 80 | # > import qualified Data.Map as M 81 | # > ( empty 82 | # > , singleton 83 | # > , ... 84 | # > , delete 85 | # > ) 86 | # 87 | # Default: inline 88 | long_list_align: inline 89 | 90 | # Align empty list (importing instances) 91 | # 92 | # Empty list align has following options 93 | # 94 | # - inherit: inherit list_align setting 95 | # 96 | # - right_after: () is right after the module name: 97 | # 98 | # > import Vector.Instances () 99 | # 100 | # Default: inherit 101 | empty_list_align: inherit 102 | 103 | # List padding determines indentation of import list on lines after import. 104 | # This option affects 'long_list_align'. 105 | # 106 | # - : constant value 107 | # 108 | # - module_name: align under start of module name. 109 | # Useful for 'file' and 'group' align settings. 110 | list_padding: 4 111 | 112 | # Separate lists option affects formating of import list for type 113 | # or class. The only difference is single space between type and list 114 | # of constructors, selectors and class functions. 115 | # 116 | # - true: There is single space between Foldable type and list of it's 117 | # functions. 118 | # 119 | # > import Data.Foldable (Foldable (fold, foldl, foldMap)) 120 | # 121 | # - false: There is no space between Foldable type and list of it's 122 | # functions. 123 | # 124 | # > import Data.Foldable (Foldable(fold, foldl, foldMap)) 125 | # 126 | # Default: true 127 | separate_lists: true 128 | 129 | # Language pragmas 130 | - language_pragmas: 131 | # We can generate different styles of language pragma lists. 132 | # 133 | # - vertical: Vertical-spaced language pragmas, one per line. 134 | # 135 | # - compact: A more compact style. 136 | # 137 | # - compact_line: Similar to compact, but wrap each line with 138 | # `{-#LANGUAGE #-}'. 139 | # 140 | # Default: vertical. 141 | style: vertical 142 | 143 | # Align affects alignment of closing pragma brackets. 144 | # 145 | # - true: Brackets are aligned in same collumn. 146 | # 147 | # - false: Brackets are not aligned together. There is only one space 148 | # between actual import and closing bracket. 149 | # 150 | # Default: true 151 | align: true 152 | 153 | # stylish-haskell can detect redundancy of some language pragmas. If this 154 | # is set to true, it will remove those redundant pragmas. Default: true. 155 | remove_redundant: true 156 | 157 | # Replace tabs by spaces. This is disabled by default. 158 | # - tabs: 159 | # # Number of spaces to use for each tab. Default: 8, as specified by the 160 | # # Haskell report. 161 | # spaces: 8 162 | 163 | # Remove trailing whitespace 164 | - trailing_whitespace: {} 165 | 166 | # A common setting is the number of columns (parts of) code will be wrapped 167 | # to. Different steps take this into account. Default: 80. 168 | columns: 800 169 | 170 | # By default, line endings are converted according to the OS. You can override 171 | # preferred format here. 172 | # 173 | # - native: Native newline format. CRLF on Windows, LF on other OSes. 174 | # 175 | # - lf: Convert to LF ("\n"). 176 | # 177 | # - crlf: Convert to CRLF ("\r\n"). 178 | # 179 | # Default: native. 180 | newline: native 181 | 182 | # Sometimes, language extensions are specified in a cabal file or from the 183 | # command line instead of using language pragmas in the file. stylish-haskell 184 | # needs to be aware of these, so it can parse the file correctly. 185 | # 186 | # No language extensions are enabled by default. 187 | # language_extensions: 188 | # - TemplateHaskell 189 | # - QuasiQuotes 190 | -------------------------------------------------------------------------------- /src/Kafka/Consumer/ConsumerProperties.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | ----------------------------------------------------------------------------- 4 | -- | 5 | -- Module with consumer properties types and functions. 6 | ----------------------------------------------------------------------------- 7 | module Kafka.Consumer.ConsumerProperties 8 | ( ConsumerProperties(..) 9 | , CallbackPollMode(..) 10 | , brokersList 11 | , autoCommit 12 | , noAutoCommit 13 | , noAutoOffsetStore 14 | , groupId 15 | , clientId 16 | , setCallback 17 | , logLevel 18 | , compression 19 | , suppressDisconnectLogs 20 | , statisticsInterval 21 | , extraProps 22 | , extraProp 23 | , debugOptions 24 | , queuedMaxMessagesKBytes 25 | , callbackPollMode 26 | , module X 27 | ) 28 | where 29 | 30 | import Control.Monad (MonadPlus (mplus)) 31 | import Data.Map (Map) 32 | import qualified Data.Map as M 33 | import Data.Semigroup as Sem 34 | import Data.Text (Text) 35 | import qualified Data.Text as Text 36 | import Kafka.Consumer.Types (ConsumerGroupId (..)) 37 | import Kafka.Types (BrokerAddress (..), ClientId (..), KafkaCompressionCodec (..), KafkaDebug (..), KafkaLogLevel (..), Millis (..), kafkaCompressionCodecToText, kafkaDebugToText) 38 | 39 | import Kafka.Consumer.Callbacks as X 40 | 41 | -- | Whether the callback polling should be done synchronously or not. 42 | data CallbackPollMode = 43 | -- | You have to poll the consumer frequently to handle new messages 44 | -- as well as rebalance and keep alive events. 45 | -- This enables lowering the footprint and having full control over when polling 46 | -- happens, at the cost of manually managing those events. 47 | CallbackPollModeSync 48 | -- | Handle polling rebalance and keep alive events for you in a background thread. 49 | | CallbackPollModeAsync deriving (Show, Eq) 50 | 51 | -- | Properties to create 'Kafka.Consumer.Types.KafkaConsumer'. 52 | data ConsumerProperties = ConsumerProperties 53 | { cpProps :: Map Text Text 54 | , cpLogLevel :: Maybe KafkaLogLevel 55 | , cpCallbacks :: [Callback] 56 | , cpCallbackPollMode :: CallbackPollMode 57 | } 58 | 59 | instance Sem.Semigroup ConsumerProperties where 60 | (ConsumerProperties m1 ll1 cb1 _) <> (ConsumerProperties m2 ll2 cb2 cup2) = 61 | ConsumerProperties (M.union m2 m1) (ll2 `mplus` ll1) (cb1 `mplus` cb2) cup2 62 | {-# INLINE (<>) #-} 63 | 64 | -- | /Right biased/ so we prefer newer properties over older ones. 65 | instance Monoid ConsumerProperties where 66 | mempty = ConsumerProperties 67 | { cpProps = M.empty 68 | , cpLogLevel = Nothing 69 | , cpCallbacks = [] 70 | , cpCallbackPollMode = CallbackPollModeAsync 71 | } 72 | {-# INLINE mempty #-} 73 | mappend = (Sem.<>) 74 | {-# INLINE mappend #-} 75 | 76 | -- | Set the to contact to connect to the Kafka cluster. 77 | brokersList :: [BrokerAddress] -> ConsumerProperties 78 | brokersList bs = 79 | let bs' = Text.intercalate "," (unBrokerAddress <$> bs) 80 | in extraProps $ M.fromList [("bootstrap.servers", bs')] 81 | 82 | -- | Set the and enables . 83 | autoCommit :: Millis -> ConsumerProperties 84 | autoCommit (Millis ms) = extraProps $ 85 | M.fromList 86 | [ ("enable.auto.commit", "true") 87 | , ("auto.commit.interval.ms", Text.pack $ show ms) 88 | ] 89 | 90 | -- | Disable for the consumer. 91 | noAutoCommit :: ConsumerProperties 92 | noAutoCommit = 93 | extraProps $ M.fromList [("enable.auto.commit", "false")] 94 | 95 | -- | Disable auto offset store for the consumer. 96 | -- 97 | -- See for more information. 98 | noAutoOffsetStore :: ConsumerProperties 99 | noAutoOffsetStore = 100 | extraProps $ M.fromList [("enable.auto.offset.store", "false")] 101 | 102 | -- | Set the consumer . 103 | groupId :: ConsumerGroupId -> ConsumerProperties 104 | groupId (ConsumerGroupId cid) = 105 | extraProps $ M.fromList [("group.id", cid)] 106 | 107 | -- | Set the . 108 | clientId :: ClientId -> ConsumerProperties 109 | clientId (ClientId cid) = 110 | extraProps $ M.fromList [("client.id", cid)] 111 | 112 | -- | Set the consumer callback. 113 | -- 114 | -- For examples of use, see: 115 | -- 116 | -- * 'errorCallback' 117 | -- * 'logCallback' 118 | -- * 'statsCallback' 119 | setCallback :: Callback -> ConsumerProperties 120 | setCallback cb = mempty { cpCallbacks = [cb] } 121 | 122 | -- | Set the logging level. 123 | -- Usually is used with 'debugOptions' to configure which logs are needed. 124 | logLevel :: KafkaLogLevel -> ConsumerProperties 125 | logLevel ll = mempty { cpLogLevel = Just ll } 126 | 127 | -- | Set the for the consumer. 128 | compression :: KafkaCompressionCodec -> ConsumerProperties 129 | compression c = 130 | extraProps $ M.singleton "compression.codec" (kafkaCompressionCodecToText c) 131 | 132 | -- | Suppresses consumer . 133 | -- 134 | -- It might be useful to turn this off when interacting with brokers 135 | -- with an aggressive @connection.max.idle.ms@ value. 136 | suppressDisconnectLogs :: ConsumerProperties 137 | suppressDisconnectLogs = 138 | extraProps $ M.fromList [("log.connection.close", "false")] 139 | 140 | -- | Set the for the producer. 141 | statisticsInterval :: Millis -> ConsumerProperties 142 | statisticsInterval (Millis t) = 143 | extraProps $ M.singleton "statistics.interval.ms" (Text.pack $ show t) 144 | 145 | -- | Set any configuration options that are supported by /librdkafka/. 146 | -- The full list can be found 147 | extraProps :: Map Text Text -> ConsumerProperties 148 | extraProps m = mempty { cpProps = m } 149 | {-# INLINE extraProps #-} 150 | 151 | -- | Set any configuration option that is supported by /librdkafka/. 152 | -- The full list can be found 153 | extraProp :: Text -> Text -> ConsumerProperties 154 | extraProp k v = mempty { cpProps = M.singleton k v } 155 | {-# INLINE extraProp #-} 156 | 157 | -- | Set features for the consumer. 158 | -- Usually is used with 'logLevel'. 159 | debugOptions :: [KafkaDebug] -> ConsumerProperties 160 | debugOptions [] = extraProps M.empty 161 | debugOptions d = 162 | let points = Text.intercalate "," (kafkaDebugToText <$> d) 163 | in extraProps $ M.fromList [("debug", points)] 164 | 165 | -- | Set 166 | queuedMaxMessagesKBytes :: Int -> ConsumerProperties 167 | queuedMaxMessagesKBytes kBytes = 168 | extraProp "queued.max.messages.kbytes" (Text.pack $ show kBytes) 169 | {-# INLINE queuedMaxMessagesKBytes #-} 170 | 171 | -- | Set the callback poll mode. Default value is 'CallbackPollModeAsync'. 172 | callbackPollMode :: CallbackPollMode -> ConsumerProperties 173 | callbackPollMode mode = mempty { cpCallbackPollMode = mode } 174 | -------------------------------------------------------------------------------- /src/Kafka/Consumer/Convert.hs: -------------------------------------------------------------------------------- 1 | module Kafka.Consumer.Convert 2 | ( offsetSyncToInt 3 | , offsetToInt64 4 | , int64ToOffset 5 | , fromNativeTopicPartitionList'' 6 | , fromNativeTopicPartitionList' 7 | , fromNativeTopicPartitionList 8 | , toNativeTopicPartitionList 9 | , toNativeTopicPartitionListNoDispose 10 | , toNativeTopicPartitionList' 11 | , topicPartitionFromMessage 12 | , topicPartitionFromMessageForCommit 13 | , toMap 14 | , fromMessagePtr 15 | , offsetCommitToBool 16 | ) 17 | where 18 | 19 | import Control.Monad ((>=>)) 20 | import qualified Data.ByteString as BS 21 | import Data.Either (fromRight) 22 | import Data.Int (Int64) 23 | import Data.Map.Strict (Map, fromListWith) 24 | import qualified Data.Set as S 25 | import qualified Data.Text as Text 26 | import Foreign.Ptr (Ptr, nullPtr) 27 | import Foreign.ForeignPtr (withForeignPtr) 28 | import Foreign.Storable (Storable(..)) 29 | import Foreign.C.Error (getErrno) 30 | import Kafka.Consumer.Types (ConsumerRecord(..), TopicPartition(..), Offset(..), OffsetCommit(..), PartitionOffset(..), OffsetStoreSync(..)) 31 | import Kafka.Internal.RdKafka 32 | ( RdKafkaRespErrT(..) 33 | , RdKafkaMessageT(..) 34 | , RdKafkaTopicPartitionListTPtr 35 | , RdKafkaTopicPartitionListT(..) 36 | , RdKafkaMessageTPtr 37 | , RdKafkaTopicPartitionT(..) 38 | , rdKafkaTopicPartitionListAdd 39 | , newRdKafkaTopicPartitionListT 40 | , rdKafkaMessageDestroy 41 | , rdKafkaTopicPartitionListSetOffset 42 | , rdKafkaTopicPartitionListNew 43 | , peekCText 44 | ) 45 | import Kafka.Internal.Shared (kafkaRespErr, readHeaders, readTopic, readKey, readPayload, readTimestamp) 46 | import Kafka.Types (KafkaError(..), PartitionId(..), TopicName(..)) 47 | 48 | -- | Converts offsets sync policy to integer (the way Kafka understands it): 49 | -- 50 | -- * @OffsetSyncDisable == -1@ 51 | -- 52 | -- * @OffsetSyncImmediate == 0@ 53 | -- 54 | -- * @OffsetSyncInterval ms == ms@ 55 | offsetSyncToInt :: OffsetStoreSync -> Int 56 | offsetSyncToInt sync = 57 | case sync of 58 | OffsetSyncDisable -> -1 59 | OffsetSyncImmediate -> 0 60 | OffsetSyncInterval ms -> ms 61 | {-# INLINE offsetSyncToInt #-} 62 | 63 | offsetToInt64 :: PartitionOffset -> Int64 64 | offsetToInt64 o = case o of 65 | PartitionOffsetBeginning -> -2 66 | PartitionOffsetEnd -> -1 67 | PartitionOffset off -> off 68 | PartitionOffsetStored -> -1000 69 | PartitionOffsetInvalid -> -1001 70 | {-# INLINE offsetToInt64 #-} 71 | 72 | int64ToOffset :: Int64 -> PartitionOffset 73 | int64ToOffset o 74 | | o == -2 = PartitionOffsetBeginning 75 | | o == -1 = PartitionOffsetEnd 76 | | o == -1000 = PartitionOffsetStored 77 | | o >= 0 = PartitionOffset o 78 | | otherwise = PartitionOffsetInvalid 79 | {-# INLINE int64ToOffset #-} 80 | 81 | fromNativeTopicPartitionList'' :: RdKafkaTopicPartitionListTPtr -> IO [TopicPartition] 82 | fromNativeTopicPartitionList'' ptr = 83 | withForeignPtr ptr $ \fptr -> fromNativeTopicPartitionList' fptr 84 | 85 | fromNativeTopicPartitionList' :: Ptr RdKafkaTopicPartitionListT -> IO [TopicPartition] 86 | fromNativeTopicPartitionList' ppl = 87 | if ppl == nullPtr 88 | then return [] 89 | else peek ppl >>= fromNativeTopicPartitionList 90 | 91 | fromNativeTopicPartitionList :: RdKafkaTopicPartitionListT -> IO [TopicPartition] 92 | fromNativeTopicPartitionList pl = 93 | let count = cnt'RdKafkaTopicPartitionListT pl 94 | elems = elems'RdKafkaTopicPartitionListT pl 95 | in mapM (peekElemOff elems >=> toPart) [0..(fromIntegral count - 1)] 96 | where 97 | toPart :: RdKafkaTopicPartitionT -> IO TopicPartition 98 | toPart p = do 99 | topic <- peekCText $ topic'RdKafkaTopicPartitionT p 100 | return TopicPartition { 101 | tpTopicName = TopicName topic, 102 | tpPartition = PartitionId $ partition'RdKafkaTopicPartitionT p, 103 | tpOffset = int64ToOffset $ offset'RdKafkaTopicPartitionT p 104 | } 105 | 106 | toNativeTopicPartitionList :: [TopicPartition] -> IO RdKafkaTopicPartitionListTPtr 107 | toNativeTopicPartitionList ps = do 108 | pl <- newRdKafkaTopicPartitionListT (length ps) 109 | mapM_ (\p -> do 110 | let TopicName tn = tpTopicName p 111 | (PartitionId tp) = tpPartition p 112 | to = offsetToInt64 $ tpOffset p 113 | tnS = Text.unpack tn 114 | _ <- rdKafkaTopicPartitionListAdd pl tnS tp 115 | rdKafkaTopicPartitionListSetOffset pl tnS tp to) ps 116 | return pl 117 | 118 | toNativeTopicPartitionListNoDispose :: [TopicPartition] -> IO RdKafkaTopicPartitionListTPtr 119 | toNativeTopicPartitionListNoDispose ps = do 120 | pl <- rdKafkaTopicPartitionListNew (length ps) 121 | mapM_ (\p -> do 122 | let TopicName tn = tpTopicName p 123 | (PartitionId tp) = tpPartition p 124 | to = offsetToInt64 $ tpOffset p 125 | tnS = Text.unpack tn 126 | _ <- rdKafkaTopicPartitionListAdd pl tnS tp 127 | rdKafkaTopicPartitionListSetOffset pl tnS tp to) ps 128 | return pl 129 | 130 | toNativeTopicPartitionList' :: [(TopicName, PartitionId)] -> IO RdKafkaTopicPartitionListTPtr 131 | toNativeTopicPartitionList' tps = do 132 | let utps = S.toList . S.fromList $ tps 133 | pl <- newRdKafkaTopicPartitionListT (length utps) 134 | mapM_ (\(TopicName t, PartitionId p) -> rdKafkaTopicPartitionListAdd pl (Text.unpack t) p) utps 135 | return pl 136 | 137 | topicPartitionFromMessage :: ConsumerRecord k v -> TopicPartition 138 | topicPartitionFromMessage m = 139 | let (Offset moff) = crOffset m 140 | in TopicPartition (crTopic m) (crPartition m) (PartitionOffset moff) 141 | 142 | -- | Creates a topic partition message for use with the offset commit message. 143 | -- We increment the offset by 1 here because when we commit, the offset is the position 144 | -- the consumer reads from to process the next message. 145 | topicPartitionFromMessageForCommit :: ConsumerRecord k v -> TopicPartition 146 | topicPartitionFromMessageForCommit m = 147 | case topicPartitionFromMessage m of 148 | (TopicPartition t p (PartitionOffset moff)) -> TopicPartition t p (PartitionOffset $ moff + 1) 149 | other -> other 150 | 151 | toMap :: Ord k => [(k, v)] -> Map k [v] 152 | toMap kvs = fromListWith (++) [(k, [v]) | (k, v) <- kvs] 153 | 154 | fromMessagePtr :: RdKafkaMessageTPtr -> IO (Either KafkaError (ConsumerRecord (Maybe BS.ByteString) (Maybe BS.ByteString))) 155 | fromMessagePtr ptr = 156 | withForeignPtr ptr $ \realPtr -> 157 | if realPtr == nullPtr then Left . kafkaRespErr <$> getErrno 158 | else do 159 | s <- peek realPtr 160 | msg <- if err'RdKafkaMessageT s /= RdKafkaRespErrNoError 161 | then return . Left . KafkaResponseError $ err'RdKafkaMessageT s 162 | else Right <$> mkRecord s realPtr 163 | rdKafkaMessageDestroy realPtr 164 | return msg 165 | where 166 | mkRecord msg rptr = do 167 | topic <- readTopic msg 168 | key <- readKey msg 169 | payload <- readPayload msg 170 | timestamp <- readTimestamp ptr 171 | headers <- fromRight mempty <$> readHeaders rptr 172 | return ConsumerRecord 173 | { crTopic = TopicName topic 174 | , crPartition = PartitionId $ partition'RdKafkaMessageT msg 175 | , crOffset = Offset $ offset'RdKafkaMessageT msg 176 | , crTimestamp = timestamp 177 | , crHeaders = headers 178 | , crKey = key 179 | , crValue = payload 180 | } 181 | 182 | offsetCommitToBool :: OffsetCommit -> Bool 183 | offsetCommitToBool OffsetCommit = False 184 | offsetCommitToBool OffsetCommitAsync = True 185 | -------------------------------------------------------------------------------- /src/Kafka/Producer.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TupleSections #-} 2 | {-# LANGUAGE LambdaCase #-} 3 | 4 | ----------------------------------------------------------------------------- 5 | -- | 6 | -- Module to produce messages to Kafka topics. 7 | -- 8 | -- Here's an example of code to produce messages to a topic: 9 | -- 10 | -- @ 11 | -- import Control.Exception (bracket) 12 | -- import Control.Monad (forM_) 13 | -- import Data.ByteString (ByteString) 14 | -- import Kafka.Producer 15 | -- 16 | -- -- Global producer properties 17 | -- producerProps :: 'ProducerProperties' 18 | -- producerProps = 'brokersList' ["localhost:9092"] 19 | -- <> 'logLevel' 'KafkaLogDebug' 20 | -- 21 | -- -- Topic to send messages to 22 | -- targetTopic :: 'TopicName' 23 | -- targetTopic = 'TopicName' "kafka-client-example-topic" 24 | -- 25 | -- -- Run an example 26 | -- runProducerExample :: IO () 27 | -- runProducerExample = 28 | -- bracket mkProducer clProducer runHandler >>= print 29 | -- where 30 | -- mkProducer = 'newProducer' producerProps 31 | -- clProducer (Left _) = pure () 32 | -- clProducer (Right prod) = 'closeProducer' prod 33 | -- runHandler (Left err) = pure $ Left err 34 | -- runHandler (Right prod) = sendMessages prod 35 | -- 36 | -- -- Example sending 2 messages and printing the response from Kafka 37 | -- sendMessages :: 'KafkaProducer' -> IO (Either 'KafkaError' ()) 38 | -- sendMessages prod = do 39 | -- err1 <- 'produceMessage' prod (mkMessage Nothing (Just "test from producer") ) 40 | -- forM_ err1 print 41 | -- 42 | -- err2 <- 'produceMessage' prod (mkMessage (Just "key") (Just "test from producer (with key)")) 43 | -- forM_ err2 print 44 | -- 45 | -- pure $ Right () 46 | -- 47 | -- mkMessage :: Maybe ByteString -> Maybe ByteString -> 'ProducerRecord' 48 | -- mkMessage k v = 'ProducerRecord' 49 | -- { 'prTopic' = targetTopic 50 | -- , 'prPartition' = 'UnassignedPartition' 51 | -- , 'prKey' = k 52 | -- , 'prValue' = v 53 | -- } 54 | -- @ 55 | ----------------------------------------------------------------------------- 56 | module Kafka.Producer 57 | ( KafkaProducer 58 | , module X 59 | , runProducer 60 | , newProducer 61 | , produceMessage 62 | , produceMessage' 63 | , flushProducer 64 | , closeProducer 65 | , RdKafkaRespErrT (..) 66 | ) 67 | where 68 | 69 | import Control.Exception (bracket) 70 | import Control.Monad (forM_) 71 | import Control.Monad.IO.Class (MonadIO (liftIO)) 72 | import qualified Data.ByteString as BS 73 | import qualified Data.ByteString.Internal as BSI 74 | import qualified Data.Text as Text 75 | import Foreign.C.String (withCString) 76 | import Foreign.ForeignPtr (withForeignPtr) 77 | import Foreign.Marshal.Utils (withMany) 78 | import Foreign.Ptr (Ptr, nullPtr, plusPtr) 79 | import Foreign.StablePtr (newStablePtr, castStablePtrToPtr) 80 | import Kafka.Internal.RdKafka (RdKafkaRespErrT (..), RdKafkaTypeT (..), RdKafkaVuT(..), newRdKafkaT, rdKafkaErrorCode, rdKafkaErrorDestroy, rdKafkaOutqLen, rdKafkaMessageProduceVa, rdKafkaSetLogLevel) 81 | import Kafka.Internal.Setup (Kafka (..), KafkaConf (..), KafkaProps (..), TopicProps (..), kafkaConf, topicConf, Callback(..)) 82 | import Kafka.Internal.Shared (pollEvents) 83 | import Kafka.Producer.Convert (copyMsgFlags, handleProduceErrT, producePartitionCInt) 84 | import Kafka.Producer.Types (KafkaProducer (..)) 85 | 86 | 87 | import Kafka.Producer.ProducerProperties as X 88 | import Kafka.Producer.Types as X hiding (KafkaProducer) 89 | import Kafka.Types as X 90 | 91 | -- | Runs Kafka Producer. 92 | -- The callback provided is expected to call 'produceMessage' 93 | -- to send messages to Kafka. 94 | {-# DEPRECATED runProducer "Use 'newProducer'/'closeProducer' instead" #-} 95 | runProducer :: ProducerProperties 96 | -> (KafkaProducer -> IO (Either KafkaError a)) 97 | -> IO (Either KafkaError a) 98 | runProducer props f = 99 | bracket mkProducer clProducer runHandler 100 | where 101 | mkProducer = newProducer props 102 | 103 | clProducer (Left _) = return () 104 | clProducer (Right prod) = closeProducer prod 105 | 106 | runHandler (Left err) = return $ Left err 107 | runHandler (Right prod) = f prod 108 | 109 | -- | Creates a new kafka producer 110 | -- A newly created producer must be closed with 'closeProducer' function. 111 | newProducer :: MonadIO m => ProducerProperties -> m (Either KafkaError KafkaProducer) 112 | newProducer pps = liftIO $ do 113 | kc@(KafkaConf kc' _ _) <- kafkaConf (KafkaProps $ (ppKafkaProps pps)) 114 | tc <- topicConf (TopicProps $ (ppTopicProps pps)) 115 | 116 | -- add default delivery report callback 117 | let Callback setDeliveryCallback = deliveryCallback (const mempty) 118 | setDeliveryCallback kc 119 | 120 | -- set callbacks 121 | forM_ (ppCallbacks pps) (\(Callback setCb) -> setCb kc) 122 | 123 | mbKafka <- newRdKafkaT RdKafkaProducer kc' 124 | case mbKafka of 125 | Left err -> return . Left $ KafkaError err 126 | Right kafka -> do 127 | forM_ (ppLogLevel pps) (rdKafkaSetLogLevel kafka . fromEnum) 128 | let prod = KafkaProducer (Kafka kafka) kc tc 129 | return (Right prod) 130 | 131 | -- | Sends a single message. 132 | -- Since librdkafka is backed by a queue, this function can return before messages are sent. See 133 | -- 'flushProducer' to wait for queue to empty. 134 | produceMessage :: MonadIO m 135 | => KafkaProducer 136 | -> ProducerRecord 137 | -> m (Maybe KafkaError) 138 | produceMessage kp m = produceMessage' kp m (pure . mempty) >>= adjustRes 139 | where 140 | adjustRes = \case 141 | Right () -> pure Nothing 142 | Left (ImmediateError err) -> pure (Just err) 143 | 144 | -- | Sends a single message with a registered callback. 145 | -- 146 | -- The callback can be a long running process, as it is forked by the thread 147 | -- that handles the delivery reports. 148 | produceMessage' :: MonadIO m 149 | => KafkaProducer 150 | -> ProducerRecord 151 | -> (DeliveryReport -> IO ()) 152 | -> m (Either ImmediateError ()) 153 | produceMessage' kp@(KafkaProducer (Kafka k) _ _) msg cb = liftIO $ 154 | fireCallbacks >> produceIt 155 | where 156 | fireCallbacks = 157 | pollEvents kp . Just . Timeout $ 0 158 | 159 | produceIt = 160 | withBS (prValue msg) $ \payloadPtr payloadLength -> 161 | withBS (prKey msg) $ \keyPtr keyLength -> 162 | withHeaders (prHeaders msg) $ \hdrs -> 163 | withCString (Text.unpack . unTopicName . prTopic $ msg) $ \topicName -> do 164 | callbackPtr <- newStablePtr cb 165 | let opts = [ 166 | Topic'RdKafkaVu topicName 167 | , Partition'RdKafkaVu . producePartitionCInt . prPartition $ msg 168 | , MsgFlags'RdKafkaVu (fromIntegral copyMsgFlags) 169 | , Value'RdKafkaVu payloadPtr (fromIntegral payloadLength) 170 | , Key'RdKafkaVu keyPtr (fromIntegral keyLength) 171 | , Opaque'RdKafkaVu (castStablePtrToPtr callbackPtr) 172 | ] 173 | 174 | code <- bracket (rdKafkaMessageProduceVa k (hdrs ++ opts)) rdKafkaErrorDestroy rdKafkaErrorCode 175 | res <- handleProduceErrT code 176 | pure $ case res of 177 | Just err -> Left . ImmediateError $ err 178 | Nothing -> Right () 179 | 180 | -- | Closes the producer. 181 | -- Will wait until the outbound queue is drained before returning the control. 182 | closeProducer :: MonadIO m => KafkaProducer -> m () 183 | closeProducer = flushProducer 184 | 185 | -- | Drains the outbound queue for a producer. 186 | -- This function is also called automatically when the producer is closed 187 | -- with 'closeProducer' to ensure that all queued messages make it to Kafka. 188 | flushProducer :: MonadIO m => KafkaProducer -> m () 189 | flushProducer kp = liftIO $ do 190 | pollEvents kp (Just $ Timeout 100) 191 | l <- outboundQueueLength (kpKafkaPtr kp) 192 | if (l == 0) 193 | then pollEvents kp (Just $ Timeout 0) -- to be sure that all the delivery reports are fired 194 | else flushProducer kp 195 | ------------------------------------------------------------------------------------ 196 | 197 | withHeaders :: Headers -> ([RdKafkaVuT] -> IO a) -> IO a 198 | withHeaders hds = withMany allocHeader (headersToList hds) 199 | where 200 | allocHeader (nm, val) f = 201 | BS.useAsCString nm $ \cnm -> 202 | withBS (Just val) $ \vp vl -> 203 | f $ Header'RdKafkaVu cnm vp (fromIntegral vl) 204 | 205 | withBS :: Maybe BS.ByteString -> (Ptr a -> Int -> IO b) -> IO b 206 | withBS Nothing f = f nullPtr 0 207 | withBS (Just bs) f = 208 | let (d, o, l) = BSI.toForeignPtr bs 209 | in withForeignPtr d $ \p -> f (p `plusPtr` o) l 210 | 211 | outboundQueueLength :: Kafka -> IO Int 212 | outboundQueueLength (Kafka k) = rdKafkaOutqLen k 213 | -------------------------------------------------------------------------------- /src/Kafka/Consumer/Types.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveDataTypeable #-} 2 | {-# LANGUAGE DeriveGeneric #-} 3 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 4 | 5 | ----------------------------------------------------------------------------- 6 | -- | 7 | -- Module holding consumer types. 8 | ----------------------------------------------------------------------------- 9 | module Kafka.Consumer.Types 10 | ( KafkaConsumer(..) 11 | , ConsumerGroupId(..) 12 | , Offset(..) 13 | , OffsetReset(..) 14 | , RebalanceEvent(..) 15 | , PartitionOffset(..) 16 | , SubscribedPartitions(..) 17 | , Timestamp(..) 18 | , OffsetCommit(..) 19 | , OffsetStoreSync(..) 20 | , OffsetStoreMethod(..) 21 | , TopicPartition(..) 22 | , ConsumerRecord(..) 23 | , crMapKey 24 | , crMapValue 25 | , crMapKV 26 | -- why are these here? 27 | 28 | -- * Deprecated 29 | , sequenceFirst 30 | , traverseFirst 31 | , traverseFirstM 32 | , traverseM 33 | , bitraverseM 34 | ) 35 | where 36 | 37 | import Data.Bifoldable (Bifoldable (..)) 38 | import Data.Bifunctor (Bifunctor (..)) 39 | import Data.Bitraversable (Bitraversable (..), bimapM, bisequence) 40 | import Data.Int (Int64) 41 | import Data.String (IsString) 42 | import Data.Text (Text) 43 | import Data.Typeable (Typeable) 44 | import GHC.Generics (Generic) 45 | import Kafka.Internal.Setup (HasKafka (..), HasKafkaConf (..), Kafka (..), KafkaConf (..)) 46 | import Kafka.Types (Millis (..), PartitionId (..), TopicName (..), Headers) 47 | 48 | -- | The main type for Kafka consumption, used e.g. to poll and commit messages. 49 | -- 50 | -- Its constructor is intentionally not exposed, instead, one should use 'Kafka.Consumer.newConsumer' to acquire such a value. 51 | data KafkaConsumer = KafkaConsumer 52 | { kcKafkaPtr :: !Kafka 53 | , kcKafkaConf :: !KafkaConf 54 | } 55 | 56 | instance HasKafka KafkaConsumer where 57 | getKafka = kcKafkaPtr 58 | {-# INLINE getKafka #-} 59 | 60 | instance HasKafkaConf KafkaConsumer where 61 | getKafkaConf = kcKafkaConf 62 | {-# INLINE getKafkaConf #-} 63 | 64 | -- | Consumer group ID. Different consumers with the same consumer group ID will get assigned different partitions of each subscribed topic. 65 | -- 66 | -- See 67 | newtype ConsumerGroupId = ConsumerGroupId 68 | { unConsumerGroupId :: Text 69 | } deriving (Show, Ord, Eq, IsString, Generic) 70 | 71 | -- | A message offset in a partition 72 | newtype Offset = Offset { unOffset :: Int64 } deriving (Show, Eq, Ord, Read, Generic) 73 | 74 | -- | Where to reset the offset when there is no initial offset in Kafka 75 | -- 76 | -- See 77 | data OffsetReset = Earliest | Latest deriving (Show, Eq, Generic) 78 | 79 | -- | A set of events which happen during the rebalancing process 80 | data RebalanceEvent = 81 | -- | Happens before Kafka Client confirms new assignment 82 | RebalanceBeforeAssign [(TopicName, PartitionId)] 83 | -- | Happens after the new assignment is confirmed 84 | | RebalanceAssign [(TopicName, PartitionId)] 85 | -- | Happens before Kafka Client confirms partitions rejection 86 | | RebalanceBeforeRevoke [(TopicName, PartitionId)] 87 | -- | Happens after the rejection is confirmed 88 | | RebalanceRevoke [(TopicName, PartitionId)] 89 | deriving (Eq, Show, Generic) 90 | 91 | -- | The partition offset 92 | data PartitionOffset = 93 | PartitionOffsetBeginning 94 | | PartitionOffsetEnd 95 | | PartitionOffset Int64 96 | | PartitionOffsetStored 97 | | PartitionOffsetInvalid 98 | deriving (Eq, Show, Generic) 99 | 100 | -- | Partitions subscribed by a consumer 101 | data SubscribedPartitions 102 | = SubscribedPartitions [PartitionId] -- ^ Subscribe only to those partitions 103 | | SubscribedPartitionsAll -- ^ Subscribe to all partitions 104 | deriving (Show, Eq, Generic) 105 | 106 | -- | Consumer record timestamp 107 | data Timestamp = 108 | CreateTime !Millis 109 | | LogAppendTime !Millis 110 | | NoTimestamp 111 | deriving (Show, Eq, Read, Generic) 112 | 113 | -- | Offsets commit mode 114 | data OffsetCommit = 115 | OffsetCommit -- ^ Forces consumer to block until the broker offsets commit is done 116 | | OffsetCommitAsync -- ^ Offsets will be committed in a non-blocking way 117 | deriving (Show, Eq, Generic) 118 | 119 | 120 | -- | Indicates how offsets are to be synced to disk 121 | data OffsetStoreSync = 122 | OffsetSyncDisable -- ^ Do not sync offsets (in Kafka: -1) 123 | | OffsetSyncImmediate -- ^ Sync immediately after each offset commit (in Kafka: 0) 124 | | OffsetSyncInterval Int -- ^ Sync after specified interval in millis 125 | deriving (Show, Eq, Generic) 126 | 127 | -- | Indicates the method of storing the offsets 128 | data OffsetStoreMethod = 129 | OffsetStoreBroker -- ^ Offsets are stored in Kafka broker (preferred) 130 | | OffsetStoreFile FilePath OffsetStoreSync -- ^ Offsets are stored in a file (and synced to disk according to the sync policy) 131 | deriving (Show, Eq, Generic) 132 | 133 | -- | Kafka topic partition structure 134 | data TopicPartition = TopicPartition 135 | { tpTopicName :: TopicName 136 | , tpPartition :: PartitionId 137 | , tpOffset :: PartitionOffset 138 | } deriving (Show, Eq, Generic) 139 | 140 | -- | Represents a /received/ message from Kafka (i.e. used in a consumer) 141 | data ConsumerRecord k v = ConsumerRecord 142 | { crTopic :: !TopicName -- ^ Kafka topic this message was received from 143 | , crPartition :: !PartitionId -- ^ Kafka partition this message was received from 144 | , crOffset :: !Offset -- ^ Offset within the 'crPartition' Kafka partition 145 | , crTimestamp :: !Timestamp -- ^ Message timestamp 146 | , crHeaders :: !Headers -- ^ Message headers 147 | , crKey :: !k -- ^ Message key 148 | , crValue :: !v -- ^ Message value 149 | } 150 | deriving (Eq, Show, Read, Typeable, Generic) 151 | 152 | instance Bifunctor ConsumerRecord where 153 | bimap f g (ConsumerRecord t p o ts hds k v) = ConsumerRecord t p o ts hds (f k) (g v) 154 | {-# INLINE bimap #-} 155 | 156 | instance Functor (ConsumerRecord k) where 157 | fmap = second 158 | {-# INLINE fmap #-} 159 | 160 | instance Foldable (ConsumerRecord k) where 161 | foldMap f r = f (crValue r) 162 | {-# INLINE foldMap #-} 163 | 164 | instance Traversable (ConsumerRecord k) where 165 | traverse f r = (\v -> crMapValue (const v) r) <$> f (crValue r) 166 | {-# INLINE traverse #-} 167 | 168 | instance Bifoldable ConsumerRecord where 169 | bifoldMap f g r = f (crKey r) `mappend` g (crValue r) 170 | {-# INLINE bifoldMap #-} 171 | 172 | instance Bitraversable ConsumerRecord where 173 | bitraverse f g r = (\k v -> bimap (const k) (const v) r) <$> f (crKey r) <*> g (crValue r) 174 | {-# INLINE bitraverse #-} 175 | 176 | {-# DEPRECATED crMapKey "Isn't concern of this library. Use 'first'" #-} 177 | crMapKey :: (k -> k') -> ConsumerRecord k v -> ConsumerRecord k' v 178 | crMapKey = first 179 | {-# INLINE crMapKey #-} 180 | 181 | {-# DEPRECATED crMapValue "Isn't concern of this library. Use 'second'" #-} 182 | crMapValue :: (v -> v') -> ConsumerRecord k v -> ConsumerRecord k v' 183 | crMapValue = second 184 | {-# INLINE crMapValue #-} 185 | 186 | {-# DEPRECATED crMapKV "Isn't concern of this library. Use 'bimap'" #-} 187 | crMapKV :: (k -> k') -> (v -> v') -> ConsumerRecord k v -> ConsumerRecord k' v' 188 | crMapKV = bimap 189 | {-# INLINE crMapKV #-} 190 | 191 | {-# DEPRECATED sequenceFirst "Isn't concern of this library. Use @'bitraverse' 'id' 'pure'@" #-} 192 | sequenceFirst :: (Bitraversable t, Applicative f) => t (f k) v -> f (t k v) 193 | sequenceFirst = bitraverse id pure 194 | {-# INLINE sequenceFirst #-} 195 | 196 | {-# DEPRECATED traverseFirst "Isn't concern of this library. Use @'bitraverse' f 'pure'@" #-} 197 | traverseFirst :: (Bitraversable t, Applicative f) 198 | => (k -> f k') 199 | -> t k v 200 | -> f (t k' v) 201 | traverseFirst f = bitraverse f pure 202 | {-# INLINE traverseFirst #-} 203 | 204 | {-# DEPRECATED traverseFirstM "Isn't concern of this library. Use @'bitraverse' 'id' 'pure' '<$>' 'bitraverse' f 'pure' r@" #-} 205 | traverseFirstM :: (Bitraversable t, Applicative f, Monad m) 206 | => (k -> m (f k')) 207 | -> t k v 208 | -> m (f (t k' v)) 209 | traverseFirstM f r = bitraverse id pure <$> bitraverse f pure r 210 | {-# INLINE traverseFirstM #-} 211 | 212 | {-# DEPRECATED traverseM "Isn't concern of this library. Use @'sequenceA' '<$>' 'traverse' f r@" #-} 213 | traverseM :: (Traversable t, Applicative f, Monad m) 214 | => (v -> m (f v')) 215 | -> t v 216 | -> m (f (t v')) 217 | traverseM f r = sequenceA <$> traverse f r 218 | {-# INLINE traverseM #-} 219 | 220 | {-# DEPRECATED bitraverseM "Isn't concern of this library. Use @'Data.Bitraversable.bisequenceA' '<$>' 'bimapM' f g r@" #-} 221 | bitraverseM :: (Bitraversable t, Applicative f, Monad m) 222 | => (k -> m (f k')) 223 | -> (v -> m (f v')) 224 | -> t k v 225 | -> m (f (t k' v')) 226 | bitraverseM f g r = bisequence <$> bimapM f g r 227 | {-# INLINE bitraverseM #-} 228 | 229 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # hw-kafka-client 2 | 3 | [![CircleCI](https://circleci.com/gh/haskell-works/hw-kafka-client.svg?style=svg&circle-token=5f3ada2650dd600bc0fd4787143024867b2afc4e)](https://circleci.com/gh/haskell-works/hw-kafka-client) 4 | 5 | Kafka bindings for Haskell backed by the 6 | [librdkafka C module](https://github.com/edenhill/librdkafka). 7 | 8 | ## Ecosystem 9 | 10 | HaskellWorks Kafka ecosystem is described here: 11 | 12 | ## Consumer 13 | 14 | High level consumers are supported by `librdkafka` starting from version 0.9. 15 | High-level consumers provide an abstraction for consuming messages from multiple 16 | partitions and topics. They also address scalability (up to a number of partitions) 17 | by providing automatic rebalancing functionality. When a new consumer joins a consumer 18 | group the set of consumers attempts to "rebalance" the load to assign partitions to each consumer. 19 | 20 | ### Consumer example 21 | 22 | See [Running integration tests locally](#running-integration-tests-locally) to learn how to configure a local environment. 23 | 24 | ```bash 25 | cabal build --flag examples 26 | ``` 27 | 28 | or 29 | 30 | ```bash 31 | cabal run kafka-client-example --flag examples 32 | ``` 33 | 34 | A working consumer example can be found here: [ConsumerExample.hs](example/ConsumerExample.hs)
35 | To run an example please compile with the `examples` flag. 36 | 37 | ```haskell 38 | import Control.Exception (bracket) 39 | import Kafka.Consumer 40 | 41 | -- Global consumer properties 42 | consumerProps :: ConsumerProperties 43 | consumerProps = brokersList ["localhost:9092"] 44 | <> groupId "consumer_example_group" 45 | <> noAutoCommit 46 | <> logLevel KafkaLogInfo 47 | 48 | -- Subscription to topics 49 | consumerSub :: Subscription 50 | consumerSub = topics ["kafka-client-example-topic"] 51 | <> offsetReset Earliest 52 | 53 | -- Running an example 54 | runConsumerExample :: IO () 55 | runConsumerExample = do 56 | res <- bracket mkConsumer clConsumer runHandler 57 | print res 58 | where 59 | mkConsumer = newConsumer consumerProps consumerSub 60 | clConsumer (Left err) = return (Left err) 61 | clConsumer (Right kc) = maybe (Right ()) Left <$> closeConsumer kc 62 | runHandler (Left err) = return (Left err) 63 | runHandler (Right kc) = processMessages kc 64 | 65 | ------------------------------------------------------------------- 66 | processMessages :: KafkaConsumer -> IO (Either KafkaError ()) 67 | processMessages kafka = do 68 | replicateM_ 10 $ do 69 | msg <- pollMessage kafka (Timeout 1000) 70 | putStrLn $ "Message: " <> show msg 71 | err <- commitAllOffsets OffsetCommit kafka 72 | putStrLn $ "Offsets: " <> maybe "Committed." show err 73 | return $ Right () 74 | ``` 75 | 76 | ## Producer 77 | 78 | `kafka-client` producer supports sending messages to multiple topics. 79 | Target topic name is a part of each message that is to be sent by `produceMessage`. 80 | 81 | A working producer example can be found here: [ProducerExample.hs](example/ProducerExample.hs) 82 | 83 | ### Delivery reports 84 | 85 | Kafka Producer maintains its own internal queue for outgoing messages. Calling `produceMessage` 86 | does not mean that the message is actually written to Kafka, it only means that the message is put 87 | to that outgoing queue and that the producer will (eventually) push it to Kafka. 88 | 89 | However, it is not always possible for the producer to send messages to Kafka. Network problems 90 | or Kafka cluster being offline can prevent the producer from doing it. 91 | 92 | When a message cannot be sent to Kafka for some time (see `message.timeout.ms` [configuration](https://github.com/edenhill/librdkafka/blob/master/CONFIGURATION.md) option), 93 | the message is *dropped from the outgoing queue* and the *delivery report* indicating an error is raised. 94 | 95 | It is possible to configure `hw-kafka-client` to set an infinite message timeout so the message is 96 | never dropped from the queue: 97 | 98 | ```haskell 99 | producerProps :: ProducerProperties 100 | producerProps = brokersList ["localhost:9092"] 101 | <> sendTimeout (Timeout 0) -- for librdkafka "0" means "infinite" (see https://github.com/edenhill/librdkafka/issues/2015) 102 | ``` 103 | 104 | *Delivery reports* provide the way to detect when producer experiences problems sending messages 105 | to Kafka. 106 | 107 | Currently `hw-kafka-client` only supports delivery error callbacks: 108 | 109 | ```haskell 110 | producerProps :: ProducerProperties 111 | producerProps = brokersList ["localhost:9092"] 112 | <> setCallback (deliveryCallback print) 113 | ``` 114 | 115 | In the example above when the producer cannot deliver the message to Kafka, 116 | the error will be printed (and the message will be dropped). 117 | 118 | ### Producer example 119 | 120 | ```haskell 121 | {-# LANGUAGE OverloadedStrings #-} 122 | import Control.Exception (bracket) 123 | import Control.Monad (forM_) 124 | import Data.ByteString (ByteString) 125 | import Kafka.Producer 126 | 127 | -- Global producer properties 128 | producerProps :: ProducerProperties 129 | producerProps = brokersList ["localhost:9092"] 130 | <> logLevel KafkaLogDebug 131 | 132 | -- Topic to send messages to 133 | targetTopic :: TopicName 134 | targetTopic = "kafka-client-example-topic" 135 | 136 | -- Run an example 137 | runProducerExample :: IO () 138 | runProducerExample = 139 | bracket mkProducer clProducer runHandler >>= print 140 | where 141 | mkProducer = newProducer producerProps 142 | clProducer (Left _) = return () 143 | clProducer (Right prod) = closeProducer prod 144 | runHandler (Left err) = return $ Left err 145 | runHandler (Right prod) = sendMessages prod 146 | 147 | sendMessages :: KafkaProducer -> IO (Either KafkaError ()) 148 | sendMessages prod = do 149 | err1 <- produceMessage prod (mkMessage Nothing (Just "test from producer") ) 150 | forM_ err1 print 151 | 152 | err2 <- produceMessage prod (mkMessage (Just "key") (Just "test from producer (with key)")) 153 | forM_ err2 print 154 | 155 | return $ Right () 156 | 157 | mkMessage :: Maybe ByteString -> Maybe ByteString -> ProducerRecord 158 | mkMessage k v = ProducerRecord 159 | { prTopic = targetTopic 160 | , prPartition = UnassignedPartition 161 | , prKey = k 162 | , prValue = v 163 | , prHeaders = mempty 164 | } 165 | ``` 166 | 167 | ### Synchronous sending of messages 168 | 169 | Because of the asynchronous nature of librdkafka, there is no API to provide 170 | synchronous production of messages. It is, however, possible to combine the 171 | delivery reports feature with that of callbacks. This can be done using the 172 | `Kafka.Producer.produceMessage'` function. 173 | 174 | ```haskell 175 | produceMessage' :: MonadIO m 176 | => KafkaProducer 177 | -> ProducerRecord 178 | -> (DeliveryReport -> IO ()) 179 | -> m (Either ImmediateError ()) 180 | ``` 181 | 182 | Using this function, you can provide a callback which will be invoked upon the 183 | produced message's delivery report. With a little help of `MVar`s or similar, 184 | you can in fact, create a synchronous-like interface. 185 | 186 | ```haskell 187 | sendMessageSync :: MonadIO m 188 | => KafkaProducer 189 | -> ProducerRecord 190 | -> m (Either KafkaError Offset) 191 | sendMessageSync producer record = liftIO $ do 192 | -- Create an empty MVar: 193 | var <- newEmptyMVar 194 | 195 | -- Produce the message and use the callback to put the delivery report in the 196 | -- MVar: 197 | res <- produceMessage' producer record (putMVar var) 198 | 199 | case res of 200 | Left (ImmediateError err) -> 201 | pure (Left err) 202 | Right () -> do 203 | -- Flush producer queue to make sure you don't get stuck waiting for the 204 | -- message to send: 205 | flushProducer producer 206 | 207 | -- Wait for the message's delivery report and map accordingly: 208 | takeMVar var >>= return . \case 209 | DeliverySuccess _ offset -> Right offset 210 | DeliveryFailure _ err -> Left err 211 | NoMessageError err -> Left err 212 | ``` 213 | 214 | _Note:_ this is a semi-naive solution as this waits forever (or until 215 | librdkafka times out). You should make sure that your configuration reflects 216 | the behavior you want out of this functionality. 217 | 218 | ## Running integration tests locally 219 | 220 | [shell.nix](./shell.nix) can be used to provide a working environment that is enough to build and test `hw-kafka-client`. 221 | 222 | To be able to run tests locally, `$KAFKA_TEST_BROKER` environment variable is expected to be set (use [shell.nix](./shell.nix) or export manually). 223 | 224 | `$KAFKA_TEST_BROKER` should contain an IP address of an accessible Kafka broker that will be used to run integration tests against. 225 | 226 | With [Docker Compose](./docker-compose.yml) this variable is used to configure a Kafka broker with a UI on localhost:8080 to listen on this address: 227 | 228 | ``` 229 | $ docker-compose up 230 | ``` 231 | 232 | After that, integration tests can switched on with using 'it' flag: 233 | 234 | ``` 235 | $ cabal test --test-show-details=direct --flag it 236 | ``` 237 | 238 | ## Credits 239 | 240 | This project is inspired by [Haskakafka](https://github.com/cosbynator/haskakafka) 241 | which unfortunately doesn't seem to be actively maintained. 242 | -------------------------------------------------------------------------------- /src/Kafka/Metadata.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveGeneric #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | 4 | ----------------------------------------------------------------------------- 5 | -- | 6 | -- Module with metadata types and functions. 7 | ----------------------------------------------------------------------------- 8 | module Kafka.Metadata 9 | ( KafkaMetadata(..), BrokerMetadata(..), TopicMetadata(..), PartitionMetadata(..) 10 | , WatermarkOffsets(..) 11 | , GroupMemberId(..), GroupMemberInfo(..) 12 | , GroupProtocolType(..), GroupProtocol(..), GroupState(..) 13 | , GroupInfo(..) 14 | , allTopicsMetadata, topicMetadata 15 | , watermarkOffsets, watermarkOffsets' 16 | , partitionWatermarkOffsets 17 | , offsetsForTime, offsetsForTime', topicOffsetsForTime 18 | , allConsumerGroupsInfo, consumerGroupInfo 19 | ) 20 | where 21 | 22 | import Control.Arrow (left) 23 | import Control.Exception (bracket) 24 | import Control.Monad.IO.Class (MonadIO (liftIO)) 25 | import Data.Bifunctor (bimap) 26 | import Data.ByteString (ByteString, pack) 27 | import Data.Text (Text) 28 | import Foreign (Storable (peek), peekArray, withForeignPtr) 29 | import GHC.Generics (Generic) 30 | import Kafka.Consumer.Convert (fromNativeTopicPartitionList'', toNativeTopicPartitionList) 31 | import Kafka.Consumer.Types (ConsumerGroupId (..), Offset (..), PartitionOffset (..), TopicPartition (..)) 32 | import Kafka.Internal.RdKafka (RdKafkaGroupInfoT (..), RdKafkaGroupListT (..), RdKafkaGroupListTPtr, RdKafkaGroupMemberInfoT (..), RdKafkaMetadataBrokerT (..), RdKafkaMetadataPartitionT (..), RdKafkaMetadataT (..), RdKafkaMetadataTPtr, RdKafkaMetadataTopicT (..), RdKafkaRespErrT (..), RdKafkaTPtr, destroyUnmanagedRdKafkaTopic, newUnmanagedRdKafkaTopicT, peekCAText, rdKafkaListGroups, rdKafkaMetadata, rdKafkaOffsetsForTimes, rdKafkaQueryWatermarkOffsets) 33 | import Kafka.Internal.Setup (HasKafka (..), Kafka (..)) 34 | import Kafka.Internal.Shared (kafkaErrorToMaybe) 35 | import Kafka.Types (BrokerId (..), ClientId (..), KafkaError (..), Millis (..), PartitionId (..), Timeout (..), TopicName (..)) 36 | 37 | import qualified Data.Set as S 38 | import qualified Data.Text as Text 39 | 40 | data KafkaMetadata = KafkaMetadata 41 | { kmBrokers :: [BrokerMetadata] 42 | , kmTopics :: [TopicMetadata] 43 | , kmOrigBroker :: !BrokerId 44 | } deriving (Show, Eq, Generic) 45 | 46 | data BrokerMetadata = BrokerMetadata 47 | { bmBrokerId :: !BrokerId 48 | , bmBrokerHost :: !Text 49 | , bmBrokerPort :: !Int 50 | } deriving (Show, Eq, Generic) 51 | 52 | data PartitionMetadata = PartitionMetadata 53 | { pmPartitionId :: !PartitionId 54 | , pmError :: Maybe KafkaError 55 | , pmLeader :: !BrokerId 56 | , pmReplicas :: [BrokerId] 57 | , pmInSyncReplicas :: [BrokerId] 58 | } deriving (Show, Eq, Generic) 59 | 60 | data TopicMetadata = TopicMetadata 61 | { tmTopicName :: !TopicName 62 | , tmPartitions :: [PartitionMetadata] 63 | , tmError :: Maybe KafkaError 64 | } deriving (Show, Eq, Generic) 65 | 66 | data WatermarkOffsets = WatermarkOffsets 67 | { woTopicName :: !TopicName 68 | , woPartitionId :: !PartitionId 69 | , woLowWatermark :: !Offset 70 | , woHighWatermark :: !Offset 71 | } deriving (Show, Eq, Generic) 72 | 73 | newtype GroupMemberId = GroupMemberId Text deriving (Show, Eq, Read, Ord) 74 | data GroupMemberInfo = GroupMemberInfo 75 | { gmiMemberId :: !GroupMemberId 76 | , gmiClientId :: !ClientId 77 | , gmiClientHost :: !Text 78 | , gmiMetadata :: !ByteString 79 | , gmiAssignment :: !ByteString 80 | } deriving (Show, Eq, Generic) 81 | 82 | newtype GroupProtocolType = GroupProtocolType Text deriving (Show, Eq, Read, Ord, Generic) 83 | newtype GroupProtocol = GroupProtocol Text deriving (Show, Eq, Read, Ord, Generic) 84 | data GroupState 85 | = GroupPreparingRebalance -- ^ Group is preparing to rebalance 86 | | GroupEmpty -- ^ Group has no more members, but lingers until all offsets have expired 87 | | GroupAwaitingSync -- ^ Group is awaiting state assignment from the leader 88 | | GroupStable -- ^ Group is stable 89 | | GroupDead -- ^ Group has no more members and its metadata is being removed 90 | deriving (Show, Eq, Read, Ord, Generic) 91 | 92 | data GroupInfo = GroupInfo 93 | { giGroup :: !ConsumerGroupId 94 | , giError :: Maybe KafkaError 95 | , giState :: !GroupState 96 | , giProtocolType :: !GroupProtocolType 97 | , giProtocol :: !GroupProtocol 98 | , giMembers :: [GroupMemberInfo] 99 | } deriving (Show, Eq, Generic) 100 | 101 | -- | Returns metadata for all topics in the cluster 102 | allTopicsMetadata :: (MonadIO m, HasKafka k) => k -> Timeout -> m (Either KafkaError KafkaMetadata) 103 | allTopicsMetadata k (Timeout timeout) = liftIO $ do 104 | meta <- rdKafkaMetadata (getKafkaPtr k) True Nothing timeout 105 | traverse fromKafkaMetadataPtr (left KafkaResponseError meta) 106 | 107 | -- | Returns metadata only for specified topic 108 | topicMetadata :: (MonadIO m, HasKafka k) => k -> Timeout -> TopicName -> m (Either KafkaError KafkaMetadata) 109 | topicMetadata k (Timeout timeout) (TopicName tn) = liftIO $ 110 | bracket mkTopic clTopic $ \mbt -> case mbt of 111 | Left err -> return (Left $ KafkaError (Text.pack err)) 112 | Right t -> do 113 | meta <- rdKafkaMetadata (getKafkaPtr k) False (Just t) timeout 114 | traverse fromKafkaMetadataPtr (left KafkaResponseError meta) 115 | where 116 | mkTopic = newUnmanagedRdKafkaTopicT (getKafkaPtr k) (Text.unpack tn) Nothing 117 | clTopic = either (return . const ()) destroyUnmanagedRdKafkaTopic 118 | 119 | -- | Query broker for low (oldest/beginning) and high (newest/end) offsets for a given topic. 120 | watermarkOffsets :: (MonadIO m, HasKafka k) => k -> Timeout -> TopicName -> m [Either KafkaError WatermarkOffsets] 121 | watermarkOffsets k timeout t = do 122 | meta <- topicMetadata k timeout t 123 | case meta of 124 | Left err -> return [Left err] 125 | Right tm -> if null (kmTopics tm) 126 | then return [] 127 | else watermarkOffsets' k timeout (head $ kmTopics tm) 128 | 129 | -- | Query broker for low (oldest/beginning) and high (newest/end) offsets for a given topic. 130 | watermarkOffsets' :: (MonadIO m, HasKafka k) => k -> Timeout -> TopicMetadata -> m [Either KafkaError WatermarkOffsets] 131 | watermarkOffsets' k timeout tm = 132 | let pids = pmPartitionId <$> tmPartitions tm 133 | in liftIO $ traverse (partitionWatermarkOffsets k timeout (tmTopicName tm)) pids 134 | 135 | -- | Query broker for low (oldest/beginning) and high (newest/end) offsets for a specific partition 136 | partitionWatermarkOffsets :: (MonadIO m, HasKafka k) => k -> Timeout -> TopicName -> PartitionId -> m (Either KafkaError WatermarkOffsets) 137 | partitionWatermarkOffsets k (Timeout timeout) (TopicName t) (PartitionId p) = liftIO $ do 138 | offs <- rdKafkaQueryWatermarkOffsets (getKafkaPtr k) (Text.unpack t) p timeout 139 | return $ bimap KafkaResponseError toWatermark offs 140 | where 141 | toWatermark (l, h) = WatermarkOffsets (TopicName t) (PartitionId p) (Offset l) (Offset h) 142 | 143 | -- | Look up the offsets for the given topic by timestamp. 144 | -- 145 | -- The returned offset for each partition is the earliest offset whose 146 | -- timestamp is greater than or equal to the given timestamp in the 147 | -- corresponding partition. 148 | topicOffsetsForTime :: (MonadIO m, HasKafka k) => k -> Timeout -> Millis -> TopicName -> m (Either KafkaError [TopicPartition]) 149 | topicOffsetsForTime k timeout timestamp topic = do 150 | meta <- topicMetadata k timeout topic 151 | case meta of 152 | Left err -> return $ Left err 153 | Right meta' -> 154 | let tps = [(tmTopicName t, pmPartitionId p)| t <- kmTopics meta', p <- tmPartitions t] 155 | in offsetsForTime k timeout timestamp tps 156 | 157 | -- | Look up the offsets for the given metadata by timestamp. 158 | -- 159 | -- The returned offset for each partition is the earliest offset whose 160 | -- timestamp is greater than or equal to the given timestamp in the 161 | -- corresponding partition. 162 | offsetsForTime' :: (MonadIO m, HasKafka k) => k -> Timeout -> Millis -> TopicMetadata -> m (Either KafkaError [TopicPartition]) 163 | offsetsForTime' k timeout timestamp t = 164 | let tps = [(tmTopicName t, pmPartitionId p) | p <- tmPartitions t] 165 | in offsetsForTime k timeout timestamp tps 166 | 167 | -- | Look up the offsets for the given partitions by timestamp. 168 | -- 169 | -- The returned offset for each partition is the earliest offset whose 170 | -- timestamp is greater than or equal to the given timestamp in the 171 | -- corresponding partition. 172 | offsetsForTime :: (MonadIO m, HasKafka k) => k -> Timeout -> Millis -> [(TopicName, PartitionId)] -> m (Either KafkaError [TopicPartition]) 173 | offsetsForTime k (Timeout timeout) (Millis t) tps = liftIO $ do 174 | ntps <- toNativeTopicPartitionList $ mkTopicPartition <$> uniqueTps 175 | res <- rdKafkaOffsetsForTimes (getKafkaPtr k) ntps timeout 176 | case res of 177 | RdKafkaRespErrNoError -> Right <$> fromNativeTopicPartitionList'' ntps 178 | err -> return $ Left (KafkaResponseError err) 179 | where 180 | uniqueTps = S.toList . S.fromList $ tps 181 | -- rd_kafka_offsets_for_times reuses `offset` to specify timestamp :( 182 | mkTopicPartition (tn, p) = TopicPartition tn p (PartitionOffset t) 183 | 184 | -- | List and describe all consumer groups in cluster. 185 | allConsumerGroupsInfo :: (MonadIO m, HasKafka k) => k -> Timeout -> m (Either KafkaError [GroupInfo]) 186 | allConsumerGroupsInfo k (Timeout t) = liftIO $ do 187 | res <- rdKafkaListGroups (getKafkaPtr k) Nothing t 188 | traverse fromGroupInfoListPtr (left KafkaResponseError res) 189 | 190 | -- | Describe a given consumer group. 191 | consumerGroupInfo :: (MonadIO m, HasKafka k) => k -> Timeout -> ConsumerGroupId -> m (Either KafkaError [GroupInfo]) 192 | consumerGroupInfo k (Timeout timeout) (ConsumerGroupId gn) = liftIO $ do 193 | res <- rdKafkaListGroups (getKafkaPtr k) (Just (Text.unpack gn)) timeout 194 | traverse fromGroupInfoListPtr (left KafkaResponseError res) 195 | 196 | ------------------------------------------------------------------------------- 197 | getKafkaPtr :: HasKafka k => k -> RdKafkaTPtr 198 | getKafkaPtr k = let (Kafka k') = getKafka k in k' 199 | {-# INLINE getKafkaPtr #-} 200 | 201 | 202 | fromGroupInfoListPtr :: RdKafkaGroupListTPtr -> IO [GroupInfo] 203 | fromGroupInfoListPtr ptr = 204 | withForeignPtr ptr $ \realPtr -> do 205 | gl <- peek realPtr 206 | pgis <- peekArray (groupCnt'RdKafkaGroupListT gl) (groups'RdKafkaGroupListT gl) 207 | traverse fromGroupInfoPtr pgis 208 | 209 | fromGroupInfoPtr :: RdKafkaGroupInfoT -> IO GroupInfo 210 | fromGroupInfoPtr gi = do 211 | --bmd <- peek (broker'RdKafkaGroupInfoT gi) -- >>= fromBrokerMetadataPtr 212 | --xxx <- fromBrokerMetadataPtr bmd 213 | cid <- peekCAText $ group'RdKafkaGroupInfoT gi 214 | stt <- peekCAText $ state'RdKafkaGroupInfoT gi 215 | prt <- peekCAText $ protocolType'RdKafkaGroupInfoT gi 216 | pr <- peekCAText $ protocol'RdKafkaGroupInfoT gi 217 | mbs <- peekArray (memberCnt'RdKafkaGroupInfoT gi) (members'RdKafkaGroupInfoT gi) 218 | mbl <- mapM fromGroupMemberInfoPtr mbs 219 | return GroupInfo 220 | { --giBroker = bmd 221 | giGroup = ConsumerGroupId cid 222 | , giError = kafkaErrorToMaybe $ KafkaResponseError (err'RdKafkaGroupInfoT gi) 223 | , giState = groupStateFromKafkaString stt 224 | , giProtocolType = GroupProtocolType prt 225 | , giProtocol = GroupProtocol pr 226 | , giMembers = mbl 227 | } 228 | 229 | fromGroupMemberInfoPtr :: RdKafkaGroupMemberInfoT -> IO GroupMemberInfo 230 | fromGroupMemberInfoPtr mi = do 231 | mid <- peekCAText $ memberId'RdKafkaGroupMemberInfoT mi 232 | cid <- peekCAText $ clientId'RdKafkaGroupMemberInfoT mi 233 | hst <- peekCAText $ clientHost'RdKafkaGroupMemberInfoT mi 234 | mtd <- peekArray (memberMetadataSize'RdKafkaGroupMemberInfoT mi) (memberMetadata'RdKafkaGroupMemberInfoT mi) 235 | ass <- peekArray (memberAssignmentSize'RdKafkaGroupMemberInfoT mi) (memberAssignment'RdKafkaGroupMemberInfoT mi) 236 | return GroupMemberInfo 237 | { gmiMemberId = GroupMemberId mid 238 | , gmiClientId = ClientId cid 239 | , gmiClientHost = hst 240 | , gmiMetadata = pack mtd 241 | , gmiAssignment = pack ass 242 | } 243 | 244 | fromTopicMetadataPtr :: RdKafkaMetadataTopicT -> IO TopicMetadata 245 | fromTopicMetadataPtr tm = do 246 | tnm <- peekCAText (topic'RdKafkaMetadataTopicT tm) 247 | pts <- peekArray (partitionCnt'RdKafkaMetadataTopicT tm) (partitions'RdKafkaMetadataTopicT tm) 248 | pms <- mapM fromPartitionMetadataPtr pts 249 | return TopicMetadata 250 | { tmTopicName = TopicName tnm 251 | , tmPartitions = pms 252 | , tmError = kafkaErrorToMaybe $ KafkaResponseError (err'RdKafkaMetadataTopicT tm) 253 | } 254 | 255 | fromPartitionMetadataPtr :: RdKafkaMetadataPartitionT -> IO PartitionMetadata 256 | fromPartitionMetadataPtr pm = do 257 | reps <- peekArray (replicaCnt'RdKafkaMetadataPartitionT pm) (replicas'RdKafkaMetadataPartitionT pm) 258 | isrs <- peekArray (isrCnt'RdKafkaMetadataPartitionT pm) (isrs'RdKafkaMetadataPartitionT pm) 259 | return PartitionMetadata 260 | { pmPartitionId = PartitionId (id'RdKafkaMetadataPartitionT pm) 261 | , pmError = kafkaErrorToMaybe $ KafkaResponseError (err'RdKafkaMetadataPartitionT pm) 262 | , pmLeader = BrokerId (leader'RdKafkaMetadataPartitionT pm) 263 | , pmReplicas = BrokerId . fromIntegral <$> reps 264 | , pmInSyncReplicas = BrokerId . fromIntegral <$> isrs 265 | } 266 | 267 | 268 | fromBrokerMetadataPtr :: RdKafkaMetadataBrokerT -> IO BrokerMetadata 269 | fromBrokerMetadataPtr bm = do 270 | host <- peekCAText (host'RdKafkaMetadataBrokerT bm) 271 | return BrokerMetadata 272 | { bmBrokerId = BrokerId (id'RdKafkaMetadataBrokerT bm) 273 | , bmBrokerHost = host 274 | , bmBrokerPort = port'RdKafkaMetadataBrokerT bm 275 | } 276 | 277 | 278 | fromKafkaMetadataPtr :: RdKafkaMetadataTPtr -> IO KafkaMetadata 279 | fromKafkaMetadataPtr ptr = 280 | withForeignPtr ptr $ \realPtr -> do 281 | km <- peek realPtr 282 | pbms <- peekArray (brokerCnt'RdKafkaMetadataT km) (brokers'RdKafkaMetadataT km) 283 | bms <- mapM fromBrokerMetadataPtr pbms 284 | ptms <- peekArray (topicCnt'RdKafkaMetadataT km) (topics'RdKafkaMetadataT km) 285 | tms <- mapM fromTopicMetadataPtr ptms 286 | return KafkaMetadata 287 | { kmBrokers = bms 288 | , kmTopics = tms 289 | , kmOrigBroker = BrokerId $ fromIntegral (origBrokerId'RdKafkaMetadataT km) 290 | } 291 | 292 | groupStateFromKafkaString :: Text -> GroupState 293 | groupStateFromKafkaString s = case s of 294 | "PreparingRebalance" -> GroupPreparingRebalance 295 | "AwaitingSync" -> GroupAwaitingSync 296 | "Stable" -> GroupStable 297 | "Dead" -> GroupDead 298 | "Empty" -> GroupEmpty 299 | _ -> error $ "Unknown group state: " <> Text.unpack s 300 | -------------------------------------------------------------------------------- /tests-it/Kafka/IntegrationSpec.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE LambdaCase #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | {-# LANGUAGE ScopedTypeVariables #-} 4 | 5 | module Kafka.IntegrationSpec 6 | where 7 | 8 | import System.Random (randomRIO) 9 | import Control.Concurrent 10 | import Control.Concurrent.MVar (newEmptyMVar, putMVar, takeMVar) 11 | import Control.Monad (forM, forM_, void) 12 | import Control.Monad.Loops 13 | import Data.Either 14 | import Data.Map (fromList) 15 | import qualified Data.Set as Set 16 | import Data.Monoid ((<>)) 17 | import Kafka.Consumer 18 | import qualified Data.Text as T 19 | import Kafka.Metadata 20 | import Kafka.Producer 21 | import Kafka.Topic 22 | import Kafka.TestEnv 23 | import Test.Hspec 24 | 25 | import qualified Data.ByteString as BS 26 | 27 | {- HLINT ignore "Redundant do" -} 28 | 29 | spec :: Spec 30 | spec = do 31 | describe "Per-message commit" $ do 32 | specWithProducer "Run producer" $ do 33 | it "1. sends 2 messages to test topic" $ \prod -> do 34 | res <- sendMessages (testMessages testTopic) prod 35 | res `shouldBe` Right () 36 | 37 | specWithConsumer "Consumer with per-message commit" consumerProps $ do 38 | it "2. should receive 2 messages" $ \k -> do 39 | res <- receiveMessages k 40 | length <$> res `shouldBe` Right 2 41 | 42 | comRes <- forM res . mapM $ commitOffsetMessage OffsetCommit k 43 | comRes `shouldBe` Right [Nothing, Nothing] 44 | 45 | specWithProducer "Run producer again" $ do 46 | it "3. sends 2 messages to test topic" $ \prod -> do 47 | res <- sendMessages (testMessages testTopic) prod 48 | res `shouldBe` Right () 49 | 50 | specWithConsumer "Consumer after per-message commit" consumerProps $ do 51 | it "4. should receive 2 messages again" $ \k -> do 52 | res <- receiveMessages k 53 | comRes <- commitAllOffsets OffsetCommit k 54 | 55 | length <$> res `shouldBe` Right 2 56 | comRes `shouldBe` Nothing 57 | 58 | describe "Store offsets" $ do 59 | specWithProducer "Run producer" $ do 60 | it "1. sends 2 messages to test topic" $ \prod -> do 61 | res <- sendMessages (testMessages testTopic) prod 62 | res `shouldBe` Right () 63 | 64 | specWithConsumer "Consumer with no auto store" consumerPropsNoStore $ do 65 | it "2. should receive 2 messages without storing" $ \k -> do 66 | res <- receiveMessages k 67 | length <$> res `shouldBe` Right 2 68 | 69 | comRes <- commitAllOffsets OffsetCommit k 70 | comRes `shouldBe` Just (KafkaResponseError RdKafkaRespErrNoOffset) 71 | 72 | specWithProducer "Run producer again" $ do 73 | it "3. sends 2 messages to test topic" $ \prod -> do 74 | res <- sendMessages (testMessages testTopic) prod 75 | res `shouldBe` Right () 76 | 77 | specWithConsumer "Consumer after commit without store" consumerPropsNoStore $ do 78 | it "4. should receive 4 messages and store them" $ \k -> do 79 | res <- receiveMessages k 80 | storeRes <- forM res . mapM $ storeOffsetMessage k 81 | comRes <- commitAllOffsets OffsetCommit k 82 | 83 | length <$> storeRes `shouldBe` Right 4 84 | length <$> res `shouldBe` Right 4 85 | comRes `shouldBe` Nothing 86 | 87 | specWithProducer "Run producer again" $ do 88 | it "5. sends 2 messages to test topic" $ \prod -> do 89 | res <- sendMessages (testMessages testTopic) prod 90 | res `shouldBe` Right () 91 | 92 | specWithConsumer "Consumer after commit with store" consumerPropsNoStore $ do 93 | it "6. should receive 2 messages" $ \k -> do 94 | res <- receiveMessages k 95 | storeRes <- forM res $ mapM (storeOffsetMessage k) 96 | comRes <- commitAllOffsets OffsetCommit k 97 | 98 | length <$> res `shouldBe` Right 2 99 | length <$> storeRes `shouldBe` Right 2 100 | comRes `shouldBe` Nothing 101 | 102 | specWithKafka "Part 3 - Consume after committing stored offsets" consumerPropsNoStore $ do 103 | it "5. sends 2 messages to test topic" $ \(_, prod) -> do 104 | res <- sendMessages (testMessages testTopic) prod 105 | res `shouldBe` Right () 106 | 107 | it "6. should receive 2 messages" $ \(k, _) -> do 108 | res <- receiveMessages k 109 | storeRes <- forM res $ mapM (storeOffsetMessage k) 110 | comRes <- commitAllOffsets OffsetCommit k 111 | 112 | length <$> res `shouldBe` Right 2 113 | length <$> storeRes `shouldBe` Right 2 114 | comRes `shouldBe` Nothing 115 | 116 | describe "Kafka.IntegrationSpec" $ do 117 | specWithProducer "Run producer" $ do 118 | it "sends messages to test topic" $ \prod -> do 119 | res <- sendMessages (testMessages testTopic) prod 120 | res `shouldBe` Right () 121 | 122 | it "sends messages with callback to test topic" $ \prod -> do 123 | var <- newEmptyMVar 124 | let 125 | msg = ProducerRecord 126 | { prTopic = "callback-topic" 127 | , prPartition = UnassignedPartition 128 | , prKey = Nothing 129 | , prValue = Just "test from producer" 130 | , prHeaders = mempty 131 | } 132 | 133 | res <- produceMessage' prod msg (putMVar var) 134 | res `shouldBe` Right () 135 | callbackRes <- flushProducer prod *> takeMVar var 136 | callbackRes `shouldSatisfy` \case 137 | DeliverySuccess _ _ -> True 138 | DeliveryFailure _ _ -> False 139 | NoMessageError _ -> False 140 | 141 | specWithConsumer "Run consumer with async polling" (consumerProps <> groupId (makeGroupId "async")) runConsumerSpec 142 | specWithConsumer "Run consumer with sync polling" (consumerProps <> groupId (makeGroupId "sync") <> callbackPollMode CallbackPollModeSync) runConsumerSpec 143 | 144 | describe "Kafka.Consumer.BatchSpec" $ do 145 | specWithConsumer "Batch consumer" (consumerProps <> groupId "batch-consumer") $ do 146 | it "should consume first batch" $ \k -> do 147 | res <- pollMessageBatch k (Timeout 1000) (BatchSize 5) 148 | length res `shouldBe` 5 149 | forM_ res (`shouldSatisfy` isRight) 150 | 151 | it "should consume second batch with not enough messages" $ \k -> do 152 | res <- pollMessageBatch k (Timeout 1000) (BatchSize 50) 153 | let res' = Prelude.filter (/= Left (KafkaResponseError RdKafkaRespErrPartitionEof)) res 154 | length res' `shouldSatisfy` (< 50) 155 | forM_ res' (`shouldSatisfy` isRight) 156 | 157 | it "should consume empty batch when there are no messages" $ \k -> do 158 | res <- pollMessageBatch k (Timeout 1000) (BatchSize 50) 159 | length res `shouldBe` 0 160 | 161 | describe "Kafka.Headers.Spec" $ do 162 | let testHeaders = headersFromList [("a-header-name", "a-header-value"), ("b-header-name", "b-header-value")] 163 | 164 | specWithKafka "Headers consumer/producer" consumerProps $ do 165 | it "1. sends 2 messages to test topic enriched with headers" $ \(k, prod) -> do 166 | void $ receiveMessages k 167 | 168 | res <- sendMessagesWithHeaders (testMessages testTopic) testHeaders prod 169 | res `shouldBe` Right () 170 | it "2. should receive 2 messages enriched with headers" $ \(k, _) -> do 171 | res <- receiveMessages k 172 | (length <$> res) `shouldBe` Right 2 173 | 174 | forM_ res $ \rcs -> 175 | forM_ rcs ((`shouldBe` Set.fromList (headersToList testHeaders)) . Set.fromList . headersToList . crHeaders) 176 | 177 | describe "Kafka.Topic.Spec" $ do 178 | let topicName = addRandomChars "admin.topic.created." 5 179 | 180 | topicsMVar <- runIO newEmptyMVar 181 | 182 | specWithConsumer "Read all topics" consumerProps $ do 183 | 184 | it "should create a topic" $ \(consumer :: KafkaConsumer) -> do 185 | tName <- topicName 186 | let newTopic = mkNewTopic (TopicName ( T.pack(tName) )) 187 | result <- createTopic consumer newTopic 188 | result `shouldSatisfy` isRight 189 | 190 | 191 | it "should return all the topics" $ \(consumer :: KafkaConsumer) -> do 192 | res <- allTopicsMetadata consumer (Timeout 1000) 193 | res `shouldSatisfy` isRight 194 | let filterUserTopics m = m { kmTopics = filter (\t -> topicType (tmTopicName t) == User) (kmTopics m) } 195 | let res' = fmap filterUserTopics res 196 | length . kmBrokers <$> res' `shouldBe` Right 1 197 | 198 | let topics = either (const []) (map tmTopicName . kmTopics) res' 199 | putMVar topicsMVar topics 200 | 201 | let topicsLen = either (const 0) (length . kmTopics) res' 202 | let hasTopic = either (const False) (any (\t -> tmTopicName t == testTopic) . kmTopics) res' 203 | 204 | topicsLen `shouldSatisfy` (>0) 205 | hasTopic `shouldBe` True 206 | 207 | it "should delete all the topics currently existing" $ \(consumer :: KafkaConsumer) -> do 208 | topics <- takeMVar topicsMVar 209 | forM_ topics $ \topic -> do 210 | result <- deleteTopic consumer topic 211 | result `shouldSatisfy` isRight 212 | 213 | ---------------------------------------------------------------------------------------------------------------- 214 | 215 | data ReadState = Skip | Read 216 | 217 | receiveMessages :: KafkaConsumer -> IO (Either KafkaError [ConsumerRecord (Maybe BS.ByteString) (Maybe BS.ByteString)]) 218 | receiveMessages kafka = 219 | Right . rights <$> allMessages 220 | where 221 | allMessages = 222 | unfoldrM (\s -> do 223 | msg <- pollMessage kafka (Timeout 1000) 224 | case (s, msg) of 225 | (Skip, Left _) -> pure $ Just (msg, Skip) 226 | (_, Right msg') -> pure $ Just (Right msg', Read) 227 | (Read, _) -> pure Nothing 228 | 229 | ) Skip 230 | 231 | testMessages :: TopicName -> [ProducerRecord] 232 | testMessages t = 233 | [ ProducerRecord t UnassignedPartition Nothing (Just "test from producer") mempty 234 | , ProducerRecord t UnassignedPartition (Just "key") (Just "test from producer (with key)") mempty 235 | ] 236 | 237 | sendMessages :: [ProducerRecord] -> KafkaProducer -> IO (Either KafkaError ()) 238 | sendMessages msgs prod = 239 | Right <$> (forM_ msgs (produceMessage prod) >> flushProducer prod) 240 | 241 | sendMessagesWithHeaders :: [ProducerRecord] -> Headers -> KafkaProducer -> IO (Either KafkaError ()) 242 | sendMessagesWithHeaders msgs hdrs prod = 243 | Right <$> (forM_ msgs (\msg -> produceMessage prod (msg {prHeaders = hdrs})) >> flushProducer prod) 244 | 245 | runConsumerSpec :: SpecWith KafkaConsumer 246 | runConsumerSpec = do 247 | it "should receive messages" $ \k -> do 248 | res <- receiveMessages k 249 | let msgsLen = either (const 0) length res 250 | msgsLen `shouldSatisfy` (> 0) 251 | 252 | let timestamps = crTimestamp <$> either (const []) id res 253 | forM_ timestamps $ \ts -> 254 | ts `shouldNotBe` NoTimestamp 255 | 256 | comRes <- commitAllOffsets OffsetCommit k 257 | comRes `shouldBe` Nothing 258 | 259 | it "should get committed" $ \k -> do 260 | res <- committed k (Timeout 1000) [(testTopic, PartitionId 0)] 261 | res `shouldSatisfy` isRight 262 | 263 | it "should get position" $ \k -> do 264 | res <- position k [(testTopic, PartitionId 0)] 265 | res `shouldSatisfy` isRight 266 | 267 | it "should get watermark offsets" $ \k -> do 268 | res <- sequence <$> watermarkOffsets k (Timeout 1000) testTopic 269 | res `shouldSatisfy` isRight 270 | length <$> res `shouldBe` (Right 1) 271 | 272 | it "should return subscription" $ \k -> do 273 | res <- subscription k 274 | res `shouldSatisfy` isRight 275 | length <$> res `shouldBe` Right 1 276 | 277 | it "should return assignment" $ \k -> do 278 | res <- assignment k 279 | res `shouldSatisfy` isRight 280 | res `shouldBe` Right (fromList [(testTopic, [PartitionId 0])]) 281 | 282 | it "should return all topics metadata" $ \k -> do 283 | res <- allTopicsMetadata k (Timeout 1000) 284 | res `shouldSatisfy` isRight 285 | let filterUserTopics m = m { kmTopics = filter (\t -> topicType (tmTopicName t) == User) (kmTopics m) } 286 | let res' = fmap filterUserTopics res 287 | length . kmBrokers <$> res' `shouldBe` Right 1 288 | 289 | let topicsLen = either (const 0) (length . kmTopics) res' 290 | let hasTopic = either (const False) (any (\t -> tmTopicName t == testTopic) . kmTopics) res' 291 | 292 | topicsLen `shouldSatisfy` (>0) 293 | hasTopic `shouldBe` True 294 | 295 | it "should return topic metadata" $ \k -> do 296 | res <- topicMetadata k (Timeout 2000) testTopic 297 | res `shouldSatisfy` isRight 298 | length . kmBrokers <$> res `shouldBe` Right 1 299 | length . kmTopics <$> res `shouldBe` Right 1 300 | 301 | it "should describe all consumer groups" $ \k -> do 302 | res <- allConsumerGroupsInfo k (Timeout 2000) 303 | res `shouldSatisfy` isRight 304 | let groups = either (const []) (fmap giGroup) res 305 | let prefixedGroups = filter isTestGroupId groups 306 | let resLen = length prefixedGroups 307 | resLen `shouldSatisfy` (>0) 308 | -- fmap giGroup <$> res `shouldBe` Right [testGroupId] 309 | 310 | it "should describe a given consumer group" $ \k -> do 311 | res <- consumerGroupInfo k (Timeout 2000) testGroupId 312 | fmap giGroup <$> res `shouldBe` Right [testGroupId] 313 | 314 | it "should describe non-existent consumer group" $ \k -> do 315 | res <- consumerGroupInfo k (Timeout 2000) "does-not-exist" 316 | res `shouldBe` Right [] 317 | 318 | it "should read topic offsets for time" $ \k -> do 319 | res <- topicOffsetsForTime k (Timeout 2000) (Millis 1904057189508) testTopic 320 | res `shouldSatisfy` isRight 321 | fmap tpOffset <$> res `shouldBe` Right [PartitionOffsetEnd] 322 | 323 | it "should seek and return no error" $ \k -> do 324 | res <- seek k (Timeout 1000) [TopicPartition testTopic (PartitionId 0) (PartitionOffset 1)] 325 | res `shouldBe` Nothing 326 | msg <- pollMessage k (Timeout 1000) 327 | crOffset <$> msg `shouldBe` Right (Offset 1) 328 | 329 | it "should seek to the beginning" $ \k -> do 330 | res <- seek k (Timeout 1000) [TopicPartition testTopic (PartitionId 0) PartitionOffsetBeginning] 331 | res `shouldBe` Nothing 332 | msg <- pollMessage k (Timeout 1000) 333 | crOffset <$> msg `shouldBe` Right (Offset 0) 334 | 335 | it "should seek to the end" $ \k -> do 336 | res <- seek k (Timeout 1000) [TopicPartition testTopic (PartitionId 0) PartitionOffsetEnd] 337 | res `shouldBe` Nothing 338 | msg <- pollMessage k (Timeout 1000) 339 | crOffset <$> msg `shouldSatisfy` (\x -> 340 | x == Left (KafkaResponseError RdKafkaRespErrPartitionEof) 341 | || x == Left (KafkaResponseError RdKafkaRespErrTimedOut)) 342 | 343 | it "should respect out-of-bound offsets (invalid offset)" $ \k -> do 344 | res <- seek k (Timeout 2000) [TopicPartition testTopic (PartitionId 0) PartitionOffsetInvalid] 345 | res `shouldBe` Nothing 346 | msg <- pollMessage k (Timeout 1000) 347 | crOffset <$> msg `shouldBe` Right (Offset 0) 348 | 349 | it "should respect out-of-bound offsets (huge offset)" $ \k -> do 350 | res <- seek k (Timeout 3000) [TopicPartition testTopic (PartitionId 0) (PartitionOffset 123456)] 351 | res `shouldBe` Nothing 352 | msg <- pollMessage k (Timeout 2000) 353 | crOffset <$> msg `shouldBe` Right (Offset 0) 354 | 355 | mkNewTopic :: TopicName -> NewTopic 356 | mkNewTopic name = NewTopic name (PartitionCount 1) (ReplicationFactor 1) mempty 357 | 358 | 359 | addRandomChars :: String -> Int -> IO String 360 | addRandomChars baseStr n = do 361 | randomChars <- mapM (\_ -> randomRIO ('a', 'z')) [1..n] 362 | return $ baseStr ++ randomChars 363 | -------------------------------------------------------------------------------- /src/Kafka/Consumer.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE LambdaCase #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | {-# LANGUAGE TupleSections #-} 4 | 5 | ----------------------------------------------------------------------------- 6 | -- | 7 | -- Module to consume messages from Kafka topics. 8 | -- 9 | -- Here's an example of code to consume messages from a topic: 10 | -- 11 | -- @ 12 | -- import Control.Exception (bracket) 13 | -- import Control.Monad (replicateM_) 14 | -- import Kafka.Consumer 15 | -- 16 | -- -- Global consumer properties 17 | -- consumerProps :: 'ConsumerProperties' 18 | -- consumerProps = 'brokersList' ["localhost:9092"] 19 | -- <> 'groupId' ('ConsumerGroupId' "consumer_example_group") 20 | -- <> 'noAutoCommit' 21 | -- <> 'logLevel' 'KafkaLogInfo' 22 | -- 23 | -- -- Subscription to topics 24 | -- consumerSub :: 'Subscription' 25 | -- consumerSub = 'topics' ['TopicName' "kafka-client-example-topic"] 26 | -- <> 'offsetReset' 'Earliest' 27 | -- 28 | -- -- Running an example 29 | -- runConsumerExample :: IO () 30 | -- runConsumerExample = do 31 | -- res <- bracket mkConsumer clConsumer runHandler 32 | -- print res 33 | -- where 34 | -- mkConsumer = 'newConsumer' consumerProps consumerSub 35 | -- clConsumer (Left err) = pure (Left err) 36 | -- clConsumer (Right kc) = (maybe (Right ()) Left) \<$\> 'closeConsumer' kc 37 | -- runHandler (Left err) = pure (Left err) 38 | -- runHandler (Right kc) = processMessages kc 39 | -- 40 | -- -- Example polling 10 times before stopping 41 | -- processMessages :: 'KafkaConsumer' -> IO (Either 'KafkaError' ()) 42 | -- processMessages kafka = do 43 | -- replicateM_ 10 $ do 44 | -- msg <- 'pollMessage' kafka ('Timeout' 1000) 45 | -- putStrLn $ "Message: " <> show msg 46 | -- err <- 'commitAllOffsets' 'OffsetCommit' kafka 47 | -- putStrLn $ "Offsets: " <> maybe "Committed." show err 48 | -- pure $ Right () 49 | -- @ 50 | ----------------------------------------------------------------------------- 51 | module Kafka.Consumer 52 | ( KafkaConsumer 53 | , module X 54 | , runConsumer 55 | , newConsumer 56 | , assign, assignment, subscription 57 | , pausePartitions, resumePartitions 58 | , committed, position, seek, seekPartitions 59 | , pollMessage, pollConsumerEvents 60 | , pollMessageBatch 61 | , commitOffsetMessage, commitAllOffsets, commitPartitionsOffsets 62 | , storeOffsets, storeOffsetMessage 63 | , rewindConsumer 64 | , closeConsumer 65 | -- ReExport Types 66 | , RdKafkaRespErrT (..) 67 | ) 68 | where 69 | 70 | import Control.Arrow (left, (&&&)) 71 | import Control.Concurrent (forkIO, modifyMVar, rtsSupportsBoundThreads, withMVar) 72 | import Control.Exception (bracket) 73 | import Control.Monad (forM_, void, when) 74 | import Control.Monad.IO.Class (MonadIO (liftIO)) 75 | import Control.Monad.Trans.Except (ExceptT (ExceptT), runExceptT) 76 | import Data.Bifunctor (bimap, first) 77 | import qualified Data.ByteString as BS 78 | import Data.IORef (readIORef, writeIORef) 79 | import qualified Data.Map as M hiding (map, foldr) 80 | import Data.Maybe (fromMaybe) 81 | import Data.Set (Set) 82 | import qualified Data.Set as Set 83 | import qualified Data.Text as Text 84 | import Foreign hiding (void) 85 | import Kafka.Consumer.Convert (fromMessagePtr, fromNativeTopicPartitionList'', offsetCommitToBool, offsetToInt64, toMap, toNativeTopicPartitionList, toNativeTopicPartitionList', topicPartitionFromMessageForCommit) 86 | import Kafka.Consumer.Types (KafkaConsumer (..)) 87 | import Kafka.Internal.RdKafka (RdKafkaRespErrT (..), RdKafkaTopicPartitionListTPtr, RdKafkaTypeT (..), rdKafkaSeekPartitions, rdKafkaErrorDestroy, rdKafkaErrorCode, newRdKafkaT, newRdKafkaTopicPartitionListT, newRdKafkaTopicT, rdKafkaAssign, rdKafkaAssignment, rdKafkaCommit, rdKafkaCommitted, rdKafkaConfSetDefaultTopicConf, rdKafkaConsumeBatchQueue, rdKafkaConsumeQueue, rdKafkaConsumerClose, rdKafkaConsumerPoll, rdKafkaOffsetsStore, rdKafkaPausePartitions, rdKafkaPollSetConsumer, rdKafkaPosition, rdKafkaQueueDestroy, rdKafkaQueueNew, rdKafkaResumePartitions, rdKafkaSeek, rdKafkaSetLogLevel, rdKafkaSubscribe, rdKafkaSubscription, rdKafkaTopicConfDup, rdKafkaTopicPartitionListAdd) 88 | import Kafka.Internal.Setup (CallbackPollStatus (..), Kafka (..), KafkaConf (..), KafkaProps (..), TopicConf (..), TopicProps (..), getKafkaConf, getRdKafka, kafkaConf, topicConf, Callback(..)) 89 | import Kafka.Internal.Shared (kafkaErrorToMaybe, maybeToLeft, rdKafkaErrorToEither) 90 | 91 | import Kafka.Consumer.ConsumerProperties as X 92 | import Kafka.Consumer.Subscription as X 93 | import Kafka.Consumer.Types as X hiding (KafkaConsumer) 94 | import Kafka.Types as X 95 | 96 | -- | Runs high-level kafka consumer. 97 | -- A callback provided is expected to call 'pollMessage' when convenient. 98 | {-# DEPRECATED runConsumer "Use 'newConsumer'/'closeConsumer' instead" #-} 99 | runConsumer :: ConsumerProperties 100 | -> Subscription 101 | -> (KafkaConsumer -> IO (Either KafkaError a)) -- ^ A callback function to poll and handle messages 102 | -> IO (Either KafkaError a) 103 | runConsumer cp sub f = 104 | bracket mkConsumer clConsumer runHandler 105 | where 106 | mkConsumer = newConsumer cp sub 107 | 108 | clConsumer (Left err) = return (Left err) 109 | clConsumer (Right kc) = maybeToLeft <$> closeConsumer kc 110 | 111 | runHandler (Left err) = return (Left err) 112 | runHandler (Right kc) = f kc 113 | 114 | -- | Create a `KafkaConsumer`. This consumer must be correctly released using 'closeConsumer'. 115 | newConsumer :: MonadIO m 116 | => ConsumerProperties 117 | -> Subscription 118 | -> m (Either KafkaError KafkaConsumer) 119 | newConsumer props (Subscription ts tp) = liftIO $ do 120 | let cp = case cpCallbackPollMode props of 121 | CallbackPollModeAsync -> setCallback (rebalanceCallback (\_ _ -> return ())) <> props 122 | CallbackPollModeSync -> props 123 | kc@(KafkaConf kc' qref _) <- newConsumerConf cp 124 | tp' <- topicConf (TopicProps tp) 125 | _ <- setDefaultTopicConf kc tp' 126 | rdk <- newRdKafkaT RdKafkaConsumer kc' 127 | case rdk of 128 | Left err -> 129 | return $ 130 | Left (KafkaError err) 131 | 132 | Right rdk' -> do 133 | let 134 | kafka = 135 | KafkaConsumer (Kafka rdk') kc 136 | 137 | when (cpCallbackPollMode props == CallbackPollModeAsync) $ do 138 | messageQueue <- rdKafkaQueueNew rdk' 139 | writeIORef qref (Just messageQueue) 140 | 141 | redErr <- redirectCallbacksPoll kafka 142 | case redErr of 143 | Just err -> do 144 | _ <- closeConsumer kafka 145 | return (Left err) 146 | 147 | Nothing -> do 148 | forM_ (cpLogLevel cp) $ 149 | setConsumerLogLevel kafka 150 | 151 | subscribeError <- 152 | if Set.null ts then 153 | pure Nothing 154 | else 155 | subscribe kafka ts 156 | 157 | case subscribeError of 158 | Nothing -> do 159 | when (cpCallbackPollMode props == CallbackPollModeAsync) $ 160 | runConsumerLoop kafka (Just $ Timeout 100) 161 | return (Right kafka) 162 | 163 | Just err -> do 164 | _ <- closeConsumer kafka 165 | return (Left err) 166 | 167 | -- | Polls a single message 168 | pollMessage :: MonadIO m 169 | => KafkaConsumer 170 | -> Timeout -- ^ the timeout, in milliseconds 171 | -> m (Either KafkaError (ConsumerRecord (Maybe BS.ByteString) (Maybe BS.ByteString))) -- ^ Left on error or timeout, right for success 172 | pollMessage c@(KafkaConsumer _ (KafkaConf _ qr _)) (Timeout ms) = liftIO $ do 173 | mbq <- readIORef qr 174 | case mbq of 175 | Nothing -> rdKafkaConsumerPoll (getRdKafka c) ms >>= fromMessagePtr 176 | Just q -> rdKafkaConsumeQueue q (fromIntegral ms) >>= fromMessagePtr 177 | 178 | -- | Polls up to 'BatchSize' messages. 179 | -- Unlike 'pollMessage' this function does not return usual "timeout" errors. 180 | -- An empty batch is returned when there are no messages available. 181 | -- 182 | -- This API is not available when 'CallbackPollMode' is set to 'CallbackPollModeSync'. 183 | pollMessageBatch :: MonadIO m 184 | => KafkaConsumer 185 | -> Timeout 186 | -> BatchSize 187 | -> m [Either KafkaError (ConsumerRecord (Maybe BS.ByteString) (Maybe BS.ByteString))] 188 | pollMessageBatch c@(KafkaConsumer _ (KafkaConf _ qr _)) (Timeout ms) (BatchSize b) = liftIO $ do 189 | pollConsumerEvents c Nothing 190 | mbq <- readIORef qr 191 | case mbq of 192 | Nothing -> return [Left $ KafkaBadSpecification "Calling pollMessageBatch while CallbackPollMode is set to CallbackPollModeSync."] 193 | Just q -> whileNoCallbackRunning c $ rdKafkaConsumeBatchQueue q ms b >>= traverse fromMessagePtr 194 | 195 | -- | Commit message's offset on broker for the message's partition. 196 | commitOffsetMessage :: MonadIO m 197 | => OffsetCommit 198 | -> KafkaConsumer 199 | -> ConsumerRecord k v 200 | -> m (Maybe KafkaError) 201 | commitOffsetMessage o k m = 202 | liftIO $ toNativeTopicPartitionList [topicPartitionFromMessageForCommit m] >>= commitOffsets o k 203 | 204 | -- | Stores message's offset locally for the message's partition. 205 | storeOffsetMessage :: MonadIO m 206 | => KafkaConsumer 207 | -> ConsumerRecord k v 208 | -> m (Maybe KafkaError) 209 | storeOffsetMessage k m = 210 | liftIO $ toNativeTopicPartitionList [topicPartitionFromMessageForCommit m] >>= commitOffsetsStore k 211 | 212 | -- | Stores offsets locally 213 | storeOffsets :: MonadIO m 214 | => KafkaConsumer 215 | -> [TopicPartition] 216 | -> m (Maybe KafkaError) 217 | storeOffsets k ps = 218 | liftIO $ toNativeTopicPartitionList ps >>= commitOffsetsStore k 219 | 220 | -- | Commit offsets for all currently assigned partitions. 221 | commitAllOffsets :: MonadIO m 222 | => OffsetCommit 223 | -> KafkaConsumer 224 | -> m (Maybe KafkaError) 225 | commitAllOffsets o k = 226 | liftIO $ newForeignPtr_ nullPtr >>= commitOffsets o k 227 | 228 | -- | Commit offsets for all currently assigned partitions. 229 | commitPartitionsOffsets :: MonadIO m 230 | => OffsetCommit 231 | -> KafkaConsumer 232 | -> [TopicPartition] 233 | -> m (Maybe KafkaError) 234 | commitPartitionsOffsets o k ps = 235 | liftIO $ toNativeTopicPartitionList ps >>= commitOffsets o k 236 | 237 | -- | Assigns the consumer to consume from the given topics, partitions, 238 | -- and offsets. 239 | assign :: MonadIO m => KafkaConsumer -> [TopicPartition] -> m (Maybe KafkaError) 240 | assign (KafkaConsumer (Kafka k) _) ps = liftIO $ do 241 | tps <- toNativeTopicPartitionList ps 242 | kafkaErrorToMaybe . KafkaResponseError <$> rdKafkaAssign k tps 243 | 244 | -- | Returns current consumer's assignment 245 | assignment :: MonadIO m => KafkaConsumer -> m (Either KafkaError (M.Map TopicName [PartitionId])) 246 | assignment (KafkaConsumer (Kafka k) _) = liftIO $ do 247 | tpl <- rdKafkaAssignment k 248 | tps <- traverse fromNativeTopicPartitionList'' (left KafkaResponseError tpl) 249 | return $ tpMap <$> tps 250 | where 251 | tpMap ts = toMap $ (tpTopicName &&& tpPartition) <$> ts 252 | 253 | -- | Returns current consumer's subscription 254 | subscription :: MonadIO m => KafkaConsumer -> m (Either KafkaError [(TopicName, SubscribedPartitions)]) 255 | subscription (KafkaConsumer (Kafka k) _) = liftIO $ do 256 | tpl <- rdKafkaSubscription k 257 | tps <- traverse fromNativeTopicPartitionList'' (left KafkaResponseError tpl) 258 | return $ toSub <$> tps 259 | where 260 | toSub ts = M.toList $ subParts <$> tpMap ts 261 | tpMap ts = toMap $ (tpTopicName &&& tpPartition) <$> ts 262 | subParts [PartitionId (-1)] = SubscribedPartitionsAll 263 | subParts ps = SubscribedPartitions ps 264 | 265 | -- | Pauses specified partitions on the current consumer. 266 | pausePartitions :: MonadIO m => KafkaConsumer -> [(TopicName, PartitionId)] -> m KafkaError 267 | pausePartitions (KafkaConsumer (Kafka k) _) ps = liftIO $ do 268 | pl <- newRdKafkaTopicPartitionListT (length ps) 269 | mapM_ (\(TopicName topicName, PartitionId partitionId) -> rdKafkaTopicPartitionListAdd pl (Text.unpack topicName) partitionId) ps 270 | KafkaResponseError <$> rdKafkaPausePartitions k pl 271 | 272 | -- | Resumes specified partitions on the current consumer. 273 | resumePartitions :: MonadIO m => KafkaConsumer -> [(TopicName, PartitionId)] -> m KafkaError 274 | resumePartitions (KafkaConsumer (Kafka k) _) ps = liftIO $ do 275 | pl <- newRdKafkaTopicPartitionListT (length ps) 276 | mapM_ (\(TopicName topicName, PartitionId partitionId) -> rdKafkaTopicPartitionListAdd pl (Text.unpack topicName) partitionId) ps 277 | KafkaResponseError <$> rdKafkaResumePartitions k pl 278 | 279 | -- | Seek a particular offset for each provided 'TopicPartition' 280 | {-# DEPRECATED seek "Use seekPartitions instead" #-} 281 | seek :: MonadIO m => KafkaConsumer -> Timeout -> [TopicPartition] -> m (Maybe KafkaError) 282 | seek (KafkaConsumer (Kafka k) _) (Timeout timeout) tps = liftIO $ 283 | either Just (const Nothing) <$> seekAll 284 | where 285 | seekAll = runExceptT $ do 286 | tr <- traverse (ExceptT . topicPair) tps 287 | mapM_ (\(kt, p, o) -> ExceptT (rdSeek kt p o)) tr 288 | 289 | rdSeek kt (PartitionId p) o = 290 | rdKafkaErrorToEither <$> rdKafkaSeek kt (fromIntegral p) (offsetToInt64 o) timeout 291 | 292 | topicPair tp = do 293 | let (TopicName tn) = tpTopicName tp 294 | nt <- newRdKafkaTopicT k (Text.unpack tn) Nothing 295 | return $ bimap KafkaError (,tpPartition tp, tpOffset tp) (first Text.pack nt) 296 | 297 | -- | Seek consumer for partitions in partitions to the per-partition 298 | -- offset in the offset field of partitions. 299 | seekPartitions :: MonadIO m => KafkaConsumer -> [TopicPartition] -> Timeout -> m (Maybe KafkaError) 300 | seekPartitions (KafkaConsumer (Kafka k) _) ps (Timeout timeout) = liftIO $ do 301 | tps <- toNativeTopicPartitionList ps 302 | err <- bracket (rdKafkaSeekPartitions k tps timeout) rdKafkaErrorDestroy rdKafkaErrorCode 303 | pure $ either Just (const Nothing) $ rdKafkaErrorToEither err 304 | 305 | -- | Retrieve committed offsets for topics+partitions. 306 | committed :: MonadIO m => KafkaConsumer -> Timeout -> [(TopicName, PartitionId)] -> m (Either KafkaError [TopicPartition]) 307 | committed (KafkaConsumer (Kafka k) _) (Timeout timeout) tps = liftIO $ do 308 | ntps <- toNativeTopicPartitionList' tps 309 | res <- rdKafkaCommitted k ntps timeout 310 | case res of 311 | RdKafkaRespErrNoError -> Right <$> fromNativeTopicPartitionList'' ntps 312 | err -> return $ Left (KafkaResponseError err) 313 | 314 | -- | Retrieve current positions (last consumed message offset+1) for the current running instance of the consumer. 315 | -- If the current consumer hasn't received any messages for a given partition, 'PartitionOffsetInvalid' is returned. 316 | position :: MonadIO m => KafkaConsumer -> [(TopicName, PartitionId)] -> m (Either KafkaError [TopicPartition]) 317 | position (KafkaConsumer (Kafka k) _) tps = liftIO $ do 318 | ntps <- toNativeTopicPartitionList' tps 319 | res <- rdKafkaPosition k ntps 320 | case res of 321 | RdKafkaRespErrNoError -> Right <$> fromNativeTopicPartitionList'' ntps 322 | err -> return $ Left (KafkaResponseError err) 323 | 324 | -- | Polls the provided kafka consumer for events. 325 | -- 326 | -- Events will cause application provided callbacks to be called. 327 | -- 328 | -- The 'Timeout' argument specifies the maximum amount of time 329 | -- (in milliseconds) that the call will block waiting for events. 330 | -- 331 | -- This function is called on each 'pollMessage' and, if runtime allows 332 | -- multi threading, it is called periodically in a separate thread 333 | -- to ensure the callbacks are handled ASAP. 334 | -- 335 | -- There is no particular need to call this function manually 336 | -- unless some special cases in a single-threaded environment 337 | -- when polling for events on each 'pollMessage' is not 338 | -- frequent enough. 339 | pollConsumerEvents :: KafkaConsumer -> Maybe Timeout -> IO () 340 | pollConsumerEvents k timeout = 341 | void . withCallbackPollEnabled k $ pollConsumerEvents' k timeout 342 | 343 | -- | Closes the consumer. 344 | -- 345 | -- See 'newConsumer' 346 | closeConsumer :: MonadIO m => KafkaConsumer -> m (Maybe KafkaError) 347 | closeConsumer (KafkaConsumer (Kafka k) (KafkaConf _ qr statusVar)) = liftIO $ 348 | -- because closing the consumer will raise callbacks, 349 | -- prevent the async loop from doing it at the same time 350 | modifyMVar statusVar $ \_ -> do 351 | -- librdkafka says: 352 | -- Prior to destroying the client instance, loose your reference to the 353 | -- background queue by calling rd_kafka_queue_destroy() 354 | readIORef qr >>= mapM_ rdKafkaQueueDestroy 355 | res <- kafkaErrorToMaybe . KafkaResponseError <$> rdKafkaConsumerClose k 356 | pure (CallbackPollDisabled, res) 357 | 358 | -- | Rewind consumer's consume position to the last committed offsets for the current assignment. 359 | -- NOTE: follows https://github.com/edenhill/librdkafka/blob/master/examples/transactions.c#L166 360 | rewindConsumer :: MonadIO m 361 | => KafkaConsumer 362 | -> Timeout 363 | -> m (Maybe KafkaError) 364 | rewindConsumer c to = liftIO $ do 365 | ret <- assignment c 366 | case ret of 367 | Left err -> pure $ Just err 368 | Right os -> do 369 | if M.size os == 0 370 | -- No current assignment to rewind 371 | then pure Nothing 372 | else do 373 | let tps = foldr (\(t, ps) acc -> map (t,) ps ++ acc) [] $ M.toList os 374 | ret' <- committed c to tps 375 | case ret' of 376 | Left err -> pure $ Just err 377 | Right ps -> do 378 | -- Seek to committed offset, or start of partition if no 379 | -- committed offset is available. 380 | let ps' = map checkOffsets ps 381 | seekPartitions c ps' to 382 | where 383 | checkOffsets :: TopicPartition -> TopicPartition 384 | checkOffsets tp 385 | | isUncommitedOffset $ tpOffset tp 386 | = tp { tpOffset = PartitionOffsetBeginning } 387 | | otherwise = tp 388 | 389 | isUncommitedOffset :: PartitionOffset -> Bool 390 | isUncommitedOffset (PartitionOffset _) = False 391 | isUncommitedOffset _ = True 392 | ----------------------------------------------------------------------------- 393 | newConsumerConf :: ConsumerProperties -> IO KafkaConf 394 | newConsumerConf ConsumerProperties {cpProps = m, cpCallbacks = cbs} = do 395 | conf <- kafkaConf (KafkaProps m) 396 | forM_ cbs (\(Callback setCb) -> setCb conf) 397 | return conf 398 | 399 | -- | Subscribes to a given list of topics. 400 | -- 401 | -- Wildcard (regex) topics are supported by the /librdkafka/ assignor: 402 | -- any topic name in the topics list that is prefixed with @^@ will 403 | -- be regex-matched to the full list of topics in the cluster and matching 404 | -- topics will be added to the subscription list. 405 | subscribe :: KafkaConsumer -> Set TopicName -> IO (Maybe KafkaError) 406 | subscribe (KafkaConsumer (Kafka k) _) ts = do 407 | pl <- newRdKafkaTopicPartitionListT (length ts) 408 | mapM_ (\(TopicName t) -> rdKafkaTopicPartitionListAdd pl (Text.unpack t) (-1)) (Set.toList ts) 409 | res <- KafkaResponseError <$> rdKafkaSubscribe k pl 410 | return $ kafkaErrorToMaybe res 411 | 412 | setDefaultTopicConf :: KafkaConf -> TopicConf -> IO () 413 | setDefaultTopicConf (KafkaConf kc _ _) (TopicConf tc) = 414 | rdKafkaTopicConfDup tc >>= rdKafkaConfSetDefaultTopicConf kc 415 | 416 | commitOffsets :: OffsetCommit -> KafkaConsumer -> RdKafkaTopicPartitionListTPtr -> IO (Maybe KafkaError) 417 | commitOffsets o (KafkaConsumer (Kafka k) _) pl = 418 | kafkaErrorToMaybe . KafkaResponseError <$> rdKafkaCommit k pl (offsetCommitToBool o) 419 | 420 | commitOffsetsStore :: KafkaConsumer -> RdKafkaTopicPartitionListTPtr -> IO (Maybe KafkaError) 421 | commitOffsetsStore (KafkaConsumer (Kafka k) _) pl = 422 | kafkaErrorToMaybe . KafkaResponseError <$> rdKafkaOffsetsStore k pl 423 | 424 | setConsumerLogLevel :: KafkaConsumer -> KafkaLogLevel -> IO () 425 | setConsumerLogLevel (KafkaConsumer (Kafka k) _) level = 426 | liftIO $ rdKafkaSetLogLevel k (fromEnum level) 427 | 428 | redirectCallbacksPoll :: KafkaConsumer -> IO (Maybe KafkaError) 429 | redirectCallbacksPoll (KafkaConsumer (Kafka k) _) = 430 | kafkaErrorToMaybe . KafkaResponseError <$> rdKafkaPollSetConsumer k 431 | 432 | runConsumerLoop :: KafkaConsumer -> Maybe Timeout -> IO () 433 | runConsumerLoop k timeout = 434 | when rtsSupportsBoundThreads $ void $ forkIO go 435 | where 436 | go = do 437 | st <- withCallbackPollEnabled k (pollConsumerEvents' k timeout) 438 | case st of 439 | CallbackPollEnabled -> go 440 | CallbackPollDisabled -> pure () 441 | 442 | whileNoCallbackRunning :: KafkaConsumer -> IO a -> IO a 443 | whileNoCallbackRunning k f = do 444 | let statusVar = kcfgCallbackPollStatus (getKafkaConf k) 445 | withMVar statusVar $ \_ -> f 446 | 447 | withCallbackPollEnabled :: KafkaConsumer -> IO () -> IO CallbackPollStatus 448 | withCallbackPollEnabled k f = do 449 | let statusVar = kcfgCallbackPollStatus (getKafkaConf k) 450 | withMVar statusVar $ \case 451 | CallbackPollEnabled -> f >> pure CallbackPollEnabled 452 | CallbackPollDisabled -> pure CallbackPollDisabled 453 | 454 | pollConsumerEvents' :: KafkaConsumer -> Maybe Timeout -> IO () 455 | pollConsumerEvents' k timeout = 456 | let (Timeout tm) = fromMaybe (Timeout 0) timeout 457 | in void $ rdKafkaConsumerPoll (getRdKafka k) tm 458 | --------------------------------------------------------------------------------