├── .github ├── ISSUE_TEMPLATE │ ├── bug_report.md │ ├── config.yml │ └── feature_request.md ├── actions │ ├── build-docs │ │ └── action.yml │ ├── ci │ │ └── action.yml │ ├── publish-docs │ │ └── action.yml │ ├── publish │ │ └── action.yml │ ├── setup-cache │ │ └── action.yml │ └── update-cabal │ │ └── action.yml ├── pull_request_template.md └── workflows │ ├── ci.yml │ ├── lint-pr-title.yml │ ├── manual-publish-docs.yml │ ├── manual-publish.yml │ ├── release-please.yml │ └── stale.yml ├── .gitignore ├── .hlint.yaml ├── .release-please-manifest.json ├── .sdk_metadata.json ├── CHANGELOG.md ├── CODEOWNERS ├── CONTRIBUTING.md ├── LICENSE ├── Makefile ├── PROVENANCE.md ├── README.md ├── SECURITY.md ├── Setup.hs ├── contract-tests ├── Setup.hs ├── package.yaml ├── src │ ├── Main.hs │ ├── Types.hs │ └── Utils.hs ├── stack.yaml ├── stack.yaml.lock └── testharness-suppressions.txt ├── fourmolu.yaml ├── launchdarkly-server-sdk.cabal ├── package.yaml ├── release-please-config.json ├── src └── LaunchDarkly │ ├── AesonCompat.hs │ ├── Server.hs │ └── Server │ ├── Client.hs │ ├── Client │ ├── Internal.hs │ └── Status.hs │ ├── Config.hs │ ├── Config │ ├── ClientContext.hs │ ├── HttpConfiguration.hs │ └── Internal.hs │ ├── Context.hs │ ├── Context │ └── Internal.hs │ ├── DataSource │ └── Internal.hs │ ├── Details.hs │ ├── Evaluate.hs │ ├── Events.hs │ ├── Features.hs │ ├── Integrations │ ├── FileData.hs │ ├── TestData.hs │ └── TestData │ │ └── FlagBuilder.hs │ ├── Network │ ├── Common.hs │ ├── Eventing.hs │ ├── Polling.hs │ └── Streaming.hs │ ├── Operators.hs │ ├── Reference.hs │ ├── Store.hs │ ├── Store │ └── Internal.hs │ └── Util.hs ├── stack.yaml ├── test-data └── filesource │ ├── all-properties.json │ ├── all-properties.yml │ ├── flag-only.json │ ├── flag-with-duplicate-key.json │ ├── malformed.json │ ├── no-data.json │ ├── segment-only.json │ ├── segment-with-duplicate-key.json │ ├── targets.json │ ├── targets.yml │ ├── value-only.json │ └── value-with-duplicate-key.json └── test ├── Spec.hs ├── Spec ├── Bucket.hs ├── Client.hs ├── Config.hs ├── Context.hs ├── DataSource.hs ├── Evaluate.hs ├── Features.hs ├── Integrations │ ├── FileData.hs │ └── TestData.hs ├── Operators.hs ├── PersistentDataStore.hs ├── Reference.hs ├── Segment.hs ├── Store.hs └── Streaming.hs └── Util └── Features.hs /.github/ISSUE_TEMPLATE/bug_report.md: -------------------------------------------------------------------------------- 1 | --- 2 | name: Bug report 3 | about: Create a report to help us improve 4 | title: '' 5 | labels: '' 6 | assignees: '' 7 | 8 | --- 9 | 10 | **Is this a support request?** 11 | This issue tracker is maintained by LaunchDarkly SDK developers and is intended for feedback on the SDK code. If you're not sure whether the problem you are having is specifically related to the SDK, or to the LaunchDarkly service overall, it may be more appropriate to contact the LaunchDarkly support team; they can help to investigate the problem and will consult the SDK team if necessary. You can submit a support request by going [here](https://support.launchdarkly.com/hc/en-us/requests/new) or by emailing support@launchdarkly.com. 12 | 13 | Note that issues filed on this issue tracker are publicly accessible. Do not provide any private account information on your issues. If your problem is specific to your account, you should submit a support request as described above. 14 | 15 | **Describe the bug** 16 | A clear and concise description of what the bug is. 17 | 18 | **To reproduce** 19 | Steps to reproduce the behavior. 20 | 21 | **Expected behavior** 22 | A clear and concise description of what you expected to happen. 23 | 24 | **Logs** 25 | If applicable, add any log output related to your problem. 26 | 27 | **SDK version** 28 | The version of this SDK that you are using. 29 | 30 | **Language version, developer tools** 31 | For instance, Go 1.11 or Ruby 2.5.3. If you are using a language that requires a separate compiler, such as C, please include the name and version of the compiler too. 32 | 33 | **OS/platform** 34 | For instance, Ubuntu 16.04, Windows 10, or Android 4.0.3. If your code is running in a browser, please also include the browser type and version. 35 | 36 | **Additional context** 37 | Add any other context about the problem here. 38 | -------------------------------------------------------------------------------- /.github/ISSUE_TEMPLATE/config.yml: -------------------------------------------------------------------------------- 1 | blank_issues_enabled: false 2 | contact_links: 3 | - name: Support request 4 | url: https://support.launchdarkly.com/hc/en-us/requests/new 5 | about: File your support requests with LaunchDarkly's support team 6 | -------------------------------------------------------------------------------- /.github/ISSUE_TEMPLATE/feature_request.md: -------------------------------------------------------------------------------- 1 | --- 2 | name: Feature request 3 | about: Suggest an idea for this project 4 | title: '' 5 | labels: '' 6 | assignees: '' 7 | 8 | --- 9 | 10 | **Is your feature request related to a problem? Please describe.** 11 | A clear and concise description of what the problem is. Ex. I would love to see the SDK [...does something new...] 12 | 13 | **Describe the solution you'd like** 14 | A clear and concise description of what you want to happen. 15 | 16 | **Describe alternatives you've considered** 17 | A clear and concise description of any alternative solutions or features you've considered. 18 | 19 | **Additional context** 20 | Add any other context about the feature request here. 21 | -------------------------------------------------------------------------------- /.github/actions/build-docs/action.yml: -------------------------------------------------------------------------------- 1 | name: Build Documentation 2 | description: 'Build Documentation.' 3 | 4 | runs: 5 | using: composite 6 | steps: 7 | - name: Build Documentation 8 | shell: bash 9 | run: stack --no-terminal haddock 10 | -------------------------------------------------------------------------------- /.github/actions/ci/action.yml: -------------------------------------------------------------------------------- 1 | name: CI Workflow 2 | description: 'Shared CI workflow.' 3 | inputs: 4 | resolver: 5 | description: 'Which resolver to use when building the package' 6 | required: false 7 | default: lts-18.28 8 | ghc-version: 9 | description: 'Which ghc version to use when building the package' 10 | required: false 11 | default: 8.10.7 12 | token: 13 | description: 'GH token used to download SDK test harness.' 14 | required: true 15 | outputs: 16 | package-hashes: 17 | description: "base64-encoded sha256 hashes of distribution files" 18 | value: ${{ steps.package-hashes.outputs.package-hashes }} 19 | 20 | runs: 21 | using: composite 22 | steps: 23 | - uses: haskell-actions/setup@v2 24 | with: 25 | ghc-version: ${{ inputs.ghc-version }} 26 | enable-stack: true 27 | 28 | - name: Build library 29 | shell: bash 30 | run: stack --no-terminal --resolver=${{ inputs.resolver }} build 31 | 32 | - name: Build sdist distribution 33 | shell: bash 34 | run: stack --no-terminal --resolver=${{ inputs.resolver }} sdist 35 | 36 | - name: Setup dist directory 37 | shell: bash 38 | run: echo "STACK_DIR=$(stack --no-terminal path --dist-dir --resolver=${{ inputs.resolver }})" >> $GITHUB_ENV 39 | 40 | - name: Hash build files for provenance 41 | id: package-hashes 42 | shell: bash 43 | working-directory: ${{ env.STACK_DIR }} 44 | run: | 45 | echo "package-hashes=$(sha256sum *tar.gz | base64 -w0)" >> "$GITHUB_OUTPUT" 46 | 47 | - name: Run tests 48 | shell: bash 49 | run: stack --no-terminal --resolver=${{ inputs.resolver }} test 50 | 51 | - name: Build contract tests 52 | shell: bash 53 | run: STACKOPTS='--no-terminal --resolver=${{ inputs.resolver }}' make build-contract-tests 54 | 55 | - name: Start contract test service 56 | shell: bash 57 | run: STACKOPTS='--no-terminal --resolver=${{ inputs.resolver }}' make start-contract-test-service-bg 58 | 59 | - uses: launchdarkly/gh-actions/actions/contract-tests@contract-tests-v1.0.2 60 | with: 61 | test_service_port: 8000 62 | token: ${{ inputs.token }} 63 | extra_params: "-skip-from contract-tests/testharness-suppressions.txt" 64 | -------------------------------------------------------------------------------- /.github/actions/publish-docs/action.yml: -------------------------------------------------------------------------------- 1 | name: Publish Documentation 2 | description: 'Publish the documentation to GitHub pages' 3 | inputs: 4 | token: 5 | description: 'Token to use for publishing.' 6 | required: true 7 | 8 | runs: 9 | using: composite 10 | steps: 11 | - name: Setup dist directory 12 | shell: bash 13 | run: echo "STACK_DIR=$(stack --no-terminal path --dist-dir)" >> $GITHUB_ENV 14 | 15 | - uses: launchdarkly/gh-actions/actions/publish-pages@publish-pages-v1.0.2 16 | name: 'Publish to Github pages' 17 | with: 18 | docs_path: ${{env.STACK_DIR}}/doc/html/launchdarkly-server-sdk/ 19 | github_token: ${{inputs.token}} 20 | -------------------------------------------------------------------------------- /.github/actions/publish/action.yml: -------------------------------------------------------------------------------- 1 | name: Publish Package 2 | description: 'Publish the package to Hackage' 3 | inputs: 4 | resolver: 5 | description: 'Which resolver to use when building the package' 6 | required: false 7 | default: lts-18.28 8 | token: 9 | description: 'Token to use for publishing.' 10 | required: true 11 | dry_run: 12 | description: 'Is this a dry run. If so no package will be published.' 13 | required: true 14 | 15 | runs: 16 | using: composite 17 | steps: 18 | - name: Setup dist directory 19 | shell: bash 20 | run: echo "STACK_DIR=$(stack --no-terminal path --dist-dir --resolver=${{ inputs.resolver }})" >> $GITHUB_ENV 21 | 22 | - uses: haskell-actions/hackage-publish@v1 23 | with: 24 | hackageToken: ${{ inputs.token }} 25 | packagesPath: ${{ env.STACK_DIR }} 26 | publish: ${{ inputs.dry_run == 'false' }} 27 | -------------------------------------------------------------------------------- /.github/actions/setup-cache/action.yml: -------------------------------------------------------------------------------- 1 | name: Setup caching for stack 2 | description: 'Enable caching for stack and cabal files' 3 | inputs: 4 | ghc-version: 5 | description: 'The version of GHC to use for cabal cache busting' 6 | required: false 7 | default: 8.8.4 8 | 9 | runs: 10 | using: composite 11 | steps: 12 | - uses: actions/cache@v4 13 | name: Cache ~/.stack 14 | with: 15 | path: ~/.stack 16 | key: ${{ runner.os }}-stack-global-${{ hashFiles('stack.yaml') }}-${{ hashFiles('package.yaml') }} 17 | restore-keys: | 18 | ${{ runner.os }}-stack-global- 19 | 20 | - uses: actions/cache@v4 21 | name: Cache .stack-work 22 | with: 23 | path: .stack-work 24 | key: ${{ runner.os }}-stack-work-${{ hashFiles('stack.yaml') }}-${{ hashFiles('package.yaml') }}-${{ hashFiles('**/*.hs') }} 25 | restore-keys: | 26 | ${{ runner.os }}-stack-work- 27 | 28 | - name: Cache ~/.cabal/packages, ~/.cabal/store and dist-newstyle 29 | uses: actions/cache@v4 30 | with: 31 | path: | 32 | ~/.cabal/packages 33 | ~/.cabal/store 34 | dist-newstyle 35 | key: ${{ runner.os }}-${{ inputs.ghc-version }}-${{ hashFiles('**/*.cabal', '**/cabal.project', '**/cabal.project.freeze') }} 36 | restore-keys: ${{ runner.os }}-${{ inputs.ghc-version }}- 37 | -------------------------------------------------------------------------------- /.github/actions/update-cabal/action.yml: -------------------------------------------------------------------------------- 1 | name: Update generated cabal file 2 | description: 'Used to update the cabal file after updating package.yaml' 3 | inputs: 4 | branch: 5 | description: 'The branch to checkout and push updates to' 6 | required: true 7 | ghc-version: 8 | description: 'The version of GHC to use for cabal cache busting' 9 | required: false 10 | default: '9.4.7' 11 | 12 | runs: 13 | using: composite 14 | steps: 15 | - uses: haskell-actions/setup@v2 16 | with: 17 | ghc-version: ${{ inputs.ghc-version }} 18 | 19 | - name: Cache ~/.cabal/packages, ~/.cabal/store and dist-newstyle 20 | uses: actions/cache@v4 21 | with: 22 | path: | 23 | ~/.cabal/packages 24 | ~/.cabal/store 25 | dist-newstyle 26 | key: ${{ runner.os }}-${{ inputs.ghc-version }}-${{ hashFiles('**/*.cabal', '**/cabal.project', '**/cabal.project.freeze') }} 27 | restore-keys: ${{ runner.os }}-${{ inputs.ghc-version }}- 28 | 29 | - uses: actions/checkout@v4 30 | with: 31 | ref: ${{ inputs.branch }} 32 | 33 | - name: Install hpack 34 | shell: bash 35 | run: cabal install --global hpack-0.35.1 36 | 37 | - name: Verify the generated .cabal file is up-to-date 38 | shell: bash 39 | run: | 40 | hpack 41 | 42 | if [ $(git status --porcelain | wc -l) -gt 0 ]; then 43 | git config --global user.name 'LaunchDarklyReleaseBot' 44 | git config --global user.email 'LaunchDarklyReleaseBot@launchdarkly.com' 45 | git add *cabal 46 | git commit -m 'Updating generated cabal file' 47 | git push 48 | fi 49 | -------------------------------------------------------------------------------- /.github/pull_request_template.md: -------------------------------------------------------------------------------- 1 | **Requirements** 2 | 3 | - [ ] I have added test coverage for new or changed functionality 4 | - [ ] I have followed the repository's [pull request submission guidelines](../blob/main/CONTRIBUTING.md#submitting-pull-requests) 5 | - [ ] I have validated my changes against all supported platform versions 6 | 7 | **Related issues** 8 | 9 | Provide links to any issues in this repository or elsewhere relating to this pull request. 10 | 11 | **Describe the solution you've provided** 12 | 13 | Provide a clear and concise description of what you expect to happen. 14 | 15 | **Describe alternatives you've considered** 16 | 17 | Provide a clear and concise description of any alternative solutions or features you've considered. 18 | 19 | **Additional context** 20 | 21 | Add any other context about the pull request here. 22 | -------------------------------------------------------------------------------- /.github/workflows/ci.yml: -------------------------------------------------------------------------------- 1 | name: Run CI 2 | on: 3 | push: 4 | branches: [ main ] 5 | paths-ignore: 6 | - '**.md' # Do not need to run CI for markdown changes. 7 | pull_request: 8 | branches: [ main ] 9 | paths-ignore: 10 | - '**.md' 11 | 12 | jobs: 13 | build-linux: 14 | runs-on: ubuntu-latest 15 | 16 | strategy: 17 | fail-fast: false 18 | matrix: 19 | include: 20 | - resolver: lts-18.28 21 | ghc-version: 8.10.7 22 | - resolver: lts-19.33 23 | ghc-version: 9.0.2 24 | - resolver: lts-20.26 25 | ghc-version: 9.2.5 26 | 27 | steps: 28 | - uses: actions/checkout@v4 29 | with: 30 | fetch-depth: 0 # If you only need the current version keep this. 31 | 32 | - name: Install PCRE development libraries 33 | run: sudo apt-get update && sudo apt-get install -y libpcre3-dev 34 | 35 | - uses: ./.github/actions/setup-cache 36 | with: 37 | ghc-version: ${{ matrix.ghc-version }} 38 | 39 | - uses: ./.github/actions/ci 40 | with: 41 | resolver: ${{ matrix.resolver }} 42 | ghc-version: ${{ matrix.ghc-version }} 43 | token: ${{ secrets.GITHUB_TOKEN }} 44 | 45 | build-macosx: 46 | runs-on: macos-latest 47 | 48 | strategy: 49 | fail-fast: false 50 | matrix: 51 | include: 52 | - resolver: lts-18.28 53 | ghc-version: 8.10.7 54 | use-llvm: 'true' 55 | - resolver: lts-19.33 56 | ghc-version: 9.0.2 57 | use-llvm: 'true' 58 | - resolver: lts-20.26 59 | ghc-version: 9.2.5 60 | use-llvm: 'false' 61 | 62 | steps: 63 | - uses: actions/checkout@v4 64 | with: 65 | fetch-depth: 0 # If you only need the current version keep this. 66 | 67 | - name: Setup C_INCLUDE_PATH 68 | run: | 69 | brew install pcre 70 | echo "C_INCLUDE_PATH=$(find /opt/homebrew/Cellar/pcre -name 'pcre.h' -exec dirname {} \;):$(xcrun --show-sdk-path)/usr/include/ffi" >> $GITHUB_ENV 71 | 72 | - name: Add LLVM to path 73 | if: ${{ matrix.use-llvm == 'true' }} 74 | run: | 75 | brew install llvm@14 76 | echo "PATH=/opt/homebrew/opt/llvm@14/bin:$PATH" >> $GITHUB_ENV 77 | 78 | - uses: ./.github/actions/setup-cache 79 | with: 80 | ghc-version: ${{ matrix.ghc-version }} 81 | 82 | - uses: ./.github/actions/ci 83 | with: 84 | resolver: ${{ matrix.resolver }} 85 | ghc-version: ${{ matrix.ghc-version }} 86 | token: ${{ secrets.GITHUB_TOKEN }} 87 | 88 | quality-checks: 89 | runs-on: ubuntu-latest 90 | 91 | steps: 92 | - uses: actions/checkout@v4 93 | with: 94 | fetch-depth: 0 # If you only need the current version keep this. 95 | 96 | - uses: ./.github/actions/setup-cache 97 | with: 98 | ghc-version: '9.4.7' 99 | 100 | - uses: haskell-actions/setup@v2 101 | with: 102 | ghc-version: '9.4.7' 103 | 104 | - name: 'Set up HLint' 105 | uses: haskell-actions/hlint-setup@v2 106 | with: 107 | version: 3.5 108 | 109 | - name: 'Run HLint' 110 | uses: haskell-actions/hlint-run@v2 111 | with: 112 | fail-on: warning 113 | 114 | - uses: haskell-actions/run-fourmolu@v10 115 | with: 116 | version: "0.10.1.0" 117 | pattern: | 118 | src 119 | test 120 | 121 | - name: Install hpack 122 | run: cabal install --global hpack-0.35.1 123 | 124 | - name: Verify the generated .cabal file is up-to-date 125 | run: | 126 | hpack 127 | if [ $(git status --porcelain | wc -l) -gt 0 ]; then 128 | echo "hpack resulted in modified files. please run hpack locally and commit those changes" 129 | echo "" 130 | echo "showing the results of `git status`" 131 | git status 132 | exit -1 133 | fi 134 | -------------------------------------------------------------------------------- /.github/workflows/lint-pr-title.yml: -------------------------------------------------------------------------------- 1 | name: Lint PR title 2 | 3 | on: 4 | pull_request_target: 5 | types: 6 | - opened 7 | - edited 8 | - synchronize 9 | 10 | jobs: 11 | lint-pr-title: 12 | uses: launchdarkly/gh-actions/.github/workflows/lint-pr-title.yml@main 13 | -------------------------------------------------------------------------------- /.github/workflows/manual-publish-docs.yml: -------------------------------------------------------------------------------- 1 | on: 2 | workflow_dispatch: 3 | 4 | name: Publish Documentation 5 | jobs: 6 | build-publish: 7 | runs-on: ubuntu-latest 8 | 9 | permissions: 10 | id-token: write # Needed if using OIDC to get release secrets. 11 | contents: write # Needed in this case to write github pages. 12 | 13 | steps: 14 | - uses: actions/checkout@v4 15 | 16 | - uses: ./.github/actions/setup-cache 17 | 18 | - name: Build and Test 19 | uses: ./.github/actions/ci 20 | with: 21 | token: ${{secrets.GITHUB_TOKEN}} 22 | 23 | - name: Build docs 24 | uses: ./.github/actions/build-docs 25 | 26 | - name: Publish Documentation 27 | uses: ./.github/actions/publish-docs 28 | with: 29 | token: ${{secrets.GITHUB_TOKEN}} 30 | -------------------------------------------------------------------------------- /.github/workflows/manual-publish.yml: -------------------------------------------------------------------------------- 1 | name: Publish Package 2 | on: 3 | workflow_dispatch: 4 | inputs: 5 | dry_run: 6 | description: 'Is this a dry run. If so no package will be published.' 7 | type: boolean 8 | required: true 9 | 10 | jobs: 11 | build-publish: 12 | runs-on: ubuntu-latest 13 | # Needed to get tokens during publishing. 14 | permissions: 15 | id-token: write 16 | contents: read 17 | outputs: 18 | package-hashes: ${{ steps.ci.outputs.package-hashes }} 19 | 20 | steps: 21 | - uses: actions/checkout@v4 22 | 23 | - uses: ./.github/actions/setup-cache 24 | 25 | - name: Build and Test 26 | id: ci 27 | uses: ./.github/actions/ci 28 | with: 29 | token: ${{secrets.GITHUB_TOKEN}} 30 | 31 | - uses: launchdarkly/gh-actions/actions/release-secrets@release-secrets-v1.2.0 32 | name: 'Get Hackage token' 33 | with: 34 | aws_assume_role: ${{ vars.AWS_ROLE_ARN }} 35 | ssm_parameter_pairs: '/production/common/releasing/hackage/password = HACKAGE_TOKEN' 36 | 37 | - name: Publish Package 38 | uses: ./.github/actions/publish 39 | with: 40 | token: ${{ env.HACKAGE_TOKEN }} 41 | dry_run: ${{ inputs.dry_run }} 42 | 43 | release-provenance: 44 | needs: [ 'build-publish' ] 45 | permissions: 46 | actions: read 47 | id-token: write 48 | contents: write 49 | uses: slsa-framework/slsa-github-generator/.github/workflows/generator_generic_slsa3.yml@v2.0.0 50 | with: 51 | base64-subjects: "${{ needs.build-publish.outputs.package-hashes }}" 52 | upload-assets: ${{ !inputs.dry_run }} 53 | -------------------------------------------------------------------------------- /.github/workflows/release-please.yml: -------------------------------------------------------------------------------- 1 | name: Run Release Please 2 | 3 | on: 4 | push: 5 | branches: 6 | - main 7 | 8 | jobs: 9 | release-package: 10 | runs-on: ubuntu-latest 11 | 12 | permissions: 13 | id-token: write # Needed if using OIDC to get release secrets. 14 | contents: write # Contents and pull-requests are for release-please to make releases. 15 | pull-requests: write 16 | outputs: 17 | release-created: ${{ steps.release.outputs.release_created }} 18 | upload-tag-name: ${{ steps.release.outputs.tag_name }} 19 | package-hashes: ${{ steps.ci.outputs.package-hashes }} 20 | 21 | steps: 22 | - uses: googleapis/release-please-action@v4 23 | id: release 24 | 25 | - uses: actions/checkout@v4 26 | with: 27 | fetch-depth: 0 # If you only need the current version keep this. 28 | 29 | # 30 | # This step runs and updates an existing PR 31 | # 32 | - uses: ./.github/actions/update-cabal 33 | if: ${{ steps.release.outputs.pr != '' }} 34 | with: 35 | branch: ${{ fromJSON(steps.release.outputs.pr).headBranchName }} 36 | 37 | # 38 | # These remaining steps are ONLY run if a release was actually created 39 | # 40 | - uses: launchdarkly/gh-actions/actions/release-secrets@release-secrets-v1.2.0 41 | name: 'Get Hackage token' 42 | if: ${{ steps.release.outputs.releases_created == 'true' }} 43 | with: 44 | aws_assume_role: ${{ vars.AWS_ROLE_ARN }} 45 | ssm_parameter_pairs: '/production/common/releasing/hackage/password = HACKAGE_TOKEN' 46 | 47 | - uses: ./.github/actions/setup-cache 48 | if: ${{ steps.release.outputs.releases_created == 'true' }} 49 | 50 | - uses: ./.github/actions/ci 51 | id: ci 52 | if: ${{ steps.release.outputs.releases_created == 'true' }} 53 | with: 54 | token: ${{secrets.GITHUB_TOKEN}} 55 | 56 | - uses: ./.github/actions/build-docs 57 | if: ${{ steps.release.outputs.releases_created == 'true' }} 58 | 59 | - uses: ./.github/actions/publish 60 | if: ${{ steps.release.outputs.releases_created == 'true' }} 61 | with: 62 | token: ${{ env.HACKAGE_TOKEN }} 63 | dry_run: 'false' 64 | 65 | - uses: ./.github/actions/publish-docs 66 | if: ${{ steps.release.outputs.releases_created == 'true' }} 67 | with: 68 | # If publishing somewhere else, then get the token from SSM. If you need both github, 69 | # and another token, then add more tokens to the composite action. 70 | token: ${{secrets.GITHUB_TOKEN}} 71 | 72 | release-provenance: 73 | needs: [ 'release-package' ] 74 | if: ${{ needs.release-package.outputs.release-created == 'true' }} 75 | permissions: 76 | actions: read 77 | id-token: write 78 | contents: write 79 | uses: slsa-framework/slsa-github-generator/.github/workflows/generator_generic_slsa3.yml@v2.0.0 80 | with: 81 | base64-subjects: "${{ needs.release-package.outputs.package-hashes }}" 82 | upload-assets: true 83 | upload-tag-name: ${{ needs.release-package.outputs.upload-tag-name }} 84 | -------------------------------------------------------------------------------- /.github/workflows/stale.yml: -------------------------------------------------------------------------------- 1 | name: 'Close stale issues and PRs' 2 | on: 3 | workflow_dispatch: 4 | schedule: 5 | # Happen once per day at 1:30 AM 6 | - cron: '30 1 * * *' 7 | 8 | jobs: 9 | sdk-close-stale: 10 | uses: launchdarkly/gh-actions/.github/workflows/sdk-stale.yml@main 11 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | contract-tests/contract-tests.cabal 2 | **/.stack-work/* 3 | dist-newstyle/ 4 | stack.yaml.lock 5 | -------------------------------------------------------------------------------- /.hlint.yaml: -------------------------------------------------------------------------------- 1 | # Warnings currently triggered by your code 2 | - ignore: {name: "Avoid lambda"} # 1 hint 3 | - ignore: {name: "Eta reduce"} # 3 hints 4 | - ignore: {name: "Functor law"} # 2 hints 5 | - ignore: {name: "Monad law, right identity"} # 1 hint 6 | - ignore: {name: "Move brackets to avoid $"} # 12 hints 7 | - ignore: {name: "Redundant $"} # 7 hints 8 | - ignore: {name: "Redundant <&>"} # 11 hints 9 | - ignore: {name: "Redundant =="} # 1 hint 10 | - ignore: {name: "Redundant bracket"} # 69 hints 11 | - ignore: {name: "Redundant fmap"} # 1 hint 12 | - ignore: {name: "Redundant fromInteger"} # 25 hints 13 | - ignore: {name: "Redundant where"} # 1 hint 14 | - ignore: {name: "Use <$>"} # 2 hints 15 | - ignore: {name: "Use <&>"} # 6 hints 16 | - ignore: {name: "Use >=>"} # 1 hint 17 | - ignore: {name: "Use fewer imports"} # 3 hints 18 | - ignore: {name: "Use first"} # 1 hint 19 | - ignore: {name: "Use if"} # 3 hints 20 | - ignore: {name: "Use infix"} # 6 hints 21 | - ignore: {name: "Use lambda-case"} # 1 hint 22 | - ignore: {name: "Use let"} # 3 hints 23 | - ignore: {name: "Use maybe"} # 4 hints 24 | - ignore: {name: "Use newtype instead of data"} # 4 hints 25 | - ignore: {name: "Use section"} # 4 hints 26 | - ignore: {name: "Use unless"} # 1 hint 27 | 28 | - arguments: [-XTypeApplications] -------------------------------------------------------------------------------- /.release-please-manifest.json: -------------------------------------------------------------------------------- 1 | { 2 | ".": "4.5.0" 3 | } 4 | -------------------------------------------------------------------------------- /.sdk_metadata.json: -------------------------------------------------------------------------------- 1 | { 2 | "version": 1, 3 | "sdks": { 4 | "haskell-server-sdk": { 5 | "name": "Haskell Server SDK", 6 | "type": "server-side", 7 | "languages": [ 8 | "Haskell" 9 | ], 10 | "userAgents": ["HaskellServerClient"] 11 | } 12 | } 13 | } 14 | -------------------------------------------------------------------------------- /CODEOWNERS: -------------------------------------------------------------------------------- 1 | # Repository Maintainers 2 | * @launchdarkly/team-sdk-haskell 3 | -------------------------------------------------------------------------------- /CONTRIBUTING.md: -------------------------------------------------------------------------------- 1 | Contributing to the LaunchDarkly Server-side SDK for Haskell 2 | ================================================ 3 | 4 | LaunchDarkly has published an [SDK contributor's guide](https://docs.launchdarkly.com/sdk/concepts/contributors-guide) that provides a detailed explanation of how our SDKs work. See below for additional information on how to contribute to this SDK. 5 | 6 | Submitting bug reports and feature requests 7 | ------------------ 8 | 9 | The LaunchDarkly SDK team monitors the [issue tracker](https://github.com/launchdarkly/haskell-server-sdk/issues) in the SDK repository. Bug reports and feature requests specific to this SDK should be filed in this issue tracker. The SDK team will respond to all newly filed issues within two business days. 10 | 11 | Submitting pull requests 12 | ------------------ 13 | 14 | We encourage pull requests and other contributions from the community. Before submitting pull requests, ensure that all temporary or unintended code is removed. Don't worry about adding reviewers to the pull request; the LaunchDarkly SDK team will add themselves. The SDK team will acknowledge all pull requests within two business days. 15 | 16 | Build instructions 17 | ------------------ 18 | 19 | ### Prerequisites 20 | 21 | The SDK is built using [Stack](https://docs.haskellstack.org/en/stable/README/). 22 | 23 | ### Prerequisites 24 | 25 | The SDK depends on [PCRE](https://www.pcre.org/) and [`pkgconf`](https://github.com/pkgconf/pkgconf). You'll need to make sure these are installed. 26 | 27 | If you use [Homebrew](https://brew.sh/) you can install the necessary packages by running the following command: 28 | 29 | ``` 30 | brew install pcre pkg-config 31 | ``` 32 | 33 | Additionally, you can install the `haskell-stack` package to install Stack via Homebrew. 34 | 35 | ### Building 36 | 37 | To build the SDK without running any tests: 38 | ``` 39 | stack build 40 | ``` 41 | 42 | ### Testing 43 | 44 | To build the SDK and run all unit tests: 45 | ``` 46 | stack test 47 | ``` 48 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright 2019 Catamorphic, Co. 2 | 3 | Licensed under the Apache License, Version 2.0 (the "License"); 4 | you may not use this file except in compliance with the License. 5 | You may obtain a copy of the License at 6 | 7 | http://www.apache.org/licenses/LICENSE-2.0 8 | 9 | Unless required by applicable law or agreed to in writing, software 10 | distributed under the License is distributed on an "AS IS" BASIS, 11 | WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. 12 | See the License for the specific language governing permissions and 13 | limitations under the License. 14 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | TEMP_TEST_OUTPUT=/tmp/contract-test-service.log 2 | 3 | # TEST_HARNESS_PARAMS can be set to add -skip parameters for any contract tests that cannot yet pass 4 | # Explanation of current skips: 5 | TEST_HARNESS_PARAMS ?= 6 | STACKOPTS ?= 7 | 8 | build-contract-tests: 9 | cd contract-tests && stack build $(STACKOPTS) 10 | 11 | start-contract-test-service: 12 | cd contract-tests && stack exec contract-tests $(STACKOPTS) 13 | 14 | start-contract-test-service-bg: 15 | echo "Test service output will be captured in $(TEMP_TEST_OUTPUT)" 16 | make start-contract-test-service >$(TEMP_TEST_OUTPUT) 2>&1 & 17 | 18 | run-contract-tests: 19 | curl -s https://raw.githubusercontent.com/launchdarkly/sdk-test-harness/main/downloader/run.sh \ 20 | | VERSION=v2 PARAMS="-url http://localhost:8000 -debug -stop-service-at-end -skip-from contract-tests/testharness-suppressions.txt $(TEST_HARNESS_PARAMS)" sh 21 | 22 | contract-tests: build-contract-tests start-contract-test-service-bg run-contract-tests 23 | 24 | .PHONY: build-contract-tests start-contract-test-service run-contract-tests contract-tests 25 | -------------------------------------------------------------------------------- /PROVENANCE.md: -------------------------------------------------------------------------------- 1 | ## Verifying SDK build provenance with the SLSA framework 2 | 3 | LaunchDarkly uses the [SLSA framework](https://slsa.dev/spec/v1.0/about) (Supply-chain Levels for Software Artifacts) to help developers make their supply chain more secure by ensuring the authenticity and build integrity of our published SDK packages. 4 | 5 | As part of [SLSA requirements for level 3 compliance](https://slsa.dev/spec/v1.0/requirements), LaunchDarkly publishes provenance about our SDK package builds using [GitHub's generic SLSA3 provenance generator](https://github.com/slsa-framework/slsa-github-generator/blob/main/internal/builders/generic/README.md#generation-of-slsa3-provenance-for-arbitrary-projects) for distribution alongside our packages. These attestations are available for download from the GitHub release page for the release version under Assets > `multiple.intoto.jsonl`. 6 | 7 | To verify SLSA provenance attestations, we recommend using [slsa-verifier](https://github.com/slsa-framework/slsa-verifier). Example usage for verifying SDK packages is included below: 8 | 9 | 10 | ``` 11 | # Set the version of the SDK to verify 12 | SDK_VERSION=4.5.0 13 | ``` 14 | 15 | 16 | 17 | ``` 18 | # Download package from Hackage 19 | $ curl -O https://hackage.haskell.org/package/launchdarkly-server-sdk-${SDK_VERSION}/launchdarkly-server-sdk-${SDK_VERSION}.tar.gz 20 | 21 | # Download provenance from Github release into same directory 22 | $ curl --location -O \ 23 | https://github.com/launchdarkly/haskell-server-sdk/releases/download/${SDK_VERSION}/launchdarkly-server-sdk-${SDK_VERSION}.tar.gz.intoto.jsonl 24 | 25 | # Run slsa-verifier to verify provenance against package artifacts 26 | $ slsa-verifier verify-artifact \ 27 | --provenance-path launchdarkly-server-sdk-${SDK_VERSION}.tar.gz.intoto.jsonl \ 28 | --source-uri github.com/launchdarkly/haskell-server-sdk \ 29 | launchdarkly-server-sdk-${SDK_VERSION}.tar.gz 30 | ``` 31 | 32 | Below is a sample of expected output. 33 | ``` 34 | Verified signature against tlog entry index 76419919 at URL: https://rekor.sigstore.dev/api/v1/log/entries/24296fb24b8ad77a56491ff79d66537ddc16157d7ba7f31d59f0929cc6ce75ed98a0efed7fd3272a 35 | Verified build using builder "https://github.com/slsa-framework/slsa-github-generator/.github/workflows/generator_generic_slsa3.yml@refs/tags/v1.7.0" at commit dcf5e4be8e0c176c875919dcd5877193fac4f634 36 | Verifying artifact launchdarkly-server-sdk-4.0.4.tar.gz: PASSED 37 | 38 | PASSED: Verified SLSA provenance 39 | ``` 40 | 41 | Alternatively, to verify the provenance manually, the SLSA framework specifies [recommendations for verifying build artifacts](https://slsa.dev/spec/v1.0/verifying-artifacts) in their documentation. 42 | 43 | **Note:** These instructions do not apply when building our SDKs from source. 44 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # LaunchDarkly Server-side SDK for Haskell 2 | 3 | [![Run CI](https://github.com/launchdarkly/haskell-server-sdk/actions/workflows/ci.yml/badge.svg)](https://github.com/launchdarkly/haskell-server-sdk/actions/workflows/ci.yml) 4 | 5 | The LaunchDarkly Server-side SDK for Haskell is designed primarily for use in multi-user systems such as web servers and applications. It follows the server-side LaunchDarkly model for multi-user contexts. It is not intended for use in desktop and embedded systems applications. 6 | 7 | ## LaunchDarkly overview 8 | 9 | [LaunchDarkly](https://www.launchdarkly.com) is a feature management platform that serves trillions of feature flags daily to help teams build better software, faster. [Get started](https://docs.launchdarkly.com/home/getting-started) using LaunchDarkly today! 10 | 11 | [![Twitter Follow](https://img.shields.io/twitter/follow/launchdarkly.svg?style=social&label=Follow&maxAge=2592000)](https://twitter.com/intent/follow?screen_name=launchdarkly) 12 | 13 | ## Getting started 14 | 15 | Download a release archive from the [GitHub Releases](https://github.com/launchdarkly/haskell-server-sdk/releases) for use in your project. Refer to the [SDK documentation](https://docs.launchdarkly.com/sdk/server-side/haskell#getting-started) for complete instructions on getting started with using the SDK. 16 | 17 | ## Learn more 18 | 19 | Read our [documentation](https://docs.launchdarkly.com) for in-depth instructions on configuring and using LaunchDarkly. You can also head straight to the [complete reference guide for this SDK](https://docs.launchdarkly.com/sdk/server-side/haskell). 20 | 21 | ## Testing 22 | 23 | We run integration tests for all our SDKs using a centralized test harness. This approach gives us the ability to test for consistency across SDKs, as well as test networking behavior in a long-running application. These tests cover each method in the SDK, and verify that event sending, flag evaluation, stream reconnection, and other aspects of the SDK all behave correctly. 24 | 25 | ## Contributing 26 | 27 | We encourage pull requests and other contributions from the community. Check out our [contributing guidelines](CONTRIBUTING.md) for instructions on how to contribute to this SDK. 28 | 29 | ## Verifying SDK build provenance with the SLSA framework 30 | 31 | LaunchDarkly uses the [SLSA framework](https://slsa.dev/spec/v1.0/about) (Supply-chain Levels for Software Artifacts) to help developers make their supply chain more secure by ensuring the authenticity and build integrity of our published SDK packages. To learn more, see the [provenance guide](PROVENANCE.md). 32 | 33 | ## About LaunchDarkly 34 | 35 | * LaunchDarkly is a continuous delivery platform that provides feature flags as a service and allows developers to iterate quickly and safely. We allow you to easily flag your features and manage them from the LaunchDarkly dashboard. With LaunchDarkly, you can: 36 | * Roll out a new feature to a subset of your users (like a group of users who opt-in to a beta tester group), gathering feedback and bug reports from real-world use cases. 37 | * Gradually roll out a feature to an increasing percentage of users, and track the effect that the feature has on key metrics (for instance, how likely is a user to complete a purchase if they have feature A versus feature B?). 38 | * Turn off a feature that you realize is causing performance problems in production, without needing to re-deploy, or even restart the application with a changed configuration file. 39 | * Grant access to certain features based on user attributes, like payment plan (eg: users on the ‘gold’ plan get access to more features than users in the ‘silver’ plan). Disable parts of your application to facilitate maintenance, without taking everything offline. 40 | * LaunchDarkly provides feature flag SDKs for a wide variety of languages and technologies. Read [our documentation](https://docs.launchdarkly.com/sdk) for a complete list. 41 | * Explore LaunchDarkly 42 | * [launchdarkly.com](https://www.launchdarkly.com/ "LaunchDarkly Main Website") for more information 43 | * [docs.launchdarkly.com](https://docs.launchdarkly.com/ "LaunchDarkly Documentation") for our documentation and SDK reference guides 44 | * [apidocs.launchdarkly.com](https://apidocs.launchdarkly.com/ "LaunchDarkly API Documentation") for our API documentation 45 | * [blog.launchdarkly.com](https://blog.launchdarkly.com/ "LaunchDarkly Blog Documentation") for the latest product updates 46 | -------------------------------------------------------------------------------- /SECURITY.md: -------------------------------------------------------------------------------- 1 | # Reporting and Fixing Security Issues 2 | 3 | Please report all security issues to the LaunchDarkly security team by submitting a bug bounty report to our [HackerOne program](https://hackerone.com/launchdarkly?type=team). LaunchDarkly will triage and address all valid security issues following the response targets defined in our program policy. Valid security issues may be eligible for a bounty. 4 | 5 | Please do not open issues or pull requests for security issues. This makes the problem immediately visible to everyone, including potentially malicious actors. 6 | -------------------------------------------------------------------------------- /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | 3 | main = defaultMain 4 | -------------------------------------------------------------------------------- /contract-tests/Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | 3 | main = defaultMain 4 | -------------------------------------------------------------------------------- /contract-tests/package.yaml: -------------------------------------------------------------------------------- 1 | name: contract-tests 2 | version: 0.0.1 3 | github: "launchdarkly/haskell-server-sdk" 4 | license: Apache-2.0 5 | license-file: "../LICENSE" 6 | author: "LaunchDarkly" 7 | maintainer: "dev@launchdarkly.com" 8 | copyright: "2019 Catamorphic, Co" 9 | 10 | dependencies: 11 | - aeson >=1.4.7.1 && <1.6 || >= 2.0.1.0 && <2.2 12 | - base >=4.13 && <5 13 | - containers >=0.6.2.1 && <0.7 14 | - generic-lens >=2.0.0.0 && <2.3 15 | - http-types >=0.12.3 && <0.13 16 | - launchdarkly-server-sdk 17 | - lens >=4.18.1 && <5.3 18 | - mtl >=2.2.2 && <2.4 19 | - scientific >=0.3.6.2 && <0.4 20 | - scotty <1.0 21 | - text >=1.2.4.0 && <2.1 22 | - unordered-containers >=0.2.10.0 && <0.3 23 | 24 | default-extensions: 25 | - AllowAmbiguousTypes 26 | - DataKinds 27 | - DeriveAnyClass 28 | - DeriveGeneric 29 | - DerivingStrategies 30 | - DuplicateRecordFields 31 | - FlexibleContexts 32 | - FlexibleInstances 33 | - GeneralizedNewtypeDeriving 34 | - LambdaCase 35 | - MonoLocalBinds 36 | - MultiParamTypeClasses 37 | - MultiWayIf 38 | - NoMonomorphismRestriction 39 | - OverloadedStrings 40 | - RankNTypes 41 | - RecordWildCards 42 | - ScopedTypeVariables 43 | - TemplateHaskell 44 | - TupleSections 45 | - TypeApplications 46 | - TypeOperators 47 | 48 | executables: 49 | contract-tests: 50 | main: Main.hs 51 | source-dirs: src 52 | ghc-options: 53 | - -threaded 54 | - -rtsopts 55 | - -with-rtsopts=-N 56 | -------------------------------------------------------------------------------- /contract-tests/src/Types.hs: -------------------------------------------------------------------------------- 1 | module Types where 2 | 3 | import Data.Aeson (FromJSON, ToJSON, object, parseJSON, toJSON, withObject, (.!=), (.:), (.:?)) 4 | import Data.Aeson.Types (Value (..)) 5 | import Data.Function ((&)) 6 | import Data.HashMap.Strict (HashMap) 7 | import Data.Maybe (fromMaybe) 8 | import Data.Set (Set) 9 | import Data.Text (Text) 10 | import GHC.Generics (Generic) 11 | import GHC.Natural (Natural) 12 | import qualified LaunchDarkly.Server as LD 13 | 14 | data CreateClientParams = CreateClientParams 15 | { tag :: !Text 16 | , configuration :: !ConfigurationParams 17 | } 18 | deriving (FromJSON, ToJSON, Show, Generic) 19 | 20 | data ConfigurationParams = ConfigurationParams 21 | { credential :: !Text 22 | , startWaitTimeMs :: !(Maybe Int) 23 | , initCanFail :: !(Maybe Bool) 24 | , streaming :: !(Maybe StreamingParams) 25 | , polling :: !(Maybe PollingParams) 26 | , events :: !(Maybe EventParams) 27 | , tags :: !(Maybe TagParams) 28 | } 29 | deriving (FromJSON, ToJSON, Show, Generic) 30 | 31 | data StreamingParams = StreamingParams 32 | { baseUri :: !(Maybe Text) 33 | , initialRetryDelayMs :: !(Maybe Int) 34 | } 35 | deriving (FromJSON, ToJSON, Show, Generic) 36 | 37 | data PollingParams = PollingParams 38 | { baseUri :: !(Maybe Text) 39 | , pollIntervalMs :: !(Maybe Natural) 40 | } 41 | deriving (FromJSON, ToJSON, Show, Generic) 42 | 43 | data EventParams = EventParams 44 | { baseUri :: !(Maybe Text) 45 | , capacity :: !(Maybe Natural) 46 | , enableDiagnostics :: !(Maybe Bool) 47 | , allAttributesPrivate :: !(Maybe Bool) 48 | , enableGzip :: !(Maybe Bool) 49 | , globalPrivateAttributes :: !(Maybe (Set Text)) 50 | , flushIntervalMs :: !(Maybe Natural) 51 | , omitAnonymousContexts :: !(Maybe Bool) 52 | } 53 | deriving (FromJSON, ToJSON, Show, Generic) 54 | 55 | data TagParams = TagParams 56 | { applicationId :: !(Maybe Text) 57 | , applicationVersion :: !(Maybe Text) 58 | } 59 | deriving (FromJSON, ToJSON, Show, Generic) 60 | 61 | data CommandParams = CommandParams 62 | { command :: !Text 63 | , evaluate :: !(Maybe EvaluateFlagParams) 64 | , evaluateAll :: !(Maybe EvaluateAllFlagsParams) 65 | , customEvent :: !(Maybe CustomEventParams) 66 | , identifyEvent :: !(Maybe IdentifyEventParams) 67 | , contextBuild :: !(Maybe ContextBuildParams) 68 | , contextConvert :: !(Maybe ContextConvertParams) 69 | , secureModeHash :: !(Maybe SecureModeHashParams) 70 | } 71 | deriving (FromJSON, Generic) 72 | 73 | data EvaluateFlagParams = EvaluateFlagParams 74 | { flagKey :: !Text 75 | , context :: !LD.Context 76 | , valueType :: !Text 77 | , defaultValue :: !Value 78 | , detail :: !Bool 79 | } 80 | deriving (FromJSON, Generic) 81 | 82 | data EvaluateFlagResponse = EvaluateFlagResponse 83 | { value :: !Value 84 | , variationIndex :: !(Maybe Integer) 85 | , reason :: !(Maybe LD.EvaluationReason) 86 | } 87 | deriving (ToJSON, Show, Generic) 88 | 89 | data EvaluateAllFlagsParams = EvaluateAllFlagsParams 90 | { context :: !LD.Context 91 | , withReasons :: !Bool 92 | , clientSideOnly :: !Bool 93 | , detailsOnlyForTrackedFlags :: !Bool 94 | } 95 | deriving (FromJSON, Generic) 96 | 97 | data EvaluateAllFlagsResponse = EvaluateAllFlagsResponse 98 | { state :: !LD.AllFlagsState 99 | } 100 | deriving (ToJSON, Show, Generic) 101 | 102 | data CustomEventParams = CustomEventParams 103 | { eventKey :: !Text 104 | , context :: !LD.Context 105 | , dataValue :: !(Maybe Value) 106 | , omitNullData :: !(Maybe Bool) 107 | , metricValue :: !(Maybe Double) 108 | } 109 | deriving (Generic) 110 | 111 | instance FromJSON CustomEventParams where 112 | parseJSON = withObject "CustomEvent" $ \o -> do 113 | eventKey <- o .: "eventKey" 114 | context <- o .: "context" 115 | dataValue <- o .:? "data" 116 | omitNullData <- o .:? "omitNullData" 117 | metricValue <- o .:? "metricValue" 118 | return $ CustomEventParams {..} 119 | 120 | data IdentifyEventParams = IdentifyEventParams 121 | { context :: !LD.Context 122 | } 123 | deriving (FromJSON, Generic) 124 | 125 | data ContextBuildParams = ContextBuildParams 126 | { single :: !(Maybe ContextBuildParam) 127 | , multi :: !(Maybe [ContextBuildParam]) 128 | } 129 | deriving (FromJSON, Generic) 130 | 131 | data ContextBuildParam = ContextBuildParam 132 | { kind :: !(Maybe Text) 133 | , key :: !Text 134 | , name :: !(Maybe Text) 135 | , anonymous :: !(Maybe Bool) 136 | , private :: !(Maybe (Set Text)) 137 | , custom :: !(Maybe (HashMap Text Value)) 138 | } 139 | deriving (FromJSON, Generic) 140 | 141 | data ContextConvertParams = ContextConvertParams 142 | { input :: !Text 143 | } 144 | deriving (FromJSON, Generic) 145 | 146 | data ContextResponse = ContextResponse 147 | { output :: !(Maybe Text) 148 | , errorMessage :: !(Maybe Text) 149 | } 150 | deriving (Generic) 151 | 152 | instance ToJSON ContextResponse where 153 | toJSON (ContextResponse {output = Just o, errorMessage = Nothing}) = object [("output", String o)] 154 | toJSON (ContextResponse {output = _, errorMessage = Just e}) = object [("error", String e)] 155 | toJSON _ = object [("error", String "Invalid context response was generated")] 156 | 157 | data SecureModeHashParams = SecureModeHashParams 158 | { context :: !(Maybe LD.Context) 159 | } 160 | deriving (FromJSON, Generic) 161 | 162 | data SecureModeHashResponse = SecureModeHashResponse 163 | { result :: !Text 164 | } 165 | deriving (ToJSON, Show, Generic) 166 | -------------------------------------------------------------------------------- /contract-tests/src/Utils.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE NumericUnderscores #-} 2 | 3 | module Utils where 4 | 5 | import Control.Concurrent (threadDelay) 6 | import Control.Lens ((&)) 7 | import Data.Generics.Product (getField) 8 | import Data.Maybe (fromMaybe) 9 | import qualified Data.Set as S 10 | import Data.Text (Text) 11 | import GHC.Natural (Natural, quotNatural) 12 | import qualified LaunchDarkly.Server as LD 13 | import qualified LaunchDarkly.Server.Reference as R 14 | import Types 15 | 16 | createClient :: CreateClientParams -> IO LD.Client 17 | createClient p = LD.makeClient $ createConfig $ getField @"configuration" p 18 | 19 | waitClient :: LD.Client -> IO () 20 | waitClient client = do 21 | status <- LD.getStatus client 22 | case status of 23 | LD.Initialized -> return () 24 | _ -> threadDelay (1 * 1_000) >> waitClient client 25 | 26 | createConfig :: ConfigurationParams -> LD.Config 27 | createConfig p = 28 | LD.makeConfig (getField @"credential" p) 29 | & streamingConfig (getField @"streaming" p) 30 | & pollingConfig (getField @"polling" p) 31 | & tagsConfig (getField @"tags" p) 32 | & eventConfig (getField @"events" p) 33 | 34 | updateConfig :: (a -> LD.Config -> LD.Config) -> Maybe a -> LD.Config -> LD.Config 35 | updateConfig f Nothing config = config 36 | updateConfig f (Just x) config = f x config 37 | 38 | streamingConfig :: Maybe StreamingParams -> LD.Config -> LD.Config 39 | streamingConfig Nothing c = c 40 | streamingConfig (Just p) c = 41 | updateConfig LD.configSetStreamURI (getField @"baseUri" p) $ 42 | updateConfig LD.configSetInitialRetryDelay (getField @"initialRetryDelayMs" p) c 43 | 44 | pollingConfig :: Maybe PollingParams -> LD.Config -> LD.Config 45 | pollingConfig Nothing c = c 46 | pollingConfig (Just p) c = 47 | updateConfig LD.configSetBaseURI (getField @"baseUri" p) $ 48 | updateConfig LD.configSetStreaming (Just False) $ 49 | updateConfig LD.configSetPollIntervalSeconds ((`quotNatural` 1_000) <$> getField @"pollIntervalMs" p) c 50 | 51 | tagsConfig :: Maybe TagParams -> LD.Config -> LD.Config 52 | tagsConfig Nothing c = c 53 | tagsConfig (Just params) c = LD.configSetApplicationInfo appInfo c 54 | where 55 | appInfo = 56 | LD.makeApplicationInfo 57 | & setApplicationInfo "id" (getField @"applicationId" params) 58 | & setApplicationInfo "version" (getField @"applicationVersion" params) 59 | 60 | setApplicationInfo :: Text -> Maybe Text -> LD.ApplicationInfo -> LD.ApplicationInfo 61 | setApplicationInfo _ Nothing appInfo = appInfo 62 | setApplicationInfo key (Just value) appInfo = LD.withApplicationValue key value appInfo 63 | 64 | eventConfig :: Maybe EventParams -> LD.Config -> LD.Config 65 | eventConfig Nothing c = updateConfig LD.configSetSendEvents (Just False) c 66 | eventConfig (Just p) c = 67 | updateConfig LD.configSetEventsURI (getField @"baseUri" p) $ 68 | updateConfig LD.configSetEventsCapacity (getField @"capacity" p) $ 69 | updateConfig LD.configSetCompressEvents (getField @"enableGzip" p) $ 70 | updateConfig LD.configSetAllAttributesPrivate (getField @"allAttributesPrivate" p) $ 71 | updateConfig LD.configSetPrivateAttributeNames ((S.map R.makeReference) <$> getField @"globalPrivateAttributes" p) $ 72 | updateConfig LD.configSetOmitAnonymousContexts (getField @"omitAnonymousContexts" p) $ 73 | updateConfig LD.configSetFlushIntervalSeconds (getField @"flushIntervalMs" p) c 74 | -------------------------------------------------------------------------------- /contract-tests/stack.yaml: -------------------------------------------------------------------------------- 1 | resolver: lts-16.31 2 | 3 | packages: 4 | - . 5 | 6 | extra-deps: 7 | - ../ 8 | -------------------------------------------------------------------------------- /contract-tests/stack.yaml.lock: -------------------------------------------------------------------------------- 1 | # This file was autogenerated by Stack. 2 | # You should not edit this file by hand. 3 | # For more information, please see the documentation at: 4 | # https://docs.haskellstack.org/en/stable/lock_files 5 | 6 | packages: [] 7 | snapshots: 8 | - completed: 9 | sha256: 637fb77049b25560622a224845b7acfe81a09fdb6a96a3c75997a10b651667f6 10 | size: 534126 11 | url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/16/31.yaml 12 | original: lts-16.31 13 | -------------------------------------------------------------------------------- /contract-tests/testharness-suppressions.txt: -------------------------------------------------------------------------------- 1 | evaluation/all flags state/client not ready 2 | -------------------------------------------------------------------------------- /fourmolu.yaml: -------------------------------------------------------------------------------- 1 | import-export-style: leading 2 | record-brace-space: true 3 | haddock-style: single-line 4 | -------------------------------------------------------------------------------- /launchdarkly-server-sdk.cabal: -------------------------------------------------------------------------------- 1 | cabal-version: 1.12 2 | 3 | -- This file has been generated from package.yaml by hpack version 0.35.1. 4 | -- 5 | -- see: https://github.com/sol/hpack 6 | 7 | name: launchdarkly-server-sdk 8 | version: 4.5.0 9 | synopsis: Server-side SDK for integrating with LaunchDarkly 10 | description: Please see the README on GitHub at 11 | category: Web 12 | homepage: https://github.com/launchdarkly/haskell-server-sdk#readme 13 | bug-reports: https://github.com/launchdarkly/haskell-server-sdk/issues 14 | author: LaunchDarkly 15 | maintainer: dev@launchdarkly.com 16 | copyright: 2019 Catamorphic, Co 17 | license: Apache-2.0 18 | license-file: LICENSE 19 | build-type: Simple 20 | extra-source-files: 21 | README.md 22 | CHANGELOG.md 23 | LICENSE 24 | test-data/filesource/all-properties.json 25 | test-data/filesource/flag-only.json 26 | test-data/filesource/flag-with-duplicate-key.json 27 | test-data/filesource/malformed.json 28 | test-data/filesource/no-data.json 29 | test-data/filesource/segment-only.json 30 | test-data/filesource/segment-with-duplicate-key.json 31 | test-data/filesource/targets.json 32 | test-data/filesource/value-only.json 33 | test-data/filesource/value-with-duplicate-key.json 34 | 35 | source-repository head 36 | type: git 37 | location: https://github.com/launchdarkly/haskell-server-sdk 38 | 39 | library 40 | exposed-modules: 41 | LaunchDarkly.AesonCompat 42 | LaunchDarkly.Server 43 | LaunchDarkly.Server.Client 44 | LaunchDarkly.Server.Config 45 | LaunchDarkly.Server.Context 46 | LaunchDarkly.Server.Reference 47 | LaunchDarkly.Server.Store 48 | LaunchDarkly.Server.Integrations.FileData 49 | LaunchDarkly.Server.Integrations.TestData 50 | other-modules: 51 | LaunchDarkly.Server.Client.Internal 52 | LaunchDarkly.Server.Client.Status 53 | LaunchDarkly.Server.Config.ClientContext 54 | LaunchDarkly.Server.Config.HttpConfiguration 55 | LaunchDarkly.Server.Config.Internal 56 | LaunchDarkly.Server.Context.Internal 57 | LaunchDarkly.Server.DataSource.Internal 58 | LaunchDarkly.Server.Details 59 | LaunchDarkly.Server.Evaluate 60 | LaunchDarkly.Server.Events 61 | LaunchDarkly.Server.Features 62 | LaunchDarkly.Server.Integrations.TestData.FlagBuilder 63 | LaunchDarkly.Server.Network.Common 64 | LaunchDarkly.Server.Network.Eventing 65 | LaunchDarkly.Server.Network.Polling 66 | LaunchDarkly.Server.Network.Streaming 67 | LaunchDarkly.Server.Operators 68 | LaunchDarkly.Server.Store.Internal 69 | LaunchDarkly.Server.Util 70 | Paths_launchdarkly_server_sdk 71 | hs-source-dirs: 72 | src 73 | default-extensions: 74 | AllowAmbiguousTypes 75 | DataKinds 76 | DeriveAnyClass 77 | DeriveGeneric 78 | DerivingStrategies 79 | DuplicateRecordFields 80 | FlexibleContexts 81 | FlexibleInstances 82 | GeneralizedNewtypeDeriving 83 | LambdaCase 84 | MonoLocalBinds 85 | MultiParamTypeClasses 86 | MultiWayIf 87 | NoMonomorphismRestriction 88 | OverloadedStrings 89 | RankNTypes 90 | RecordWildCards 91 | ScopedTypeVariables 92 | TemplateHaskell 93 | TupleSections 94 | TypeApplications 95 | TypeOperators 96 | ghc-options: -fwarn-unused-imports -Wall -Wno-name-shadowing 97 | build-depends: 98 | aeson >=1.4.7.1 && <1.6 || >=2.0.1.0 && <2.3 99 | , attoparsec >=0.13.2.4 && <0.15 100 | , base >=4.13 && <5 101 | , base16-bytestring >=0.1.1.7 && <1.1 102 | , bytestring >=0.10.10.1 && <0.12 103 | , clock ==0.8.* 104 | , containers >=0.6.2.1 && <0.7 105 | , cryptohash >=0.11.9 && <0.12 106 | , exceptions >=0.10.4 && <0.11 107 | , extra >=1.7.9 && <1.8 108 | , generic-lens >=2.0.0.0 && <2.3 109 | , hashtables >=1.2.4.1 && <1.4 110 | , http-client >=0.6.4.1 && <0.8 111 | , http-client-tls >=0.3.5.3 && <0.4 112 | , http-types >=0.12.3 && <0.13 113 | , iso8601-time >=0.1.5 && <0.2 114 | , lens >=4.18.1 && <5.3 115 | , lrucache >=1.2.0.1 && <1.3 116 | , memory >=0.15.0 117 | , monad-logger >=0.3.36 && <0.4 118 | , monad-loops ==0.4.* 119 | , mtl >=2.2.2 && <2.4 120 | , pcre-light >=0.4.1.0 && <0.5 121 | , random >=1.1 && <1.3 122 | , scientific >=0.3.6.2 && <0.4 123 | , semver >=0.3.4 && <0.5 124 | , text >=1.2.4.0 && <2.1 125 | , time >=1.9.3 && <1.13 126 | , unordered-containers >=0.2.10.0 && <0.3 127 | , uuid >=1.3.13 && <1.4 128 | , yaml >=0.11.5.0 && <0.12 129 | , zlib >=0.6.2.2 && <0.7 130 | default-language: Haskell2010 131 | 132 | test-suite haskell-server-sdk-test 133 | type: exitcode-stdio-1.0 134 | main-is: Spec.hs 135 | other-modules: 136 | Spec.Bucket 137 | Spec.Client 138 | Spec.Config 139 | Spec.Context 140 | Spec.DataSource 141 | Spec.Evaluate 142 | Spec.Features 143 | Spec.Integrations.FileData 144 | Spec.Integrations.TestData 145 | Spec.Operators 146 | Spec.PersistentDataStore 147 | Spec.Reference 148 | Spec.Segment 149 | Spec.Store 150 | Spec.Streaming 151 | Util.Features 152 | LaunchDarkly.AesonCompat 153 | LaunchDarkly.Server 154 | LaunchDarkly.Server.Client 155 | LaunchDarkly.Server.Client.Internal 156 | LaunchDarkly.Server.Client.Status 157 | LaunchDarkly.Server.Config 158 | LaunchDarkly.Server.Config.ClientContext 159 | LaunchDarkly.Server.Config.HttpConfiguration 160 | LaunchDarkly.Server.Config.Internal 161 | LaunchDarkly.Server.Context 162 | LaunchDarkly.Server.Context.Internal 163 | LaunchDarkly.Server.DataSource.Internal 164 | LaunchDarkly.Server.Details 165 | LaunchDarkly.Server.Evaluate 166 | LaunchDarkly.Server.Events 167 | LaunchDarkly.Server.Features 168 | LaunchDarkly.Server.Integrations.FileData 169 | LaunchDarkly.Server.Integrations.TestData 170 | LaunchDarkly.Server.Integrations.TestData.FlagBuilder 171 | LaunchDarkly.Server.Network.Common 172 | LaunchDarkly.Server.Network.Eventing 173 | LaunchDarkly.Server.Network.Polling 174 | LaunchDarkly.Server.Network.Streaming 175 | LaunchDarkly.Server.Operators 176 | LaunchDarkly.Server.Reference 177 | LaunchDarkly.Server.Store 178 | LaunchDarkly.Server.Store.Internal 179 | LaunchDarkly.Server.Util 180 | Paths_launchdarkly_server_sdk 181 | hs-source-dirs: 182 | test 183 | src 184 | default-extensions: 185 | AllowAmbiguousTypes 186 | DataKinds 187 | DeriveAnyClass 188 | DeriveGeneric 189 | DerivingStrategies 190 | DuplicateRecordFields 191 | FlexibleContexts 192 | FlexibleInstances 193 | GeneralizedNewtypeDeriving 194 | LambdaCase 195 | MonoLocalBinds 196 | MultiParamTypeClasses 197 | MultiWayIf 198 | NoMonomorphismRestriction 199 | OverloadedStrings 200 | RankNTypes 201 | RecordWildCards 202 | ScopedTypeVariables 203 | TemplateHaskell 204 | TupleSections 205 | TypeApplications 206 | TypeOperators 207 | ghc-options: -rtsopts -threaded -with-rtsopts=-N -Wno-name-shadowing -fwarn-unused-imports 208 | build-depends: 209 | HUnit 210 | , aeson >=1.4.7.1 && <1.6 || >=2.0.1.0 && <2.3 211 | , attoparsec >=0.13.2.4 && <0.15 212 | , base >=4.13 && <5 213 | , base16-bytestring >=0.1.1.7 && <1.1 214 | , bytestring >=0.10.10.1 && <0.12 215 | , clock ==0.8.* 216 | , containers >=0.6.2.1 && <0.7 217 | , cryptohash >=0.11.9 && <0.12 218 | , exceptions >=0.10.4 && <0.11 219 | , extra >=1.7.9 && <1.8 220 | , generic-lens >=2.0.0.0 && <2.3 221 | , hashtables >=1.2.4.1 && <1.4 222 | , http-client >=0.6.4.1 && <0.8 223 | , http-client-tls >=0.3.5.3 && <0.4 224 | , http-types >=0.12.3 && <0.13 225 | , iso8601-time >=0.1.5 && <0.2 226 | , lens >=4.18.1 && <5.3 227 | , lrucache >=1.2.0.1 && <1.3 228 | , memory >=0.15.0 229 | , monad-logger >=0.3.36 && <0.4 230 | , monad-loops ==0.4.* 231 | , mtl >=2.2.2 && <2.4 232 | , pcre-light >=0.4.1.0 && <0.5 233 | , random >=1.1 && <1.3 234 | , scientific >=0.3.6.2 && <0.4 235 | , semver >=0.3.4 && <0.5 236 | , text >=1.2.4.0 && <2.1 237 | , time >=1.9.3 && <1.13 238 | , unordered-containers >=0.2.10.0 && <0.3 239 | , uuid >=1.3.13 && <1.4 240 | , yaml >=0.11.5.0 && <0.12 241 | , zlib >=0.6.2.2 && <0.7 242 | default-language: Haskell2010 243 | -------------------------------------------------------------------------------- /package.yaml: -------------------------------------------------------------------------------- 1 | name: launchdarkly-server-sdk 2 | version: 4.5.0 3 | github: launchdarkly/haskell-server-sdk 4 | license: Apache-2.0 5 | license-file: LICENSE 6 | author: LaunchDarkly 7 | maintainer: dev@launchdarkly.com 8 | copyright: 2019 Catamorphic, Co 9 | extra-source-files: 10 | - README.md 11 | - CHANGELOG.md 12 | - LICENSE 13 | - test-data/**/*.json 14 | synopsis: Server-side SDK for integrating with LaunchDarkly 15 | category: Web 16 | description: >- 17 | Please see the README on GitHub at 18 | 19 | dependencies: 20 | - aeson >=1.4.7.1 && <1.6 || >= 2.0.1.0 && <2.3 21 | - attoparsec >=0.13.2.4 && <0.15 22 | - base >=4.13 && <5 23 | - base16-bytestring >=0.1.1.7 && <1.1 24 | - bytestring >=0.10.10.1 && <0.12 25 | - clock ==0.8.* 26 | - containers >=0.6.2.1 && <0.7 27 | - cryptohash >=0.11.9 && <0.12 28 | - exceptions >=0.10.4 && <0.11 29 | - extra >=1.7.9 && <1.8 30 | - generic-lens >=2.0.0.0 && <2.3 31 | - hashtables >=1.2.4.1 && <1.4 32 | - http-client >=0.6.4.1 && <0.8 33 | - http-client-tls >=0.3.5.3 && <0.4 34 | - http-types >=0.12.3 && <0.13 35 | - iso8601-time >=0.1.5 && <0.2 36 | - lens >=4.18.1 && <5.3 37 | - lrucache >=1.2.0.1 && <1.3 38 | - memory>=0.15.0 39 | - monad-logger >=0.3.36 && <0.4 40 | - monad-loops ==0.4.* 41 | - mtl >=2.2.2 && <2.4 42 | - pcre-light >=0.4.1.0 && <0.5 43 | - random >=1.1 && <1.3 44 | - scientific >=0.3.6.2 && <0.4 45 | - semver >=0.3.4 && <0.5 46 | - text >=1.2.4.0 && <2.1 47 | - time >=1.9.3 && <1.13 48 | - unordered-containers >=0.2.10.0 && <0.3 49 | - uuid >=1.3.13 && <1.4 50 | - yaml >=0.11.5.0 && <0.12 51 | - zlib >= 0.6.2.2 && <0.7 52 | default-extensions: 53 | - AllowAmbiguousTypes 54 | - DataKinds 55 | - DeriveAnyClass 56 | - DeriveGeneric 57 | - DerivingStrategies 58 | - DuplicateRecordFields 59 | - FlexibleContexts 60 | - FlexibleInstances 61 | - GeneralizedNewtypeDeriving 62 | - LambdaCase 63 | - MonoLocalBinds 64 | - MultiParamTypeClasses 65 | - MultiWayIf 66 | - NoMonomorphismRestriction 67 | - OverloadedStrings 68 | - RankNTypes 69 | - RecordWildCards 70 | - ScopedTypeVariables 71 | - TemplateHaskell 72 | - TupleSections 73 | - TypeApplications 74 | - TypeOperators 75 | library: 76 | source-dirs: src 77 | ghc-options: 78 | - '-fwarn-unused-imports' 79 | - '-Wall' 80 | - '-Wno-name-shadowing' 81 | exposed-modules: 82 | - LaunchDarkly.AesonCompat 83 | - LaunchDarkly.Server 84 | - LaunchDarkly.Server.Client 85 | - LaunchDarkly.Server.Config 86 | - LaunchDarkly.Server.Context 87 | - LaunchDarkly.Server.Reference 88 | - LaunchDarkly.Server.Store 89 | - LaunchDarkly.Server.Integrations.FileData 90 | - LaunchDarkly.Server.Integrations.TestData 91 | tests: 92 | haskell-server-sdk-test: 93 | main: Spec.hs 94 | source-dirs: 95 | - test 96 | - src 97 | ghc-options: 98 | - '-rtsopts' 99 | - '-threaded' 100 | - '-with-rtsopts=-N' 101 | - '-Wno-name-shadowing' 102 | - '-fwarn-unused-imports' 103 | dependencies: 104 | - HUnit 105 | -------------------------------------------------------------------------------- /release-please-config.json: -------------------------------------------------------------------------------- 1 | { 2 | "packages": { 3 | ".": { 4 | "release-type": "simple", 5 | "bump-minor-pre-major": true, 6 | "versioning": "default", 7 | "include-component-in-tag": false, 8 | "include-v-in-tag": false, 9 | "extra-files": [ 10 | "package.yaml", 11 | "PROVENANCE.md", 12 | "src/LaunchDarkly/Server/Client/Internal.hs" 13 | ] 14 | } 15 | } 16 | } 17 | -------------------------------------------------------------------------------- /src/LaunchDarkly/AesonCompat.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | 3 | -- | 4 | -- The LaunchDarkly SDK supports a subset of Aeson 1.x and 2.x. These two 5 | -- versions differ in their type signatures, but are otherwise largely 6 | -- compatible. To support both versions, we provide this compatibility module. 7 | -- 8 | -- Depending on the version of Aeson you have installed, this module will 9 | -- expose a KeyMap type that is either 10 | -- 11 | -- - In the case of 1.x, a HashMap T.Text, or 12 | -- - In the case of 2.x, the new KeyMap type 13 | -- 14 | -- The compatibility layer exposes common map operations that the SDK needs and 15 | -- may prove useful to customers. In nearly all instances, these are simple 16 | -- aliases for the underlying Aeson equivalents. 17 | -- 18 | -- The Aeson 2.x KeyMap is keyed by a new Key type that does not exist in 1.x. 19 | -- To keep the API as consistent as possible, all functions requiring a key 20 | -- will provide a Text value. In the 2.x compatibility layer, we will convert 21 | -- it to a from the appropriate Key type as necessary. 22 | module LaunchDarkly.AesonCompat where 23 | 24 | #if MIN_VERSION_aeson(2,0,0) 25 | import Data.Aeson (Key) 26 | import qualified Data.Aeson.Key as Key 27 | import qualified Data.Aeson.KeyMap as KeyMap 28 | import Data.Functor.Identity (Identity(..), runIdentity) 29 | import qualified Data.Map.Strict as M 30 | #else 31 | import qualified Data.HashMap.Strict as HM 32 | #endif 33 | import qualified Data.Text as T 34 | 35 | #if MIN_VERSION_aeson(2,0,0) 36 | type KeyMap = KeyMap.KeyMap 37 | 38 | null :: KeyMap v -> Bool 39 | null = KeyMap.null 40 | 41 | emptyObject :: KeyMap v 42 | emptyObject = KeyMap.empty 43 | 44 | singleton :: T.Text -> v -> KeyMap v 45 | singleton key = KeyMap.singleton (Key.fromText key) 46 | 47 | fromList :: [(T.Text, v)] -> KeyMap v 48 | fromList list = KeyMap.fromList (map (\(k, v) -> ((Key.fromText k), v)) list) 49 | 50 | toList :: KeyMap v -> [(T.Text, v)] 51 | toList m = map (\(k, v) -> ((Key.toText k), v)) (KeyMap.toList m) 52 | 53 | deleteKey :: T.Text -> KeyMap.KeyMap v -> KeyMap.KeyMap v 54 | deleteKey key = KeyMap.delete (Key.fromText key) 55 | 56 | lookupKey :: T.Text -> KeyMap.KeyMap v -> Maybe v 57 | lookupKey key = KeyMap.lookup (Key.fromText key) 58 | 59 | objectKeys :: KeyMap.KeyMap v -> [T.Text] 60 | objectKeys = map Key.toText . KeyMap.keys 61 | 62 | objectValues :: KeyMap.KeyMap v -> [v] 63 | objectValues m = map snd $ KeyMap.toList m 64 | 65 | keyToText :: Key -> T.Text 66 | keyToText = Key.toText 67 | 68 | insertKey :: T.Text -> v -> KeyMap.KeyMap v -> KeyMap.KeyMap v 69 | insertKey key = KeyMap.insert (Key.fromText key) 70 | 71 | filterKeys :: (Key -> Bool) -> KeyMap.KeyMap a -> KeyMap.KeyMap a 72 | filterKeys p = KeyMap.filterWithKey (\key _ -> p key) 73 | 74 | filterObject :: (v -> Bool) -> KeyMap.KeyMap v -> KeyMap.KeyMap v 75 | filterObject = KeyMap.filter 76 | 77 | adjustKey :: (v -> v) -> Key -> KeyMap.KeyMap v -> KeyMap.KeyMap v 78 | adjustKey f k = runIdentity . KeyMap.alterF (Identity . fmap f) k 79 | 80 | mapValues :: (v1 -> v2) -> KeyMap.KeyMap v1 -> KeyMap.KeyMap v2 81 | mapValues = KeyMap.map 82 | 83 | mapWithKey :: (T.Text -> v1 -> v2) -> KeyMap.KeyMap v1 -> KeyMap.KeyMap v2 84 | mapWithKey f m = KeyMap.fromMap (M.mapWithKey (\k v -> f (keyToText k) v) (KeyMap.toMap m)) 85 | 86 | mapMaybeValues :: (v1 -> Maybe v2) -> KeyMap.KeyMap v1 -> KeyMap.KeyMap v2 87 | mapMaybeValues = KeyMap.mapMaybe 88 | 89 | keyMapUnion :: KeyMap.KeyMap v -> KeyMap.KeyMap v -> KeyMap.KeyMap v 90 | keyMapUnion = KeyMap.union 91 | 92 | foldrWithKey :: (T.Text -> v -> a -> a) -> a -> KeyMap.KeyMap v -> a 93 | foldrWithKey f accum initial = KeyMap.foldrWithKey (\k v a -> f (keyToText k) v a) accum initial 94 | #else 95 | type KeyMap = HM.HashMap T.Text 96 | 97 | null :: KeyMap v -> Bool 98 | null = HM.null 99 | 100 | emptyObject :: KeyMap v 101 | emptyObject = HM.empty 102 | 103 | singleton :: T.Text -> v -> HM.HashMap T.Text v 104 | singleton = HM.singleton 105 | 106 | fromList :: [(T.Text, v)] -> KeyMap v 107 | fromList = HM.fromList 108 | 109 | toList :: HM.HashMap T.Text v -> [(T.Text, v)] 110 | toList = HM.toList 111 | 112 | deleteKey :: T.Text -> HM.HashMap T.Text v -> HM.HashMap T.Text v 113 | deleteKey = HM.delete 114 | 115 | lookupKey :: T.Text -> HM.HashMap T.Text v -> Maybe v 116 | lookupKey = HM.lookup 117 | 118 | objectKeys :: HM.HashMap T.Text v -> [T.Text] 119 | objectKeys = HM.keys 120 | 121 | objectValues :: HM.HashMap T.Text v -> [v] 122 | objectValues = HM.elems 123 | 124 | keyToText :: T.Text -> T.Text 125 | keyToText = id 126 | 127 | insertKey :: T.Text -> v -> HM.HashMap T.Text v -> HM.HashMap T.Text v 128 | insertKey = HM.insert 129 | 130 | filterKeys :: (T.Text -> Bool) -> HM.HashMap T.Text a -> HM.HashMap T.Text a 131 | filterKeys p = HM.filterWithKey (\key _ -> p key) 132 | 133 | filterObject :: (v -> Bool) -> HM.HashMap T.Text v -> HM.HashMap T.Text v 134 | filterObject = HM.filter 135 | 136 | adjustKey :: (v -> v) -> T.Text -> HM.HashMap T.Text v -> HM.HashMap T.Text v 137 | adjustKey = HM.adjust 138 | 139 | mapValues :: (v1 -> v2) -> HM.HashMap T.Text v1 -> HM.HashMap T.Text v2 140 | mapValues = HM.map 141 | 142 | mapWithKey :: (T.Text -> v1 -> v2) -> HM.HashMap T.Text v1 -> HM.HashMap T.Text v2 143 | mapWithKey = HM.mapWithKey 144 | 145 | mapMaybeValues :: (v1 -> Maybe v2) -> HM.HashMap T.Text v1 -> HM.HashMap T.Text v2 146 | mapMaybeValues = HM.mapMaybe 147 | 148 | keyMapUnion :: HM.HashMap T.Text v -> HM.HashMap T.Text v -> HM.HashMap T.Text v 149 | keyMapUnion = HM.union 150 | 151 | foldrWithKey :: (T.Text -> v -> a -> a) -> a -> HM.HashMap T.Text v -> a 152 | foldrWithKey = HM.foldrWithKey 153 | #endif 154 | -------------------------------------------------------------------------------- /src/LaunchDarkly/Server.hs: -------------------------------------------------------------------------------- 1 | -- | This module re-exports the Client, Config, and Context modules. 2 | module LaunchDarkly.Server 3 | ( module LaunchDarkly.Server.Client 4 | , module LaunchDarkly.Server.Config 5 | , module LaunchDarkly.Server.Context 6 | ) where 7 | 8 | import LaunchDarkly.Server.Client 9 | import LaunchDarkly.Server.Config 10 | import LaunchDarkly.Server.Context 11 | -------------------------------------------------------------------------------- /src/LaunchDarkly/Server/Client/Internal.hs: -------------------------------------------------------------------------------- 1 | module LaunchDarkly.Server.Client.Internal 2 | ( Client (..) 3 | , Status (..) 4 | , clientVersion 5 | , setStatus 6 | , getStatusI 7 | ) where 8 | 9 | import Control.Concurrent (ThreadId) 10 | import Control.Concurrent.MVar (MVar) 11 | import Data.Generics.Product (getField) 12 | import Data.IORef (IORef, atomicModifyIORef', readIORef) 13 | import Data.Text (Text) 14 | import GHC.Generics (Generic) 15 | 16 | import LaunchDarkly.Server.Client.Status (Status (..), transitionStatus) 17 | import LaunchDarkly.Server.Config.Internal (Config) 18 | import LaunchDarkly.Server.DataSource.Internal (DataSource) 19 | import LaunchDarkly.Server.Events (EventState) 20 | import LaunchDarkly.Server.Store.Internal (StoreHandle, getInitializedC) 21 | 22 | -- | The version string for this library. 23 | clientVersion :: Text 24 | clientVersion = "4.5.0" -- x-release-please-version 25 | 26 | -- | 27 | -- Client is the LaunchDarkly client. Client instances are thread-safe. 28 | -- Applications should instantiate a single instance for the lifetime of their 29 | -- application. 30 | data Client = Client 31 | { config :: !(Config) 32 | , store :: !(StoreHandle IO) 33 | , status :: !(IORef Status) 34 | , events :: !EventState 35 | , eventThreadPair :: !(Maybe (ThreadId, MVar ())) 36 | , dataSource :: !DataSource 37 | } 38 | deriving (Generic) 39 | 40 | setStatus :: Client -> Status -> IO () 41 | setStatus client status' = 42 | atomicModifyIORef' (getField @"status" client) (fmap (,()) (transitionStatus status')) 43 | 44 | getStatusI :: Client -> IO Status 45 | getStatusI client = 46 | readIORef (getField @"status" client) >>= \case 47 | Unauthorized -> pure Unauthorized 48 | ShuttingDown -> pure ShuttingDown 49 | _ -> 50 | getInitializedC (getField @"store" client) >>= \case 51 | Right True -> pure Initialized 52 | _ -> pure Uninitialized 53 | -------------------------------------------------------------------------------- /src/LaunchDarkly/Server/Client/Status.hs: -------------------------------------------------------------------------------- 1 | module LaunchDarkly.Server.Client.Status 2 | ( Status (..) 3 | , transitionStatus 4 | ) 5 | where 6 | 7 | -- | The status of the client initialization. 8 | data Status 9 | = -- | The client has not yet finished connecting to LaunchDarkly. 10 | Uninitialized 11 | | -- | The client attempted to connect to LaunchDarkly and was denied. 12 | Unauthorized 13 | | -- | The client has successfuly connected to LaunchDarkly. 14 | Initialized 15 | | -- | The client is being terminated 16 | ShuttingDown 17 | deriving (Show, Eq) 18 | 19 | transitionStatus :: Status -> Status -> Status 20 | transitionStatus requestedStatus oldStatus = 21 | case requestedStatus of 22 | -- Only allow setting Initialized if Uninitialized 23 | Initialized -> if oldStatus == Uninitialized then Initialized else oldStatus 24 | -- Only allow setting status if not ShuttingDown 25 | _ -> if oldStatus == ShuttingDown then ShuttingDown else requestedStatus 26 | -------------------------------------------------------------------------------- /src/LaunchDarkly/Server/Config.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE NumericUnderscores #-} 2 | 3 | -- | This module is for configuration of the SDK. 4 | module LaunchDarkly.Server.Config 5 | ( Config 6 | , makeConfig 7 | , configSetKey 8 | , configSetBaseURI 9 | , configSetStreamURI 10 | , configSetEventsURI 11 | , configSetStreaming 12 | , configSetInitialRetryDelay 13 | , configSetAllAttributesPrivate 14 | , configSetPrivateAttributeNames 15 | , configSetFlushIntervalSeconds 16 | , configSetPollIntervalSeconds 17 | , configSetContextKeyLRUCapacity 18 | , configSetUserKeyLRUCapacity 19 | , configSetEventsCapacity 20 | , configSetCompressEvents 21 | , configSetLogger 22 | , configSetManager 23 | , configSetSendEvents 24 | , configSetOffline 25 | , configSetRequestTimeoutSeconds 26 | , configSetStoreBackend 27 | , configSetStoreTTL 28 | , configSetUseLdd 29 | , configSetDataSourceFactory 30 | , configSetApplicationInfo 31 | , configSetOmitAnonymousContexts 32 | , ApplicationInfo 33 | , makeApplicationInfo 34 | , withApplicationValue 35 | ) where 36 | 37 | import Control.Monad.Logger (LoggingT, runStdoutLoggingT) 38 | import Data.Generics.Product (setField) 39 | import Data.Set (Set) 40 | import Data.Text (Text, dropWhileEnd) 41 | import GHC.Natural (Natural) 42 | import Network.HTTP.Client (Manager) 43 | 44 | import LaunchDarkly.Server.Config.Internal (ApplicationInfo, Config (..), makeApplicationInfo, withApplicationValue) 45 | import LaunchDarkly.Server.DataSource.Internal (DataSourceFactory) 46 | import LaunchDarkly.Server.Reference (Reference) 47 | import LaunchDarkly.Server.Store (PersistentDataStore) 48 | 49 | -- | Create a default configuration from a given SDK key. 50 | makeConfig :: Text -> Config 51 | makeConfig key = 52 | Config 53 | { key = key 54 | , baseURI = "https://sdk.launchdarkly.com" 55 | , streamURI = "https://stream.launchdarkly.com" 56 | , eventsURI = "https://events.launchdarkly.com" 57 | , compressEvents = False 58 | , storeBackend = Nothing 59 | , storeTTLSeconds = 10 60 | , streaming = True 61 | , initialRetryDelay = 1_000 62 | , allAttributesPrivate = False 63 | , privateAttributeNames = mempty 64 | , flushIntervalSeconds = 5 65 | , pollIntervalSeconds = 30 66 | , contextKeyLRUCapacity = 1_000 67 | , eventsCapacity = 10_000 68 | , logger = runStdoutLoggingT 69 | , sendEvents = True 70 | , offline = False 71 | , requestTimeoutSeconds = 30 72 | , useLdd = False 73 | , dataSourceFactory = Nothing 74 | , manager = Nothing 75 | , applicationInfo = Nothing 76 | , omitAnonymousContexts = False 77 | } 78 | 79 | -- | Set the SDK key used to authenticate with LaunchDarkly. 80 | configSetKey :: Text -> Config -> Config 81 | configSetKey = setField @"key" 82 | 83 | -- | 84 | -- The base URI of the main LaunchDarkly service. This should not normally be 85 | -- changed except for testing. 86 | configSetBaseURI :: Text -> Config -> Config 87 | configSetBaseURI = setField @"baseURI" . dropWhileEnd ((==) '/') 88 | 89 | -- | 90 | -- The base URI of the LaunchDarkly streaming service. This should not 91 | -- normally be changed except for testing. 92 | configSetStreamURI :: Text -> Config -> Config 93 | configSetStreamURI = setField @"streamURI" . dropWhileEnd ((==) '/') 94 | 95 | -- | 96 | -- The base URI of the LaunchDarkly service that accepts analytics events. 97 | -- This should not normally be changed except for testing. 98 | configSetEventsURI :: Text -> Config -> Config 99 | configSetEventsURI = setField @"eventsURI" . dropWhileEnd ((==) '/') 100 | 101 | -- | Configures a handle to an external store such as Redis. 102 | configSetStoreBackend :: Maybe PersistentDataStore -> Config -> Config 103 | configSetStoreBackend = setField @"storeBackend" 104 | 105 | -- | 106 | -- When a store backend is configured, control how long values should be 107 | -- cached in memory before going back to the backend. 108 | configSetStoreTTL :: Natural -> Config -> Config 109 | configSetStoreTTL = setField @"storeTTLSeconds" 110 | 111 | -- | 112 | -- Sets whether streaming mode should be enabled. By default, streaming is 113 | -- enabled. It should only be disabled on the advice of LaunchDarkly support. 114 | configSetStreaming :: Bool -> Config -> Config 115 | configSetStreaming = setField @"streaming" 116 | 117 | -- | 118 | -- The initial delay in milliseconds before reconnecting after an error in the 119 | -- SSE client. Defaults to 1 second. 120 | -- 121 | -- This only applies to the streaming connection. Providing a non-positive 122 | -- integer is a no-op. 123 | configSetInitialRetryDelay :: Int -> Config -> Config 124 | configSetInitialRetryDelay seconds config 125 | | seconds <= 0 = config 126 | | otherwise = setField @"initialRetryDelay" seconds config 127 | 128 | -- | 129 | -- Sets whether or not all context attributes (other than the key) should be 130 | -- hidden from LaunchDarkly. If this is true, all context attribute values will 131 | -- be private, not just the attributes specified in PrivateAttributeNames. 132 | configSetAllAttributesPrivate :: Bool -> Config -> Config 133 | configSetAllAttributesPrivate = setField @"allAttributesPrivate" 134 | 135 | -- | 136 | -- Marks a set of context attribute names private. Any contexts sent to 137 | -- LaunchDarkly with this configuration active will have attributes with these 138 | -- names removed. 139 | configSetPrivateAttributeNames :: Set Reference -> Config -> Config 140 | configSetPrivateAttributeNames = setField @"privateAttributeNames" 141 | 142 | -- | 143 | -- The time between flushes of the event buffer. Decreasing the flush 144 | -- interval means that the event buffer is less likely to reach capacity. 145 | configSetFlushIntervalSeconds :: Natural -> Config -> Config 146 | configSetFlushIntervalSeconds = setField @"flushIntervalSeconds" 147 | 148 | -- | The polling interval (when streaming is disabled). 149 | configSetPollIntervalSeconds :: Natural -> Config -> Config 150 | configSetPollIntervalSeconds = setField @"pollIntervalSeconds" 151 | 152 | -- | 153 | -- The number of context keys that the event processor can remember at any 154 | -- one time, so that duplicate context details will not be sent in analytics 155 | -- events. 156 | configSetContextKeyLRUCapacity :: Natural -> Config -> Config 157 | configSetContextKeyLRUCapacity = setField @"contextKeyLRUCapacity" 158 | 159 | {-# DEPRECATED configSetUserKeyLRUCapacity "Use configSetContextKeyLRUCapacity instead" #-} 160 | 161 | -- | 162 | -- Deprecated historically named function which proxies to 163 | -- 'configSetContextKeyLRUCapacity'. 164 | configSetUserKeyLRUCapacity :: Natural -> Config -> Config 165 | configSetUserKeyLRUCapacity = configSetContextKeyLRUCapacity 166 | 167 | -- | 168 | -- The capacity of the events buffer. The client buffers up to this many 169 | -- events in memory before flushing. If the capacity is exceeded before the 170 | -- buffer is flushed, events will be discarded. 171 | configSetEventsCapacity :: Natural -> Config -> Config 172 | configSetEventsCapacity = setField @"eventsCapacity" 173 | 174 | -- | 175 | -- Should the event payload sent to LaunchDarkly use gzip compression. By 176 | -- default this is false to prevent backward breaking compatibility issues with 177 | -- older versions of the relay proxy. 178 | -- 179 | -- Customers not using the relay proxy are strongly encouraged to enable this 180 | -- feature to reduce egress bandwidth cost. 181 | configSetCompressEvents :: Bool -> Config -> Config 182 | configSetCompressEvents = setField @"compressEvents" 183 | 184 | -- | Set the logger to be used by the client. 185 | configSetLogger :: (LoggingT IO () -> IO ()) -> Config -> Config 186 | configSetLogger = setField @"logger" 187 | 188 | -- | 189 | -- Sets whether to send analytics events back to LaunchDarkly. By default, 190 | -- the client will send events. This differs from Offline in that it only 191 | -- affects sending events, not streaming or polling for events from the server. 192 | configSetSendEvents :: Bool -> Config -> Config 193 | configSetSendEvents = setField @"sendEvents" 194 | 195 | -- | 196 | -- Sets whether this client is offline. An offline client will not make any 197 | -- network connections to LaunchDarkly, and will return default values for all 198 | -- feature flags. 199 | configSetOffline :: Bool -> Config -> Config 200 | configSetOffline = setField @"offline" 201 | 202 | -- | 203 | -- Sets how long an the HTTP client should wait before a response is 204 | -- returned. 205 | configSetRequestTimeoutSeconds :: Natural -> Config -> Config 206 | configSetRequestTimeoutSeconds = setField @"requestTimeoutSeconds" 207 | 208 | -- | 209 | -- Sets whether this client should use the LaunchDarkly Relay Proxy in daemon 210 | -- mode. In this mode, the client does not subscribe to the streaming or 211 | -- polling API, but reads data only from the feature store. See: 212 | -- https://docs.launchdarkly.com/home/relay-proxy 213 | configSetUseLdd :: Bool -> Config -> Config 214 | configSetUseLdd = setField @"useLdd" 215 | 216 | -- | 217 | -- Sets a data source to use instead of the default network based data source 218 | -- see "LaunchDarkly.Server.Integrations.FileData" 219 | configSetDataSourceFactory :: Maybe DataSourceFactory -> Config -> Config 220 | configSetDataSourceFactory = setField @"dataSourceFactory" 221 | 222 | -- | 223 | -- Sets the 'Manager' to use with the client. If not set explicitly a new 224 | -- 'Manager' will be created when creating the client. 225 | configSetManager :: Manager -> Config -> Config 226 | configSetManager = setField @"manager" . Just 227 | 228 | -- | 229 | -- An object that allows configuration of application metadata. 230 | -- 231 | -- Application metadata may be used in LaunchDarkly analytics or other product 232 | -- features, but does not affect feature flag evaluations. 233 | -- 234 | -- If you want to set non-default values for any of these fields, provide the 235 | -- appropriately configured dict to the 'Config' object. 236 | configSetApplicationInfo :: ApplicationInfo -> Config -> Config 237 | configSetApplicationInfo = setField @"applicationInfo" . Just 238 | 239 | -- | 240 | -- Sets whether anonymous contexts should be omitted from index and identify events. 241 | -- 242 | -- By default, anonymous contexts are included in index and identify events. 243 | configSetOmitAnonymousContexts :: Bool -> Config -> Config 244 | configSetOmitAnonymousContexts = setField @"omitAnonymousContexts" 245 | -------------------------------------------------------------------------------- /src/LaunchDarkly/Server/Config/ClientContext.hs: -------------------------------------------------------------------------------- 1 | module LaunchDarkly.Server.Config.ClientContext (ClientContext (..)) 2 | where 3 | 4 | import Control.Monad.Logger (LoggingT) 5 | 6 | import LaunchDarkly.Server.Config.HttpConfiguration (HttpConfiguration) 7 | 8 | data ClientContext = ClientContext 9 | { runLogger :: !(LoggingT IO () -> IO ()) 10 | , httpConfiguration :: !HttpConfiguration 11 | } 12 | -------------------------------------------------------------------------------- /src/LaunchDarkly/Server/Config/HttpConfiguration.hs: -------------------------------------------------------------------------------- 1 | module LaunchDarkly.Server.Config.HttpConfiguration 2 | ( HttpConfiguration (..) 3 | , prepareRequest 4 | ) 5 | where 6 | 7 | import Control.Monad.Catch (MonadThrow) 8 | import Network.HTTP.Client (Manager, Request, ResponseTimeout, parseRequest, requestHeaders, responseTimeout, setRequestIgnoreStatus) 9 | import Network.HTTP.Types (Header) 10 | 11 | data HttpConfiguration = HttpConfiguration 12 | { defaultRequestHeaders :: ![Header] 13 | , defaultRequestTimeout :: !ResponseTimeout 14 | , tlsManager :: !Manager 15 | } 16 | 17 | prepareRequest :: (MonadThrow m) => HttpConfiguration -> String -> m Request 18 | prepareRequest config uri = do 19 | baseReq <- parseRequest uri 20 | pure $ 21 | setRequestIgnoreStatus $ 22 | baseReq 23 | { requestHeaders = defaultRequestHeaders config <> requestHeaders baseReq 24 | , responseTimeout = defaultRequestTimeout config 25 | } 26 | -------------------------------------------------------------------------------- /src/LaunchDarkly/Server/Config/Internal.hs: -------------------------------------------------------------------------------- 1 | module LaunchDarkly.Server.Config.Internal 2 | ( Config (..) 3 | , shouldSendEvents 4 | , ApplicationInfo 5 | , makeApplicationInfo 6 | , withApplicationValue 7 | , getApplicationInfoHeader 8 | ) where 9 | 10 | import Control.Monad.Logger (LoggingT) 11 | import Data.Generics.Product (getField) 12 | import Data.Set (Set) 13 | import Data.Text (Text) 14 | import qualified Data.Text as T 15 | import GHC.Generics (Generic) 16 | import GHC.Natural (Natural) 17 | import Network.HTTP.Client (Manager) 18 | 19 | import Control.Lens ((&)) 20 | import Data.List (sortBy) 21 | import Data.Ord (comparing) 22 | import LaunchDarkly.AesonCompat (KeyMap, emptyObject, insertKey, toList) 23 | import qualified LaunchDarkly.AesonCompat as AesonCompat 24 | import LaunchDarkly.Server.DataSource.Internal (DataSourceFactory) 25 | import LaunchDarkly.Server.Reference (Reference) 26 | import LaunchDarkly.Server.Store (PersistentDataStore) 27 | 28 | -- | Config allows advanced configuration of the LaunchDarkly client. 29 | data Config = Config 30 | { key :: !Text 31 | , baseURI :: !Text 32 | , streamURI :: !Text 33 | , eventsURI :: !Text 34 | , storeBackend :: !(Maybe PersistentDataStore) 35 | , storeTTLSeconds :: !Natural 36 | , streaming :: !Bool 37 | , initialRetryDelay :: !Int 38 | , allAttributesPrivate :: !Bool 39 | , privateAttributeNames :: !(Set Reference) 40 | , flushIntervalSeconds :: !Natural 41 | , pollIntervalSeconds :: !Natural 42 | , contextKeyLRUCapacity :: !Natural 43 | , eventsCapacity :: !Natural 44 | , compressEvents :: !Bool 45 | , logger :: !(LoggingT IO () -> IO ()) 46 | , sendEvents :: !Bool 47 | , offline :: !Bool 48 | , requestTimeoutSeconds :: !Natural 49 | , useLdd :: !Bool 50 | , dataSourceFactory :: !(Maybe DataSourceFactory) 51 | , manager :: !(Maybe Manager) 52 | , applicationInfo :: !(Maybe ApplicationInfo) 53 | , omitAnonymousContexts :: !Bool 54 | } 55 | deriving (Generic) 56 | 57 | shouldSendEvents :: Config -> Bool 58 | shouldSendEvents config = (not $ getField @"offline" config) && (getField @"sendEvents" config) 59 | 60 | -- | 61 | -- An object that allows configuration of application metadata. 62 | -- 63 | -- Application metadata may be used in LaunchDarkly analytics or other product 64 | -- features, but does not affect feature flag evaluations. 65 | -- 66 | -- To use these properties, provide an instance of ApplicationInfo to the 'Config' with 'configSetApplicationInfo'. 67 | newtype ApplicationInfo = ApplicationInfo (KeyMap Text) deriving (Show, Eq) 68 | 69 | -- | Create a default instance 70 | makeApplicationInfo :: ApplicationInfo 71 | makeApplicationInfo = ApplicationInfo emptyObject 72 | 73 | -- | 74 | -- Set a new name / value pair into the application info instance. 75 | -- 76 | -- Values have the following restrictions: 77 | -- - Cannot be empty 78 | -- - Cannot exceed 64 characters in length 79 | -- - Can only contain a-z, A-Z, 0-9, period (.), dash (-), and underscore (_). 80 | -- 81 | -- Invalid values or unsupported keys will be ignored. 82 | withApplicationValue :: Text -> Text -> ApplicationInfo -> ApplicationInfo 83 | withApplicationValue _ "" info = info 84 | withApplicationValue name value info@(ApplicationInfo map) 85 | | (name `elem` ["id", "version"]) == False = info 86 | | T.length (value) > 64 = info 87 | | (all (`elem` ['a' .. 'z'] ++ ['A' .. 'Z'] ++ ['0' .. '9'] ++ ['.', '-', '_']) (T.unpack value)) == False = info 88 | | otherwise = ApplicationInfo $ insertKey name value map 89 | 90 | getApplicationInfoHeader :: ApplicationInfo -> Maybe Text 91 | getApplicationInfoHeader (ApplicationInfo values) 92 | | AesonCompat.null values = Nothing 93 | | otherwise = 94 | toList values 95 | & sortBy (comparing fst) 96 | & map makeTag 97 | & T.unwords 98 | & Just 99 | where 100 | makeTag (key, value) = "application-" <> key <> "/" <> value 101 | -------------------------------------------------------------------------------- /src/LaunchDarkly/Server/Context.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE BlockArguments #-} 2 | {-# LANGUAGE NamedFieldPuns #-} 3 | {-# LANGUAGE ViewPatterns #-} 4 | 5 | -- | 6 | -- Context is a collection of attributes that can be referenced in flag 7 | -- evaluations and analytics events. 8 | -- 9 | -- To create a Context of a single kind, such as a user, you may use 10 | -- 'makeContext'. 11 | -- 12 | -- To create an LDContext with multiple kinds, use 'makeMultiContext'. 13 | -- 14 | -- Additional properties can be set on a single-kind context using the set 15 | -- methods found in this module. 16 | -- 17 | -- Each method will always return a Context. However, that Context may be 18 | -- invalid. You can check the validity of the resulting context, and the 19 | -- associated errors by calling 'isValid' and 'getError'. 20 | module LaunchDarkly.Server.Context 21 | ( Context 22 | , makeContext 23 | , makeMultiContext 24 | , withName 25 | , withAnonymous 26 | , withAttribute 27 | , withPrivateAttributes 28 | , isValid 29 | , getError 30 | , getIndividualContext 31 | , getValueForReference 32 | , getValue 33 | ) 34 | where 35 | 36 | import Data.Aeson (Value (..)) 37 | import Data.Maybe (fromMaybe) 38 | import Data.Text (Text) 39 | import LaunchDarkly.AesonCompat (lookupKey) 40 | import LaunchDarkly.Server.Context.Internal (Context (..), MultiContext (..), SingleContext (..), makeContext, makeMultiContext, withAnonymous, withAttribute, withName, withPrivateAttributes) 41 | import LaunchDarkly.Server.Reference (Reference) 42 | import qualified LaunchDarkly.Server.Reference as R 43 | 44 | -- | Determines if the provided context is valid. 45 | isValid :: Context -> Bool 46 | isValid (Invalid _) = False 47 | isValid _ = True 48 | 49 | -- | Returns the error associated with the context if it is invalid. 50 | getError :: Context -> Text 51 | getError (Invalid e) = e 52 | getError _ = "" 53 | 54 | -- | 55 | -- Returns the single-kind Context corresponding to one of the kinds in this 56 | -- context. 57 | -- 58 | -- If this method is called on a single-kind Context and the requested kind 59 | -- matches the context's kind, then that context is returned. 60 | -- 61 | -- If the method is called on a multi-context, the provided kind must match the 62 | -- context kind of one of the individual contexts. 63 | -- 64 | -- If there is no context corresponding to `kind`, the method returns Nothing. 65 | getIndividualContext :: Text -> Context -> Maybe Context 66 | getIndividualContext kind (Multi (MultiContext {contexts})) = Single <$> lookupKey kind contexts 67 | getIndividualContext kind c@(Single (SingleContext {kind = k})) 68 | | kind == k = Just c 69 | | otherwise = Nothing 70 | getIndividualContext _ _ = Nothing 71 | 72 | -- | 73 | -- Looks up the value of any attribute of the Context by name. This includes 74 | -- only attributes that are addressable in evaluations-- not metadata such as 75 | -- private attributes. 76 | -- 77 | -- For a single-kind context, the attribute name can be any custom attribute. 78 | -- It can also be one of the built-in ones like "kind", "key", or "name". 79 | -- 80 | -- For a multi-kind context, the only supported attribute name is "kind". Use 81 | -- 'getIndividualContext' to inspect a Context for a particular kind and then 82 | -- get its attributes. 83 | -- 84 | -- This method does not support complex expressions for getting individual 85 | -- values out of JSON objects or arrays, such as "/address/street". Use 86 | -- 'getValueForReference' for that purpose. 87 | -- 88 | -- If the value is found, the return value is the attribute value; otherwise, 89 | -- it is Null. 90 | getValue :: Text -> Context -> Value 91 | getValue ref = getValueForReference (R.makeLiteral ref) 92 | 93 | -- | 94 | -- Looks up the value of any attribute of the Context, or a value contained 95 | -- within an attribute, based on a 'Reference' instance. This includes only 96 | -- attributes that are addressable in evaluations-- not metadata such as 97 | -- private attributes. 98 | -- 99 | -- This implements the same behavior that the SDK uses to resolve attribute 100 | -- references during a flag evaluation. In a single-kind context, the 101 | -- 'Reference' can represent a simple attribute name-- either a built-in one 102 | -- like "name" or "key", or a custom attribute -- or, it can be a 103 | -- slash-delimited path using a JSON-Pointer-like syntax. See 'Reference' for 104 | -- more details. 105 | -- 106 | -- For a multi-kind context, the only supported attribute name is "kind". Use 107 | -- 'getIndividualContext' to inspect a Context for a particular kind and then 108 | -- get its attributes. 109 | -- 110 | -- If the value is found, the return value is the attribute value; otherwise, 111 | -- it is Null. 112 | getValueForReference :: Reference -> Context -> Value 113 | getValueForReference (R.isValid -> False) _ = Null 114 | getValueForReference reference context = case R.getComponents reference of 115 | [] -> Null 116 | (component : components) -> 117 | let value = getTopLevelValue component context 118 | in foldl getValueFromJsonObject value components 119 | 120 | -- This helper method retrieves a Value from a JSON object type. 121 | -- 122 | -- If the key does not exist, or the type isn't an object, this method will 123 | -- return Null. 124 | getValueFromJsonObject :: Value -> Text -> Value 125 | getValueFromJsonObject (Object nm) component = fromMaybe Null (lookupKey component nm) 126 | getValueFromJsonObject _ _ = Null 127 | 128 | -- Attribute retrieval can mostly be defined recursively. However, this isn't 129 | -- true for the top level attribute since the entire context isn't stored in a 130 | -- single object property. 131 | -- 132 | -- To prime the recursion, we define this simple helper function to retrieve 133 | -- attributes addressable at the top level. 134 | getTopLevelValue :: Text -> Context -> Value 135 | getTopLevelValue _ (Invalid _) = Null 136 | getTopLevelValue "kind" (Multi _) = "multi" 137 | getTopLevelValue _ (Multi _) = Null 138 | getTopLevelValue "key" (Single SingleContext {key}) = String key 139 | getTopLevelValue "kind" (Single SingleContext {kind}) = String kind 140 | getTopLevelValue "name" (Single SingleContext {name = Nothing}) = Null 141 | getTopLevelValue "name" (Single SingleContext {name = Just n}) = String n 142 | getTopLevelValue "anonymous" (Single SingleContext {anonymous}) = Bool anonymous 143 | getTopLevelValue _ (Single SingleContext {attributes = Nothing}) = Null 144 | getTopLevelValue key (Single SingleContext {attributes = Just attrs}) = fromMaybe Null $ lookupKey key attrs 145 | -------------------------------------------------------------------------------- /src/LaunchDarkly/Server/DataSource/Internal.hs: -------------------------------------------------------------------------------- 1 | module LaunchDarkly.Server.DataSource.Internal 2 | ( DataSourceFactory 3 | , nullDataSourceFactory 4 | , DataSource (..) 5 | , DataSourceUpdates (..) 6 | , defaultDataSourceUpdates 7 | ) 8 | where 9 | 10 | import Data.IORef (IORef, atomicModifyIORef') 11 | import Data.Text (Text) 12 | import GHC.Natural (Natural) 13 | 14 | import LaunchDarkly.AesonCompat (KeyMap) 15 | import LaunchDarkly.Server.Client.Status (Status, transitionStatus) 16 | import LaunchDarkly.Server.Config.ClientContext (ClientContext) 17 | import LaunchDarkly.Server.Features (Flag, Segment) 18 | import LaunchDarkly.Server.Store.Internal (StoreHandle, deleteFlag, deleteSegment, initializeStore, insertFlag, insertSegment) 19 | 20 | type DataSourceFactory = ClientContext -> DataSourceUpdates -> IO DataSource 21 | 22 | nullDataSourceFactory :: DataSourceFactory 23 | nullDataSourceFactory _ _ = 24 | pure $ DataSource (pure False) (pure ()) (pure ()) 25 | 26 | data DataSource = DataSource 27 | { dataSourceIsInitialized :: IO Bool 28 | , dataSourceStart :: IO () 29 | , dataSourceStop :: IO () 30 | } 31 | 32 | data DataSourceUpdates = DataSourceUpdates 33 | { dataSourceUpdatesInit :: !(KeyMap Flag -> KeyMap Segment -> IO (Either Text ())) 34 | , dataSourceUpdatesInsertFlag :: !(Flag -> IO (Either Text ())) 35 | , dataSourceUpdatesInsertSegment :: !(Segment -> IO (Either Text ())) 36 | , dataSourceUpdatesDeleteFlag :: !(Text -> Natural -> IO (Either Text ())) 37 | , dataSourceUpdatesDeleteSegment :: !(Text -> Natural -> IO (Either Text ())) 38 | , dataSourceUpdatesSetStatus :: Status -> IO () 39 | } 40 | 41 | defaultDataSourceUpdates :: IORef Status -> StoreHandle IO -> DataSourceUpdates 42 | defaultDataSourceUpdates status store = 43 | let modifyStatus status' = atomicModifyIORef' status (fmap (,()) (transitionStatus status')) 44 | in DataSourceUpdates 45 | { dataSourceUpdatesInit = initializeStore store 46 | , dataSourceUpdatesInsertFlag = insertFlag store 47 | , dataSourceUpdatesInsertSegment = insertSegment store 48 | , dataSourceUpdatesDeleteFlag = deleteFlag store 49 | , dataSourceUpdatesDeleteSegment = deleteSegment store 50 | , dataSourceUpdatesSetStatus = modifyStatus 51 | } 52 | -------------------------------------------------------------------------------- /src/LaunchDarkly/Server/Details.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedLists #-} 2 | 3 | module LaunchDarkly.Server.Details where 4 | 5 | import Data.Aeson.Types (ToJSON, Value (..), toJSON) 6 | import Data.Text (Text) 7 | import GHC.Exts (fromList) 8 | import GHC.Generics (Generic) 9 | import GHC.Natural (Natural) 10 | 11 | -- | 12 | -- Combines the result of a flag evaluation with an explanation of how it was 13 | -- calculated. 14 | data EvaluationDetail value = EvaluationDetail 15 | { value :: !value 16 | -- ^ The result of the flag evaluation. This will be either one of the 17 | -- flag's variations or the default value passed by the application. 18 | , variationIndex :: !(Maybe Integer) 19 | -- ^ The index of the returned value within the flag's list of variations, 20 | -- e.g. 0 for the first variation - or Nothing if the default value was 21 | -- returned. 22 | , reason :: !EvaluationReason 23 | -- ^ Describes the main factor that influenced the flag evaluation value. 24 | } 25 | deriving (Generic, Eq, Show) 26 | 27 | instance ToJSON a => ToJSON (EvaluationDetail a) where 28 | toJSON = toJSON 29 | 30 | -- | Defines the possible values of the Kind property of EvaluationReason. 31 | data EvaluationReason 32 | = -- | Indicates that the flag was off and therefore returned its configured 33 | -- off value. 34 | EvaluationReasonOff 35 | | -- | indicates that the context key was specifically targeted for this flag. 36 | EvaluationReasonTargetMatch 37 | | EvaluationReasonRuleMatch 38 | { ruleIndex :: !Natural 39 | -- ^ The index of the rule that was matched (0 being the first). 40 | , ruleId :: !Text 41 | -- ^ The unique identifier of the rule that was matched. 42 | , inExperiment :: !Bool 43 | -- ^ Whether the evaluation was part of an experiment. Is true if 44 | -- the evaluation resulted in an experiment rollout *and* served 45 | -- one of the variations in the experiment. Otherwise false. 46 | } 47 | | -- \^ Indicates that the context matched one of the flag's rules. 48 | EvaluationReasonPrerequisiteFailed 49 | { prerequisiteKey :: !Text 50 | -- ^ The flag key of the prerequisite that failed. 51 | } 52 | | -- \^ Indicates that the flag was considered off because it had at least 53 | -- one prerequisite flag that either was off or did not return the desired 54 | -- variation. 55 | EvaluationReasonFallthrough 56 | { inExperiment :: !Bool 57 | -- ^ Whether the evaluation was part of an experiment. Is 58 | -- true if the evaluation resulted in an experiment rollout *and* 59 | -- served one of the variations in the experiment. Otherwise false. 60 | } 61 | | -- \^ Indicates that the flag was on but the context did not match any targets 62 | -- or rules. 63 | EvaluationReasonError 64 | { errorKind :: !EvalErrorKind 65 | -- ^ Describes the type of error. 66 | } 67 | -- \^ Indicates that the flag could not be evaluated, e.g. because it does 68 | -- not exist or due to an unexpected error. In this case the result value 69 | -- will be the default value that the caller passed to the client. 70 | deriving (Generic, Eq, Show) 71 | 72 | instance ToJSON EvaluationReason where 73 | toJSON x = case x of 74 | EvaluationReasonOff -> 75 | Object $ fromList [("kind", "OFF")] 76 | EvaluationReasonTargetMatch -> 77 | Object $ fromList [("kind", "TARGET_MATCH")] 78 | (EvaluationReasonRuleMatch ruleIndex ruleId True) -> 79 | Object $ fromList [("kind", "RULE_MATCH"), ("ruleIndex", toJSON ruleIndex), ("ruleId", toJSON ruleId), ("inExperiment", toJSON True)] 80 | (EvaluationReasonRuleMatch ruleIndex ruleId False) -> 81 | Object $ fromList [("kind", "RULE_MATCH"), ("ruleIndex", toJSON ruleIndex), ("ruleId", toJSON ruleId)] 82 | (EvaluationReasonPrerequisiteFailed prerequisiteKey) -> 83 | Object $ fromList [("kind", "PREREQUISITE_FAILED"), ("prerequisiteKey", toJSON prerequisiteKey)] 84 | EvaluationReasonFallthrough True -> 85 | Object $ fromList [("kind", "FALLTHROUGH"), ("inExperiment", toJSON True)] 86 | EvaluationReasonFallthrough False -> 87 | Object $ fromList [("kind", "FALLTHROUGH")] 88 | (EvaluationReasonError errorKind) -> 89 | Object $ fromList [("kind", "ERROR"), ("errorKind", toJSON errorKind)] 90 | 91 | isInExperiment :: EvaluationReason -> Bool 92 | isInExperiment reason = case reason of 93 | EvaluationReasonRuleMatch _ _ inExperiment -> inExperiment 94 | EvaluationReasonFallthrough inExperiment -> inExperiment 95 | _ -> False 96 | 97 | -- | Defines the possible values of the errorKind property of EvaluationReason. 98 | data EvalErrorKind 99 | = -- | Indicates that there was an internal inconsistency in the flag data, 100 | -- e.g. a rule specified a nonexistent variation. 101 | EvalErrorKindMalformedFlag 102 | | -- | Indicates that the caller provided a flag key that did not match any 103 | -- known flag. 104 | EvalErrorFlagNotFound 105 | | -- | Indicates that the result value was not of the requested type, e.g. 106 | -- you called boolVariationDetail but the value was an integer. 107 | EvalErrorWrongType 108 | | -- | Indicates that the caller tried to evaluate a flag before the client 109 | -- had successfully initialized. 110 | EvalErrorClientNotReady 111 | | -- | Indicates that the caller tried to evaluate a flag with an invalid 112 | -- context 113 | EvalErrorInvalidContext 114 | | -- | Indicates that some error was returned by the external feature store. 115 | EvalErrorExternalStore !Text 116 | deriving (Generic, Eq, Show) 117 | 118 | instance ToJSON EvalErrorKind where 119 | toJSON x = String $ case x of 120 | EvalErrorKindMalformedFlag -> "MALFORMED_FLAG" 121 | EvalErrorFlagNotFound -> "FLAG_NOT_FOUND" 122 | EvalErrorWrongType -> "WRONG_TYPE" 123 | EvalErrorClientNotReady -> "CLIENT_NOT_READY" 124 | EvalErrorExternalStore _ -> "EXTERNAL_STORE_ERROR" 125 | EvalErrorInvalidContext -> "ERROR_INVALID_CONTEXT" 126 | -------------------------------------------------------------------------------- /src/LaunchDarkly/Server/Features.hs: -------------------------------------------------------------------------------- 1 | module LaunchDarkly.Server.Features where 2 | 3 | import Control.Lens (element, (^?)) 4 | import Control.Monad (mzero) 5 | import Data.Aeson (FromJSON (..), ToJSON (..), Value (..), object, withObject, (.!=), (.:), (.:?), (.=)) 6 | import Data.Generics.Product (getField) 7 | import Data.HashSet (HashSet) 8 | import Data.Maybe (fromMaybe) 9 | import Data.Text (Text) 10 | import GHC.Generics (Generic) 11 | import GHC.Natural (Natural) 12 | 13 | import LaunchDarkly.Server.Details (EvaluationReason (..)) 14 | import qualified LaunchDarkly.Server.Details as D 15 | import LaunchDarkly.Server.Operators (Op) 16 | import LaunchDarkly.Server.Reference (Reference, makeLiteral, makeReference) 17 | 18 | data Target = Target 19 | { values :: !(HashSet Text) 20 | , variation :: !Integer 21 | , contextKind :: Text 22 | } 23 | deriving (Generic, ToJSON, Show, Eq) 24 | 25 | instance FromJSON Target where 26 | parseJSON = withObject "Target" $ \t -> 27 | Target 28 | <$> t .: "values" 29 | <*> t .: "variation" 30 | <*> t .:? "contextKind" .!= "user" 31 | 32 | data Rule = Rule 33 | { id :: !Text 34 | , clauses :: ![Clause] 35 | , variationOrRollout :: !VariationOrRollout 36 | , trackEvents :: !Bool 37 | } 38 | deriving (Generic, Show, Eq) 39 | 40 | instance FromJSON Rule where 41 | parseJSON = withObject "Rule" $ \o -> do 42 | id <- o .:? "id" 43 | clauses <- o .: "clauses" 44 | variation <- o .:? "variation" 45 | rollout <- o .:? "rollout" 46 | trackEvents <- o .: "trackEvents" 47 | pure 48 | Rule 49 | { id = fromMaybe "" id 50 | , clauses = clauses 51 | , variationOrRollout = 52 | VariationOrRollout 53 | { variation = variation 54 | , rollout = rollout 55 | } 56 | , trackEvents = trackEvents 57 | } 58 | 59 | instance ToJSON Rule where 60 | toJSON rule = 61 | object 62 | [ "id" .= getField @"id" rule 63 | , "clauses" .= getField @"clauses" rule 64 | , "trackEvents" .= getField @"trackEvents" rule 65 | , "variation" .= getField @"variation" (getField @"variationOrRollout" rule) 66 | , "rollout" .= getField @"rollout" (getField @"variationOrRollout" rule) 67 | ] 68 | 69 | data WeightedVariation = WeightedVariation 70 | { variation :: !Integer 71 | , weight :: !Float 72 | , untracked :: !Bool 73 | } 74 | deriving (Generic, ToJSON, Show, Eq) 75 | 76 | instance FromJSON WeightedVariation where 77 | parseJSON = withObject "WeightedVariation" $ \o -> do 78 | variation <- o .: "variation" 79 | weight <- o .: "weight" 80 | untracked <- o .:? "untracked" .!= False 81 | pure WeightedVariation {..} 82 | 83 | data RolloutKind = RolloutKindExperiment | RolloutKindRollout 84 | deriving (Eq, Show) 85 | 86 | instance ToJSON RolloutKind where 87 | toJSON x = String $ case x of 88 | RolloutKindExperiment -> "experiment" 89 | RolloutKindRollout -> "rollout" 90 | 91 | instance FromJSON RolloutKind where 92 | parseJSON x = case x of 93 | (String "experiment") -> pure RolloutKindExperiment 94 | (String "rollout") -> pure RolloutKindRollout 95 | _ -> mzero 96 | 97 | data Rollout = Rollout 98 | { variations :: ![WeightedVariation] 99 | , bucketBy :: !(Maybe Text) 100 | , kind :: !RolloutKind 101 | , contextKind :: !(Maybe Text) 102 | , seed :: !(Maybe Int) 103 | } 104 | deriving (Generic, ToJSON, Show, Eq) 105 | 106 | instance FromJSON Rollout where 107 | parseJSON = withObject "rollout" $ \o -> do 108 | variations <- o .: "variations" 109 | bucketBy <- o .:? "bucketBy" 110 | kind <- o .:? "kind" .!= RolloutKindRollout 111 | contextKind <- o .:? "contextKind" 112 | seed <- o .:? "seed" 113 | pure Rollout {..} 114 | 115 | data VariationOrRollout = VariationOrRollout 116 | { variation :: !(Maybe Integer) 117 | , rollout :: !(Maybe Rollout) 118 | } 119 | deriving (Generic, FromJSON, ToJSON, Show, Eq) 120 | 121 | data ClientSideAvailability = ClientSideAvailability 122 | { usingEnvironmentId :: !Bool 123 | , usingMobileKey :: !Bool 124 | , explicit :: !Bool 125 | } 126 | deriving (Generic, Show, Eq) 127 | 128 | instance FromJSON ClientSideAvailability where 129 | parseJSON = withObject "ClientSideAvailability" $ \obj -> 130 | ClientSideAvailability 131 | <$> obj .: "usingEnvironmentId" 132 | <*> obj .: "usingMobileKey" 133 | <*> pure True 134 | 135 | instance ToJSON ClientSideAvailability where 136 | toJSON (ClientSideAvailability env mob _) = 137 | object ["usingEnvironmentId" .= env, "usingMobileKey" .= mob] 138 | 139 | data Flag = Flag 140 | { key :: !Text 141 | , version :: !Natural 142 | , on :: !Bool 143 | , trackEvents :: !Bool 144 | , trackEventsFallthrough :: !Bool 145 | , deleted :: !Bool 146 | , prerequisites :: ![Prerequisite] 147 | , salt :: !Text 148 | , targets :: ![Target] 149 | , contextTargets :: ![Target] 150 | , rules :: ![Rule] 151 | , fallthrough :: !VariationOrRollout 152 | , offVariation :: !(Maybe Integer) 153 | , variations :: ![Value] 154 | , debugEventsUntilDate :: !(Maybe Natural) 155 | , clientSideAvailability :: !ClientSideAvailability 156 | } 157 | deriving (Generic, Show, Eq) 158 | 159 | instance ToJSON Flag where 160 | toJSON flag = 161 | object $ 162 | [ "key" .= getField @"key" flag 163 | , "version" .= getField @"version" flag 164 | , "on" .= getField @"on" flag 165 | , "trackEvents" .= getField @"trackEvents" flag 166 | , "trackEventsFallthrough" .= getField @"trackEventsFallthrough" flag 167 | , "deleted" .= getField @"deleted" flag 168 | , "prerequisites" .= getField @"prerequisites" flag 169 | , "salt" .= getField @"salt" flag 170 | , "targets" .= getField @"targets" flag 171 | , "contextTargets" .= getField @"contextTargets" flag 172 | , "rules" .= getField @"rules" flag 173 | , "fallthrough" .= getField @"fallthrough" flag 174 | , "offVariation" .= getField @"offVariation" flag 175 | , "variations" .= getField @"variations" flag 176 | , "debugEventsUntilDate" .= getField @"debugEventsUntilDate" flag 177 | , "clientSide" .= (getField @"usingEnvironmentId" $ getField @"clientSideAvailability" flag) 178 | ] 179 | <> case getField @"explicit" $ getField @"clientSideAvailability" flag of 180 | True -> ["clientSideAvailability" .= getField @"clientSideAvailability" flag] 181 | False -> [] 182 | 183 | instance FromJSON Flag where 184 | parseJSON = withObject "Flag" $ \obj -> do 185 | key <- obj .: "key" 186 | version <- obj .: "version" 187 | on <- obj .: "on" 188 | trackEvents <- obj .: "trackEvents" 189 | trackEventsFallthrough <- obj .: "trackEventsFallthrough" 190 | deleted <- obj .: "deleted" 191 | prerequisites <- obj .: "prerequisites" 192 | salt <- obj .: "salt" 193 | targets <- obj .: "targets" 194 | contextTargets <- obj .:? "contextTargets" .!= mempty 195 | rules <- obj .: "rules" 196 | fallthrough <- obj .: "fallthrough" 197 | offVariation <- obj .:? "offVariation" 198 | variations <- obj .: "variations" 199 | debugEventsUntilDate <- obj .:? "debugEventsUntilDate" 200 | clientSide <- obj .:? "clientSide" .!= False 201 | clientSideAvailability <- obj .:? "clientSideAvailability" .!= ClientSideAvailability clientSide True False 202 | pure Flag {..} 203 | 204 | isClientSideOnlyFlag :: Flag -> Bool 205 | isClientSideOnlyFlag flag = getField @"usingEnvironmentId" $ getField @"clientSideAvailability" flag 206 | 207 | -- If the reason for the flag is in an experiment, 208 | -- or if it's a fallthrough reason and the flag has trackEventsFallthrough 209 | -- or if it's a rule match and the rule that matched has track events turned on 210 | -- otherwise false 211 | isInExperiment :: Flag -> EvaluationReason -> Bool 212 | isInExperiment _ reason 213 | | D.isInExperiment reason = True 214 | isInExperiment flag EvaluationReasonFallthrough {} = getField @"trackEventsFallthrough" flag 215 | isInExperiment flag (EvaluationReasonRuleMatch ruleIndex _ _) = 216 | let index = fromIntegral ruleIndex 217 | rules = getField @"rules" flag 218 | rule = rules ^? element index 219 | in fromMaybe False $ fmap (getField @"trackEvents") rule 220 | isInExperiment _ _ = False 221 | 222 | data Prerequisite = Prerequisite 223 | { key :: !Text 224 | , variation :: !Integer 225 | } 226 | deriving (Generic, FromJSON, ToJSON, Show, Eq) 227 | 228 | data SegmentRule = SegmentRule 229 | { id :: !Text 230 | , clauses :: ![Clause] 231 | , weight :: !(Maybe Float) 232 | , bucketBy :: !(Maybe Text) 233 | , rolloutContextKind :: !(Maybe Text) 234 | } 235 | deriving (Generic, ToJSON, Show, Eq) 236 | 237 | instance FromJSON SegmentRule where 238 | parseJSON = withObject "SegmentRule" $ \o -> do 239 | id <- o .: "id" 240 | clauses <- o .: "clauses" 241 | weight <- o .:? "weight" 242 | bucketBy <- o .:? "bucketBy" 243 | rolloutContextKind <- o .:? "rolloutContextKind" 244 | return $ SegmentRule {..} 245 | 246 | data Segment = Segment 247 | { key :: !Text 248 | , included :: !(HashSet Text) 249 | , includedContexts :: ![SegmentTarget] 250 | , excluded :: !(HashSet Text) 251 | , excludedContexts :: ![SegmentTarget] 252 | , salt :: !Text 253 | , rules :: ![SegmentRule] 254 | , version :: !Natural 255 | , deleted :: !Bool 256 | } 257 | deriving (Generic, FromJSON, ToJSON, Show, Eq) 258 | 259 | data SegmentTarget = SegmentTarget 260 | { values :: !(HashSet Text) 261 | , contextKind :: !Text 262 | } 263 | deriving (Generic, FromJSON, ToJSON, Show, Eq) 264 | 265 | data Clause = Clause 266 | { attribute :: !Reference 267 | , contextKind :: !Text 268 | , negate :: !Bool 269 | , op :: !Op 270 | , values :: ![Value] 271 | } 272 | deriving (Generic, ToJSON, Show, Eq) 273 | 274 | instance FromJSON Clause where 275 | parseJSON = withObject "Clause" $ \o -> do 276 | attr <- o .: "attribute" 277 | kind <- o .:? "contextKind" 278 | negate <- o .: "negate" 279 | op <- o .: "op" 280 | values <- o .: "values" 281 | 282 | let contextKind = fromMaybe "user" kind 283 | attribute = case kind of Nothing -> makeLiteral (attr); _ -> makeReference (attr) 284 | return $ Clause {..} 285 | -------------------------------------------------------------------------------- /src/LaunchDarkly/Server/Integrations/FileData.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE BangPatterns #-} 2 | 3 | -- | 4 | -- Integration between the LaunchDarkly SDK and file data. 5 | -- 6 | -- The file data source allows you to use local files as a source of feature 7 | -- flag state. This would typically be used in a test environment, to operate 8 | -- using a predetermined feature flag state without an actual LaunchDarkly 9 | -- connection. See 'dataSourceFactory' for details. 10 | -- 11 | -- @since 2.2.1 12 | module LaunchDarkly.Server.Integrations.FileData 13 | ( dataSourceFactory 14 | ) 15 | where 16 | 17 | import Control.Applicative ((<|>)) 18 | import Data.Aeson (FromJSON, Value, decode) 19 | import qualified Data.ByteString.Lazy as BSL 20 | import Data.Generics.Product (getField) 21 | import Data.HashSet (HashSet) 22 | import Data.IORef (newIORef, readIORef, writeIORef) 23 | import Data.Maybe (fromMaybe) 24 | import Data.Text (Text) 25 | import qualified Data.Yaml as Yaml 26 | import GHC.Generics (Generic) 27 | import GHC.Natural (Natural) 28 | import LaunchDarkly.AesonCompat (KeyMap, mapWithKey) 29 | import LaunchDarkly.Server.Client.Status 30 | import LaunchDarkly.Server.DataSource.Internal (DataSource (..), DataSourceFactory, DataSourceUpdates (..)) 31 | import qualified LaunchDarkly.Server.Features as F 32 | 33 | data FileFlag = FileFlag 34 | { version :: Maybe Natural 35 | , on :: Maybe Bool 36 | , targets :: Maybe [F.Target] 37 | , contextTargets :: Maybe [F.Target] 38 | , rules :: Maybe [F.Rule] 39 | , fallthrough :: Maybe F.VariationOrRollout 40 | , offVariation :: Maybe Integer 41 | , variations :: ![Value] 42 | } 43 | deriving (Generic, FromJSON, Show, Eq) 44 | 45 | expandSimpleFlag :: Value -> FileFlag 46 | expandSimpleFlag value = 47 | FileFlag 48 | { version = Nothing 49 | , on = Nothing 50 | , targets = Nothing 51 | , contextTargets = Nothing 52 | , rules = Nothing 53 | , fallthrough = Just (F.VariationOrRollout (Just 0) Nothing) 54 | , offVariation = Just 0 55 | , variations = [value] 56 | } 57 | 58 | fromFileFlag :: Text -> FileFlag -> F.Flag 59 | fromFileFlag key fileFlag = 60 | F.Flag 61 | { F.key = key 62 | , F.version = fromMaybe 1 $ getField @"version" fileFlag 63 | , F.on = fromMaybe True $ on fileFlag 64 | , F.trackEvents = False 65 | , F.trackEventsFallthrough = False 66 | , F.deleted = False 67 | , F.prerequisites = [] 68 | , F.salt = "" 69 | , F.targets = fromMaybe [] $ targets fileFlag 70 | , F.contextTargets = fromMaybe [] $ contextTargets fileFlag 71 | , F.rules = fromMaybe [] $ getField @"rules" fileFlag 72 | , F.fallthrough = fromMaybe noFallthrough $ fallthrough fileFlag 73 | , F.offVariation = offVariation fileFlag 74 | , F.variations = variations fileFlag 75 | , F.debugEventsUntilDate = Nothing 76 | , F.clientSideAvailability = F.ClientSideAvailability False False False 77 | } 78 | 79 | noFallthrough :: F.VariationOrRollout 80 | noFallthrough = 81 | F.VariationOrRollout Nothing Nothing 82 | 83 | data FileSegment = FileSegment 84 | { included :: Maybe (HashSet Text) 85 | , includedContexts :: Maybe [F.SegmentTarget] 86 | , excluded :: Maybe (HashSet Text) 87 | , excludedContexts :: Maybe [F.SegmentTarget] 88 | , rules :: Maybe [F.SegmentRule] 89 | , version :: Maybe Natural 90 | } 91 | deriving (Generic, FromJSON, Show, Eq) 92 | 93 | fromFileSegment :: Text -> FileSegment -> F.Segment 94 | fromFileSegment key fileSegment = 95 | F.Segment 96 | { F.key = key 97 | , F.version = fromMaybe 1 $ getField @"version" fileSegment 98 | , F.included = fromMaybe mempty $ included fileSegment 99 | , F.includedContexts = fromMaybe mempty $ includedContexts fileSegment 100 | , F.excluded = fromMaybe mempty $ excluded fileSegment 101 | , F.excludedContexts = fromMaybe mempty $ excludedContexts fileSegment 102 | , F.salt = "" 103 | , F.rules = fromMaybe [] $ getField @"rules" fileSegment 104 | , F.deleted = False 105 | } 106 | 107 | data FileBody = FileBody 108 | { flags :: Maybe (KeyMap FileFlag) 109 | , flagValues :: Maybe (KeyMap Value) 110 | , segments :: Maybe (KeyMap FileSegment) 111 | } 112 | deriving (Generic, Show, FromJSON) 113 | 114 | instance Semigroup FileBody where 115 | f1 <> f2 = 116 | FileBody 117 | { flags = flags f1 <> flags f2 118 | , flagValues = flagValues f1 <> flagValues f2 119 | , segments = segments f1 <> segments f2 120 | } 121 | instance Monoid FileBody where 122 | mempty = 123 | FileBody 124 | { flags = mempty 125 | , flagValues = mempty 126 | , segments = mempty 127 | } 128 | mappend = (<>) 129 | 130 | -- | 131 | -- Creates a @DataSourceFactory@ which uses the configured file data sources. 132 | -- 133 | -- This allows you to use local files as a source of feature flag state, 134 | -- instead of using an actual LaunchDarkly connection. 135 | -- 136 | -- To use the file dataSource you can add it to the 137 | -- 'LaunchDarkly.Server.Config' using 138 | -- 'LaunchDarkly.Server.Config.configSetDataSourceFactory' 139 | -- 140 | -- @ 141 | -- let config = configSetDataSourceFactory (FileData.dataSourceFactory ["./testData/flags.json"]) $ 142 | -- makeConfig "sdk-key" 143 | -- client <- makeClient config 144 | -- @ 145 | -- 146 | -- This will cause the client /not/ to connect to LaunchDarkly to get feature 147 | -- flags. The client may still make network connections to send analytics 148 | -- events, unless you have disabled this with 149 | -- 'LaunchDarkly.Server.Config.configSetSendEvents' to @False@. IMPORTANT: Do 150 | -- /not/ set 'LaunchDarkly.Server.Config.configSetOffline' to @True@; doing so 151 | -- would not just put the SDK \"offline\" with regard to LaunchDarkly, but will 152 | -- completely turn off all flag data sources to the SDK /including the file 153 | -- data source/. 154 | -- 155 | -- Flag data files can be either JSON or YAML. They contain an object with 156 | -- three possible properties: 157 | -- 158 | -- [@flags@]: Feature flag definitions. 159 | -- [@flagValues@]: Simplified feature flags that contain only a value. 160 | -- [@segments@]: Context segment definitions. 161 | -- 162 | -- The format of the data in @flags@ and @segments@ is defined by the 163 | -- LaunchDarkly application and is subject to change. Rather than trying to 164 | -- construct these objects yourself, it is simpler to request existing flags 165 | -- directly from the LaunchDarkly server in JSON format, and use this output as 166 | -- the starting point for your file. In Linux you would do this: 167 | -- 168 | -- @ 169 | -- curl -H "Authorization: {your sdk key}" https://sdk.launchdarkly.com/sdk/latest-all 170 | -- @ 171 | -- 172 | -- The output will look something like this (but with many more properties): 173 | -- 174 | -- @ 175 | -- { 176 | -- "flags": { 177 | -- "flag-key-1": { 178 | -- "key": "flag-key-1", 179 | -- "on": true, 180 | -- "variations": [ "a", "b" ] 181 | -- }, 182 | -- "flag-key-2": { 183 | -- "key": "flag-key-2", 184 | -- "on": true, 185 | -- "variations": [ "c", "d" ] 186 | -- } 187 | -- }, 188 | -- "segments": { 189 | -- "segment-key-1": { 190 | -- "key": "segment-key-1", 191 | -- "includes": [ "user-key-1" ] 192 | -- } 193 | -- } 194 | -- } 195 | -- @ 196 | -- 197 | -- Data in this format allows the SDK to exactly duplicate all the kinds of 198 | -- flag behavior supported by LaunchDarkly. However, in many cases you will not 199 | -- need this complexity, but will just want to set specific flag keys to 200 | -- specific values. For that, you can use a much simpler format: 201 | -- 202 | -- @ 203 | -- { 204 | -- "flagValues": { 205 | -- "my-string-flag-key": "value-1", 206 | -- "my-boolean-flag-key": true, 207 | -- "my-integer-flag-key": 3 208 | -- } 209 | -- } 210 | -- @ 211 | -- 212 | -- Or, in YAML: 213 | -- 214 | -- @ 215 | -- flagValues: 216 | -- my-string-flag-key: "value-1" 217 | -- my-boolean-flag-key: true 218 | -- @ 219 | -- 220 | -- It is also possible to specify both @flags@ and @flagValues@, if you want 221 | -- some flags to have simple values and others to have complex behavior. 222 | -- However, it is an error to use the same flag key or segment key more than 223 | -- once, either in a single file or across multiple files. 224 | -- 225 | -- If the data source encounters any error in any file(malformed content, a 226 | -- missing file) it will not load flags from that file. If the data source 227 | -- encounters a duplicate key it will ignore that duplicate entry. 228 | -- 229 | -- @since 2.2.1 230 | dataSourceFactory :: [FilePath] -> DataSourceFactory 231 | dataSourceFactory sources _clientContext dataSourceUpdates = do 232 | inited <- newIORef False 233 | let dataSourceIsInitialized = 234 | readIORef inited 235 | dataSourceStart = do 236 | FileBody mFlags mFlagValues mSegments <- mconcat <$> traverse loadFile sources 237 | let mSimpleFlags = fmap (fmap expandSimpleFlag) mFlagValues 238 | flags' = maybe mempty (mapWithKey fromFileFlag) (mFlags <> mSimpleFlags) 239 | segments' = maybe mempty (mapWithKey fromFileSegment) mSegments 240 | _ <- dataSourceUpdatesInit dataSourceUpdates flags' segments' 241 | dataSourceUpdatesSetStatus dataSourceUpdates Initialized 242 | writeIORef inited True 243 | dataSourceStop = pure () 244 | pure $ DataSource {..} 245 | 246 | loadFile :: FilePath -> IO FileBody 247 | loadFile filePath = do 248 | file <- BSL.readFile filePath 249 | let mDecodedFile = decode file <|> Yaml.decodeThrow (BSL.toStrict file) 250 | case mDecodedFile of 251 | Just !fileBody -> 252 | pure fileBody 253 | Nothing -> 254 | pure mempty 255 | -------------------------------------------------------------------------------- /src/LaunchDarkly/Server/Integrations/TestData.hs: -------------------------------------------------------------------------------- 1 | -- | 2 | -- A mechanism for providing dynamically updatable feature flag state in a 3 | -- simplified form to an SDK client in test scenarios. 4 | -- 5 | -- Unlike "LaunchDarkly.Server.Integrations.FileData", this mechanism does not 6 | -- use any external resources. It provides only the data that the application 7 | -- has put into it using the 'update' function. 8 | -- 9 | -- @ 10 | -- td <- TestData.newTestData 11 | -- update td =<< (flag td "flag-key-1" 12 | -- \<&\> booleanFlag 13 | -- \<&\> variationForAll True) 14 | -- 15 | -- let config = makeConfig "sdkKey" 16 | -- & configSetDataSourceFactory (dataSourceFactory td) 17 | -- client <- makeClient config 18 | -- 19 | -- -- flags can be updated at any time: 20 | -- update td =<< 21 | -- (flag td "flag-key-2" 22 | -- \<&\> variationForKey "user" "some-user-key" True 23 | -- \<&\> fallthroughVariation False) 24 | -- @ 25 | -- 26 | -- The above example uses a simple boolean flag, but more complex 27 | -- configurations are possible using the methods of the 'FlagBuilder' that is 28 | -- returned by 'flag'. 'FlagBuilder' supports many of the ways a flag can be 29 | -- configured on the LaunchDarkly dashboard, but does not currently support: 30 | -- 31 | -- 1. Rule operators other than "in" and "not in" 32 | -- 2. Percentage rollouts. 33 | -- 34 | -- If the same 'TestData' instance is used to configure multiple 35 | -- 'LaunchDarkly.Server.Client.Client' instances, any changes made to the data 36 | -- will propagate to all of the @Client@s. 37 | -- 38 | -- see "LaunchDarkly.Server.Integrations.FileData" 39 | -- 40 | -- @since 2.2.1 41 | module LaunchDarkly.Server.Integrations.TestData 42 | ( TestData 43 | , newTestData 44 | , flag 45 | , update 46 | , dataSourceFactory 47 | 48 | -- * FlagBuilder 49 | , FlagBuilder 50 | , booleanFlag 51 | , on 52 | , fallthroughVariation 53 | , offVariation 54 | , variationForAll 55 | , variationForAllUsers 56 | , valueForAll 57 | , valueForAllUsers 58 | , variationForKey 59 | , variationForUser 60 | , variations 61 | , ifMatch 62 | , ifMatchContext 63 | , ifNotMatch 64 | , ifNotMatchContext 65 | , VariationIndex 66 | 67 | -- * FlagRuleBuilder 68 | , FlagRuleBuilder 69 | , andMatch 70 | , andMatchContext 71 | , andNotMatch 72 | , andNotMatchContext 73 | , thenReturn 74 | ) 75 | where 76 | 77 | import Control.Concurrent.MVar (MVar, modifyMVar_, newEmptyMVar, newMVar, putMVar, readMVar) 78 | import Control.Monad (void) 79 | import Data.Foldable (traverse_) 80 | import Data.IntMap.Strict (IntMap) 81 | import qualified Data.IntMap.Strict as IntMap 82 | import Data.Map.Strict (Map) 83 | import qualified Data.Map.Strict as Map 84 | import qualified Data.Maybe as Maybe 85 | import Data.Text (Text) 86 | 87 | import Data.Generics.Product (getField) 88 | import LaunchDarkly.AesonCompat (KeyMap, insertKey, lookupKey) 89 | import LaunchDarkly.Server.DataSource.Internal 90 | import qualified LaunchDarkly.Server.Features as Features 91 | import LaunchDarkly.Server.Integrations.TestData.FlagBuilder 92 | 93 | dataSourceFactory :: TestData -> DataSourceFactory 94 | dataSourceFactory (TestData ref) _clientContext dataSourceUpdates = do 95 | listenerIdRef <- newEmptyMVar 96 | let upsert flag = void $ dataSourceUpdatesInsertFlag dataSourceUpdates flag 97 | dataSourceStart = do 98 | modifyMVar_ ref $ \td -> do 99 | void $ dataSourceUpdatesInit dataSourceUpdates (currentFlags td) mempty 100 | let (td', listenerId) = addDataSourceListener td upsert 101 | putMVar listenerIdRef listenerId 102 | pure td' 103 | dataSourceIsInitialized = 104 | pure True 105 | dataSourceStop = 106 | modifyMVar_ ref $ \td -> 107 | removeDataSourceListener td <$> readMVar listenerIdRef 108 | pure $ DataSource {..} 109 | 110 | newtype TestData = TestData (MVar TestData') 111 | 112 | type TestDataListener = Features.Flag -> IO () 113 | 114 | data TestData' = TestData' 115 | { flagBuilders :: Map Text FlagBuilder 116 | , currentFlags :: KeyMap Features.Flag 117 | , nextDataSourceListenerId :: Int 118 | , dataSourceListeners :: IntMap TestDataListener 119 | } 120 | 121 | -- | Creates a new instance of the test data source. 122 | newTestData :: 123 | -- | a new configurable test data source 124 | IO TestData 125 | newTestData = 126 | TestData <$> newMVar (TestData' mempty mempty 0 mempty) 127 | 128 | addDataSourceListener :: TestData' -> TestDataListener -> (TestData', Int) 129 | addDataSourceListener td listener = 130 | ( td 131 | { nextDataSourceListenerId = nextDataSourceListenerId td + 1 132 | , dataSourceListeners = IntMap.insert (nextDataSourceListenerId td) listener (dataSourceListeners td) 133 | } 134 | , nextDataSourceListenerId td 135 | ) 136 | 137 | removeDataSourceListener :: TestData' -> Int -> TestData' 138 | removeDataSourceListener td listenerId = 139 | td 140 | { dataSourceListeners = 141 | IntMap.delete listenerId (dataSourceListeners td) 142 | } 143 | 144 | -- | 145 | -- Creates or copies a 'FlagBuilder' for building a test flag configuration. 146 | -- 147 | -- If this flag key has already been defined in this 'TestData' instance, then 148 | -- the builder starts with the same configuration that was last provided for 149 | -- this flag. 150 | -- 151 | -- Otherwise, it starts with a new default configuration in which the flag has 152 | -- @True@ and @False@ variations, is @True@ for all users when targeting is 153 | -- turned on and @False@ otherwise, and currently has targeting turned on. You 154 | -- can change any of those properties, and provide more complex behavior, 155 | -- using the 'FlagBuilder' methods. 156 | -- 157 | -- Once you have set the desired configuration, pass the builder to 'update'. 158 | -- 159 | -- see 'update' 160 | flag :: 161 | TestData -> 162 | -- | the flag key 163 | Text -> 164 | -- | a flag configuration builder 165 | IO FlagBuilder 166 | flag (TestData ref) key = do 167 | td <- readMVar ref 168 | pure $ 169 | Maybe.fromMaybe (booleanFlag $ newFlagBuilder key) $ 170 | Map.lookup key (flagBuilders td) 171 | 172 | -- | 173 | -- Updates the test data with the specified flag configuration. 174 | -- 175 | -- This has the same effect as if a flag were added or modified on the 176 | -- LaunchDarkly dashboard. It immediately propagates the flag change to any 177 | -- 'LaunchDarkly.Server.Client.Client' instance(s) that you have already 178 | -- configured to use this 'TestData'. If no @Client@ has been started yet, it 179 | -- simply adds this flag to the test data which will be provided to any 180 | -- @Client@ that you subsequently configure. 181 | -- 182 | -- Any subsequent changes to this 'FlagBuilder' instance do not affect the 183 | -- test data, unless you call 'update' 184 | -- 185 | -- see 'flag' 186 | update :: 187 | TestData -> 188 | -- | a flag configuration builder 189 | FlagBuilder -> 190 | IO () 191 | update (TestData ref) fb = 192 | modifyMVar_ ref $ \td -> do 193 | let key = fbKey fb 194 | mOldFlag = lookupKey key (currentFlags td) 195 | oldFlagVersion = maybe 0 (getField @"version") mOldFlag 196 | newFlag = buildFlag (oldFlagVersion + 1) fb 197 | td' = 198 | td 199 | { flagBuilders = Map.insert key fb (flagBuilders td) 200 | , currentFlags = insertKey key newFlag (currentFlags td) 201 | } 202 | notifyListeners td newFlag 203 | pure td' 204 | where 205 | notifyListeners td newFlag = 206 | traverse_ ($ newFlag) (dataSourceListeners td) 207 | -------------------------------------------------------------------------------- /src/LaunchDarkly/Server/Network/Common.hs: -------------------------------------------------------------------------------- 1 | module LaunchDarkly.Server.Network.Common 2 | ( withResponseGeneric 3 | , tryAuthorized 4 | , checkAuthorization 5 | , throwIfNot200 6 | , getServerTime 7 | , tryHTTP 8 | , addToAL 9 | , handleUnauthorized 10 | , isHttpUnrecoverable 11 | ) where 12 | 13 | import Control.Monad (when) 14 | import Control.Monad.Catch (Exception, MonadCatch, MonadMask, MonadThrow, bracket, handle, throwM, try) 15 | import Control.Monad.IO.Class (MonadIO, liftIO) 16 | import Control.Monad.Logger (MonadLogger, logError) 17 | import Data.ByteString.Internal (unpackChars) 18 | import Data.Maybe (fromMaybe) 19 | import Data.Time.Clock.POSIX (utcTimeToPOSIXSeconds) 20 | import Data.Time.Format (defaultTimeLocale, parseTimeM, rfc822DateFormat) 21 | import Network.HTTP.Client (BodyReader, HttpException, Manager, Request (..), Response (..), responseClose, responseOpen, throwErrorStatusCodes) 22 | import Network.HTTP.Types.Header (hDate) 23 | import Network.HTTP.Types.Status (forbidden403, unauthorized401) 24 | 25 | import LaunchDarkly.Server.Client.Internal (Client, Status (Unauthorized), setStatus) 26 | import LaunchDarkly.Server.DataSource.Internal (DataSourceUpdates (..)) 27 | import Network.HTTP.Types (ok200) 28 | 29 | tryHTTP :: MonadCatch m => m a -> m (Either HttpException a) 30 | tryHTTP = try 31 | 32 | addToAL :: Eq k => [(k, v)] -> k -> v -> [(k, v)] 33 | addToAL l k v = (k, v) : filter ((/=) k . fst) l 34 | 35 | withResponseGeneric :: (MonadIO m, MonadMask m) => Request -> Manager -> (Response BodyReader -> m a) -> m a 36 | withResponseGeneric req man f = bracket (liftIO $ responseOpen req man) (liftIO . responseClose) f 37 | 38 | data UnauthorizedE = UnauthorizedE deriving (Show, Exception) 39 | 40 | handleUnauthorized :: (MonadIO m, MonadLogger m, MonadCatch m) => DataSourceUpdates -> m () -> m () 41 | handleUnauthorized dataSourceUpdates = handle $ \UnauthorizedE -> do 42 | $(logError) "SDK key is unauthorized" 43 | liftIO $ dataSourceUpdatesSetStatus dataSourceUpdates Unauthorized 44 | 45 | tryAuthorized :: (MonadIO m, MonadLogger m, MonadCatch m) => Client -> m a -> m () 46 | tryAuthorized client operation = 47 | try operation >>= \case 48 | (Left UnauthorizedE) -> do 49 | $(logError) "SDK key is unauthorized" 50 | liftIO $ setStatus client Unauthorized 51 | _ -> pure () 52 | 53 | checkAuthorization :: (MonadThrow m) => Response body -> m () 54 | checkAuthorization response = when (elem (responseStatus response) [unauthorized401, forbidden403]) $ throwM UnauthorizedE 55 | 56 | throwIfNot200 :: (MonadIO m) => Request -> Response BodyReader -> m () 57 | throwIfNot200 request response = when (responseStatus response /= ok200) $ throwErrorStatusCodes request response 58 | 59 | getServerTime :: Response body -> Integer 60 | getServerTime response 61 | | date == "" = 0 62 | | otherwise = fromMaybe 0 (truncate <$> utcTimeToPOSIXSeconds <$> parsedTime) 63 | where 64 | headers = responseHeaders response 65 | date = fromMaybe "" $ lookup hDate headers 66 | parsedTime = parseTimeM True defaultTimeLocale rfc822DateFormat (unpackChars date) 67 | 68 | isHttpUnrecoverable :: Int -> Bool 69 | isHttpUnrecoverable status 70 | | status < 400 || status >= 500 = False 71 | | status `elem` [400, 408, 429] = False 72 | | otherwise = True 73 | -------------------------------------------------------------------------------- /src/LaunchDarkly/Server/Network/Eventing.hs: -------------------------------------------------------------------------------- 1 | module LaunchDarkly.Server.Network.Eventing (eventThread) where 2 | 3 | import qualified Codec.Compression.GZip as GZip 4 | import Control.Concurrent (killThread, myThreadId) 5 | import Control.Concurrent.MVar (modifyMVar_, readMVar, swapMVar, takeMVar) 6 | import Control.Monad (forever, unless, void, when) 7 | import Control.Monad.Catch (MonadMask, MonadThrow) 8 | import Control.Monad.IO.Class (MonadIO, liftIO) 9 | import Control.Monad.Logger (MonadLogger, logDebug, logError, logWarn) 10 | import Data.Aeson (encode) 11 | import qualified Data.ByteString.Lazy as L 12 | import Data.Function ((&)) 13 | import Data.Generics.Product (getField) 14 | import Data.IORef (atomicModifyIORef', newIORef, readIORef) 15 | import qualified Data.Text as T 16 | import Data.Text.Encoding (decodeUtf8) 17 | import Data.Tuple (swap) 18 | import qualified Data.UUID as UUID 19 | import Network.HTTP.Client (Manager, Request (..), RequestBody (..), httpLbs, responseStatus) 20 | import Network.HTTP.Types.Status (Status (statusCode), status400) 21 | import System.Random (newStdGen, random) 22 | import System.Timeout (timeout) 23 | 24 | import LaunchDarkly.Server.Client.Internal (Client, Status (ShuttingDown)) 25 | import LaunchDarkly.Server.Config.ClientContext 26 | import LaunchDarkly.Server.Config.HttpConfiguration (prepareRequest) 27 | import LaunchDarkly.Server.Events (EventState, processSummary) 28 | import LaunchDarkly.Server.Network.Common (addToAL, checkAuthorization, getServerTime, isHttpUnrecoverable, tryAuthorized, tryHTTP) 29 | 30 | -- A true result indicates a retry does not need to be attempted 31 | processSend :: (MonadIO m, MonadLogger m, MonadMask m, MonadThrow m) => Manager -> Request -> m (Bool, Integer) 32 | processSend manager req = 33 | (liftIO $ tryHTTP $ httpLbs req manager) >>= \case 34 | (Left err) -> $(logError) (T.pack $ show err) >> pure (False, 0) 35 | (Right response) -> do 36 | checkAuthorization response 37 | let code = responseStatus response 38 | serverTime = getServerTime response 39 | in $(logWarn) (T.append "@@@ server time from LD was determined to be: " $ T.pack $ show serverTime) 40 | >> if code < status400 41 | then pure (True, serverTime) 42 | else 43 | if isHttpUnrecoverable $ statusCode $ code 44 | then $(logWarn) (T.append "got non recoverable event post response dropping payload: " $ T.pack $ show code) >> pure (True, serverTime) 45 | else pure (False, serverTime) 46 | 47 | setEventHeaders :: Request -> Request 48 | setEventHeaders request = 49 | request 50 | { requestHeaders = 51 | (requestHeaders request) 52 | & \l -> 53 | addToAL l "Content-Type" "application/json" 54 | & \l -> addToAL l "X-LaunchDarkly-Event-Schema" "4" 55 | , method = "POST" 56 | } 57 | 58 | updateLastKnownServerTime :: EventState -> Integer -> IO () 59 | updateLastKnownServerTime state serverTime = modifyMVar_ (getField @"lastKnownServerTime" state) (\lastKnown -> pure $ max serverTime lastKnown) 60 | 61 | eventThread :: (MonadIO m, MonadLogger m, MonadMask m) => Manager -> Client -> ClientContext -> m () 62 | eventThread manager client clientContext = do 63 | let 64 | state = getField @"events" client 65 | config = getField @"config" client 66 | compressEvents = getField @"compressEvents" config 67 | httpConfig = httpConfiguration clientContext 68 | rngRef <- liftIO $ newStdGen >>= newIORef 69 | req <- (liftIO $ prepareRequest httpConfig $ (T.unpack $ getField @"eventsURI" config) ++ "/bulk") >>= pure . setEventHeaders 70 | void $ tryAuthorized client $ forever $ do 71 | liftIO $ processSummary config state 72 | events' <- liftIO $ swapMVar (getField @"events" state) [] 73 | when (not $ null events') $ do 74 | payloadId <- liftIO $ atomicModifyIORef' rngRef (swap . random) 75 | let 76 | encoded = encode events' 77 | payload = if compressEvents then GZip.compress encoded else encoded 78 | thisReq = 79 | req 80 | { requestBody = RequestBodyLBS payload 81 | , requestHeaders = 82 | (requestHeaders req) 83 | & \l -> 84 | addToAL l "X-LaunchDarkly-Payload-ID" (UUID.toASCIIBytes payloadId) 85 | & \l -> if compressEvents then addToAL l "Content-Encoding" "gzip" else l 86 | } 87 | (success, serverTime) <- processSend manager thisReq 88 | $(logDebug) $ T.append "sending events: " $ decodeUtf8 $ L.toStrict encoded 89 | _ <- case success of 90 | True -> liftIO $ updateLastKnownServerTime state serverTime 91 | False -> do 92 | $(logWarn) "retrying event delivery after one second" 93 | liftIO $ void $ timeout (1 * 1000000) $ readMVar $ getField @"flush" state 94 | (success', serverTime') <- processSend manager thisReq 95 | unless success' $ do 96 | $(logWarn) "failed sending events on retry, dropping event batch" 97 | liftIO $ updateLastKnownServerTime state serverTime' 98 | $(logDebug) "finished send of event batch" 99 | status <- liftIO $ readIORef $ getField @"status" client 100 | liftIO $ when (status == ShuttingDown) (myThreadId >>= killThread) 101 | liftIO $ void $ timeout ((*) 1000000 $ fromIntegral $ getField @"flushIntervalSeconds" config) $ takeMVar $ getField @"flush" state 102 | -------------------------------------------------------------------------------- /src/LaunchDarkly/Server/Network/Polling.hs: -------------------------------------------------------------------------------- 1 | module LaunchDarkly.Server.Network.Polling (pollingThread) where 2 | 3 | import Control.Concurrent (threadDelay) 4 | import Control.Monad.Catch (MonadMask, MonadThrow) 5 | import Control.Monad.IO.Class (MonadIO, liftIO) 6 | import Control.Monad.Logger (MonadLogger, logDebug, logError) 7 | import Data.Aeson (FromJSON (..), eitherDecode) 8 | import Data.Generics.Product (getField) 9 | import Data.Text (Text) 10 | import qualified Data.Text as T 11 | import GHC.Generics (Generic) 12 | import Network.HTTP.Client (Manager, Request (..), Response (..), httpLbs) 13 | import Network.HTTP.Types.Status (Status (statusCode), ok200) 14 | 15 | import LaunchDarkly.AesonCompat (KeyMap) 16 | import LaunchDarkly.Server.Features (Flag, Segment) 17 | import LaunchDarkly.Server.Network.Common (checkAuthorization, handleUnauthorized, isHttpUnrecoverable, tryHTTP) 18 | 19 | import Data.ByteString.Lazy (ByteString) 20 | import GHC.Natural (Natural) 21 | import LaunchDarkly.Server.Client.Internal (Status (..)) 22 | import LaunchDarkly.Server.Config.ClientContext 23 | import LaunchDarkly.Server.Config.HttpConfiguration (HttpConfiguration (..), prepareRequest) 24 | import LaunchDarkly.Server.DataSource.Internal (DataSourceUpdates (..)) 25 | 26 | data PollingResponse = PollingResponse 27 | { flags :: !(KeyMap Flag) 28 | , segments :: !(KeyMap Segment) 29 | } 30 | deriving (Generic, FromJSON, Show) 31 | 32 | processPoll :: (MonadIO m, MonadLogger m, MonadMask m, MonadThrow m) => Manager -> DataSourceUpdates -> Request -> m Bool 33 | processPoll manager dataSourceUpdates request = 34 | liftIO (tryHTTP $ httpLbs request manager) >>= \case 35 | (Left err) -> do 36 | $(logError) (T.pack $ show err) 37 | pure True 38 | (Right response) -> 39 | checkAuthorization response >> processResponse response 40 | where 41 | processResponse :: (MonadIO m, MonadLogger m, MonadMask m, MonadThrow m) => Response ByteString -> m Bool 42 | processResponse response 43 | | isHttpUnrecoverable $ statusCode $ responseStatus response = do 44 | $(logError) "polling stopping after receiving unrecoverable error" 45 | pure False 46 | | responseStatus response /= ok200 = do 47 | $(logError) "unexpected polling status code" 48 | pure True 49 | | otherwise = case (eitherDecode (responseBody response) :: Either String PollingResponse) of 50 | (Left err) -> do 51 | $(logError) (T.pack $ show err) 52 | pure $ True 53 | (Right body) -> do 54 | status <- liftIO $ dataSourceUpdatesInit dataSourceUpdates (getField @"flags" body) (getField @"segments" body) 55 | case status of 56 | Right () -> do 57 | liftIO $ dataSourceUpdatesSetStatus dataSourceUpdates Initialized 58 | pure $ True 59 | Left err -> do 60 | $(logError) $ T.append "store failed put: " err 61 | pure $ True 62 | 63 | pollingThread :: (MonadIO m, MonadLogger m, MonadMask m) => Text -> Natural -> ClientContext -> DataSourceUpdates -> m () 64 | pollingThread baseURI pollingIntervalSeconds clientContext dataSourceUpdates = do 65 | let pollingMicroseconds = fromIntegral pollingIntervalSeconds * 1000000 66 | req <- liftIO $ prepareRequest (httpConfiguration clientContext) (T.unpack baseURI ++ "/sdk/latest-all") 67 | handleUnauthorized dataSourceUpdates $ (poll req pollingMicroseconds) 68 | where 69 | poll :: (MonadIO m, MonadLogger m, MonadMask m) => Request -> Int -> m () 70 | poll req pollingMicroseconds = do 71 | $(logDebug) "starting poll" 72 | processPoll (tlsManager $ httpConfiguration clientContext) dataSourceUpdates req >>= \case 73 | True -> do 74 | liftIO $ threadDelay pollingMicroseconds 75 | poll req pollingMicroseconds 76 | False -> pure () 77 | -------------------------------------------------------------------------------- /src/LaunchDarkly/Server/Operators.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE NoPatternSynonyms #-} 2 | 3 | module LaunchDarkly.Server.Operators 4 | ( Op (..) 5 | , getOperation 6 | ) where 7 | 8 | import Control.Lens ((.~)) 9 | import Control.Monad (liftM2) 10 | import Data.Aeson.Types (FromJSON, ToJSON (..), Value (..), parseJSON, withText) 11 | import Data.Char (isDigit) 12 | import Data.Either (fromRight) 13 | import Data.Maybe (fromMaybe, isJust) 14 | import Data.Scientific (Scientific, toRealFloat) 15 | import Data.SemVer (Version, fromText, metadata, toText) 16 | import Data.Text (Text, isInfixOf, isPrefixOf, isSuffixOf, unpack) 17 | import qualified Data.Text as T 18 | import Data.Text.Encoding (encodeUtf8) 19 | import Data.Time.Clock (UTCTime) 20 | import Data.Time.Clock.POSIX (POSIXTime, posixSecondsToUTCTime) 21 | import Data.Time.ISO8601 (parseISO8601) 22 | import GHC.Generics (Generic) 23 | import Text.Regex.PCRE.Light (compileM, match) 24 | 25 | data Op 26 | = OpIn 27 | | OpEndsWith 28 | | OpStartsWith 29 | | OpMatches 30 | | OpContains 31 | | OpLessThan 32 | | OpLessThanOrEqual 33 | | OpGreaterThan 34 | | OpGreaterThanOrEqual 35 | | OpBefore 36 | | OpAfter 37 | | OpSemVerEqual 38 | | OpSemVerLessThan 39 | | OpSemVerGreaterThan 40 | | OpSegmentMatch 41 | | OpUnknown 42 | deriving (Generic, Show, Eq) 43 | 44 | instance FromJSON Op where 45 | parseJSON = withText "Op" $ \v -> case v of 46 | "in" -> pure OpIn 47 | "endsWith" -> pure OpEndsWith 48 | "startsWith" -> pure OpStartsWith 49 | "matches" -> pure OpMatches 50 | "contains" -> pure OpContains 51 | "lessThan" -> pure OpLessThan 52 | "lessThanOrEqual" -> pure OpLessThanOrEqual 53 | "greaterThan" -> pure OpGreaterThan 54 | "greaterThanOrEqual" -> pure OpGreaterThanOrEqual 55 | "before" -> pure OpBefore 56 | "after" -> pure OpAfter 57 | "semVerEqual" -> pure OpSemVerEqual 58 | "semVerLessThan" -> pure OpSemVerLessThan 59 | "semVerGreaterThan" -> pure OpSemVerGreaterThan 60 | "segmentMatch" -> pure OpSegmentMatch 61 | _ -> pure OpUnknown 62 | 63 | instance ToJSON Op where 64 | toJSON op = String $ case op of 65 | OpIn -> "in" 66 | OpEndsWith -> "endsWith" 67 | OpStartsWith -> "startsWith" 68 | OpMatches -> "matches" 69 | OpContains -> "contains" 70 | OpLessThan -> "lessThan" 71 | OpLessThanOrEqual -> "lessThanOrEqual" 72 | OpGreaterThan -> "greaterThan" 73 | OpGreaterThanOrEqual -> "greaterThanOrEqual" 74 | OpBefore -> "before" 75 | OpAfter -> "after" 76 | OpSemVerEqual -> "semVerEqual" 77 | OpSemVerLessThan -> "semVerLessThan" 78 | OpSemVerGreaterThan -> "semVerGreaterThan" 79 | OpSegmentMatch -> "segmentMatch" 80 | OpUnknown -> "unknown" 81 | 82 | checkString :: (Text -> Text -> Bool) -> Value -> Value -> Bool 83 | checkString op (String x) (String y) = op x y 84 | checkString _ _ _ = False 85 | 86 | checkNumber :: (Scientific -> Scientific -> Bool) -> Value -> Value -> Bool 87 | checkNumber op (Number x) (Number y) = op x y 88 | checkNumber _ _ _ = False 89 | 90 | doubleToPOSIXTime :: Double -> POSIXTime 91 | doubleToPOSIXTime = realToFrac 92 | 93 | parseTime :: Value -> Maybe UTCTime 94 | parseTime (Number x) = Just $ posixSecondsToUTCTime $ doubleToPOSIXTime $ (toRealFloat x) / 1000 95 | parseTime (String x) = parseISO8601 $ unpack x 96 | parseTime _ = Nothing 97 | 98 | compareTime :: (UTCTime -> UTCTime -> Bool) -> Value -> Value -> Bool 99 | compareTime op x y = fromMaybe False $ liftM2 op (parseTime x) (parseTime y) 100 | 101 | padSemVer :: Text -> Text 102 | padSemVer text = T.concat [l, padding, r] 103 | where 104 | (l, r) = T.span (\c -> isDigit c || c == '.') text 105 | dots = T.count "." l 106 | padding = if dots < 2 then T.replicate (2 - dots) ".0" else "" 107 | 108 | parseSemVer :: Text -> Either String Version 109 | parseSemVer raw = 110 | fmap (metadata .~ []) (fromText $ padSemVer raw) >>= \x -> 111 | if T.isPrefixOf (toText x) (padSemVer raw) then Right x else Left "mismatch" 112 | where 113 | 114 | compareSemVer :: (Version -> Version -> Bool) -> Text -> Text -> Bool 115 | compareSemVer op x y = fromRight False $ liftM2 op (parseSemVer x) (parseSemVer y) 116 | 117 | matches :: Text -> Text -> Bool 118 | matches text pattern = case compileM (encodeUtf8 pattern) [] of 119 | Left _ -> False 120 | Right compiled -> isJust $ match compiled (encodeUtf8 text) [] 121 | 122 | getOperation :: Op -> (Value -> Value -> Bool) 123 | getOperation op = case op of 124 | OpIn -> (==) 125 | OpEndsWith -> checkString (flip isSuffixOf) 126 | OpStartsWith -> checkString (flip isPrefixOf) 127 | OpContains -> checkString (flip isInfixOf) 128 | OpMatches -> checkString matches 129 | OpLessThan -> checkNumber (<) 130 | OpLessThanOrEqual -> checkNumber (<=) 131 | OpGreaterThan -> checkNumber (>) 132 | OpGreaterThanOrEqual -> checkNumber (>=) 133 | OpBefore -> compareTime (<) 134 | OpAfter -> compareTime (>) 135 | OpSemVerEqual -> checkString $ compareSemVer (==) 136 | OpSemVerLessThan -> checkString $ compareSemVer (<) 137 | OpSemVerGreaterThan -> checkString $ compareSemVer (>) 138 | OpSegmentMatch -> error "cannot get operation for OpSegmentMatch" 139 | OpUnknown -> const $ const False 140 | -------------------------------------------------------------------------------- /src/LaunchDarkly/Server/Reference.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE NamedFieldPuns #-} 2 | {-# LANGUAGE ViewPatterns #-} 3 | 4 | -- | 5 | -- Reference is an attribute name or path expression identifying a value within 6 | -- a Context. 7 | -- 8 | -- This type is mainly intended to be used internally by LaunchDarkly SDK and 9 | -- service code, where efficiency is a major concern so it's desirable to do 10 | -- any parsing or preprocessing just once. Applications are unlikely to need to 11 | -- use the Reference type directly. 12 | -- 13 | -- It can be used to retrieve a value with 14 | -- 'LaunchDarkly.Server.Context.getValueForReference' or to identify an 15 | -- attribute or nested value that should be considered private. 16 | -- 17 | -- Parsing and validation are done at the time that the Reference is 18 | -- constructed. If a Reference instance was created from an invalid string, it 19 | -- is considered invalid. The error can be inspected with 'getError'. 20 | -- 21 | -- == Syntax 22 | -- 23 | -- The string representation of an attribute reference in LaunchDarkly JSON 24 | -- data uses the following syntax: 25 | -- 26 | -- If the first character is not a slash, the string is interpreted literally 27 | -- as an attribute name. An attribute name can contain any characters, but must 28 | -- not be empty. 29 | -- 30 | -- If the first character is a slash, the string is interpreted as a 31 | -- slash-delimited path where the first path component is an attribute name, 32 | -- and each subsequent path component is the name of a property in a JSON 33 | -- object. Any instances of the characters "/" or "~" in a path component are 34 | -- escaped as "~1" or "~0" respectively. This syntax deliberately resembles 35 | -- JSON Pointer, but no JSON Pointer behaviors other than those mentioned here 36 | -- are supported. 37 | -- 38 | -- == Examples 39 | -- 40 | -- Suppose there is a context whose JSON implementation looks like this: 41 | -- 42 | -- { 43 | -- "kind": "user", 44 | -- "key": "value1", 45 | -- "address": { 46 | -- "street": { 47 | -- "line1": "value2", 48 | -- "line2": "value3" 49 | -- }, 50 | -- "city": "value4" 51 | -- }, 52 | -- "good/bad": "value5" 53 | -- } 54 | -- 55 | -- The attribute references "key" and "/key" would both point to "value1". 56 | -- 57 | -- The attribute reference "/address/street/line1" would point to "value2". 58 | -- 59 | -- The attribute references "good/bad" and "/good~1bad" would both point to 60 | -- "value5". 61 | module LaunchDarkly.Server.Reference 62 | ( Reference 63 | , makeReference 64 | , makeLiteral 65 | , isValid 66 | , getError 67 | , getComponents 68 | , getRawPath 69 | ) 70 | where 71 | 72 | import Data.Aeson (ToJSON, Value (String), toJSON) 73 | import Data.Text (Text) 74 | import qualified Data.Text as T 75 | 76 | -- | data record for the Reference type. 77 | data Reference 78 | = Valid {rawPath :: !Text, components :: ![Text]} 79 | | Invalid {rawPath :: !Text, error :: !Text} 80 | deriving (Show, Eq) 81 | 82 | instance Ord Reference where 83 | compare (Invalid _ _) (Valid _ _) = LT 84 | compare (Valid _ _) (Invalid _ _) = GT 85 | compare (Valid lhsRaw lhsComponents) (Valid rhsRaw rhsComponents) 86 | | lhsComponents == rhsComponents = compare lhsRaw rhsRaw 87 | | otherwise = compare lhsComponents rhsComponents 88 | compare (Invalid lhsRaw lhsError) (Invalid rhsRaw rhsError) 89 | | lhsRaw == rhsRaw = compare lhsError rhsError 90 | | otherwise = compare lhsRaw rhsRaw 91 | 92 | instance ToJSON Reference where 93 | toJSON = String . rawPath 94 | 95 | -- | 96 | -- Creates a Reference from a string. For the supported syntax and examples, 97 | -- see comments on the "LaunchDarkly.Server.Reference" module. 98 | -- 99 | -- This function always returns a Reference that preserves the original string, 100 | -- even if validation fails, so that accessing 'getRawPath' (or serializing the 101 | -- Reference to JSON) will produce the original string. If validation fails, 102 | -- 'getError' will return an error and any SDK method that takes this Reference 103 | -- as a parameter will consider it invalid. 104 | makeReference :: Text -> Reference 105 | makeReference "" = Invalid {rawPath = "", error = "empty reference"} 106 | makeReference "/" = Invalid {rawPath = "/", error = "empty reference"} 107 | makeReference value@(T.stripPrefix "/" -> Nothing) = Valid {rawPath = value, components = [value]} 108 | makeReference value@(T.stripSuffix "/" -> Just _) = Invalid {rawPath = value, error = "trailing slash"} 109 | makeReference value = foldr addComponentToReference (Valid {rawPath = value, components = []}) (T.splitOn "/" $ T.drop 1 value) 110 | 111 | -- | 112 | -- makeLiteral is similar to 'makeReference' except that it always interprets 113 | -- the string as a literal attribute name, never as a slash-delimited path 114 | -- expression. There is no escaping or unescaping, even if the name contains 115 | -- literal '/' or '~' characters. Since an attribute name can contain any 116 | -- characters, this method always returns a valid Reference unless the name is 117 | -- empty. 118 | -- 119 | -- For example: @makeLiteral "name"@ is exactly equivalent to @makeReference 120 | -- "name"@. @makeLiteral "a/b"@ is exactly equivalent to @makeReference "a/b"@ 121 | -- (since the syntax used by 'makeReference' treats the whole string as a 122 | -- literal as long as it does not start with a slash), or to @makeReference 123 | -- "/a~1b"@. 124 | makeLiteral :: Text -> Reference 125 | makeLiteral "" = Invalid {rawPath = "", error = "empty reference"} 126 | makeLiteral value@(T.stripPrefix "/" -> Nothing) = Valid {rawPath = value, components = [value]} 127 | makeLiteral value = Valid {rawPath = "/" <> (T.replace "/" "~1" $ T.replace "~" "~0" value), components = [value]} 128 | 129 | -- | 130 | -- Returns True for a valid Reference; False otherwise. 131 | -- 132 | -- A Reference is invalid if the input string is empty, or starts with a slash 133 | -- but is not a valid slash-delimited path, or starts with a slash and contains 134 | -- an invalid escape sequence. 135 | -- 136 | -- Otherwise, the Reference is valid, but that does not guarantee that such an 137 | -- attribute exists in any given Context. For instance, @makeReference "name"@ 138 | -- is a valid Reference, but a specific Context might or might not have a name. 139 | -- 140 | -- See comments on the "LaunchDarkly.Server.Reference" module for more details 141 | -- of the attribute reference syntax. 142 | isValid :: Reference -> Bool 143 | isValid (Invalid _ _) = False 144 | isValid _ = True 145 | 146 | -- | 147 | -- Returns an empty string for a valid Reference, or a Text error description 148 | -- for an invalid Reference. 149 | -- 150 | -- See comments on the "LaunchDarkly.Server.Reference" module for more details 151 | -- of the attribute reference syntax. 152 | getError :: Reference -> Text 153 | getError (Invalid {error = e}) = e 154 | getError _ = "" 155 | 156 | -- | 157 | -- Retrieves path components from the attribute reference. 158 | -- 159 | -- Invalid references will return an empty list. 160 | -- 161 | -- > makeReference "" & getComponents -- returns [] 162 | -- > makeReference "a" & getComponents -- returns ["a"] 163 | -- > makeReference "/a/b" & getComponents -- returns ["a", "b"] 164 | getComponents :: Reference -> [Text] 165 | getComponents (Valid {components}) = components 166 | getComponents _ = [] 167 | 168 | -- | 169 | -- Returns the attribute reference as a string, in the same format provided 170 | -- to 'makeReference'. 171 | -- 172 | -- If the Reference was created with 'makeReference', this value is identical 173 | -- to the original string. If it was created with 'makeLiteral', the value may 174 | -- be different due to unescaping (for instance, an attribute whose name is 175 | -- "/a" would be represented as "~1a"). 176 | getRawPath :: Reference -> Text 177 | getRawPath = rawPath 178 | 179 | -- Method intended to be used with a foldr. If you do not use this with a 180 | -- foldr, the components will be in the wrong order as this method does 181 | -- prepending. 182 | -- 183 | -- This function helps assist in the construction of a Valid reference by 184 | -- incrementally adding a new component to the Reference. If the component 185 | -- cannot be added, or if the Reference is already invalid, we return an 186 | -- Invalid reference with the appropriate error description. 187 | addComponentToReference :: Text -> Reference -> Reference 188 | addComponentToReference _ r@(Invalid _ _) = r 189 | addComponentToReference "" (Valid {rawPath}) = Invalid {rawPath, error = "double slash"} 190 | addComponentToReference component (Valid {rawPath, components}) = case unescapePath component of 191 | Left c -> Valid {rawPath, components = (c : components)} 192 | Right e -> Invalid {rawPath, error = e} 193 | 194 | -- Performs unescaping of attribute reference path components: 195 | -- 196 | -- "~1" becomes "/" 197 | -- "~0" becomes "~" 198 | -- "~" followed by any character other than "0" or "1" is invalid 199 | -- 200 | -- This method returns an Either. Left Text is the path if unescaping was 201 | -- valid; otherwise, Right Text will be a description error message. 202 | unescapePath :: Text -> Either Text Text 203 | unescapePath value@(T.isInfixOf "~" -> False) = Left value 204 | unescapePath (T.stripSuffix "~" -> Just _) = Right "invalid escape sequence" 205 | unescapePath value = 206 | let component = T.foldl unescapeComponent (ComponentState {acc = [], valid = True, inEscape = False}) value 207 | in case component of 208 | ComponentState {acc = acc, valid = True} -> Left $ T.pack $ reverse acc 209 | _ -> Right "invalid escape sequence" 210 | 211 | -- Component state is a helper record to assist with unescaping a string. 212 | -- 213 | -- When we are processing a string, we have to ensure that ~ is followed by 0 214 | -- or 1. Any other value is invalid. To track this, we update this component 215 | -- state through a fold operation. 216 | data ComponentState = ComponentState 217 | { acc :: ![Char] -- Container to hold the piece of the input that has been successfully parsed. 218 | , valid :: !Bool -- Is the state currently valid? 219 | , inEscape :: !Bool -- Was the last character seen a tilde? 220 | } 221 | 222 | -- Intended to be used in a foldl operation to apply unescaping rules as 223 | -- defined in 'unescapePath'. 224 | -- 225 | -- Note that the 'ComponentState.acc' will be built backwards. This is because 226 | -- prepending is faster in Haskell. Calling functions should reverse 227 | -- accordingly. 228 | unescapeComponent :: ComponentState -> Char -> ComponentState 229 | -- Short circuit if we are already invalid 230 | unescapeComponent component@(ComponentState {valid = False}) _ = component 231 | -- Escape mode with a 0 or 1 means a valid escape sequence. We can append this 232 | -- to the state's accumulator. 233 | unescapeComponent component@(ComponentState {acc, inEscape = True}) '0' = component {acc = '~' : acc, valid = True, inEscape = False} 234 | unescapeComponent component@(ComponentState {acc, inEscape = True}) '1' = component {acc = '/' : acc, valid = True, inEscape = False} 235 | -- Any other character during an escape sequence isn't valid 236 | unescapeComponent component@(ComponentState {inEscape = True}) _ = component {valid = False} 237 | -- ~ means we should start escaping 238 | unescapeComponent component '~' = component {inEscape = True} 239 | -- Regular characters can be added without issue 240 | unescapeComponent component@(ComponentState {acc}) c = component {acc = c : acc} 241 | -------------------------------------------------------------------------------- /src/LaunchDarkly/Server/Store.hs: -------------------------------------------------------------------------------- 1 | -- | This module contains details for external store implementations. 2 | module LaunchDarkly.Server.Store 3 | ( StoreResult 4 | , FeatureKey 5 | , FeatureNamespace 6 | , PersistentDataStore (..) 7 | , SerializedItemDescriptor (..) 8 | , serializeWithPlaceholder 9 | , byteStringToVersionedData 10 | ) where 11 | 12 | import LaunchDarkly.Server.Store.Internal 13 | -------------------------------------------------------------------------------- /src/LaunchDarkly/Server/Util.hs: -------------------------------------------------------------------------------- 1 | module LaunchDarkly.Server.Util 2 | ( fst3 3 | , snd3 4 | , trd 5 | ) 6 | where 7 | 8 | -- | 9 | -- Returns the first element of a 3-tuple. 10 | fst3 :: (a, b, c) -> a 11 | fst3 (x, _, _) = x 12 | 13 | -- | 14 | -- Returns the second element of a 3-tuple. 15 | snd3 :: (a, b, c) -> b 16 | snd3 (_, x, _) = x 17 | 18 | -- | 19 | -- Returns the third element of a 3-tuple. 20 | trd :: (a, b, c) -> c 21 | trd (_, _, x) = x 22 | -------------------------------------------------------------------------------- /stack.yaml: -------------------------------------------------------------------------------- 1 | resolver: lts-16.31 2 | 3 | packages: 4 | - . 5 | -------------------------------------------------------------------------------- /test-data/filesource/all-properties.json: -------------------------------------------------------------------------------- 1 | { 2 | "flags": { 3 | "flag1": { 4 | "key": "flag1", 5 | "on": true, 6 | "fallthrough": { 7 | "variation": 2 8 | }, 9 | "variations": [ "fall", "off", "on" ] 10 | } 11 | }, 12 | "flagValues": { 13 | "flag2": "value2" 14 | }, 15 | "segments": { 16 | "seg1": { 17 | "key": "seg1", 18 | "included": ["user1"] 19 | } 20 | } 21 | } 22 | -------------------------------------------------------------------------------- /test-data/filesource/all-properties.yml: -------------------------------------------------------------------------------- 1 | --- 2 | flags: 3 | flag1: 4 | key: flag1 5 | "on": true 6 | fallthrough: 7 | variation: 2 8 | variations: 9 | - fall 10 | - "off" 11 | - "on" 12 | flagValues: 13 | flag2: value2 14 | segments: 15 | seg1: 16 | key: seg1 17 | included: ["user1"] 18 | -------------------------------------------------------------------------------- /test-data/filesource/flag-only.json: -------------------------------------------------------------------------------- 1 | { 2 | "flags": { 3 | "flag1": { 4 | "key": "flag1", 5 | "on": true, 6 | "fallthrough": { 7 | "variation": 2 8 | }, 9 | "variations": [ "fall", "off", "on" ] 10 | } 11 | } 12 | } -------------------------------------------------------------------------------- /test-data/filesource/flag-with-duplicate-key.json: -------------------------------------------------------------------------------- 1 | { 2 | "flags": { 3 | "another": { 4 | "key": "another", 5 | "on": true, 6 | "fallthrough": { 7 | "variation": 0 8 | }, 9 | "variations": [ 10 | "fall", 11 | "off", 12 | "on" 13 | ] 14 | }, 15 | "flag1": { 16 | "key": "flag1", 17 | "on": false, 18 | "fallthrough": { 19 | "variation": 0 20 | }, 21 | "variations": [ 22 | "fall", 23 | "off", 24 | "on" 25 | ] 26 | } 27 | } 28 | } 29 | -------------------------------------------------------------------------------- /test-data/filesource/malformed.json: -------------------------------------------------------------------------------- 1 | { 2 | -------------------------------------------------------------------------------- /test-data/filesource/no-data.json: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/launchdarkly/haskell-server-sdk/bb9631661ef92bd89ad95af44ffcfed2abe9a25e/test-data/filesource/no-data.json -------------------------------------------------------------------------------- /test-data/filesource/segment-only.json: -------------------------------------------------------------------------------- 1 | { 2 | "segments": { 3 | "seg1": { 4 | "key": "seg1", 5 | "included": ["user1"] 6 | } 7 | } 8 | } 9 | -------------------------------------------------------------------------------- /test-data/filesource/segment-with-duplicate-key.json: -------------------------------------------------------------------------------- 1 | { 2 | "segments": { 3 | "another": { 4 | "key": "another", 5 | "included": [] 6 | }, 7 | "seg1": { 8 | "key": "seg1", 9 | "included": ["user1a"] 10 | } 11 | } 12 | } 13 | -------------------------------------------------------------------------------- /test-data/filesource/targets.json: -------------------------------------------------------------------------------- 1 | { 2 | "flags": { 3 | "flag1": { 4 | "key": "flag1", 5 | "on": true, 6 | "targets": [ 7 | { 8 | "values": ["user1"], 9 | "variation": 0 10 | } 11 | ], 12 | "contextTargets": [ 13 | { 14 | "values": [], 15 | "variation": 0, 16 | "contextKind": "user" 17 | }, 18 | { 19 | "values": ["org1"], 20 | "variation": 1, 21 | "contextKind": "org" 22 | } 23 | ], 24 | "fallthrough": { 25 | "variation": 3 26 | }, 27 | "variations": [ "user", "org", "fall" ] 28 | } 29 | }, 30 | "flagValues": {}, 31 | "segments": {} 32 | } 33 | -------------------------------------------------------------------------------- /test-data/filesource/targets.yml: -------------------------------------------------------------------------------- 1 | --- 2 | flags: 3 | flag1: 4 | key: flag1 5 | "on": true 6 | targets: 7 | - values: ["user1"] 8 | variation: 0 9 | contextTargets: 10 | - values: [] 11 | variation: 0 12 | contextKind: "user" 13 | - values: ["org1"] 14 | variation: 1 15 | contextKind: "org" 16 | fallthrough: 17 | variation: 3 18 | variations: 19 | - "user" 20 | - "org" 21 | - "fall" 22 | -------------------------------------------------------------------------------- /test-data/filesource/value-only.json: -------------------------------------------------------------------------------- 1 | 2 | { 3 | "flagValues": { 4 | "flag2": "value2" 5 | } 6 | } -------------------------------------------------------------------------------- /test-data/filesource/value-with-duplicate-key.json: -------------------------------------------------------------------------------- 1 | { 2 | "flagValues": { 3 | "flag1": "value1", 4 | "flag2": "value2a" 5 | } 6 | } -------------------------------------------------------------------------------- /test/Spec.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import Test.HUnit (Counts (..), Test (TestLabel, TestList), runTestTT) 4 | 5 | import Control.Monad.Cont (when) 6 | import qualified Spec.Bucket 7 | import qualified Spec.Client 8 | import qualified Spec.Config 9 | import qualified Spec.Context 10 | import qualified Spec.DataSource 11 | import qualified Spec.Evaluate 12 | import qualified Spec.Features 13 | import qualified Spec.Integrations.FileData 14 | import qualified Spec.Integrations.TestData 15 | import qualified Spec.Operators 16 | import qualified Spec.PersistentDataStore 17 | import qualified Spec.Reference 18 | import qualified Spec.Segment 19 | import qualified Spec.Store 20 | import qualified Spec.Streaming 21 | import System.Exit (ExitCode (ExitFailure), exitWith) 22 | 23 | main :: IO () 24 | main = do 25 | Counts {..} <- 26 | runTestTT $ 27 | TestList 28 | [ Spec.Bucket.allTests 29 | , Spec.Client.allTests 30 | , Spec.Config.allTests 31 | , Spec.Context.allTests 32 | , Spec.DataSource.allTests 33 | , Spec.Evaluate.allTests 34 | , Spec.Features.allTests 35 | , Spec.Operators.allTests 36 | , Spec.Reference.allTests 37 | , Spec.Segment.allTests 38 | , Spec.Store.allTests 39 | , Spec.PersistentDataStore.allTests 40 | , Spec.Streaming.allTests 41 | , TestLabel "Integration.FileData" Spec.Integrations.FileData.allTests 42 | , TestLabel "Integration.TestData" Spec.Integrations.TestData.allTests 43 | ] 44 | when (errors + failures > 0) $ exitWith (ExitFailure 1) 45 | -------------------------------------------------------------------------------- /test/Spec/Bucket.hs: -------------------------------------------------------------------------------- 1 | module Spec.Bucket (allTests) where 2 | 3 | import Data.Aeson.Types (Value (..)) 4 | import Data.Function ((&)) 5 | import Test.HUnit 6 | 7 | import LaunchDarkly.Server.Context (makeContext, withAttribute) 8 | import LaunchDarkly.Server.Evaluate 9 | import LaunchDarkly.Server.Features 10 | 11 | testBucketUserByKey :: Test 12 | testBucketUserByKey = 13 | TestList 14 | [ TestCase $ assertEqual "bucket one" (Just 0.42157587) (bucketContext (makeContext "userKeyA" "user") (Just "user") "hashKey" "key" "saltyA" Nothing) 15 | , TestCase $ assertEqual "bucket two" (Just 0.6708485) (bucketContext (makeContext "userKeyB" "user") (Just "user") "hashKey" "key" "saltyA" Nothing) 16 | , TestCase $ assertEqual "bucket three" (Just 0.10343106) (bucketContext (makeContext "userKeyC" "user") (Just "user") "hashKey" "key" "saltyA" Nothing) 17 | ] 18 | 19 | testBucketUserByUnknownKind :: Test 20 | testBucketUserByUnknownKind = 21 | TestList 22 | [ TestCase $ assertEqual "bucket one" (Just 0.42157587) (bucketContext (makeContext "userKeyA" "user") (Just "user") "hashKey" "key" "saltyA" Nothing) 23 | , TestCase $ assertEqual "bucket one" Nothing (bucketContext (makeContext "userKeyA" "org") (Just "user") "hashKey" "key" "saltyA" Nothing) 24 | , TestCase $ assertEqual "bucket one" Nothing (bucketContext (makeContext "userKeyA" "user") (Just "org") "hashKey" "key" "saltyA" Nothing) 25 | ] 26 | 27 | testBucketUserWithSeed :: Test 28 | testBucketUserWithSeed = 29 | TestList 30 | [ TestCase $ assertEqual "bucket one" (Just 0.09801207) (bucketContext (makeContext "userKeyA" "user") (Just "user") "hashKey" "key" "saltyA" (Just 61)) 31 | , TestCase $ assertEqual "bucket two" (Just 0.14483777) (bucketContext (makeContext "userKeyB" "user") (Just "user") "hashKey" "key" "saltyA" (Just 61)) 32 | , TestCase $ assertEqual "bucket three" (Just 0.9242641) (bucketContext (makeContext "userKeyC" "user") (Just "user") "hashKey" "key" "saltyA" (Just 61)) 33 | ] 34 | 35 | testBucketUserByIntAttr :: Test 36 | testBucketUserByIntAttr = 37 | TestList 38 | [ TestCase $ assertEqual "intAttr" (Just 0.54771423) $ bucketContext (makeContext "userKeyD" "user" & withAttribute "intAttr" (Number 33333)) (Just "user") "hashKey" "intAttr" "saltyA" Nothing 39 | , TestCase $ assertEqual "stringAttr" (Just 0.54771423) $ bucketContext (makeContext "userKeyD" "user" & withAttribute "stringAttr" (String "33333")) (Just "user") "hashKey" "stringAttr" "saltyA" Nothing 40 | ] 41 | 42 | testBucketUserByFloatAttrNotAllowed :: Test 43 | testBucketUserByFloatAttrNotAllowed = (~=?) (Just 0) $ bucketContext (makeContext "userKeyE" "user" & withAttribute "floatAttr" (Number 999.999)) (Just "user") "hashKey" "floatAttr" "saltyA" Nothing 44 | 45 | testBucketUserByFloatAttrThatIsReallyAnIntIsAllowed :: Test 46 | testBucketUserByFloatAttrThatIsReallyAnIntIsAllowed = (~=?) (Just 0.54771423) $ bucketContext (makeContext "userKeyE" "user" & withAttribute "floatAttr" (Number 33333)) (Just "user") "hashKey" "floatAttr" "saltyA" Nothing 47 | 48 | testVariationIndexForUser :: Test 49 | testVariationIndexForUser = TestCase $ do 50 | assertEqual "test" (Just 0, False) $ variationIndexForContext rollout (makeContext "userKeyA" "user") "hashKey" "saltyA" 51 | assertEqual "test" (Just 1, True) $ variationIndexForContext rollout (makeContext "userKeyB" "user") "hashKey" "saltyA" 52 | assertEqual "test" (Just 0, False) $ variationIndexForContext rollout (makeContext "userKeyC" "user") "hashKey" "saltyA" 53 | where 54 | rollout = 55 | VariationOrRollout 56 | { variation = Nothing 57 | , rollout = 58 | Just 59 | Rollout 60 | { bucketBy = Nothing 61 | , seed = Nothing 62 | , kind = RolloutKindExperiment 63 | , contextKind = Just "user" 64 | , variations = 65 | [ WeightedVariation 66 | { variation = 0 67 | , weight = 60000 68 | , untracked = True 69 | } 70 | , WeightedVariation 71 | { variation = 1 72 | , weight = 40000 73 | , untracked = False 74 | } 75 | ] 76 | } 77 | } 78 | 79 | allTests :: Test 80 | allTests = 81 | TestList 82 | [ testBucketUserByKey 83 | , testBucketUserByUnknownKind 84 | , testBucketUserWithSeed 85 | , testBucketUserByIntAttr 86 | , testBucketUserByFloatAttrNotAllowed 87 | , testBucketUserByFloatAttrThatIsReallyAnIntIsAllowed 88 | , testVariationIndexForUser 89 | ] 90 | -------------------------------------------------------------------------------- /test/Spec/Client.hs: -------------------------------------------------------------------------------- 1 | module Spec.Client (allTests) where 2 | 3 | import Data.Function ((&)) 4 | import Data.Generics.Product (getField) 5 | import Test.HUnit 6 | 7 | import LaunchDarkly.Server.Client 8 | import LaunchDarkly.Server.Config 9 | import LaunchDarkly.Server.Context 10 | import LaunchDarkly.Server.Store.Internal 11 | 12 | import Data.Text (Text) 13 | 14 | makeEmptyStore :: IO (StoreHandle IO) 15 | makeEmptyStore = do 16 | handle <- makeStoreIO Nothing 0 17 | initializeStore handle mempty mempty 18 | pure handle 19 | 20 | testSecureModeHashIsGeneratedCorrectly :: Test 21 | testSecureModeHashIsGeneratedCorrectly = TestCase $ do 22 | client <- makeTestClient "secret" 23 | assertEqual "" "aa747c502a898200f9e4fa21bac68136f886a0e27aec70ba06daf2e2a5cb5597" (secureModeHash client userContext) 24 | assertEqual "" "a045e65c6d23bda4559ed4f2371a2508ce63016ceff58b00aa07b435e2bfedaa" (secureModeHash client orgContext) 25 | where 26 | userContext = makeContext "Message" "user" 27 | orgContext = makeContext "Message" "org" 28 | 29 | makeTestClient :: Text -> IO Client 30 | makeTestClient sdkKey = do 31 | client <- makeClient $ (makeConfig sdkKey) & configSetOffline True 32 | initializeStore (getField @"store" client) mempty mempty 33 | pure client 34 | 35 | allTests :: Test 36 | allTests = 37 | TestList 38 | [ testSecureModeHashIsGeneratedCorrectly 39 | ] 40 | -------------------------------------------------------------------------------- /test/Spec/Config.hs: -------------------------------------------------------------------------------- 1 | module Spec.Config (allTests) where 2 | 3 | import Control.Lens ((&)) 4 | import LaunchDarkly.Server (makeApplicationInfo) 5 | import LaunchDarkly.Server.Config.Internal (getApplicationInfoHeader, withApplicationValue) 6 | import Test.HUnit 7 | 8 | testEmptyApplicationInfoGeneratesNoHeader :: Test 9 | testEmptyApplicationInfoGeneratesNoHeader = TestCase $ do 10 | assertEqual "" Nothing $ getApplicationInfoHeader $ makeApplicationInfo 11 | 12 | testEmptyApplicationInfoIgnoresInvalidKeys :: Test 13 | testEmptyApplicationInfoIgnoresInvalidKeys = TestCase $ do 14 | assertEqual "" emptyInfo modified 15 | where 16 | emptyInfo = makeApplicationInfo 17 | modified = 18 | withApplicationValue "invalid-key" "value" emptyInfo 19 | & withApplicationValue "another-invalid-key" "value" 20 | 21 | testEmptyApplicationInfoIgnoresInvalidValues :: Test 22 | testEmptyApplicationInfoIgnoresInvalidValues = TestCase $ do 23 | assertEqual "" emptyInfo modified 24 | where 25 | emptyInfo = makeApplicationInfo 26 | modified = 27 | withApplicationValue "id" " " emptyInfo 28 | & withApplicationValue "id" "&" 29 | & withApplicationValue "id" "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789._-a" 30 | 31 | testCorrectlyGeneratesHeaderText :: Test 32 | testCorrectlyGeneratesHeaderText = TestCase $ do 33 | assertEqual "" (Just "application-id/my-id application-version/my-version") value 34 | assertEqual "" (Just "application-id/my-id application-version/my-version") ignoreError 35 | where 36 | info = 37 | makeApplicationInfo 38 | & withApplicationValue "id" "my-id" 39 | & withApplicationValue "version" "my-version" 40 | value = getApplicationInfoHeader info 41 | ignoreError = withApplicationValue "version" "should-ignore-@me" info & getApplicationInfoHeader 42 | 43 | allTests :: Test 44 | allTests = 45 | TestList 46 | [ testEmptyApplicationInfoGeneratesNoHeader 47 | , testEmptyApplicationInfoIgnoresInvalidKeys 48 | , testEmptyApplicationInfoIgnoresInvalidValues 49 | , testCorrectlyGeneratesHeaderText 50 | ] 51 | -------------------------------------------------------------------------------- /test/Spec/DataSource.hs: -------------------------------------------------------------------------------- 1 | module Spec.DataSource (allTests) where 2 | 3 | import Test.HUnit 4 | 5 | allTests :: Test 6 | allTests = 7 | TestList [] 8 | -------------------------------------------------------------------------------- /test/Spec/Features.hs: -------------------------------------------------------------------------------- 1 | module Spec.Features (allTests) where 2 | 3 | import Data.Aeson 4 | import Data.ByteString.Lazy 5 | import Data.Text as T 6 | import LaunchDarkly.Server.Features 7 | import Test.HUnit 8 | 9 | assertFlagClientAvailabilityValues :: ByteString -> Bool -> Bool -> Bool -> IO () 10 | assertFlagClientAvailabilityValues jsonString expectedExplicit expectedUsingMobileKey expectedUsingEnvironmentId = 11 | case (decode jsonString) of 12 | Just Flag {clientSideAvailability = ClientSideAvailability {usingMobileKey = usingMobileKey, usingEnvironmentId = usingEnvironmentId, explicit = explicit}, ..} -> do 13 | assertEqual "explicit did not match expected value" expectedExplicit explicit 14 | assertEqual "usingEnvironmentId did not match expected value" expectedUsingEnvironmentId usingEnvironmentId 15 | assertEqual "usingMobileKey did not match expected value" expectedUsingMobileKey usingMobileKey 16 | Nothing -> assertFailure "Failed to decode into flag" 17 | 18 | testCanDecodeOldSchema :: Test 19 | testCanDecodeOldSchema = TestCase $ do 20 | let json = 21 | "{\ 22 | \\"trackEventsFallthrough\":false,\ 23 | \\"rules\":[],\ 24 | \\"offVariation\":null,\ 25 | \\"fallthrough\":{\"rollout\":null,\ 26 | \\"variation\":null},\ 27 | \\"key\":\"flag-key\",\ 28 | \\"version\":1,\ 29 | \\"variations\":[],\ 30 | \\"salt\":\"\",\ 31 | \\"targets\":[],\ 32 | \\"prerequisites\":[],\ 33 | \\"deleted\":false,\ 34 | \\"trackEvents\":false,\ 35 | \\"debugEventsUntilDate\":null,\ 36 | \\"on\":true,\ 37 | \\"clientSide\": true\ 38 | \}" 39 | assertFlagClientAvailabilityValues json False True True 40 | case decode json :: Maybe Flag of 41 | Just flag -> do 42 | assertBool "Re-encoding retains clientSide" ("clientSide\": true" `T.isInfixOf` json) 43 | assertBool "Re-encoding does not include new clientSideAvailability" (not $ "clientSideAvailability" `T.isInfixOf` json) 44 | Nothing -> assertFailure "Failed to decode into flag" 45 | 46 | testCanDecodeNewSchema :: Test 47 | testCanDecodeNewSchema = TestCase $ do 48 | let json = 49 | "{\ 50 | \\"trackEventsFallthrough\":false,\ 51 | \\"rules\":[],\ 52 | \\"offVariation\":null,\ 53 | \\"fallthrough\":{\"rollout\":null,\ 54 | \\"variation\":null},\ 55 | \\"key\":\"flag-key\",\ 56 | \\"version\":1,\ 57 | \\"variations\":[],\ 58 | \\"salt\":\"\",\ 59 | \\"targets\":[],\ 60 | \\"prerequisites\":[],\ 61 | \\"deleted\":false,\ 62 | \\"trackEvents\":false,\ 63 | \\"debugEventsUntilDate\":null,\ 64 | \\"on\":true,\ 65 | \\"clientSideAvailability\": {\ 66 | \\"usingMobileKey\": false,\ 67 | \\"usingEnvironmentId\": false\ 68 | \}\ 69 | \}" 70 | assertFlagClientAvailabilityValues json True False False 71 | case decode json :: Maybe Flag of 72 | Just flag -> do 73 | assertBool "Re-encoding does not include clientSide" (not $ ("clientSide\": true" `T.isInfixOf` json)) 74 | assertBool "Re-encoding does include new clientSideAvailability" ("clientSideAvailability" `T.isInfixOf` json) 75 | assertBool "Re-encoding sets usingMobileKey correctly" ("usingMobileKey\": false" `T.isInfixOf` json) 76 | assertBool "Re-encoding sets usingEnvironmentId correctly" ("usingEnvironmentId\": false" `T.isInfixOf` json) 77 | Nothing -> assertFailure "Failed to decode into flag" 78 | 79 | allTests :: Test 80 | allTests = 81 | TestList 82 | [ testCanDecodeNewSchema 83 | , testCanDecodeOldSchema 84 | ] 85 | -------------------------------------------------------------------------------- /test/Spec/Integrations/FileData.hs: -------------------------------------------------------------------------------- 1 | module Spec.Integrations.FileData (allTests) 2 | where 3 | 4 | import Test.HUnit 5 | 6 | import Control.Exception 7 | import Control.Monad.Logger 8 | import Data.Generics.Product (getField) 9 | import qualified Data.HashSet as HS 10 | import LaunchDarkly.AesonCompat (emptyObject) 11 | import LaunchDarkly.Server 12 | import LaunchDarkly.Server.Client.Internal 13 | import LaunchDarkly.Server.DataSource.Internal 14 | import LaunchDarkly.Server.Features (Segment (..)) 15 | import LaunchDarkly.Server.Integrations.FileData 16 | import LaunchDarkly.Server.Store.Internal (storeHandleGetSegment) 17 | 18 | allTests :: Test 19 | allTests = 20 | TestList 21 | [ TestLabel "testAllProperties" testAllProperties 22 | , TestLabel "testTargettingJson" testTargettingJson 23 | , TestLabel "testTargettingYaml" testTargettingYaml 24 | , TestLabel "testMultiFileFlagDuplicate" testMultiFileFlagDuplicate 25 | , TestLabel "testMalformedFile" testMalformedFile 26 | , TestLabel "testNoDataFile" testNoDataFile 27 | , TestLabel "testSegmentFile" testSegmentFile 28 | , TestLabel "testAllPropertiesYaml" testAllPropertiesYaml 29 | ] 30 | 31 | withClient :: Config -> (Client -> IO a) -> IO a 32 | withClient config = bracket (makeClient config) close 33 | 34 | testConfig :: DataSourceFactory -> Config 35 | testConfig factory = 36 | configSetSendEvents False $ 37 | configSetDataSourceFactory (Just factory) $ 38 | configSetLogger (runStdoutLoggingT . filterLogger (\_ lvl -> lvl /= LevelDebug)) $ 39 | makeConfig "sdk-key" 40 | 41 | testAllProperties :: Test 42 | testAllProperties = TestCase $ do 43 | let factory = dataSourceFactory ["test-data/filesource/all-properties.json"] 44 | config = testConfig factory 45 | user1 = makeContext "user1" "user" 46 | user2 = makeContext "user2" "user" 47 | withClient config $ \client -> do 48 | status <- getStatus client 49 | assertEqual "status initialized" Initialized status 50 | 51 | flag1 <- stringVariation client "flag1" user1 "fallback" 52 | assertEqual "flag1 value" "on" flag1 53 | 54 | flag2 <- stringVariation client "flag2" user1 "fallback" 55 | assertEqual "flag2 value" "value2" flag2 56 | 57 | testTargettingJson :: Test 58 | testTargettingJson = TestCase $ do 59 | let factory = dataSourceFactory ["test-data/filesource/targets.json"] 60 | config = testConfig factory 61 | user1 = makeContext "user1" "user" 62 | user2 = makeContext "user2" "user" 63 | org1 = makeContext "org1" "org" 64 | org2 = makeContext "org2" "org" 65 | withClient config $ \client -> do 66 | status <- getStatus client 67 | assertEqual "status initialized" Initialized status 68 | 69 | flag1 <- stringVariation client "flag1" user1 "fall" 70 | assertEqual "flag1 user1" "user" flag1 71 | 72 | flag1 <- stringVariation client "flag1" user2 "fall" 73 | assertEqual "flag1 user2" "fall" flag1 74 | 75 | flag1 <- stringVariation client "flag1" org1 "fall" 76 | assertEqual "flag1 org1" "org" flag1 77 | 78 | flag1 <- stringVariation client "flag1" org2 "fall" 79 | assertEqual "flag1 org2" "fall" flag1 80 | 81 | testTargettingYaml :: Test 82 | testTargettingYaml = TestCase $ do 83 | let factory = dataSourceFactory ["test-data/filesource/targets.yml"] 84 | config = testConfig factory 85 | user1 = makeContext "user1" "user" 86 | user2 = makeContext "user2" "user" 87 | org1 = makeContext "org1" "org" 88 | org2 = makeContext "org2" "org" 89 | withClient config $ \client -> do 90 | status <- getStatus client 91 | assertEqual "status initialized" Initialized status 92 | 93 | flag1 <- stringVariation client "flag1" user1 "fall" 94 | assertEqual "flag1 user1" "user" flag1 95 | 96 | flag1 <- stringVariation client "flag1" user2 "fall" 97 | assertEqual "flag1 user2" "fall" flag1 98 | 99 | flag1 <- stringVariation client "flag1" org1 "fall" 100 | assertEqual "flag1 org1" "org" flag1 101 | 102 | flag1 <- stringVariation client "flag1" org2 "fall" 103 | assertEqual "flag1 org2" "fall" flag1 104 | 105 | testMultiFileFlagDuplicate :: Test 106 | testMultiFileFlagDuplicate = TestCase $ do 107 | let factory = 108 | dataSourceFactory 109 | [ "test-data/filesource/flag-only.json" 110 | , "test-data/filesource/flag-with-duplicate-key.json" 111 | ] 112 | config = testConfig factory 113 | user1 = makeContext "user1" "user" 114 | withClient config $ \client -> do 115 | status <- getStatus client 116 | assertEqual "status initialized" Initialized status 117 | 118 | flag1 <- stringVariation client "flag1" user1 "fallback" 119 | assertEqual "flag1 value" "on" flag1 120 | 121 | anotherFlag <- stringVariation client "another" user1 "fallback" 122 | assertEqual "flag2 value" "fall" anotherFlag 123 | 124 | testMalformedFile :: Test 125 | testMalformedFile = TestCase $ do 126 | let factory = dataSourceFactory ["test-data/filesource/malformed.json"] 127 | config = testConfig factory 128 | user1 = makeContext "user1" "user" 129 | withClient config $ \client -> do 130 | (\state -> assertEqual "No Flags set" emptyObject (getField @"evaluations" state)) 131 | =<< allFlagsState client user1 False False False 132 | 133 | testNoDataFile :: Test 134 | testNoDataFile = TestCase $ do 135 | let factory = dataSourceFactory ["test-data/filesource/no-data.json"] 136 | config = testConfig factory 137 | user1 = makeContext "user1" "user" 138 | withClient config $ \client -> do 139 | (\state -> assertEqual "No Flags set" emptyObject (getField @"evaluations" state)) 140 | =<< allFlagsState client user1 False False False 141 | 142 | testSegmentFile :: Test 143 | testSegmentFile = TestCase $ do 144 | let factory = dataSourceFactory ["test-data/filesource/segment-only.json"] 145 | config = testConfig factory 146 | withClient config $ \client -> do 147 | eSeg1 <- storeHandleGetSegment (store client) "seg1" 148 | mSeg1 <- either (assertFailure . show) pure eSeg1 149 | seg1 <- maybe (assertFailure "Segment Not Found") pure mSeg1 150 | assertEqual "Segment" (included seg1) (HS.fromList ["user1"]) 151 | 152 | eSeg2 <- storeHandleGetSegment (store client) "seg2" 153 | mSeg2 <- either (assertFailure . show) pure eSeg2 154 | assertEqual "No Segment" Nothing mSeg2 155 | 156 | testAllPropertiesYaml :: Test 157 | testAllPropertiesYaml = TestCase $ do 158 | let factory = dataSourceFactory ["test-data/filesource/all-properties.yml"] 159 | config = testConfig factory 160 | user1 = makeContext "user1" "user" 161 | user2 = makeContext "user2" "user" 162 | withClient config $ \client -> do 163 | status <- getStatus client 164 | assertEqual "status initialized" Initialized status 165 | 166 | flag1 <- stringVariation client "flag1" user1 "fallback" 167 | assertEqual "flag1 value" "on" flag1 168 | 169 | flag2 <- stringVariation client "flag2" user1 "fallback" 170 | assertEqual "flag2 value" "value2" flag2 171 | -------------------------------------------------------------------------------- /test/Spec/Integrations/TestData.hs: -------------------------------------------------------------------------------- 1 | module Spec.Integrations.TestData (allTests) 2 | where 3 | 4 | import Test.HUnit 5 | 6 | import Data.Aeson (ToJSON, toJSON) 7 | import Data.Function ((&)) 8 | import Data.Functor ((<&>)) 9 | import Data.Text (Text) 10 | import GHC.Generics (Generic) 11 | 12 | import Control.Monad.Logger 13 | import LaunchDarkly.Server 14 | import LaunchDarkly.Server.DataSource.Internal 15 | import qualified LaunchDarkly.Server.Integrations.TestData as TestData 16 | 17 | allTests :: Test 18 | allTests = 19 | TestList 20 | [ testVariationForAll 21 | , testMultipleFlags 22 | , testModifyFlags 23 | , testMultipleClients 24 | , testTargeting 25 | , testRules 26 | , testValueForAll 27 | ] 28 | 29 | testConfig :: DataSourceFactory -> Config 30 | testConfig factory = 31 | configSetSendEvents False $ 32 | configSetDataSourceFactory (Just factory) $ 33 | configSetLogger (runStdoutLoggingT . filterLogger (\_ lvl -> lvl /= LevelDebug)) $ 34 | makeConfig "sdk-key" 35 | 36 | testVariationForAll :: Test 37 | testVariationForAll = TestCase $ do 38 | td <- TestData.newTestData 39 | TestData.update td 40 | =<< ( TestData.flag td "flag-key-1" 41 | <&> TestData.variationForAll True 42 | ) 43 | let config = testConfig (TestData.dataSourceFactory td) 44 | client <- makeClient config 45 | let user1 = makeContext "user1" "user" 46 | user2 = makeContext "user2" "user" 47 | assertEqual "user1 set" True =<< boolVariation client "flag-key-1" user1 False 48 | assertEqual "user2 set" True =<< boolVariation client "flag-key-1" user2 False 49 | assertEqual "user not set for another flag" False =<< boolVariation client "another-key" user1 False 50 | close client 51 | 52 | testModifyFlags :: Test 53 | testModifyFlags = TestCase $ do 54 | td <- TestData.newTestData 55 | TestData.update td 56 | =<< ( TestData.flag td "flag-key-1" 57 | <&> TestData.variations 58 | [ toJSON ("blue" :: Text) 59 | , toJSON ("red" :: Text) 60 | , toJSON ("green" :: Text) 61 | ] 62 | <&> TestData.variationForAll (0 :: TestData.VariationIndex) 63 | ) 64 | let config = testConfig (TestData.dataSourceFactory td) 65 | client <- makeClient config 66 | let user = makeContext "user" "user" 67 | assertEqual "user set" "blue" =<< stringVariation client "flag-key-1" user "none" 68 | 69 | TestData.update td 70 | =<< ( TestData.flag td "flag-key-1" 71 | <&> TestData.variationForAll (2 :: TestData.VariationIndex) 72 | ) 73 | 74 | assertEqual "user set to green after update" "green" =<< stringVariation client "flag-key-1" user "none" 75 | close client 76 | 77 | testMultipleFlags :: Test 78 | testMultipleFlags = TestCase $ do 79 | td <- TestData.newTestData 80 | TestData.update td 81 | =<< ( TestData.flag td "flag-key-1" 82 | <&> TestData.variations 83 | [ toJSON ("blue" :: Text) 84 | , toJSON ("red" :: Text) 85 | , toJSON ("green" :: Text) 86 | ] 87 | <&> TestData.variationForAll (0 :: TestData.VariationIndex) 88 | ) 89 | TestData.update td 90 | =<< ( TestData.flag td "flag-key-2" 91 | <&> TestData.variationForAll True 92 | ) 93 | let config = testConfig (TestData.dataSourceFactory td) 94 | client <- makeClient config 95 | let user = makeContext "user" "user" 96 | assertEqual "flag 1" "blue" =<< stringVariation client "flag-key-1" user "none" 97 | assertEqual "flag 2" True =<< boolVariation client "flag-key-2" user False 98 | close client 99 | 100 | testMultipleClients :: Test 101 | testMultipleClients = TestCase $ do 102 | td <- TestData.newTestData 103 | let config = testConfig (TestData.dataSourceFactory td) 104 | client1 <- makeClient config 105 | client2 <- makeClient config 106 | let user = makeContext "user" "user" 107 | TestData.update td 108 | =<< ( TestData.flag td "flag-key-1" 109 | <&> TestData.variations 110 | [ toJSON ("blue" :: Text) 111 | , toJSON ("red" :: Text) 112 | , toJSON ("green" :: Text) 113 | ] 114 | <&> TestData.variationForAll (0 :: TestData.VariationIndex) 115 | ) 116 | assertEqual "client1 recieved update" "blue" =<< stringVariation client1 "flag-key-1" user "none" 117 | assertEqual "client2 recieved update" "blue" =<< stringVariation client2 "flag-key-1" user "none" 118 | close client2 119 | TestData.update td 120 | =<< ( TestData.flag td "flag-key-1" 121 | <&> TestData.variationForAll (2 :: TestData.VariationIndex) 122 | ) 123 | 124 | assertEqual "client1 recieved update to green" "green" =<< stringVariation client1 "flag-key-1" user "none" 125 | assertEqual "client2 no update after close" "none" =<< stringVariation client2 "flag-key-1" user "none" 126 | close client1 127 | 128 | testTargeting :: Test 129 | testTargeting = TestCase $ do 130 | td <- TestData.newTestData 131 | TestData.update td 132 | =<< ( TestData.flag td "flag-key-1" 133 | <&> TestData.variations 134 | [ toJSON ("blue" :: Text) 135 | , toJSON ("red" :: Text) 136 | , toJSON ("green" :: Text) 137 | ] 138 | <&> TestData.variationForUser "ben" (0 :: TestData.VariationIndex) 139 | <&> TestData.variationForUser "todd" (0 :: TestData.VariationIndex) 140 | <&> TestData.variationForKey "org" "ben" (0 :: TestData.VariationIndex) 141 | <&> TestData.offVariation (1 :: TestData.VariationIndex) 142 | <&> TestData.fallthroughVariation (2 :: TestData.VariationIndex) 143 | ) 144 | let config = testConfig (TestData.dataSourceFactory td) 145 | ben = makeContext "ben" "user" 146 | todd = makeContext "todd" "user" 147 | evelyn = makeContext "evelyn" "user" 148 | benAsOrg = makeContext "ben" "org" 149 | toddAsOrg = makeContext "todd" "org" 150 | 151 | client <- makeClient config 152 | 153 | assertEqual "ben receives blue" "blue" =<< stringVariation client "flag-key-1" ben "none" 154 | assertEqual "todd receives blue" "blue" =<< stringVariation client "flag-key-1" todd "none" 155 | assertEqual "evelyn receives green" "green" =<< stringVariation client "flag-key-1" evelyn "none" 156 | assertEqual "ben as org receives blue" "blue" =<< stringVariation client "flag-key-1" benAsOrg "none" 157 | assertEqual "todd as org receives green" "green" =<< stringVariation client "flag-key-1" toddAsOrg "none" 158 | TestData.update td 159 | =<< ( TestData.flag td "flag-key-1" 160 | <&> TestData.on False 161 | ) 162 | 163 | assertEqual "targeting off ben receives red" "red" =<< stringVariation client "flag-key-1" ben "none" 164 | assertEqual "targeting off todd receives red" "red" =<< stringVariation client "flag-key-1" todd "none" 165 | assertEqual "targeting off evelyn receives red" "red" =<< stringVariation client "flag-key-1" evelyn "none" 166 | assertEqual "targeting off ben as org receives red" "red" =<< stringVariation client "flag-key-1" benAsOrg "none" 167 | assertEqual "targeting off todd as org receives red" "red" =<< stringVariation client "flag-key-1" toddAsOrg "none" 168 | 169 | close client 170 | 171 | testRules :: Test 172 | testRules = TestCase $ do 173 | td <- TestData.newTestData 174 | TestData.update td 175 | =<< ( TestData.flag td "flag-key-1" 176 | <&> TestData.variations 177 | [ toJSON ("blue" :: Text) 178 | , toJSON ("red" :: Text) 179 | , toJSON ("green" :: Text) 180 | ] 181 | <&> TestData.ifMatch "country" [toJSON ("gb" :: Text), toJSON ("usa" :: Text)] 182 | <&> TestData.andMatch "name" [toJSON ("Todd" :: Text)] 183 | <&> TestData.thenReturn (1 :: TestData.VariationIndex) 184 | <&> TestData.ifNotMatch "name" [toJSON ("Todd" :: Text)] 185 | <&> TestData.andMatch "country" [toJSON ("gb" :: Text), toJSON ("usa" :: Text)] 186 | <&> TestData.thenReturn (2 :: TestData.VariationIndex) 187 | <&> TestData.fallthroughVariation (0 :: TestData.VariationIndex) 188 | ) 189 | let config = testConfig (TestData.dataSourceFactory td) 190 | ben = 191 | makeContext "ben" "user" 192 | & withAttribute "country" "usa" 193 | & withAttribute "name" "Ben" 194 | todd = 195 | makeContext "todd" "user" 196 | & withAttribute "country" "gb" 197 | & withAttribute "name" "Todd" 198 | evelyn = makeContext "evelyn" "user" 199 | 200 | client <- makeClient config 201 | 202 | assertEqual "ben receives green" "green" =<< stringVariation client "flag-key-1" ben "none" 203 | assertEqual "todd receives red" "red" =<< stringVariation client "flag-key-1" todd "none" 204 | assertEqual "evelyn receives blue" "blue" =<< stringVariation client "flag-key-1" evelyn "none" 205 | 206 | close client 207 | 208 | data CustomType 209 | = CustomType1 210 | | CustomType2 211 | deriving (Generic, Eq, Show, ToJSON) 212 | 213 | testValueForAll :: Test 214 | testValueForAll = TestCase $ do 215 | td <- TestData.newTestData 216 | TestData.update td 217 | =<< ( TestData.flag td "flag-key-1" 218 | <&> TestData.valueForAll CustomType1 219 | ) 220 | let config = testConfig (TestData.dataSourceFactory td) 221 | ben = makeContext "ben" "user" 222 | todd = makeContext "todd" "user" 223 | 224 | client <- makeClient config 225 | 226 | assertEqual "ben receives CustomType1" "CustomType1" =<< stringVariation client "flag-key-1" ben "CustomType2" 227 | assertEqual "todd receives CustomType1" "CustomType1" =<< stringVariation client "flag-key-1" todd "CustomType2" 228 | 229 | close client 230 | -------------------------------------------------------------------------------- /test/Spec/Operators.hs: -------------------------------------------------------------------------------- 1 | module Spec.Operators (allTests) where 2 | 3 | import Data.Aeson.Types (Value (..)) 4 | import Test.HUnit 5 | 6 | import LaunchDarkly.Server.Operators 7 | 8 | dateStr1 :: Value 9 | dateStr1 = String "2017-12-06T00:00:00.000-07:00" 10 | 11 | dateStr2 :: Value 12 | dateStr2 = String "2017-12-06T00:01:01.000-07:00" 13 | 14 | invalidDate :: Value 15 | invalidDate = String "hey what's this?" 16 | 17 | dateMs1 :: Value 18 | dateMs1 = Number $ fromInteger 10000000 19 | 20 | dateMs2 :: Value 21 | dateMs2 = Number $ fromInteger 10000001 22 | 23 | makeTest :: (Op, Value, Value, Bool) -> Test 24 | makeTest f@(o, x, y, e) = TestCase $ assertEqual (show f) e $ (getOperation o) x y 25 | 26 | allTests :: Test 27 | allTests = 28 | TestList $ 29 | map 30 | makeTest 31 | -- numeric operators 32 | [ (OpIn, Number $ fromInteger 50, Number $ fromInteger 50, True) 33 | , (OpIn, Number $ fromRational 99.0001, Number $ fromRational 99.0001, True) 34 | , (OpLessThan, Number $ fromInteger 1, Number $ fromRational 1.99999, True) 35 | , (OpLessThan, Number $ fromRational 1.99999, Number $ fromInteger 1, False) 36 | , (OpLessThan, Number $ fromInteger 1, Number $ fromInteger 2, True) 37 | , (OpLessThanOrEqual, Number $ fromInteger 1, Number $ fromInteger 1, True) 38 | , (OpGreaterThan, Number $ fromInteger 2, Number $ fromRational 1.99999, True) 39 | , (OpGreaterThan, Number $ fromRational 1.99999, Number $ fromInteger 2, False) 40 | , (OpGreaterThan, Number $ fromInteger 2, Number $ fromInteger 1, True) 41 | , (OpGreaterThanOrEqual, Number $ fromInteger 1, Number $ fromInteger 1, True) 42 | , -- string operators 43 | (OpIn, String "x", String "x", True) 44 | , (OpIn, String "x", String "xyz", False) 45 | , (OpStartsWith, String "xyz", String "x", True) 46 | , (OpStartsWith, String "x", String "xyz", False) 47 | , (OpEndsWith, String "xyz", String "z", True) 48 | , (OpEndsWith, String "z", String "xyz", False) 49 | , (OpContains, String "xyz", String "y", True) 50 | , (OpContains, String "y", String "yz", False) 51 | , -- mixed strings and numbers 52 | (OpIn, String "99", Number $ fromInteger 99, False) 53 | , (OpIn, Number $ fromInteger 99, String "99", False) 54 | , (OpContains, String "99", Number $ fromInteger 99, False) 55 | , (OpStartsWith, String "99", Number $ fromInteger 99, False) 56 | , (OpEndsWith, String "99", Number $ fromInteger 99, False) 57 | , (OpLessThanOrEqual, String "99", Number $ fromInteger 99, False) 58 | , (OpLessThanOrEqual, Number $ fromInteger 99, String "99", False) 59 | , (OpGreaterThanOrEqual, String "99", Number $ fromInteger 99, False) 60 | , (OpGreaterThanOrEqual, Number $ fromInteger 99, String "99", False) 61 | , -- date operators 62 | (OpBefore, dateStr1, dateStr2, True) 63 | , (OpBefore, dateMs1, dateMs2, True) 64 | , (OpBefore, dateStr2, dateStr1, False) 65 | , (OpBefore, dateMs2, dateMs1, False) 66 | , (OpBefore, dateStr1, dateStr1, False) 67 | , (OpBefore, dateMs1, dateMs1, False) 68 | , (OpBefore, String "", dateStr1, False) 69 | , (OpBefore, dateStr1, invalidDate, False) 70 | , (OpAfter, dateStr2, dateStr1, True) 71 | , (OpAfter, dateMs2, dateMs1, True) 72 | , (OpAfter, dateStr1, dateStr2, False) 73 | , (OpAfter, dateMs1, dateMs2, False) 74 | , (OpAfter, dateStr1, dateStr1, False) 75 | , (OpAfter, dateMs1, dateMs1, False) 76 | , (OpAfter, String "", dateStr1, False) 77 | , (OpAfter, dateStr1, invalidDate, False) 78 | , -- regex 79 | (OpMatches, String "hello world", String "hello.*rld", True) 80 | , (OpMatches, String "hello world", String "hello.*orl", True) 81 | , (OpMatches, String "hello world", String "l+", True) 82 | , (OpMatches, String "hello world", String "(world|planet)", True) 83 | , (OpMatches, String "hello world", String "aloha", False) 84 | , (OpMatches, String "hello world", String "***bad rg", False) 85 | , -- semver operators 86 | (OpSemVerEqual, String "2.0.0", String "2.0.0", True) 87 | , (OpSemVerEqual, String "2.0", String "2.0.0", True) 88 | , (OpSemVerEqual, String "2.0-rc1", String "2.0.0-rc1", True) 89 | , (OpSemVerEqual, String "2+build2", String "2.0.0+build2", True) 90 | , (OpSemVerEqual, String "2.0.0", String "2.0.1", False) 91 | , (OpSemVerEqual, String "02.0.0", String "2.0.0", False) 92 | , (OpSemVerLessThan, String "2.0.0", String "2.0.1", True) 93 | , (OpSemVerLessThan, String "2.0", String "2.0.1", True) 94 | , (OpSemVerLessThan, String "2.0.1", String "2.0.0", False) 95 | , (OpSemVerLessThan, String "2.0.1", String "2.0", False) 96 | , (OpSemVerLessThan, String "2.0.1", String "xbad%ver", False) 97 | , (OpSemVerLessThan, String "2.0.0-rc", String "2.0.0-rc.beta", True) 98 | , (OpSemVerGreaterThan, String "2.0.1", String "2.0", True) 99 | , (OpSemVerGreaterThan, String "2.0.0", String "2.0.1", False) 100 | , (OpSemVerGreaterThan, String "2.0", String "2.0.1", False) 101 | , (OpSemVerGreaterThan, String "2.0.1", String "xbad%ver", False) 102 | , (OpSemVerGreaterThan, String "2.0.0-rc.1", String "2.0.0-rc.0", True) 103 | ] 104 | -------------------------------------------------------------------------------- /test/Spec/PersistentDataStore.hs: -------------------------------------------------------------------------------- 1 | module Spec.PersistentDataStore (allTests) where 2 | 3 | import Data.ByteString () 4 | import Data.Either (isLeft) 5 | import Data.Function ((&)) 6 | import Data.IORef (atomicModifyIORef', newIORef, readIORef, writeIORef) 7 | import System.Clock (TimeSpec (..)) 8 | import Test.HUnit 9 | 10 | import Util.Features (makeTestFlag) 11 | 12 | import LaunchDarkly.AesonCompat (emptyObject, insertKey, singleton) 13 | import LaunchDarkly.Server.Store.Internal 14 | 15 | makeTestStore :: Maybe PersistentDataStore -> IO (StoreHandle IO) 16 | makeTestStore backend = makeStoreIO backend $ TimeSpec 10 0 17 | 18 | makeStoreInterface :: PersistentDataStore 19 | makeStoreInterface = 20 | PersistentDataStore 21 | { persistentDataStoreAllFeatures = const $ assertFailure "allFeatures should not be called" 22 | , persistentDataStoreGetFeature = const $ const $ assertFailure "getFeatures should not be called" 23 | , persistentDataStoreUpsertFeature = const $ const $ const $ assertFailure "upsertFeature should not be called" 24 | , persistentDataStoreIsInitialized = assertFailure "isInitialized should not be called" 25 | , persistentDataStoreInitialize = const $ assertFailure "initialize should not be called" 26 | } 27 | 28 | testFailInit :: Test 29 | testFailInit = TestCase $ do 30 | store <- 31 | makeTestStore $ 32 | pure $ 33 | makeStoreInterface 34 | { persistentDataStoreInitialize = \_ -> pure $ Left "err" 35 | } 36 | initializeStore store emptyObject emptyObject >>= (Left "err" @?=) 37 | 38 | testFailGet :: Test 39 | testFailGet = TestCase $ do 40 | store <- 41 | makeTestStore $ 42 | pure $ 43 | makeStoreInterface 44 | { persistentDataStoreGetFeature = \_ _ -> pure $ Left "err" 45 | } 46 | getFlagC store "abc" >>= (Left "err" @?=) 47 | 48 | testFailAll :: Test 49 | testFailAll = TestCase $ do 50 | store <- 51 | makeTestStore $ 52 | pure $ 53 | makeStoreInterface 54 | { persistentDataStoreAllFeatures = \_ -> pure $ Left "err" 55 | } 56 | getAllFlagsC store >>= (Left "err" @?=) 57 | 58 | testFailIsInitialized :: Test 59 | testFailIsInitialized = TestCase $ do 60 | store <- 61 | makeTestStore $ 62 | pure $ 63 | makeStoreInterface 64 | { persistentDataStoreIsInitialized = pure $ Left "err" 65 | } 66 | getInitializedC store >>= (Left "err" @?=) 67 | 68 | testFailUpsert :: Test 69 | testFailUpsert = TestCase $ do 70 | store <- 71 | makeTestStore $ 72 | pure $ 73 | makeStoreInterface 74 | { persistentDataStoreUpsertFeature = \_ _ _ -> pure $ Left "err" 75 | } 76 | insertFlag store (makeTestFlag "test" 123) >>= (Left "err" @?=) 77 | 78 | testFailGetInvalidJSON :: Test 79 | testFailGetInvalidJSON = TestCase $ do 80 | store <- 81 | makeTestStore $ 82 | pure $ 83 | makeStoreInterface 84 | { persistentDataStoreGetFeature = \_ _ -> pure $ Right $ Just $ SerializedItemDescriptor (pure "invalid json") 0 False 85 | } 86 | getFlagC store "abc" >>= (\v -> True @?= isLeft v) 87 | 88 | testGetAllInvalidJSON :: Test 89 | testGetAllInvalidJSON = TestCase $ do 90 | let flag = makeTestFlag "abc" 52 91 | store <- 92 | makeTestStore $ 93 | pure $ 94 | makeStoreInterface 95 | { persistentDataStoreAllFeatures = \_ -> 96 | pure $ 97 | Right $ 98 | emptyObject 99 | & insertKey "abc" (createSerializedItemDescriptor $ ItemDescriptor (pure flag) 52) 100 | & insertKey "xyz" (SerializedItemDescriptor (pure "invalid json") 64 False) 101 | } 102 | getAllFlagsC store >>= (Right (singleton "abc" flag) @?=) 103 | 104 | testInitializedCache :: Test 105 | testInitializedCache = TestCase $ do 106 | counter <- newIORef 0 107 | value <- newIORef False 108 | store <- 109 | makeTestStore $ 110 | pure $ 111 | makeStoreInterface 112 | { persistentDataStoreIsInitialized = do 113 | atomicModifyIORef' counter (\c -> (c + 1, ())) 114 | Right <$> readIORef value 115 | } 116 | getInitializedC store >>= (Right False @=?) 117 | readIORef counter >>= (1 @=?) 118 | getInitializedC store >>= (Right False @=?) 119 | readIORef counter >>= (1 @=?) 120 | storeHandleExpireAll store >>= (Right () @=?) 121 | getInitializedC store >>= (Right False @=?) 122 | readIORef counter >>= (2 @=?) 123 | writeIORef value True 124 | storeHandleExpireAll store >>= (Right () @=?) 125 | getInitializedC store >>= (Right True @=?) 126 | readIORef counter >>= (3 @=?) 127 | getInitializedC store >>= (Right True @=?) 128 | readIORef counter >>= (3 @=?) 129 | 130 | testGetCache :: Test 131 | testGetCache = TestCase $ do 132 | counter <- newIORef 0 133 | value <- newIORef $ Just $ SerializedItemDescriptor Nothing 0 False 134 | store <- 135 | makeTestStore $ 136 | pure $ 137 | makeStoreInterface 138 | { persistentDataStoreGetFeature = \_ _ -> do 139 | atomicModifyIORef' counter (\c -> (c + 1, ())) 140 | Right <$> readIORef value 141 | } 142 | getFlagC store "abc" >>= (Right Nothing @?=) 143 | readIORef counter >>= (1 @=?) 144 | getFlagC store "abc" >>= (Right Nothing @?=) 145 | readIORef counter >>= (1 @=?) 146 | storeHandleExpireAll store >>= (Right () @=?) 147 | let flag = pure $ makeTestFlag "abc" 12 148 | writeIORef value $ Just $ createSerializedItemDescriptor $ ItemDescriptor flag 12 149 | getFlagC store "abc" >>= (Right flag @=?) 150 | readIORef counter >>= (2 @=?) 151 | getFlagC store "abc" >>= (Right flag @=?) 152 | readIORef counter >>= (2 @=?) 153 | 154 | testUpsertInvalidatesAllFlags :: Test 155 | testUpsertInvalidatesAllFlags = TestCase $ do 156 | allCounter <- newIORef 0 157 | upsertCounter <- newIORef 0 158 | upsertResult <- newIORef $ Right True 159 | store <- 160 | makeTestStore $ 161 | pure $ 162 | makeStoreInterface 163 | { persistentDataStoreUpsertFeature = \_ _ _ -> do 164 | atomicModifyIORef' upsertCounter (\c -> (c + 1, ())) 165 | readIORef upsertResult 166 | , persistentDataStoreAllFeatures = \_ -> do 167 | atomicModifyIORef' allCounter (\c -> (c + 1, ())) 168 | pure $ Right emptyObject 169 | } 170 | getAllFlagsC store >>= (Right emptyObject @=?) 171 | readIORef allCounter >>= (1 @=?) 172 | deleteFlag store "abc" 52 >>= (Right () @=?) 173 | readIORef upsertCounter >>= (1 @=?) 174 | getAllFlagsC store >>= (Right emptyObject @=?) 175 | readIORef allCounter >>= (2 @=?) 176 | writeIORef upsertResult $ Right False 177 | deleteFlag store "abc" 53 >>= (Right () @=?) 178 | readIORef upsertCounter >>= (2 @=?) 179 | getAllFlagsC store >>= (Right emptyObject @=?) 180 | readIORef allCounter >>= (2 @=?) 181 | 182 | testAllFlagsCache :: Test 183 | testAllFlagsCache = TestCase $ do 184 | counter <- newIORef 0 185 | value <- newIORef emptyObject 186 | store <- 187 | makeTestStore $ 188 | pure $ 189 | makeStoreInterface 190 | { persistentDataStoreAllFeatures = \_ -> do 191 | atomicModifyIORef' counter (\c -> (c + 1, ())) 192 | pure $ Right emptyObject 193 | } 194 | getAllFlagsC store >>= (Right emptyObject @=?) 195 | readIORef counter >>= (1 @=?) 196 | getAllFlagsC store >>= (Right emptyObject @=?) 197 | readIORef counter >>= (1 @=?) 198 | storeHandleExpireAll store >>= (Right () @=?) 199 | getAllFlagsC store >>= (Right emptyObject @=?) 200 | readIORef counter >>= (2 @=?) 201 | 202 | testAllFlagsUpdatesRegularCache :: Test 203 | testAllFlagsUpdatesRegularCache = TestCase $ do 204 | let flag = makeTestFlag "abc" 12 205 | store <- 206 | makeTestStore $ 207 | pure $ 208 | makeStoreInterface 209 | { persistentDataStoreAllFeatures = \_ -> 210 | pure $ 211 | Right $ 212 | singleton "abc" (createSerializedItemDescriptor $ ItemDescriptor (pure flag) 12) 213 | } 214 | getAllFlagsC store >>= (Right (singleton "abc" flag) @=?) 215 | getFlagC store "abc" >>= (Right (pure flag) @=?) 216 | 217 | allTests :: Test 218 | allTests = 219 | TestList 220 | [ testFailInit 221 | , testFailGet 222 | , testFailAll 223 | , testFailIsInitialized 224 | , testFailUpsert 225 | , testFailGetInvalidJSON 226 | , testGetAllInvalidJSON 227 | , testInitializedCache 228 | , testGetCache 229 | , testUpsertInvalidatesAllFlags 230 | , testAllFlagsCache 231 | , testAllFlagsUpdatesRegularCache 232 | ] 233 | -------------------------------------------------------------------------------- /test/Spec/Reference.hs: -------------------------------------------------------------------------------- 1 | module Spec.Reference (allTests) where 2 | 3 | import LaunchDarkly.Server.Reference (getComponents, getError, getRawPath, makeLiteral, makeReference) 4 | import Test.HUnit 5 | 6 | invalidReferences :: Test 7 | invalidReferences = 8 | TestCase $ 9 | ( do 10 | confirm "empty reference" "" 11 | confirm "empty reference" "/" 12 | 13 | confirm "trailing slash" "//" 14 | confirm "trailing slash" "/a/b/" 15 | confirm "double slash" "/a//b" 16 | 17 | confirm "invalid escape sequence" "/a~x" 18 | confirm "invalid escape sequence" "/a~" 19 | confirm "invalid escape sequence" "/a/b~x" 20 | confirm "invalid escape sequence" "/a/b~" 21 | ) 22 | where 23 | confirm err reference = assertEqual "" err $ getError $ makeReference reference 24 | 25 | validReferencesWithoutLeadingSlash :: Test 26 | validReferencesWithoutLeadingSlash = 27 | TestCase $ 28 | ( do 29 | confirm "key" 30 | confirm "kind" 31 | confirm "name" 32 | confirm "name/with/slashes" 33 | confirm "name~0~1with-what-looks-like-escape-sequences" 34 | ) 35 | where 36 | confirm ref = 37 | let reference = makeReference ref 38 | in ( do 39 | assertEqual "" "" $ getError reference 40 | assertEqual "" ref $ getRawPath reference 41 | assertEqual "" [ref] $ getComponents reference 42 | ) 43 | 44 | validReferencesWithLeadingSlash :: Test 45 | validReferencesWithLeadingSlash = 46 | TestCase $ 47 | ( do 48 | confirm "/key" "key" 49 | confirm "/0" "0" 50 | confirm "/name~1with~1slashes~0and~0tildes" "name/with/slashes~and~tildes" 51 | ) 52 | where 53 | confirm ref component = 54 | let reference = makeReference ref 55 | in ( do 56 | assertEqual "" "" $ getError reference 57 | assertEqual "" [component] $ getComponents reference 58 | assertEqual "" ref $ getRawPath reference 59 | ) 60 | 61 | canAccessSubcomponents :: Test 62 | canAccessSubcomponents = 63 | TestCase $ 64 | ( do 65 | confirm "/key" ["key"] 66 | confirm "/a/b" ["a", "b"] 67 | confirm "/a~1b/c" ["a/b", "c"] 68 | confirm "/a~0b/c" ["a~b", "c"] 69 | confirm "/a/10/20/30x" ["a", "10", "20", "30x"] 70 | 71 | confirm "" [] 72 | confirm "key" ["key"] 73 | confirm "/key" ["key"] 74 | confirm "/a/b" ["a", "b"] 75 | ) 76 | where 77 | confirm ref components = 78 | let reference = makeReference ref 79 | in assertEqual "" components $ getComponents reference 80 | 81 | validLiteralReferences :: Test 82 | validLiteralReferences = 83 | TestCase $ 84 | ( do 85 | confirm "name" "name" 86 | confirm "a/b" "a/b" 87 | confirm "/a/b~c" "/~1a~1b~0c" 88 | confirm "/" "/~1" 89 | ) 90 | where 91 | confirm ref path = 92 | let literal = makeLiteral ref 93 | reference = makeReference path 94 | in assertEqual "" (getRawPath literal) (getRawPath reference) 95 | 96 | invalidLiteralReferences :: Test 97 | invalidLiteralReferences = TestCase $ assertEqual "" "empty reference" $ getError $ makeLiteral "" 98 | 99 | allTests :: Test 100 | allTests = 101 | TestList 102 | [ invalidReferences 103 | , validReferencesWithoutLeadingSlash 104 | , validReferencesWithLeadingSlash 105 | , canAccessSubcomponents 106 | , validLiteralReferences 107 | , invalidLiteralReferences 108 | ] 109 | -------------------------------------------------------------------------------- /test/Spec/Store.hs: -------------------------------------------------------------------------------- 1 | module Spec.Store (allTests, testWithStore) where 2 | 3 | import Test.HUnit 4 | 5 | import Util.Features (makeTestFlag, makeTestSegment) 6 | 7 | import LaunchDarkly.AesonCompat (emptyObject, singleton) 8 | import LaunchDarkly.Server.Store.Internal 9 | 10 | testInitializationEmpty :: IO (StoreHandle IO) -> Test 11 | testInitializationEmpty makeStore = TestCase $ do 12 | store <- makeStore 13 | getInitializedC store >>= (pure False @=?) 14 | storeHandleInitialize store emptyObject emptyObject >>= (pure () @=?) 15 | getInitializedC store >>= (pure True @=?) 16 | 17 | testInitializationWithFeatures :: IO (StoreHandle IO) -> Test 18 | testInitializationWithFeatures makeStore = TestCase $ do 19 | store <- makeStore 20 | getInitializedC store >>= (pure False @=?) 21 | storeHandleInitialize store flagsV segmentsV >>= (pure () @=?) 22 | getInitializedC store >>= (pure True @=?) 23 | storeHandleGetFlag store "a" >>= (pure (pure flagA) @=?) 24 | storeHandleAllFlags store >>= (pure flagsR @=?) 25 | storeHandleGetSegment store "a" >>= (pure (pure segmentA) @=?) 26 | where 27 | segmentA = makeTestSegment "a" 50 28 | flagA = makeTestFlag "a" 52 29 | flagsR = singleton "a" flagA 30 | flagsV = singleton "a" (ItemDescriptor flagA 52) 31 | segmentsV = singleton "a" (ItemDescriptor segmentA 50) 32 | 33 | testGetAndUpsertAndGetAndGetAllFlags :: IO (StoreHandle IO) -> Test 34 | testGetAndUpsertAndGetAndGetAllFlags makeStore = TestCase $ do 35 | store <- makeStore 36 | getFlagC store "a" >>= (pure Nothing @=?) 37 | upsertFlagC store "a" (ItemDescriptor (pure flag) 52) >>= (pure () @=?) 38 | getFlagC store "a" >>= (pure (pure flag) @=?) 39 | getAllFlagsC store >>= (pure (singleton "a" flag) @=?) 40 | where 41 | flag = makeTestFlag "a" 52 42 | 43 | testGetAndUpsertAndGetSegment :: IO (StoreHandle IO) -> Test 44 | testGetAndUpsertAndGetSegment makeStore = TestCase $ do 45 | store <- makeStore 46 | getSegmentC store "a" >>= (pure Nothing @=?) 47 | upsertSegmentC store "a" (ItemDescriptor (pure segment) 52) >>= (pure () @=?) 48 | getSegmentC store "a" >>= (pure (pure segment) @=?) 49 | where 50 | segment = makeTestSegment "a" 52 51 | 52 | testUpsertRespectsVersion :: IO (StoreHandle IO) -> Test 53 | testUpsertRespectsVersion makeStore = TestCase $ do 54 | store <- makeStore 55 | upsertFlagC store "a" (ItemDescriptor (pure $ makeTestFlag "a" 1) 1) >>= (pure () @=?) 56 | upsertFlagC store "a" (ItemDescriptor (pure $ makeTestFlag "a" 2) 2) >>= (pure () @=?) 57 | getFlagC store "a" >>= (pure (pure $ makeTestFlag "a" 2) @=?) 58 | getAllFlagsC store >>= (pure (singleton "a" $ makeTestFlag "a" 2) @=?) 59 | upsertFlagC store "a" (ItemDescriptor (pure $ makeTestFlag "a" 1) 1) >>= (pure () @=?) 60 | getFlagC store "a" >>= (pure (pure $ makeTestFlag "a" 2) @=?) 61 | getAllFlagsC store >>= (pure (singleton "a" $ makeTestFlag "a" 2) @=?) 62 | upsertFlagC store "a" (ItemDescriptor Nothing 3) >>= (pure () @=?) 63 | getFlagC store "a" >>= (pure Nothing @=?) 64 | getAllFlagsC store >>= (pure mempty @=?) 65 | 66 | testWithStore :: IO (StoreHandle IO) -> Test 67 | testWithStore makeStore = 68 | TestList $ 69 | map 70 | (\f -> f makeStore) 71 | [ testInitializationEmpty 72 | , testInitializationWithFeatures 73 | , testGetAndUpsertAndGetAndGetAllFlags 74 | , testUpsertRespectsVersion 75 | , testGetAndUpsertAndGetSegment 76 | ] 77 | 78 | allTests :: Test 79 | allTests = 80 | TestList 81 | [ testWithStore $ makeStoreIO Nothing 0 82 | ] 83 | -------------------------------------------------------------------------------- /test/Spec/Streaming.hs: -------------------------------------------------------------------------------- 1 | module Spec.Streaming (allTests) where 2 | 3 | import Test.HUnit 4 | 5 | allTests :: Test 6 | allTests = TestList [] 7 | -------------------------------------------------------------------------------- /test/Util/Features.hs: -------------------------------------------------------------------------------- 1 | module Util.Features (makeTestFlag, makeTestSegment) where 2 | 3 | import Data.Text (Text) 4 | import GHC.Natural (Natural) 5 | 6 | import LaunchDarkly.Server.Features 7 | 8 | makeTestFlag :: Text -> Natural -> Flag 9 | makeTestFlag key version = 10 | Flag 11 | { key = key 12 | , version = version 13 | , on = True 14 | , trackEvents = False 15 | , trackEventsFallthrough = False 16 | , deleted = False 17 | , prerequisites = [] 18 | , salt = "" 19 | , targets = [] 20 | , contextTargets = [] 21 | , rules = [] 22 | , fallthrough = 23 | VariationOrRollout 24 | { variation = Nothing 25 | , rollout = Nothing 26 | } 27 | , offVariation = Nothing 28 | , variations = [] 29 | , debugEventsUntilDate = Nothing 30 | , clientSideAvailability = ClientSideAvailability {usingEnvironmentId = True, usingMobileKey = False, explicit = True} 31 | } 32 | 33 | makeTestSegment :: Text -> Natural -> Segment 34 | makeTestSegment key version = 35 | Segment 36 | { key = key 37 | , included = mempty 38 | , includedContexts = mempty 39 | , excluded = mempty 40 | , excludedContexts = mempty 41 | , salt = "" 42 | , rules = mempty 43 | , version = version 44 | , deleted = False 45 | } 46 | --------------------------------------------------------------------------------