├── .envrc ├── .github └── workflows │ └── haskell.yml ├── .gitignore ├── .stylish-haskell.yaml ├── .vscode └── tasks.json ├── LICENSE ├── README.md ├── Setup.hs ├── cabal.project ├── docker-compose.yml ├── example ├── Main.hs └── Message.hs ├── hw-kafka-avro.cabal ├── project.sh ├── scripts ├── copy-docs.sh ├── hackage-docs.sh └── release ├── shell.nix ├── src └── Kafka │ ├── Avro.hs │ └── Avro │ ├── Decode.hs │ ├── Encode.hs │ └── SchemaRegistry.hs └── test └── Spec.hs /.envrc: -------------------------------------------------------------------------------- 1 | type nix-shell >/dev/null 2>&1 && use nix 2 | -------------------------------------------------------------------------------- /.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 | setup: 15 | runs-on: ubuntu-latest 16 | outputs: 17 | repository_name: ${{ steps.repo.outputs.repository_name }} 18 | version: ${{ steps.tag.outputs.version }} 19 | tag: ${{ steps.tag.outputs.tag }} 20 | has_new_tag: ${{ steps.tag.outputs.has_new_tag }} 21 | 22 | steps: 23 | - uses: actions/checkout@v4 24 | with: 25 | fetch-depth: 0 26 | 27 | - name: Determine repository name 28 | id: repo 29 | run: | 30 | echo "repository_name=$(echo ${{ github.repository }} | cut -d'/' -f2)" >> $GITHUB_OUTPUT 31 | 32 | - name: Determine package version 33 | id: tag 34 | run: | 35 | package_version="$(cat *.cabal | grep '^version:' | cut -d : -f 2 | xargs)" 36 | echo "Package version is v$package_version" 37 | echo "version=$package_version" >> $GITHUB_OUTPUT 38 | if ! git rev-parse "v$package_version" >/dev/null 2>&1; then 39 | echo "New tag to be created" 40 | echo "tag=v$package_version" >> $GITHUB_OUTPUT 41 | echo "has_new_tag=true" >> $GITHUB_OUTPUT 42 | fi 43 | 44 | 45 | build: 46 | permissions: 47 | contents: write 48 | 49 | runs-on: ${{ matrix.os }} 50 | needs: setup 51 | 52 | strategy: 53 | fail-fast: false 54 | matrix: 55 | ghc: ["9.10.1", "9.8.2", "9.6.6"] 56 | os: [ubuntu-latest, macOS-latest, windows-latest] 57 | 58 | steps: 59 | - uses: actions/checkout@v4 60 | 61 | - uses: haskell-actions/setup@v2.7.5 62 | id: setup-haskell 63 | with: 64 | ghc-version: ${{ matrix.ghc }} 65 | cabal-version: 3.12.1.0 66 | 67 | - name: Set some window specific things 68 | if: matrix.os == 'windows-latest' 69 | run: echo 'EXE_EXT=.exe' >> $GITHUB_ENV 70 | 71 | - name: Configure project 72 | run: | 73 | cabal configure --enable-tests --enable-benchmarks --write-ghc-environment-files=ghc8.4.4+ 74 | cabal build all --enable-tests --dry-run 75 | 76 | - name: Record dependencies 77 | run: | 78 | cat dist-newstyle/cache/plan.json | jq -r '."install-plan"[].id' | sort | uniq > dependencies.txt 79 | date +"%Y-%m-%d" > date.txt 80 | 81 | - name: Cache cabal store 82 | uses: actions/cache/restore@v4 83 | with: 84 | path: ${{ steps.setup-haskell.outputs.cabal-store }} 85 | key: | 86 | ${{ needs.setup.outputs.repository_name }}-${{ vars.CACHE_VERSION }}-${{ runner.os }}-${{ matrix.ghc }}-${{ hashFiles('dependencies.txt') }}-${{ hashFiles('date.txt') }} 87 | restore-keys: | 88 | ${{ needs.setup.outputs.repository_name }}-${{ vars.CACHE_VERSION }}-${{ runner.os }}-${{ matrix.ghc }}-${{ hashFiles('dependencies.txt') }}-${{ hashFiles('date.txt') }} 89 | ${{ needs.setup.outputs.repository_name }}-${{ vars.CACHE_VERSION }}-${{ runner.os }}-${{ matrix.ghc }}-${{ hashFiles('dependencies.txt') }} 90 | ${{ needs.setup.outputs.repository_name }}-${{ vars.CACHE_VERSION }}-${{ runner.os }}-${{ matrix.ghc }} 91 | 92 | - name: Build 93 | run: cabal build all --enable-tests --enable-benchmarks 94 | 95 | - name: Test 96 | run: cabal test all --enable-tests --enable-benchmarks 97 | 98 | - name: Cache Cabal store 99 | uses: actions/cache/save@v4 100 | with: 101 | path: ${{ steps.setup-haskell.outputs.cabal-store }} 102 | key: | 103 | ${{ needs.setup.outputs.repository_name }}-${{ vars.CACHE_VERSION }}-${{ runner.os }}-${{ matrix.ghc }}-${{ hashFiles('dependencies.txt') }}-${{ hashFiles('date.txt') }} 104 | 105 | 106 | check: 107 | needs: [build, setup] 108 | runs-on: ubuntu-latest 109 | steps: 110 | - uses: actions/checkout@v4 111 | 112 | - name: Check if cabal project is sane 113 | run: | 114 | PROJECT_DIR=$PWD 115 | mkdir -p $PROJECT_DIR/build/sdist 116 | for i in $(git ls-files | grep '\.cabal'); do 117 | cd $PROJECT_DIR && cd `dirname $i` 118 | cabal check 119 | done 120 | 121 | 122 | release: 123 | needs: [build, setup] 124 | runs-on: ubuntu-latest 125 | if: github.ref == 'refs/heads/main' && needs.setup.outputs.has_new_tag == 'true' 126 | outputs: 127 | upload_url: ${{ steps.create_release.outputs.upload_url }} 128 | 129 | steps: 130 | - uses: actions/checkout@v4 131 | 132 | - name: Create source distribution 133 | run: | 134 | PROJECT_DIR=$PWD 135 | mkdir -p $PROJECT_DIR/build/sdist 136 | for i in $(git ls-files | grep '\.cabal'); do 137 | cd $PROJECT_DIR && cd `dirname $i` 138 | cabal v2-sdist -o $PROJECT_DIR/build/sdist 139 | done; 140 | 141 | - name: Publish to hackage 142 | env: 143 | server: http://hackage.haskell.org 144 | username: ${{ secrets.HACKAGE_USER }} 145 | password: ${{ secrets.HACKAGE_PASS }} 146 | candidate: false 147 | run: | 148 | package_version="$(cat *.cabal | grep '^version:' | cut -d : -f 2 | xargs)" 149 | for PACKAGE_TARBALL in $(find ./build/sdist/ -name "*.tar.gz"); do 150 | PACKAGE_NAME=$(basename ${PACKAGE_TARBALL%.*.*}) 151 | if ${{ env.candidate }}; then 152 | TARGET_URL="${{ env.server }}/packages/candidates"; 153 | DOCS_URL="${{ env.server }}/package/$PACKAGE_NAME/candidate/docs" 154 | else 155 | TARGET_URL="${{ env.server }}/packages/upload"; 156 | DOCS_URL="${{ env.server }}/package/$PACKAGE_NAME/docs" 157 | fi 158 | HACKAGE_STATUS=$(curl --silent --head -w %{http_code} -XGET --anyauth --user "${{ env.username }}:${{ env.password }}" ${{ env.server }}/package/$PACKAGE_NAME -o /dev/null) 159 | if [ "$HACKAGE_STATUS" = "404" ]; then 160 | echo "Uploading $PACKAGE_NAME to $TARGET_URL" 161 | curl -X POST -f --user "${{ env.username }}:${{ env.password }}" $TARGET_URL -F "package=@$PACKAGE_TARBALL" 162 | echo "Uploaded $PACKAGE_NAME" 163 | else 164 | echo "Package $PACKAGE_NAME" already exists on Hackage. 165 | fi 166 | done 167 | 168 | - name: "Build Changelog" 169 | id: build_changelog 170 | uses: mikepenz/release-changelog-builder-action@v5 171 | env: 172 | GITHUB_TOKEN: ${{ github.token }} 173 | with: 174 | toTag: HEAD 175 | 176 | - name: Tag published version 177 | uses: actions/github-script@v7 178 | with: 179 | github-token: ${{ secrets.GITHUB_TOKEN }} 180 | script: | 181 | github.rest.git.createRef({ 182 | owner: context.repo.owner, 183 | repo: context.repo.repo, 184 | ref: 'refs/tags/${{ needs.setup.outputs.tag }}', 185 | sha: context.sha, 186 | force: true 187 | }) 188 | 189 | - name: Create Release 190 | id: create_release 191 | uses: ncipollo/release-action@v1 192 | env: 193 | GITHUB_TOKEN: ${{ secrets.GITHUB_TOKEN }} # This token is provided by Actions, you do not need to create your own token 194 | with: 195 | tag: ${{ needs.setup.outputs.tag }} 196 | name: Release ${{ needs.setup.outputs.tag }} 197 | body: ${{ steps.build_changelog.outputs.changelog }} 198 | draft: false 199 | prerelease: false 200 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | ### OSX ### 2 | .DS_Store 3 | *.DS_Store 4 | .AppleDouble 5 | .LSOverride 6 | 7 | # Icon must ends with two \r. 8 | Icon 9 | 10 | # Thumbnails 11 | ._* 12 | 13 | # Files that might appear on external disk 14 | .Spotlight-V100 15 | .Trashes 16 | 17 | ### Haskell ### 18 | dist/ 19 | dist-newstyle/ 20 | cabal-dev 21 | .ghc.environment* 22 | *.o 23 | *.hi 24 | *.chi 25 | *.chs.h 26 | .virthualenv 27 | .hsenv 28 | .cabal-sandbox/ 29 | cabal.sandbox.config 30 | cabal.config 31 | cabal.project.local 32 | .stack-work/ 33 | *.aux 34 | *.ps 35 | *.hp 36 | *.prof 37 | 38 | ### Emacs ### 39 | # -*- mode: gitignore; -*- 40 | *~ 41 | \#*\# 42 | /.emacs.desktop 43 | /.emacs.desktop.lock 44 | *.elc 45 | auto-save-list 46 | tramp 47 | .\#* 48 | 49 | # Org-mode 50 | .org-id-locations 51 | *_archive 52 | 53 | # flymake-mode 54 | *_flymake.* 55 | 56 | # eshell files 57 | /eshell/history 58 | /eshell/lastdir 59 | 60 | # elpa packages 61 | /elpa/ 62 | TAGS 63 | 64 | .direnv/ 65 | -------------------------------------------------------------------------------- /.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 | -------------------------------------------------------------------------------- /.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 v2-build --enable-tests && 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 v2-test --enable-tests --test-show-details=direct && 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 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright Alexey Raga (c) 2016 2 | 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions are met: 7 | 8 | * Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | 11 | * Redistributions in binary form must reproduce the above 12 | copyright notice, this list of conditions and the following 13 | disclaimer in the documentation and/or other materials provided 14 | with the distribution. 15 | 16 | * Neither the name of Alexey Raga nor the names of other 17 | contributors may be used to endorse or promote products derived 18 | from this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # kafka-avro-serialiser 2 | 3 | Avro serialiser/deserialiser for Kafka messages. Uses SchemaRegistry for schema compatibility and discoverability functionality. 4 | 5 | This library is meant to be compatible (on both sending and receiving sides) with Java kafka/avro serialiser (written by Confluent). 6 | -------------------------------------------------------------------------------- /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /cabal.project: -------------------------------------------------------------------------------- 1 | packages: . 2 | -------------------------------------------------------------------------------- /docker-compose.yml: -------------------------------------------------------------------------------- 1 | version: '2' 2 | services: 3 | 4 | zookeeper: 5 | image: confluentinc/cp-zookeeper:3.1.2 6 | hostname: zookeeper 7 | ports: 8 | - 2182:2181 9 | environment: 10 | SERVICE_NAME: zookeeper 11 | ZOOKEEPER_CLIENT_PORT: 2181 12 | 13 | kafka: 14 | image: confluentinc/cp-kafka:3.1.2 15 | hostname: kafka 16 | ports: 17 | - 9092:9092 18 | links: 19 | - zookeeper:zookeeper 20 | environment: 21 | KAFKA_ZOOKEEPER_CONNECT: "zookeeper:2181" 22 | KAFKA_ADVERTISED_LISTENERS: "PLAINTEXT://$DOCKER_IP:9092" 23 | KAFKA_CREATE_TOPICS: 24 | 25 | 26 | schema-registry: 27 | image: confluentinc/cp-schema-registry:3.1.2 28 | hostname: schema-registry 29 | ports: 30 | - 8081:8081 31 | links: 32 | - zookeeper:zookeeper 33 | environment: 34 | SCHEMA_REGISTRY_KAFKASTORE_CONNECTION_URL: zookeeper:2181 35 | SCHEMA_REGISTRY_HOST_NAME: schema_registry 36 | depends_on: 37 | - zookeeper 38 | - kafka 39 | -------------------------------------------------------------------------------- /example/Main.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | {-# LANGUAGE ScopedTypeVariables #-} 3 | module Main where 4 | 5 | import Control.Monad.Trans.Except 6 | import qualified Data.Aeson as J 7 | import Data.Monoid 8 | 9 | import Data.Int 10 | import Data.Text 11 | import Kafka.Avro 12 | import Message 13 | 14 | exampleMessage = TestMessage 1 "Example" True 12345678 15 | 16 | data AppError = EncError EncodeError | DecError DecodeError 17 | deriving (Show) 18 | 19 | main :: IO () 20 | main = do 21 | sr <- schemaRegistry "http://localhost:8081" 22 | res <- runExceptT $ roundtrip sr 23 | print res 24 | 25 | roundtrip :: SchemaRegistry -> ExceptT AppError IO TestMessage 26 | roundtrip sr = do 27 | enc <- withExceptT EncError (encode' exampleMessage) 28 | dec <- withExceptT DecError (decode' enc) 29 | return dec 30 | where 31 | encode' msg = ExceptT $ encode sr (Subject "example-subject") exampleMessage 32 | decode' msg = ExceptT $ decode sr msg 33 | -------------------------------------------------------------------------------- /example/Message.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveGeneric #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | {-# LANGUAGE QuasiQuotes #-} 4 | {-# LANGUAGE TemplateHaskell #-} 5 | module Message 6 | ( TestMessage(..) 7 | , schema'TestMessage 8 | ) where 9 | 10 | import Data.Avro 11 | import Data.Avro.Deriving 12 | 13 | deriveAvroFromByteString [r| 14 | { 15 | "type": "record", 16 | "name": "TestMessage", 17 | "namespace": "hw.kafka.avro.test", 18 | "fields": [ 19 | { "name": "id", "type": "long" }, 20 | { "name": "name", "type": "string" }, 21 | { "name": "is_active", "type": "boolean" }, 22 | { "name": "timestamp", "type": "long" } 23 | ] 24 | } 25 | |] 26 | 27 | -------------------------------------------------------------------------------- /hw-kafka-avro.cabal: -------------------------------------------------------------------------------- 1 | cabal-version: 2.4 2 | 3 | name: hw-kafka-avro 4 | version: 6.1.2 5 | synopsis: Avro support for Kafka infrastructure 6 | description: Avro support for Kafka infrastructure. 7 | category: Services 8 | homepage: https://github.com/haskell-works/hw-kafka-avro#readme 9 | bug-reports: https://github.com/haskell-works/hw-kafka-avro/issues 10 | author: Alexey Raga 11 | maintainer: alexey.raga@gmail.com 12 | copyright: Alexey Raga 13 | license: BSD-3-Clause 14 | license-file: LICENSE 15 | build-type: Simple 16 | tested-with: GHC == 9.10.1, GHC == 9.8.2, GHC == 9.6.6 17 | extra-source-files: README.md 18 | 19 | source-repository head 20 | type: git 21 | location: https://github.com/haskell-works/hw-kafka-avro 22 | 23 | flag examples 24 | description: Also compile examples 25 | manual: True 26 | default: False 27 | 28 | common base { build-depends: base >= 4 && < 5 } 29 | common avro { build-depends: avro >= 0.6.0.2 && < 0.7 } 30 | 31 | common aeson { build-depends: aeson >= 2.0.1.0 } 32 | common binary { build-depends: binary } 33 | common bytestring { build-depends: bytestring } 34 | common containers { build-depends: containers } 35 | common cache { build-depends: cache } 36 | common fail { build-depends: fail } 37 | common hashable { build-depends: hashable } 38 | common hedgehog { build-depends: hedgehog } 39 | common hw-hspec-hedgehog { build-depends: hw-hspec-hedgehog } 40 | common hspec { build-depends: hspec } 41 | common lens { build-depends: lens } 42 | common mtl { build-depends: mtl } 43 | common semigroups { build-depends: semigroups } 44 | common tagged { build-depends: tagged } 45 | common http-client { build-depends: http-client } 46 | common http-types { build-depends: http-types } 47 | common text { build-depends: text >= 1.2.3 && < 1.3 || >= 2.0 && < 2.2 } 48 | common transformers { build-depends: transformers >= 0.5.6.2 && < 0.7 } 49 | common unordered-containers { build-depends: unordered-containers } 50 | common safe-exceptions { build-depends: safe-exceptions >= 0.1.7.2 && < 0.2 } 51 | common wreq { build-depends: wreq } 52 | 53 | common config 54 | default-language: Haskell2010 55 | 56 | library 57 | import: base 58 | , aeson 59 | , avro 60 | , binary 61 | , bytestring 62 | , cache 63 | , containers 64 | , hashable 65 | , http-client 66 | , http-types 67 | , lens 68 | , mtl 69 | , safe-exceptions 70 | , semigroups 71 | , tagged 72 | , text 73 | , transformers 74 | , unordered-containers 75 | , wreq 76 | , config 77 | exposed-modules: 78 | Kafka.Avro 79 | Kafka.Avro.Decode 80 | Kafka.Avro.Encode 81 | Kafka.Avro.SchemaRegistry 82 | hs-source-dirs: src 83 | 84 | executable kafka-avro-example 85 | import: base 86 | , aeson 87 | , avro 88 | , bytestring 89 | , cache 90 | , containers 91 | , lens 92 | , mtl 93 | , semigroups 94 | , text 95 | , transformers 96 | , unordered-containers 97 | , config 98 | main-is: Main.hs 99 | other-modules: 100 | Message 101 | hs-source-dirs: example 102 | ghc-options: -threaded -rtsopts -with-rtsopts=-N 103 | build-depends: hw-kafka-avro 104 | if !(flag(examples)) 105 | buildable: False 106 | 107 | test-suite kafka-avro-test 108 | import: base 109 | , config 110 | , hedgehog 111 | , hspec 112 | , hw-hspec-hedgehog 113 | type: exitcode-stdio-1.0 114 | main-is: Spec.hs 115 | other-modules: 116 | hs-source-dirs: test 117 | ghc-options: -threaded -rtsopts -with-rtsopts=-N 118 | build-depends: hw-kafka-avro 119 | -------------------------------------------------------------------------------- /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 | -------------------------------------------------------------------------------- /scripts/copy-docs.sh: -------------------------------------------------------------------------------- 1 | #!/bin/bash 2 | set -e 3 | 4 | pkg=$(cat *.cabal | grep -e "^name" | tr -s " " | cut -d' ' -f2) 5 | ver=$(cat *.cabal | grep -e "^version" | tr -s " " | cut -d' ' -f2) 6 | 7 | if [ -z "$pkg" ]; then 8 | echo "Unable to determine package name" 9 | exit 1 10 | fi 11 | 12 | if [ -z "$ver" ]; then 13 | echo "Unable to determine package version" 14 | exit 1 15 | fi 16 | 17 | echo "Detected package: $pkg-$ver" 18 | 19 | mkdir -p mkdir /tmp/doc 20 | 21 | cp -R $(stack path --local-install-root)/doc/$pkg-$ver/ /tmp/doc/$pkg-$ver 22 | -------------------------------------------------------------------------------- /scripts/hackage-docs.sh: -------------------------------------------------------------------------------- 1 | #!/bin/bash 2 | set -e 3 | 4 | # This if stack-enabled fork of https://github.com/ekmett/lens/blob/master/scripts/hackage-docs.sh 5 | 6 | if [ "$#" -ne 1 ]; then 7 | echo "Usage: scripts/hackage-docs.sh HACKAGE_USER" 8 | exit 1 9 | fi 10 | 11 | user=$1 12 | 13 | cabal_file=$(find . -maxdepth 1 -name "*.cabal" -print -quit) 14 | if [ ! -f "$cabal_file" ]; then 15 | echo "Run this script in the top-level package directory" 16 | exit 1 17 | fi 18 | 19 | pkg=$(awk -F ":[[:space:]]*" 'tolower($1)=="name" { print $2 }' < "$cabal_file") 20 | ver=$(awk -F ":[[:space:]]*" 'tolower($1)=="version" { print $2 }' < "$cabal_file") 21 | 22 | if [ -z "$pkg" ]; then 23 | echo "Unable to determine package name" 24 | exit 1 25 | fi 26 | 27 | if [ -z "$ver" ]; then 28 | echo "Unable to determine package version" 29 | exit 1 30 | fi 31 | 32 | echo "Detected package: $pkg-$ver" 33 | 34 | dir=$(mktemp -d build-docs.XXXXXX) 35 | trap 'rm -r "$dir"' EXIT 36 | 37 | export PATH=$(stack path --bin-path) 38 | 39 | ghc --version 40 | cabal --version 41 | stack --version 42 | 43 | if haddock --hyperlinked-source >/dev/null 44 | then 45 | echo "Using fancy hyperlinked source" 46 | HYPERLINK_FLAG="--haddock-option=--hyperlinked-source" 47 | else 48 | echo "Using boring hyperlinked source" 49 | HYPERLINK_FLAG="--hyperlink-source" 50 | fi 51 | 52 | # Cabal dist in temporary location 53 | builddir=$dir/dist 54 | 55 | # Build dependencies haddocks with stack, so we get links 56 | stack haddock --only-dependencies 57 | 58 | # Configure using stack databases 59 | snapshotpkgdb=$(stack path --snapshot-pkg-db) 60 | localpkgdb=$(stack path --local-pkg-db) 61 | cabal configure -v2 --builddir=$builddir --package-db=clear --package-db=global --package-db=$snapshotpkgdb --package-db=$localpkgdb 62 | 63 | # Build Hadckage compatible docs 64 | cabal haddock -v2 --builddir=$builddir $HYPERLINK_FLAG --html-location='/package/$pkg-$version/docs' --contents-location='/package/$pkg-$version' 65 | 66 | # Copy into right directory 67 | cp -R $builddir/doc/html/$pkg/ $dir/$pkg-$ver-docs 68 | 69 | # Tar and gzip 70 | tar cvz -C $dir --format=ustar -f $dir/$pkg-$ver-docs.tar.gz $pkg-$ver-docs 71 | 72 | # Upload 73 | curl -X PUT \ 74 | -H 'Content-Type: application/x-tar' \ 75 | -H 'Content-Encoding: gzip' \ 76 | -u "$user" \ 77 | --data-binary "@$dir/$pkg-$ver-docs.tar.gz" \ 78 | "https://hackage.haskell.org/package/$pkg-$ver/docs" -------------------------------------------------------------------------------- /scripts/release: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env bash 2 | 3 | if [ "$_system_type" == "Darwin" ]; then 4 | sed () { 5 | gsed "$@" 6 | } 7 | fi 8 | 9 | _version=$(cat package.yaml | grep -i -e "^version:" | cut -d : -f 2 | xargs) 10 | 11 | _branch=$(git rev-parse --abbrev-ref HEAD) 12 | _branch_prefix=${_branch%-branch} 13 | 14 | if [[ $(git ls-remote origin "refs/tags/v$_version") ]]; then 15 | echo "The tag v$_version already exists. Will not tag" 16 | exit 0 17 | fi 18 | 19 | _commit=$(git rev-parse --verify HEAD) 20 | 21 | _release_data=$(cat < {config.allowUnfree = true;}); 2 | 3 | let 4 | in 5 | pkgs.mkShell { 6 | buildInputs = with pkgs; [ 7 | zlib 8 | haskell.compiler.ghc92 9 | cabal-install 10 | haskell-language-server 11 | ]; 12 | 13 | shellHook = '' 14 | PATH=~/.cabal/bin:$PATH 15 | LD_LIBRARY_PATH=${pkgs.zlib}/lib/:$LD_LIBRARY_PATH 16 | ''; 17 | } 18 | -------------------------------------------------------------------------------- /src/Kafka/Avro.hs: -------------------------------------------------------------------------------- 1 | module Kafka.Avro 2 | ( module X 3 | , propagateKeySchema 4 | , propagateValueSchema 5 | ) where 6 | 7 | import Control.Monad.IO.Class 8 | import Data.ByteString.Lazy 9 | 10 | import Kafka.Avro.Decode as X 11 | import Kafka.Avro.Encode as X 12 | import Kafka.Avro.SchemaRegistry as X 13 | 14 | -- | Registers schema that was used for a given payload against the specified subject as a key shema. 15 | -- It is possible that a given payload doesn't have schema registered against it, in this case no prapagation happens. 16 | propagateKeySchema :: MonadIO m => SchemaRegistry -> Subject -> ByteString -> m (Either SchemaRegistryError (Maybe SchemaId)) 17 | propagateKeySchema sr subj = propagateSchema sr (keySubject subj) 18 | 19 | -- | Registers schema that was used for a given payload against the specified subject as a value schema. 20 | -- It is possible that a given payload doesn't have schema registered against it, in this case no prapagation happens. 21 | propagateValueSchema :: MonadIO m => SchemaRegistry -> Subject -> ByteString -> m (Either SchemaRegistryError (Maybe SchemaId)) 22 | propagateValueSchema sr subj = propagateSchema sr (valueSubject subj) 23 | 24 | propagateSchema :: MonadIO m 25 | => SchemaRegistry 26 | -> Subject 27 | -> ByteString 28 | -> m (Either SchemaRegistryError (Maybe SchemaId)) 29 | propagateSchema sr subj bs = 30 | case extractSchemaId bs of 31 | Nothing -> return $ Right Nothing 32 | Just (sid, _) -> do 33 | mSchema <- loadSchema sr sid 34 | case mSchema of 35 | Left (SchemaRegistrySchemaNotFound _) -> return $ Right Nothing 36 | Left err -> return $ Left err 37 | Right schema -> fmap Just <$> sendSchema sr subj schema 38 | -------------------------------------------------------------------------------- /src/Kafka/Avro/Decode.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ScopedTypeVariables #-} 2 | {-# LANGUAGE TypeApplications #-} 3 | module Kafka.Avro.Decode 4 | ( 5 | DecodeError(..) 6 | , decode 7 | , decodeWithSchema 8 | , extractSchemaId 9 | ) where 10 | 11 | import Control.Arrow (left) 12 | import Control.Monad.IO.Class (MonadIO) 13 | import Control.Monad.Trans.Except 14 | import Data.Avro (FromAvro, HasAvroSchema (..), Schema, decodeValueWithSchema, deconflict) 15 | import Data.Bits (shiftL) 16 | import Data.ByteString.Lazy (ByteString) 17 | import qualified Data.ByteString.Lazy as BL hiding (zipWith) 18 | import Data.Int 19 | import Data.Tagged (untag) 20 | import Kafka.Avro.SchemaRegistry 21 | 22 | data DecodeError = DecodeRegistryError SchemaRegistryError 23 | | BadPayloadNoSchemaId 24 | | DecodeError Schema String 25 | | IncompatibleSchema Schema String 26 | deriving (Show, Eq) 27 | 28 | -- | Decodes a provided Avro-encoded value. 29 | -- The serialised value is expected to be in a "confluent-compatible" format 30 | -- where the "real" value bytestring is prepended with extra 5 bytes: 31 | -- a "magic" byte and 4 bytes representing the schema ID. 32 | decode :: forall a m. (MonadIO m, HasAvroSchema a, FromAvro a) 33 | => SchemaRegistry 34 | -> ByteString 35 | -> m (Either DecodeError a) 36 | decode sr = decodeWithSchema sr (untag @a schema) 37 | {-# INLINE decode #-} 38 | 39 | decodeWithSchema :: forall a m. (MonadIO m, FromAvro a) 40 | => SchemaRegistry 41 | -> Schema 42 | -> ByteString 43 | -> m (Either DecodeError a) 44 | decodeWithSchema sr readerSchema bs = 45 | case schemaData of 46 | Left err -> return $ Left err 47 | Right (sid, payload) -> runExceptT $ do 48 | writerSchema <- withError DecodeRegistryError (loadSchema sr sid) 49 | readSchema <- withPureError (IncompatibleSchema writerSchema) $ deconflict writerSchema readerSchema 50 | withPureError (DecodeError writerSchema) (decodeValueWithSchema readSchema payload) 51 | where 52 | schemaData = maybe (Left BadPayloadNoSchemaId) Right (extractSchemaId bs) 53 | withError f = withExceptT f . ExceptT 54 | withPureError f = withError f . pure 55 | 56 | extractSchemaId :: ByteString -> Maybe (SchemaId, ByteString) 57 | extractSchemaId bs = do 58 | (_ , b0) <- BL.uncons bs 59 | (w1, b1) <- BL.uncons b0 60 | (w2, b2) <- BL.uncons b1 61 | (w3, b3) <- BL.uncons b2 62 | (w4, b4) <- BL.uncons b3 63 | let ints = fromIntegral <$> [w4, w3, w2, w1] :: [Int32] 64 | let int = sum $ zipWith shiftL ints [0, 8, 16, 24] 65 | return (SchemaId int, b4) 66 | 67 | -------------------------------------------------------------------------------- /src/Kafka/Avro/Encode.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | {-# LANGUAGE ScopedTypeVariables #-} 3 | {-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} 4 | {-# HLINT ignore "Use newtype instead of data" #-} 5 | module Kafka.Avro.Encode 6 | ( EncodeError(..) 7 | , encodeKey 8 | , encodeValue 9 | , encode 10 | 11 | , encodeKeyWithSchema 12 | , encodeValueWithSchema 13 | , encodeWithSchema 14 | 15 | , keySubject, valueSubject 16 | ) where 17 | 18 | import Control.Monad.IO.Class (MonadIO) 19 | import Data.Avro (HasAvroSchema, Schema, ToAvro, schemaOf) 20 | import qualified Data.Avro as A 21 | import qualified Data.Binary as B 22 | import Data.Bits (shiftL) 23 | import Data.ByteString.Lazy (ByteString) 24 | import qualified Data.ByteString.Lazy as BL hiding (zipWith) 25 | import Data.Monoid 26 | import Kafka.Avro.SchemaRegistry 27 | 28 | data EncodeError = EncodeRegistryError SchemaRegistryError 29 | deriving (Show, Eq) 30 | 31 | keySubject :: Subject -> Subject 32 | keySubject (Subject subj) = Subject (subj <> "-key") 33 | {-# INLINE keySubject #-} 34 | 35 | valueSubject :: Subject -> Subject 36 | valueSubject (Subject subj) = Subject (subj <> "-value") 37 | {-# INLINE valueSubject #-} 38 | 39 | -- | Encodes a provided value as a message key with "-key" subject. 40 | encodeKey :: (MonadIO m, HasAvroSchema a, ToAvro a) 41 | => SchemaRegistry 42 | -> Subject 43 | -> a 44 | -> m (Either EncodeError ByteString) 45 | encodeKey sr subj = encode sr (keySubject subj) 46 | {-# INLINE encodeKey #-} 47 | 48 | -- | Encodes a provided value as a message key with "-key" subject. 49 | encodeKeyWithSchema :: (MonadIO m, ToAvro a) 50 | => SchemaRegistry 51 | -> Subject 52 | -> Schema 53 | -> a 54 | -> m (Either EncodeError ByteString) 55 | encodeKeyWithSchema sr subj = encodeWithSchema sr (keySubject subj) 56 | {-# INLINE encodeKeyWithSchema #-} 57 | 58 | -- | Encodes a provided value as a message value with "-value" subject. 59 | encodeValue :: (MonadIO m, HasAvroSchema a, ToAvro a) 60 | => SchemaRegistry 61 | -> Subject 62 | -> a 63 | -> m (Either EncodeError ByteString) 64 | encodeValue sr subj = encode sr (valueSubject subj) 65 | {-# INLINE encodeValue #-} 66 | 67 | -- | Encodes a provided value as a message value with "-value" subject. 68 | encodeValueWithSchema :: (MonadIO m, ToAvro a) 69 | => SchemaRegistry 70 | -> Subject 71 | -> Schema 72 | -> a 73 | -> m (Either EncodeError ByteString) 74 | encodeValueWithSchema sr subj = encodeWithSchema sr (valueSubject subj) 75 | {-# INLINE encodeValueWithSchema #-} 76 | 77 | encode :: (MonadIO m, HasAvroSchema a, ToAvro a) 78 | => SchemaRegistry 79 | -> Subject 80 | -> a 81 | -> m (Either EncodeError ByteString) 82 | encode sr subj a = encodeWithSchema sr subj (schemaOf a) a 83 | {-# INLINE encode #-} 84 | 85 | -- | Encodes a provided value into Avro 86 | encodeWithSchema :: forall a m. (MonadIO m, ToAvro a) 87 | => SchemaRegistry 88 | -> Subject 89 | -> Schema 90 | -> a 91 | -> m (Either EncodeError ByteString) 92 | encodeWithSchema sr subj sch a = do 93 | mbSid <- sendSchema sr subj sch 94 | case mbSid of 95 | Left err -> return . Left . EncodeRegistryError $ err 96 | Right sid -> return . Right $ appendSchemaId sid (A.encodeValueWithSchema sch a) 97 | 98 | 99 | appendSchemaId :: SchemaId -> ByteString -> ByteString 100 | appendSchemaId (SchemaId sid) bs = 101 | -- add a "magic byte" followed by schema id 102 | BL.cons (toEnum 0) (B.encode sid) <> bs 103 | -------------------------------------------------------------------------------- /src/Kafka/Avro/SchemaRegistry.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE DeriveGeneric #-} 3 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 4 | {-# LANGUAGE OverloadedStrings #-} 5 | {-# LANGUAGE ScopedTypeVariables #-} 6 | {-# LANGUAGE TupleSections #-} 7 | 8 | module Kafka.Avro.SchemaRegistry 9 | ( schemaRegistry, loadSchema, sendSchema 10 | , schemaRegistry_ 11 | , schemaRegistryWithHeaders 12 | , loadSubjectSchema 13 | , getGlobalConfig, getSubjectConfig 14 | , getVersions, isCompatible 15 | , getSubjects 16 | , defaultSchemaRegistryConfig 17 | , cfgAuth 18 | , cfgHeaders 19 | , cfgAutoRegisterSchemas 20 | , SchemaId(..), Subject(..) 21 | , SchemaRegistryConfig 22 | , SchemaRegistry, SchemaRegistryError(..) 23 | , Schema(..) 24 | , Compatibility(..), Version(..) 25 | ) where 26 | 27 | import Control.Arrow (first) 28 | import Control.Exception (SomeException (SomeException), throwIO) 29 | import Control.Exception.Safe (MonadCatch, try) 30 | import Control.Lens (view, (%~), (&), (.~), (^.)) 31 | import Control.Monad (void) 32 | import Control.Monad.Except (liftEither) 33 | import Control.Monad.IO.Class (MonadIO, liftIO) 34 | import Control.Monad.Trans.Except (ExceptT (ExceptT), except, runExceptT, withExceptT) 35 | import Data.Aeson 36 | import qualified Data.Aeson.Key as A 37 | import qualified Data.Aeson.KeyMap as KM 38 | import Data.Aeson.Types (typeMismatch) 39 | import Data.Avro.Schema.Schema (Schema (..), typeName) 40 | import Data.Bifunctor (bimap) 41 | import Data.Cache as C 42 | import Data.Foldable (traverse_) 43 | import Data.Functor (($>)) 44 | import Data.Hashable (Hashable) 45 | import qualified Data.HashMap.Lazy as HM 46 | import Data.Int (Int32) 47 | import Data.List (find) 48 | import Data.String (IsString) 49 | import Data.Text (Text, append, cons, unpack) 50 | import qualified Data.Text.Encoding as Text 51 | import qualified Data.Text.Lazy.Encoding as LText 52 | import Data.Word (Word32) 53 | import GHC.Exception (SomeException, displayException, fromException) 54 | import GHC.Generics (Generic) 55 | import Network.HTTP.Client (HttpException (..), HttpExceptionContent (..), Manager, defaultManagerSettings, newManager, responseStatus) 56 | import Network.HTTP.Types.Header (Header) 57 | import Network.HTTP.Types.Status (notFound404) 58 | import qualified Network.Wreq as Wreq 59 | 60 | newtype SchemaId = SchemaId { unSchemaId :: Int32} deriving (Eq, Ord, Show, Hashable) 61 | newtype SchemaName = SchemaName Text deriving (Eq, Ord, IsString, Show, Hashable) 62 | 63 | newtype Subject = Subject { unSubject :: Text} deriving (Eq, Show, IsString, Ord, Generic, Hashable) 64 | 65 | newtype RegisteredSchema = RegisteredSchema { unRegisteredSchema :: Schema} deriving (Generic, Show) 66 | 67 | newtype Version = Version { unVersion :: Word32 } deriving (Eq, Ord, Show, Hashable) 68 | 69 | data Compatibility = NoCompatibility 70 | | FullCompatibility 71 | | ForwardCompatibility 72 | | BackwardCompatibility 73 | deriving (Eq, Show, Ord) 74 | 75 | data SchemaRegistryConfig = SchemaRegistryConfig 76 | { cAuth :: Maybe Wreq.Auth 77 | , cExtraHeaders :: [Header] 78 | , cAutoRegisterSchemas :: Bool 79 | } 80 | 81 | data SchemaRegistry = SchemaRegistry 82 | { srCache :: Cache SchemaId Schema 83 | , srReverseCache :: Cache (Subject, SchemaName) SchemaId 84 | , srBaseUrl :: String 85 | , srConfig :: SchemaRegistryConfig 86 | } 87 | 88 | data SchemaRegistryError = SchemaRegistryConnectError String 89 | | SchemaRegistryLoadError SchemaId 90 | | SchemaRegistrySchemaNotFound SchemaId 91 | | SchemaRegistrySubjectNotFound Subject 92 | | SchemaRegistryNoCompatibleSchemaFound Schema 93 | | SchemaRegistryUrlNotFound String 94 | | SchemaRegistrySendError String 95 | | SchemaRegistryCacheError 96 | deriving (Show, Eq) 97 | 98 | defaultSchemaRegistryConfig :: SchemaRegistryConfig 99 | defaultSchemaRegistryConfig = SchemaRegistryConfig 100 | { cAuth = Nothing 101 | , cExtraHeaders = [] 102 | , cAutoRegisterSchemas = True 103 | } 104 | 105 | schemaRegistry :: MonadIO m => String -> m SchemaRegistry 106 | schemaRegistry = schemaRegistry_ Nothing 107 | 108 | schemaRegistry_ :: MonadIO m => Maybe Wreq.Auth -> String -> m SchemaRegistry 109 | schemaRegistry_ auth = schemaRegistryWithHeaders auth [] 110 | 111 | schemaRegistryWithHeaders :: MonadIO m => Maybe Wreq.Auth -> [Header] -> String -> m SchemaRegistry 112 | schemaRegistryWithHeaders auth headers url 113 | = schemaRegistryWithConfig url $ cfgAuth auth $ cfgHeaders headers defaultSchemaRegistryConfig 114 | 115 | schemaRegistryWithConfig :: MonadIO m => String -> SchemaRegistryConfig -> m SchemaRegistry 116 | schemaRegistryWithConfig url config = liftIO $ 117 | SchemaRegistry 118 | <$> newCache Nothing 119 | <*> newCache Nothing 120 | <*> pure url 121 | <*> pure config 122 | 123 | -- | Add authentication options 124 | cfgAuth :: Maybe Wreq.Auth -> SchemaRegistryConfig -> SchemaRegistryConfig 125 | cfgAuth auth config = config { cAuth = auth } 126 | 127 | -- | Add extra headers 128 | cfgHeaders :: [Header] -> SchemaRegistryConfig -> SchemaRegistryConfig 129 | cfgHeaders headers config = config { cExtraHeaders = headers } 130 | 131 | -- | Set whether to auto-publish schemas 132 | -- If set to 'False', encoding will fail if there is no compatible schema 133 | -- in the schema registy. 134 | -- This is equivalent to the confluent 'auto.register.schemas' option. 135 | cfgAutoRegisterSchemas :: Bool -> SchemaRegistryConfig -> SchemaRegistryConfig 136 | cfgAutoRegisterSchemas autoRegisterSchemas config = config { cAutoRegisterSchemas = autoRegisterSchemas } 137 | 138 | loadSchema :: MonadIO m => SchemaRegistry -> SchemaId -> m (Either SchemaRegistryError Schema) 139 | loadSchema sr sid = do 140 | sc <- cachedSchema sr sid 141 | case sc of 142 | Just s -> return (Right s) 143 | Nothing -> liftIO $ do 144 | res <- getSchemaById sr sid 145 | traverse ((\schema -> schema <$ cacheSchema sr sid schema) . unRegisteredSchema) res 146 | 147 | loadSubjectSchema :: MonadIO m => SchemaRegistry -> Subject -> Version -> m (Either SchemaRegistryError Schema) 148 | loadSubjectSchema sr (Subject sbj) (Version version) = do 149 | let url = srBaseUrl sr ++ "/subjects/" ++ unpack sbj ++ "/versions/" ++ show version 150 | respE <- liftIO . try $ Wreq.getWith (wreqOpts sr) url 151 | case respE of 152 | Left exc -> pure . Left $ wrapErrorWithUrl url exc 153 | Right resp -> do 154 | 155 | let wrapped = bimap wrapError (view Wreq.responseBody) (Wreq.asValue resp) 156 | schema <- getData "schema" wrapped 157 | schemaId <- getData "id" wrapped 158 | 159 | case (,) <$> schema <*> schemaId of 160 | Left err -> return $ Left err 161 | Right (RegisteredSchema schema, schemaId) -> cacheSchema sr schemaId schema $> Right schema 162 | where 163 | 164 | getData :: (MonadIO m, FromJSON a) => String -> Either e Value -> m (Either e a) 165 | getData key = either (pure . Left) (viewData key) 166 | 167 | viewData :: (MonadIO m, FromJSON a) => String -> Value -> m (Either e a) 168 | viewData key value = liftIO $ either (throwIO . Wreq.JSONError) 169 | (return . return) 170 | (toData value) 171 | 172 | toData :: FromJSON a => Value -> Either String a 173 | toData value = case fromJSON value of 174 | Success a -> Right a 175 | Error e -> Left e 176 | 177 | 178 | -- | Get the schema ID. 179 | -- If the 'SchemaRegistry' is configured to auto-register schemas, 180 | -- this posts the schema to the schema registry server. 181 | -- Otherwise, this searches for a compatible schema and returns a 'SchemaRegistryNoCompatibleSchemaFound' 182 | -- if none is found. 183 | sendSchema :: MonadIO m => SchemaRegistry -> Subject -> Schema -> m (Either SchemaRegistryError SchemaId) 184 | sendSchema sr subj sc = do 185 | let schemaName = fullTypeName sc 186 | sid <- cachedId sr subj schemaName 187 | case sid of 188 | Just sid' -> return (Right sid') 189 | Nothing -> if cAutoRegisterSchemas (srConfig sr) 190 | then registerSchema sr subj sc 191 | else getCompatibleSchema sr subj sc 192 | 193 | registerSchema :: MonadIO m => SchemaRegistry -> Subject -> Schema -> m (Either SchemaRegistryError SchemaId) 194 | registerSchema sr subj sc = do 195 | let schemaName = fullTypeName sc 196 | res <- liftIO $ putSchema sr subj (RegisteredSchema sc) 197 | traverse_ (cacheId sr subj schemaName) res 198 | traverse_ (\sid' -> cacheSchema sr sid' sc) res 199 | pure res 200 | 201 | getCompatibleSchema :: MonadIO m => SchemaRegistry -> Subject -> Schema -> m (Either SchemaRegistryError SchemaId) 202 | getCompatibleSchema sr subj sc = liftIO . runExceptT $ do 203 | let schemaName = fullTypeName sc 204 | versions <- liftEither =<< getVersions sr subj 205 | compatibilites <- liftEither . sequenceA 206 | =<< traverse (\ver -> fmap (,ver) <$> isCompatible sr subj ver sc) versions 207 | let mCompatibleVersion = snd <$> find fst compatibilites 208 | compatibleVersion <- liftEither 209 | $ case mCompatibleVersion of 210 | Just version -> Right version 211 | Nothing -> Left $ SchemaRegistryNoCompatibleSchemaFound sc 212 | _ <- liftEither =<< loadSubjectSchema sr subj compatibleVersion -- caches the schema ID 213 | mSid <- cachedId sr subj schemaName 214 | liftEither $ case mSid of 215 | Just sid' -> pure sid' 216 | Nothing -> Left SchemaRegistryCacheError 217 | 218 | getVersions :: MonadIO m => SchemaRegistry -> Subject -> m (Either SchemaRegistryError [Version]) 219 | getVersions sr subj@(Subject sbj) = liftIO . runExceptT $ do 220 | let url = srBaseUrl sr ++ "/subjects/" ++ unpack sbj ++ "/versions" 221 | resp <- tryWith (wrapErrorWithSubject subj) $ Wreq.getWith (wreqOpts sr) url 222 | except $ bimap wrapError (fmap Version . view Wreq.responseBody) (Wreq.asJSON resp) 223 | 224 | isCompatible :: MonadIO m => SchemaRegistry -> Subject -> Version -> Schema -> m (Either SchemaRegistryError Bool) 225 | isCompatible sr (Subject sbj) (Version version) schema = do 226 | let url = srBaseUrl sr ++ "/compatibility/subjects/" ++ unpack sbj ++ "/versions/" ++ show version 227 | respE <- liftIO . try $ Wreq.postWith (wreqOpts sr) url (toJSON $ RegisteredSchema schema) 228 | case respE of 229 | Left exc -> pure . Left $ wrapErrorWithUrl url exc 230 | Right resp -> do 231 | let wrapped = bimap wrapError (view Wreq.responseBody) (Wreq.asValue resp) 232 | either (return . Left) getCompatibility wrapped 233 | where 234 | getCompatibility :: MonadIO m => Value -> m (Either e Bool) 235 | getCompatibility = liftIO . maybe (throwIO $ Wreq.JSONError "Missing key 'is_compatible' in Schema Registry response") (return . return) . viewCompatibility 236 | 237 | viewCompatibility :: Value -> Maybe Bool 238 | viewCompatibility (Object obj) = KM.lookup "is_compatible" obj >>= toBool 239 | viewCompatibility _ = Nothing 240 | 241 | toBool :: Value -> Maybe Bool 242 | toBool (Bool b) = Just b 243 | toBool _ = Nothing 244 | 245 | getGlobalConfig :: MonadIO m => SchemaRegistry -> m (Either SchemaRegistryError Compatibility) 246 | getGlobalConfig sr = do 247 | let url = srBaseUrl sr ++ "/config" 248 | respE <- liftIO . try $ Wreq.getWith (wreqOpts sr) url 249 | pure $ case respE of 250 | Left exc -> Left $ wrapError exc 251 | Right resp -> bimap wrapError (view Wreq.responseBody) (Wreq.asJSON resp) 252 | 253 | getSubjectConfig :: MonadIO m => SchemaRegistry -> Subject -> m (Either SchemaRegistryError Compatibility) 254 | getSubjectConfig sr subj@(Subject sbj) = liftIO . runExceptT $ do 255 | let url = srBaseUrl sr ++ "/config/" ++ unpack sbj 256 | resp <- tryWith (wrapErrorWithSubject subj) $ Wreq.getWith (wreqOpts sr) url 257 | except $ bimap wrapError (view Wreq.responseBody) (Wreq.asJSON resp) 258 | 259 | getSubjects :: MonadIO m => SchemaRegistry -> m (Either SchemaRegistryError [Subject]) 260 | getSubjects sr = liftIO . runExceptT $ do 261 | let url = srBaseUrl sr ++ "/subjects" 262 | resp <- tryWith wrapError $ Wreq.getWith (wreqOpts sr) url 263 | except $ bimap wrapError (fmap Subject . view Wreq.responseBody) (Wreq.asJSON resp) 264 | 265 | ------------------ PRIVATE: HELPERS -------------------------------------------- 266 | 267 | wreqOpts :: SchemaRegistry -> Wreq.Options 268 | wreqOpts sr = 269 | let 270 | accept = ["application/vnd.schemaregistry.v1+json", "application/vnd.schemaregistry+json", "application/json"] 271 | acceptHeader = Wreq.header "Accept" .~ accept 272 | authHeader = Wreq.auth .~ cAuth (srConfig sr) 273 | extraHeaders = Wreq.headers %~ (++ cExtraHeaders (srConfig sr)) 274 | in Wreq.defaults & acceptHeader & authHeader & extraHeaders 275 | 276 | getSchemaById :: SchemaRegistry -> SchemaId -> IO (Either SchemaRegistryError RegisteredSchema) 277 | getSchemaById sr sid@(SchemaId i) = runExceptT $ do 278 | let 279 | baseUrl = srBaseUrl sr 280 | schemaUrl = baseUrl ++ "/schemas/ids/" ++ show i 281 | resp <- tryWith (wrapErrorWithSchemaId sid) $ Wreq.getWith (wreqOpts sr) schemaUrl 282 | except $ bimap (const (SchemaRegistryLoadError sid)) (view Wreq.responseBody) (Wreq.asJSON resp) 283 | 284 | putSchema :: SchemaRegistry -> Subject -> RegisteredSchema -> IO (Either SchemaRegistryError SchemaId) 285 | putSchema sr subj@(Subject sbj) schema = runExceptT $ do 286 | let 287 | baseUrl = srBaseUrl sr 288 | schemaUrl = baseUrl ++ "/subjects/" ++ unpack sbj ++ "/versions" 289 | resp <- tryWith (wrapErrorWithSubject subj) $ Wreq.postWith (wreqOpts sr) schemaUrl (toJSON schema) 290 | except $ bimap wrapError (view Wreq.responseBody) (Wreq.asJSON resp) 291 | 292 | fromHttpError :: HttpException -> (HttpExceptionContent -> SchemaRegistryError) -> SchemaRegistryError 293 | fromHttpError err f = case err of 294 | InvalidUrlException fld err' -> SchemaRegistryConnectError (fld ++ ": " ++ err') 295 | HttpExceptionRequest _ (ConnectionFailure err) -> SchemaRegistryConnectError (displayException err) 296 | HttpExceptionRequest _ ConnectionTimeout -> SchemaRegistryConnectError (displayException err) 297 | HttpExceptionRequest _ ProxyConnectException{} -> SchemaRegistryConnectError (displayException err) 298 | HttpExceptionRequest _ ConnectionClosed -> SchemaRegistryConnectError (displayException err) 299 | HttpExceptionRequest _ (InvalidDestinationHost _) -> SchemaRegistryConnectError (displayException err) 300 | HttpExceptionRequest _ TlsNotSupported -> SchemaRegistryConnectError (displayException err) 301 | 302 | HttpExceptionRequest _ (InvalidProxySettings _) -> SchemaRegistryConnectError (displayException err) 303 | 304 | HttpExceptionRequest _ err' -> f err' 305 | 306 | wrapError :: SomeException -> SchemaRegistryError 307 | wrapError someErr = case fromException someErr of 308 | Nothing -> SchemaRegistrySendError (displayException someErr) 309 | Just httpErr -> fromHttpError httpErr (\_ -> SchemaRegistrySendError (displayException someErr)) 310 | 311 | wrapErrorWithSchemaId :: SchemaId -> SomeException -> SchemaRegistryError 312 | wrapErrorWithSchemaId = wrapErrorWith SchemaRegistrySchemaNotFound 313 | 314 | wrapErrorWithSubject :: Subject -> SomeException -> SchemaRegistryError 315 | wrapErrorWithSubject = wrapErrorWith SchemaRegistrySubjectNotFound 316 | 317 | wrapErrorWithUrl :: String -> SomeException -> SchemaRegistryError 318 | wrapErrorWithUrl = wrapErrorWith SchemaRegistryUrlNotFound 319 | 320 | wrapErrorWith :: (a -> SchemaRegistryError) -> a -> SomeException -> SchemaRegistryError 321 | wrapErrorWith mkError x exception = case fromException exception of 322 | Just (HttpExceptionRequest _ (StatusCodeException response _)) | responseStatus response == notFound404 -> mkError x 323 | _ -> wrapError exception 324 | 325 | tryWith :: MonadCatch m => (SomeException -> e) -> m a -> ExceptT e m a 326 | tryWith wrapException = withExceptT wrapException . ExceptT . try 327 | 328 | --------------------------------------------------------------------- 329 | fullTypeName :: Schema -> SchemaName 330 | fullTypeName r = SchemaName $ typeName r 331 | 332 | cachedSchema :: MonadIO m => SchemaRegistry -> SchemaId -> m (Maybe Schema) 333 | cachedSchema sr k = liftIO $ C.lookup (srCache sr) k 334 | {-# INLINE cachedSchema #-} 335 | 336 | cacheSchema :: MonadIO m => SchemaRegistry -> SchemaId -> Schema -> m () 337 | cacheSchema sr k v = liftIO $ C.insert (srCache sr) k v 338 | {-# INLINE cacheSchema #-} 339 | 340 | cachedId :: MonadIO m => SchemaRegistry -> Subject -> SchemaName -> m (Maybe SchemaId) 341 | cachedId sr subj scn = liftIO $ C.lookup (srReverseCache sr) (subj, scn) 342 | {-# INLINE cachedId #-} 343 | 344 | cacheId :: MonadIO m => SchemaRegistry -> Subject -> SchemaName -> SchemaId -> m () 345 | cacheId sr subj scn sid = liftIO $ C.insert (srReverseCache sr) (subj, scn) sid 346 | {-# INLINE cacheId #-} 347 | 348 | instance FromJSON RegisteredSchema where 349 | parseJSON (Object v) = 350 | withObject "expected schema" (\obj -> do 351 | sch <- obj .: "schema" 352 | maybe mempty (return . RegisteredSchema) (decode $ LText.encodeUtf8 sch) 353 | ) (Object v) 354 | 355 | parseJSON _ = mempty 356 | 357 | instance ToJSON RegisteredSchema where 358 | toJSON (RegisteredSchema v) = object ["schema" .= LText.decodeUtf8 (encode $ toJSON v)] 359 | 360 | instance FromJSON SchemaId where 361 | parseJSON (Object v) = SchemaId <$> v .: "id" 362 | parseJSON _ = mempty 363 | 364 | instance FromJSON Compatibility where 365 | parseJSON = withObject "Compatibility" $ \v -> do 366 | compatibility <- v .: "compatibilityLevel" 367 | case compatibility of 368 | "NONE" -> return $ NoCompatibility 369 | "FULL" -> return $ FullCompatibility 370 | "FORWARD" -> return $ ForwardCompatibility 371 | "BACKWARD" -> return $ BackwardCompatibility 372 | _ -> typeMismatch "Compatibility" compatibility 373 | 374 | 375 | 376 | 377 | 378 | 379 | 380 | 381 | 382 | 383 | 384 | 385 | 386 | -------------------------------------------------------------------------------- /test/Spec.hs: -------------------------------------------------------------------------------- 1 | main :: IO () 2 | main = putStrLn "Test suite not yet implemented" 3 | --------------------------------------------------------------------------------