├── .github └── workflows │ ├── ci.yaml │ └── publish.yaml ├── .gitignore ├── .hlint.yaml ├── LICENSE ├── README.md ├── cabal.project ├── flake.lock ├── flake.nix ├── fourmolu.yaml ├── hie.yaml ├── nix ├── haskell-packages │ ├── scotty.nix │ ├── servant-server.nix │ └── servant.nix └── overlays │ └── haskell.nix ├── scripts └── hackage-upload.sh ├── stack.yaml ├── stack.yaml.lock ├── webgear-benchmarks ├── LICENSE ├── README.md ├── criterion-report.html ├── src │ ├── Main.hs │ ├── Scotty.hs │ ├── Servant.hs │ └── WebGear.hs ├── user.json └── webgear-benchmarks.cabal ├── webgear-core ├── CHANGELOG.md ├── LICENSE ├── README.md ├── src │ └── WebGear │ │ ├── Core.hs │ │ └── Core │ │ ├── Handler.hs │ │ ├── Handler │ │ └── Static.hs │ │ ├── MIMETypes.hs │ │ ├── Modifiers.hs │ │ ├── Request.hs │ │ ├── Response.hs │ │ ├── Trait.hs │ │ ├── Trait │ │ ├── Auth │ │ │ ├── Basic.hs │ │ │ ├── Common.hs │ │ │ └── JWT.hs │ │ ├── Body.hs │ │ ├── Cookie.hs │ │ ├── Header.hs │ │ ├── Method.hs │ │ ├── Path.hs │ │ ├── QueryParam.hs │ │ └── Status.hs │ │ └── Traits.hs └── webgear-core.cabal ├── webgear-example-realworld ├── LICENSE ├── README.md ├── realworld.db ├── realworld.jwk ├── src │ ├── API │ │ ├── Article.hs │ │ ├── Comment.hs │ │ ├── Common.hs │ │ ├── Profile.hs │ │ ├── Tag.hs │ │ ├── UI.hs │ │ └── User.hs │ ├── Main.hs │ └── Model │ │ ├── Article.hs │ │ ├── Comment.hs │ │ ├── Common.hs │ │ ├── Entities.hs │ │ ├── Profile.hs │ │ ├── Tag.hs │ │ └── User.hs ├── ui │ ├── README.md │ ├── assets │ │ ├── ember-realworld-2e28dcaa9120be6d6a7fd97eaf79424f.js │ │ ├── ember-realworld-d41d8cd98f00b204e9800998ecf8427e.css │ │ ├── ember.ico │ │ ├── vendor-d41d8cd98f00b204e9800998ecf8427e.css │ │ └── vendor-efed152f664f9c2069478d5ed32bbf51.js │ └── index.html └── webgear-example-realworld.cabal ├── webgear-example-users ├── LICENSE ├── README.md ├── postman-collection.json ├── src │ └── Main.hs └── webgear-example-users.cabal ├── webgear-openapi ├── CHANGELOG.md ├── LICENSE ├── README.md ├── src │ └── WebGear │ │ ├── OpenApi.hs │ │ └── OpenApi │ │ ├── Handler.hs │ │ ├── Trait │ │ ├── Auth.hs │ │ ├── Auth │ │ │ ├── Basic.hs │ │ │ └── JWT.hs │ │ ├── Body.hs │ │ ├── Cookie.hs │ │ ├── Header.hs │ │ ├── Method.hs │ │ ├── Path.hs │ │ ├── QueryParam.hs │ │ └── Status.hs │ │ └── Traits.hs └── webgear-openapi.cabal ├── webgear-server ├── CHANGELOG.md ├── LICENSE ├── README.md ├── src │ └── WebGear │ │ ├── Server.hs │ │ └── Server │ │ ├── Handler.hs │ │ ├── MIMETypes.hs │ │ ├── Trait │ │ ├── Auth │ │ │ ├── Basic.hs │ │ │ └── JWT.hs │ │ ├── Body.hs │ │ ├── Cookie.hs │ │ ├── Header.hs │ │ ├── Method.hs │ │ ├── Path.hs │ │ ├── QueryParam.hs │ │ └── Status.hs │ │ └── Traits.hs ├── test │ ├── Main.hs │ ├── Properties.hs │ ├── Properties │ │ └── Trait │ │ │ ├── Auth │ │ │ └── Basic.hs │ │ │ ├── Body.hs │ │ │ ├── Header.hs │ │ │ ├── Method.hs │ │ │ ├── Path.hs │ │ │ └── QueryParam.hs │ ├── Unit.hs │ └── Unit │ │ └── Trait │ │ ├── Header.hs │ │ └── Path.hs └── webgear-server.cabal ├── webgear-swagger-ui ├── CHANGELOG.md ├── LICENSE ├── README.md ├── index.html ├── src │ └── WebGear │ │ └── Swagger │ │ ├── UI.hs │ │ └── UI │ │ └── Embedded.hs ├── swagger-ui-5.10.5 │ ├── LICENSE │ ├── NOTICE │ └── dist │ │ ├── favicon-16x16.png │ │ ├── favicon-32x32.png │ │ ├── index.css │ │ ├── oauth2-redirect.html │ │ ├── swagger-initializer.js │ │ ├── swagger-ui-bundle.js │ │ ├── swagger-ui-bundle.js.map │ │ ├── swagger-ui-es-bundle-core.js │ │ ├── swagger-ui-es-bundle-core.js.map │ │ ├── swagger-ui-es-bundle.js │ │ ├── swagger-ui-es-bundle.js.map │ │ ├── swagger-ui-standalone-preset.js │ │ ├── swagger-ui-standalone-preset.js.map │ │ ├── swagger-ui.css │ │ ├── swagger-ui.css.map │ │ ├── swagger-ui.js │ │ └── swagger-ui.js.map └── webgear-swagger-ui.cabal └── webgear-swagger ├── CHANGELOG.md ├── LICENSE ├── README.md ├── src └── WebGear │ ├── Swagger.hs │ └── Swagger │ ├── Handler.hs │ ├── Trait │ ├── Auth.hs │ ├── Auth │ │ ├── Basic.hs │ │ └── JWT.hs │ ├── Body.hs │ ├── Cookie.hs │ ├── Header.hs │ ├── Method.hs │ ├── Path.hs │ ├── QueryParam.hs │ └── Status.hs │ └── Traits.hs └── webgear-swagger.cabal /.github/workflows/ci.yaml: -------------------------------------------------------------------------------- 1 | name: CI 2 | 3 | on: 4 | push: 5 | branches: 6 | - main 7 | - release-* 8 | pull_request: 9 | branches: 10 | - main 11 | - release-* 12 | 13 | jobs: 14 | nix-build: 15 | name: Nix - ghc-${{ matrix.ghc }} os-${{ matrix.os }} 16 | 17 | runs-on: ${{ matrix.os }} 18 | strategy: 19 | fail-fast: false 20 | matrix: 21 | os: 22 | - ubuntu-latest 23 | ghc: 24 | - 9.12.1 25 | - 9.10.1 26 | - 9.8.2 27 | - 9.6.6 28 | - 9.4.8 29 | 30 | steps: 31 | - name: Checkout Source Code 32 | uses: actions/checkout@v4 33 | 34 | - name: Install Nix 35 | uses: cachix/install-nix-action@v31 36 | 37 | - name: Set up Cachix 38 | uses: cachix/cachix-action@v16 39 | with: 40 | name: haskell-webgear 41 | authToken: '${{ secrets.CACHIX_AUTH_TOKEN }}' 42 | 43 | - name: Build Packages 44 | run: | 45 | GHC_VERSION=$(echo ${{ matrix.ghc }} | tr -d .) 46 | nix build --print-build-logs --no-link \ 47 | .#webgear-core-ghc${GHC_VERSION} \ 48 | .#webgear-server-ghc${GHC_VERSION} \ 49 | .#webgear-swagger-ghc${GHC_VERSION} \ 50 | .#webgear-swagger-ui-ghc${GHC_VERSION} \ 51 | .#webgear-openapi-ghc${GHC_VERSION} \ 52 | .#webgear-benchmarks-ghc${GHC_VERSION} 53 | 54 | - name: Build Examples 55 | if: matrix.ghc == '9.12.1' 56 | run: | 57 | GHC_VERSION=$(echo ${{ matrix.ghc }} | tr -d .) 58 | nix build --print-build-logs --no-link \ 59 | .#webgear-example-users-ghc${GHC_VERSION} \ 60 | .#webgear-example-realworld-ghc${GHC_VERSION} 61 | 62 | - name: Benchmark 63 | run: | 64 | GHC_VERSION=$(echo ${{ matrix.ghc }} | tr -d .) 65 | BENCHMARK=$(nix build --no-link --json .#webgear-benchmarks-ghc${GHC_VERSION} | jq -r .[].outputs.out) 66 | ${BENCHMARK}/bin/benchmarks +RTS -N -RTS 67 | 68 | stack-build: 69 | name: Stack 70 | 71 | runs-on: ubuntu-latest 72 | strategy: 73 | fail-fast: false 74 | 75 | steps: 76 | - uses: actions/checkout@v4 77 | name: Checkout Source Code 78 | 79 | - uses: haskell-actions/setup@v2 80 | name: Setup Haskell Build Environment 81 | with: 82 | ghc-version: 9.10.1 83 | enable-stack: true 84 | 85 | - uses: actions/cache@v4 86 | name: Cache dependencies 87 | with: 88 | path: ~/.stack 89 | key: stack 90 | restore-keys: | 91 | stack- 92 | 93 | - name: Build 94 | run: stack build --system-ghc --test --bench --no-run-tests --no-run-benchmarks 95 | 96 | - name: Test 97 | run: stack test --system-ghc --ta '--quickcheck-tests 100000' 98 | 99 | - name: Haddock 100 | run: | 101 | stack haddock --system-ghc \ 102 | webgear-core \ 103 | webgear-server \ 104 | webgear-swagger \ 105 | webgear-swagger-ui \ 106 | webgear-openapi 107 | -------------------------------------------------------------------------------- /.github/workflows/publish.yaml: -------------------------------------------------------------------------------- 1 | name: Publish to Hackage 2 | 3 | on: 4 | workflow_dispatch: 5 | inputs: 6 | ref: 7 | description: The git ref to publish to Hackage 8 | required: true 9 | type: string 10 | 11 | jobs: 12 | hackage-publish: 13 | name: Publish to Hackage 14 | 15 | runs-on: ubuntu-latest 16 | 17 | steps: 18 | - name: Checkout Source Code 19 | uses: actions/checkout@v3 20 | with: 21 | ref: ${{ inputs.ref }} 22 | 23 | - name: Install Nix 24 | uses: cachix/install-nix-action@v20 25 | 26 | - name: Set up Cachix 27 | uses: cachix/cachix-action@v12 28 | with: 29 | name: haskell-webgear 30 | authToken: '${{ secrets.CACHIX_AUTH_TOKEN }}' 31 | 32 | - name: Upload to Hackage 33 | run: | 34 | nix develop .#webgear-hackage-upload-shell --command ./scripts/hackage-upload.sh ${{ secrets.HACKAGE_TOKEN }} 35 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | .stack-work/ 2 | .hie/ 3 | dist-newstyle/ 4 | cabal.project.freeze 5 | *~ 6 | /result* -------------------------------------------------------------------------------- /.hlint.yaml: -------------------------------------------------------------------------------- 1 | - arguments: 2 | - -XApplicativeDo 3 | - -XArrows 4 | - -XBangPatterns 5 | - -XConstraintKinds 6 | - -XDataKinds 7 | - -XDefaultSignatures 8 | - -XDeriveAnyClass 9 | - -XDeriveFoldable 10 | - -XDeriveFunctor 11 | - -XDeriveGeneric 12 | - -XDeriveLift 13 | - -XDeriveTraversable 14 | - -XDerivingStrategies 15 | - -XDerivingVia 16 | - -XEmptyCase 17 | - -XExistentialQuantification 18 | - -XFlexibleContexts 19 | - -XFlexibleInstances 20 | - -XFunctionalDependencies 21 | - -XGADTs 22 | - -XGeneralizedNewtypeDeriving 23 | - -XInstanceSigs 24 | - -XKindSignatures 25 | - -XLambdaCase 26 | - -XMultiParamTypeClasses 27 | - -XMultiWayIf 28 | - -XNamedFieldPuns 29 | - -XOverloadedStrings 30 | - -XPatternSynonyms 31 | - -XPolyKinds 32 | - -XRankNTypes 33 | - -XScopedTypeVariables 34 | - -XStandaloneDeriving 35 | - -XTemplateHaskell 36 | - -XTupleSections 37 | - -XTypeApplications 38 | - -XTypeFamilies 39 | - -XTypeFamilyDependencies 40 | - -XTypeOperators 41 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # WebGear - Build HTTP APIs 2 | 3 | ------------------------------------------------------------------------------- 4 | 5 | * webgear-core - [![Hackage](https://img.shields.io/hackage/v/webgear-core)](https://hackage.haskell.org/package/webgear-core) 6 | * webgear-server - [![Hackage](https://img.shields.io/hackage/v/webgear-server)](https://hackage.haskell.org/package/webgear-server) 7 | * webgear-swagger - [![Hackage](https://img.shields.io/hackage/v/webgear-swagger)](https://hackage.haskell.org/package/webgear-swagger) 8 | * webgear-swagger-ui - [![Hackage](https://img.shields.io/hackage/v/webgear-swagger-ui)](https://hackage.haskell.org/package/webgear-swagger-ui) 9 | * webgear-openapi - [![Hackage](https://img.shields.io/hackage/v/webgear-openapi)](https://hackage.haskell.org/package/webgear-openapi) 10 | 11 | [![Build Status](https://img.shields.io/github/actions/workflow/status/haskell-webgear/webgear/ci.yaml?branch=main)](https://github.com/haskell-webgear/webgear/actions/workflows/ci.yaml) 12 | 13 | ------------------------------------------------------------------------------- 14 | 15 | WebGear is a Haskell library for building composable, type-safe HTTP APIs. 16 | 17 | This is the main repository of WebGear project. It contains multiple packages: 18 | 19 | - `webgear-core`: The core library. 20 | - `webgear-server`: Serve WebGear applications using `wai` and `warp`. 21 | - `webgear-swagger`: Generate Swagger 2.0 specifications from WebGear specifications. 22 | - `webgear-swagger-ui`: Server to host swagger UI based on WebGear APIs. 23 | - `webgear-openapi`: Generate OpenAPI specifications from WebGear specifications. 24 | 25 | Examples of WebGear applications can be found at: 26 | 27 | - https://github.com/haskell-webgear/webgear/webgear-example-users 28 | - https://github.com/haskell-webgear/webgear/webgear-example-realworld 29 | 30 | Documentation is available at https://haskell-webgear.github.io 31 | 32 | ## Development 33 | 34 | Use Nix to start a reproducible development environment: 35 | 36 | ```shell 37 | nix develop 38 | ``` 39 | 40 | This starts a shell with the default GHC. You can also use a specific GHC version with: 41 | 42 | ```shell 43 | nix develop .#webgear-dev-ghc 44 | ``` 45 | 46 | You can use the standard cabal commands in the development shell. 47 | 48 | You can build packages using Nix: 49 | 50 | ```shell 51 | nix build \ 52 | .#webgear-core-ghc \ 53 | .#webgear-server-ghc \ 54 | .#webgear-swagger-ghc \ 55 | .#webgear-swagger-ui-ghc \ 56 | .#webgear-openapi-ghc 57 | ``` 58 | -------------------------------------------------------------------------------- /cabal.project: -------------------------------------------------------------------------------- 1 | packages: webgear-core/ 2 | webgear-server/ 3 | webgear-swagger/ 4 | webgear-swagger-ui/ 5 | webgear-openapi/ 6 | webgear-benchmarks/ 7 | webgear-example-users/ 8 | webgear-example-realworld/ 9 | -------------------------------------------------------------------------------- /flake.lock: -------------------------------------------------------------------------------- 1 | { 2 | "nodes": { 3 | "flake-utils": { 4 | "inputs": { 5 | "systems": "systems" 6 | }, 7 | "locked": { 8 | "lastModified": 1731533236, 9 | "narHash": "sha256-l0KFg5HjrsfsO/JpG+r7fRrqm12kzFHyUHqHCVpMMbI=", 10 | "owner": "numtide", 11 | "repo": "flake-utils", 12 | "rev": "11707dc2f618dd54ca8739b309ec4fc024de578b", 13 | "type": "github" 14 | }, 15 | "original": { 16 | "owner": "numtide", 17 | "repo": "flake-utils", 18 | "type": "github" 19 | } 20 | }, 21 | "gitignore": { 22 | "inputs": { 23 | "nixpkgs": [ 24 | "nixpkgs" 25 | ] 26 | }, 27 | "locked": { 28 | "lastModified": 1709087332, 29 | "narHash": "sha256-HG2cCnktfHsKV0s4XW83gU3F57gaTljL9KNSuG6bnQs=", 30 | "owner": "hercules-ci", 31 | "repo": "gitignore.nix", 32 | "rev": "637db329424fd7e46cf4185293b9cc8c88c95394", 33 | "type": "github" 34 | }, 35 | "original": { 36 | "owner": "hercules-ci", 37 | "repo": "gitignore.nix", 38 | "type": "github" 39 | } 40 | }, 41 | "nixpkgs": { 42 | "locked": { 43 | "lastModified": 1744960667, 44 | "narHash": "sha256-GhZOni4cMvmmcQ7gHhv7fq+5FUusD7DKb6CgupKDekA=", 45 | "owner": "NixOS", 46 | "repo": "nixpkgs", 47 | "rev": "c5dbc50d989180a50e0e371e10061d4f739a0511", 48 | "type": "github" 49 | }, 50 | "original": { 51 | "owner": "NixOS", 52 | "ref": "haskell-updates", 53 | "repo": "nixpkgs", 54 | "type": "github" 55 | } 56 | }, 57 | "root": { 58 | "inputs": { 59 | "flake-utils": "flake-utils", 60 | "gitignore": "gitignore", 61 | "nixpkgs": "nixpkgs" 62 | } 63 | }, 64 | "systems": { 65 | "locked": { 66 | "lastModified": 1681028828, 67 | "narHash": "sha256-Vy1rq5AaRuLzOxct8nz4T6wlgyUR7zLU309k9mBC768=", 68 | "owner": "nix-systems", 69 | "repo": "default", 70 | "rev": "da67096a3b9bf56a91d16901293e51ba5b49a27e", 71 | "type": "github" 72 | }, 73 | "original": { 74 | "owner": "nix-systems", 75 | "repo": "default", 76 | "type": "github" 77 | } 78 | } 79 | }, 80 | "root": "root", 81 | "version": 7 82 | } 83 | -------------------------------------------------------------------------------- /flake.nix: -------------------------------------------------------------------------------- 1 | { 2 | description = "WebGear Project"; 3 | 4 | inputs = { 5 | nixpkgs.url = "github:NixOS/nixpkgs/haskell-updates"; 6 | flake-utils.url = "github:numtide/flake-utils"; 7 | gitignore = { 8 | url = "github:hercules-ci/gitignore.nix"; 9 | # Use the same nixpkgs 10 | inputs.nixpkgs.follows = "nixpkgs"; 11 | }; 12 | }; 13 | 14 | outputs = { self, nixpkgs, flake-utils, gitignore }: 15 | { 16 | overlays.default = import ./nix/overlays/haskell.nix { inherit gitignore; }; 17 | } 18 | // flake-utils.lib.eachSystem ["x86_64-linux" "x86_64-darwin"] (system: 19 | let 20 | pkgs = import nixpkgs { 21 | inherit system; 22 | overlays = [ self.overlays.default ]; 23 | }; 24 | 25 | mkVersionedPackages = ghcVersion: 26 | pkgs.lib.attrsets.mapAttrs' (name: _: { 27 | name = "${name}-ghc${ghcVersion}"; 28 | value = pkgs.haskell.packages."ghc${ghcVersion}".${name}; 29 | }) pkgs.localHsPackages; 30 | 31 | versionedDevShells = pkgs.lib.mapcat pkgs.mkDevShell pkgs.ghcVersions; 32 | in { 33 | packages = pkgs.lib.mapcat mkVersionedPackages pkgs.ghcVersions; 34 | 35 | devShells = pkgs.hackageUploadShell // versionedDevShells // { 36 | default = versionedDevShells."webgear-dev-ghc${pkgs.defaultGHCVersion}"; 37 | }; 38 | }); 39 | } 40 | -------------------------------------------------------------------------------- /fourmolu.yaml: -------------------------------------------------------------------------------- 1 | # Number of spaces per indentation step 2 | indentation: 2 3 | 4 | # Max line length for automatic line breaking 5 | column-limit: none 6 | 7 | # Styling of arrows in type signatures (choices: trailing, leading, or leading-args) 8 | function-arrows: trailing 9 | 10 | # How to place commas in multi-line lists, records, etc. (choices: leading or trailing) 11 | comma-style: leading 12 | 13 | # Styling of import/export lists (choices: leading, trailing, or diff-friendly) 14 | import-export-style: diff-friendly 15 | 16 | # Whether to full-indent or half-indent 'where' bindings past the preceding body 17 | indent-wheres: true 18 | 19 | # Whether to leave a space before an opening record brace 20 | record-brace-space: false 21 | 22 | # Number of spaces between top-level declarations 23 | newlines-between-decls: 1 24 | 25 | # How to print Haddock comments (choices: single-line, multi-line, or multi-line-compact) 26 | haddock-style: multi-line 27 | 28 | # How to print module docstring 29 | haddock-style-module: null 30 | 31 | # Styling of let blocks (choices: auto, inline, newline, or mixed) 32 | let-style: auto 33 | 34 | # How to align the 'in' keyword with respect to the 'let' keyword (choices: left-align, right-align, or no-space) 35 | in-style: right-align 36 | 37 | # Whether to put parentheses around a single constraint (choices: auto, always, or never) 38 | single-constraint-parens: always 39 | 40 | # Output Unicode syntax (choices: detect, always, or never) 41 | unicode: never 42 | 43 | # Give the programmer more choice on where to insert blank lines 44 | respectful: true 45 | 46 | # Fixity information for operators 47 | fixities: [] 48 | 49 | # Module reexports Fourmolu should know about 50 | reexports: [] 51 | 52 | -------------------------------------------------------------------------------- /hie.yaml: -------------------------------------------------------------------------------- 1 | cradle: 2 | multi: 3 | - path: "./webgear-core/src" 4 | config: 5 | cradle: 6 | cabal: 7 | component: "lib:webgear-core" 8 | - path: "./webgear-server/src" 9 | config: 10 | cradle: 11 | cabal: 12 | component: "lib:webgear-server" 13 | - path: "./webgear-server/test" 14 | config: 15 | cradle: 16 | cabal: 17 | component: "webgear-server:webgear-server-test" 18 | - path: "./webgear-swagger/src" 19 | config: 20 | cradle: 21 | cabal: 22 | component: "lib:webgear-swagger" 23 | - path: "./webgear-swagger-ui/src" 24 | config: 25 | cradle: 26 | cabal: 27 | component: "lib:webgear-swagger-ui" 28 | - path: "./webgear-openapi/src" 29 | config: 30 | cradle: 31 | cabal: 32 | component: "lib:webgear-openapi" 33 | - path: "./webgear-benchmarks/src" 34 | config: 35 | cradle: 36 | cabal: 37 | component: "webgear-benchmarks:exe:benchmarks" 38 | - path: "./webgear-example-users/src" 39 | config: 40 | cradle: 41 | cabal: 42 | component: "webgear-example-users:exe:users" 43 | - path: "./webgear-example-realworld/src" 44 | config: 45 | cradle: 46 | cabal: 47 | component: "webgear-example-realworld:exe:realworld" 48 | -------------------------------------------------------------------------------- /nix/haskell-packages/scotty.nix: -------------------------------------------------------------------------------- 1 | { mkDerivation, aeson, async, base, blaze-builder, bytestring 2 | , case-insensitive, cookie, data-default-class, directory, doctest 3 | , exceptions, hspec, hspec-discover, hspec-wai, http-client 4 | , http-types, lib, lifted-base, lucid, monad-control, mtl, network 5 | , regex-compat, resourcet, stm, text, time, transformers 6 | , transformers-base, unliftio, wai, wai-extra, warp, weigh 7 | }: 8 | mkDerivation { 9 | pname = "scotty"; 10 | version = "0.22"; 11 | sha256 = "ceb998c12502cd639c8aa59c5b5ea8f2651198e62f2f86cf18b8b5a087b4b81c"; 12 | revision = "2"; 13 | editedCabalFile = "1m3qvb5q6yigw6ijxnp6h66rmyqg54619hb240s7cqc9qjrrkixk"; 14 | libraryHaskellDepends = [ 15 | aeson base blaze-builder bytestring case-insensitive cookie 16 | data-default-class exceptions http-types monad-control mtl network 17 | regex-compat resourcet stm text time transformers transformers-base 18 | unliftio wai wai-extra warp 19 | ]; 20 | testHaskellDepends = [ 21 | async base bytestring directory doctest hspec hspec-wai http-client 22 | http-types lifted-base network text time wai wai-extra 23 | ]; 24 | testToolDepends = [ hspec-discover ]; 25 | benchmarkHaskellDepends = [ 26 | base bytestring lucid mtl resourcet text transformers weigh 27 | ]; 28 | homepage = "https://github.com/scotty-web/scotty"; 29 | description = "Haskell web framework inspired by Ruby's Sinatra, using WAI and Warp"; 30 | license = lib.licenses.bsd3; 31 | } 32 | -------------------------------------------------------------------------------- /nix/haskell-packages/servant-server.nix: -------------------------------------------------------------------------------- 1 | { mkDerivation, aeson, base, base-compat, base64-bytestring 2 | , bytestring, constraints, containers, directory, exceptions 3 | , filepath, hspec, hspec-discover, hspec-wai, http-api-data 4 | , http-media, http-types, lib, monad-control, mtl, network 5 | , resourcet, safe, servant, should-not-typecheck, sop-core, tagged 6 | , temporary, text, transformers, transformers-base, wai 7 | , wai-app-static, wai-extra, warp, word8 8 | }: 9 | mkDerivation { 10 | pname = "servant-server"; 11 | version = "0.20.2"; 12 | sha256 = "1ecf500dcc045f2232294313f0a7faaabfb3150d04ed0103219cc8f5feb70f3b"; 13 | revision = "1"; 14 | editedCabalFile = "0qjl1yrr0l7kynrndv8qmpzl0jz9nzb7c4v9r7kxq05nnb7xpqbz"; 15 | isLibrary = true; 16 | isExecutable = true; 17 | libraryHaskellDepends = [ 18 | base base64-bytestring bytestring constraints containers exceptions 19 | filepath http-api-data http-media http-types monad-control mtl 20 | network resourcet servant sop-core tagged text transformers 21 | transformers-base wai wai-app-static word8 22 | ]; 23 | executableHaskellDepends = [ 24 | aeson base base-compat text wai warp 25 | ]; 26 | testHaskellDepends = [ 27 | aeson base base-compat base64-bytestring bytestring directory hspec 28 | hspec-wai http-types mtl resourcet safe servant 29 | should-not-typecheck temporary text wai wai-extra 30 | ]; 31 | testToolDepends = [ hspec-discover ]; 32 | homepage = "http://docs.servant.dev/"; 33 | description = "A family of combinators for defining webservices APIs and serving them"; 34 | license = lib.licenses.bsd3; 35 | mainProgram = "greet"; 36 | } 37 | -------------------------------------------------------------------------------- /nix/haskell-packages/servant.nix: -------------------------------------------------------------------------------- 1 | { mkDerivation, aeson, attoparsec, base, bifunctors, bytestring 2 | , case-insensitive, constraints, containers, deepseq, hspec 3 | , hspec-discover, http-api-data, http-media, http-types, lib 4 | , mmorph, mtl, network-uri, QuickCheck, quickcheck-instances 5 | , singleton-bool, sop-core, text, transformers, vault 6 | }: 7 | mkDerivation { 8 | pname = "servant"; 9 | version = "0.20.2"; 10 | sha256 = "6a39e279d34f42b20eace9b5296fa8dcfd2116ed7391d99f58ba005bb3f45365"; 11 | revision = "1"; 12 | editedCabalFile = "17n769vwyyc5hshm71r33ksvn26qcz19017wl9p8xj4igav790pa"; 13 | libraryHaskellDepends = [ 14 | aeson attoparsec base bifunctors bytestring case-insensitive 15 | constraints containers deepseq http-api-data http-media http-types 16 | mmorph mtl network-uri QuickCheck singleton-bool sop-core text 17 | transformers vault 18 | ]; 19 | testHaskellDepends = [ 20 | aeson base bytestring hspec http-media mtl QuickCheck 21 | quickcheck-instances text 22 | ]; 23 | testToolDepends = [ hspec-discover ]; 24 | homepage = "http://docs.servant.dev/"; 25 | description = "A family of combinators for defining webservices APIs"; 26 | license = lib.licenses.bsd3; 27 | } 28 | -------------------------------------------------------------------------------- /scripts/hackage-upload.sh: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env bash 2 | 3 | # This script uploads packages to hackage 4 | 5 | set -euo pipefail 6 | 7 | HACKAGE_API_KEY=$1 8 | 9 | if [[ "$HACKAGE_API_KEY" == "" ]]; then 10 | echo "Usage: $0 " 11 | exit 1 12 | fi 13 | 14 | upload_package() { 15 | local package=$(find dist-newstyle/sdist -maxdepth 1 -regex "dist-newstyle/sdist/$1-[0-9.]+\.tar\.gz") 16 | local doc=$(find dist-newstyle/haddock -maxdepth 1 -regex "dist-newstyle/haddock/webgear-swagger-[0-9.]+-docs\.tar\.gz") 17 | echo "Uploading package $package" 18 | curl --verbose \ 19 | --header "Accept: text/plain" \ 20 | --header "Authorization: X-ApiKey $HACKAGE_API_KEY" \ 21 | --form "package=@$package" \ 22 | https://hackage.haskell.org/packages/ 23 | sleep 10 24 | echo "Uploading doc $doc" 25 | curl --verbose \ 26 | --request PUT \ 27 | --header "Accept: text/plain" \ 28 | --header "Authorization: X-ApiKey $HACKAGE_API_KEY" \ 29 | --data-binary "@$doc" \ 30 | https://hackage.haskell.org/package/$1/docs 31 | } 32 | 33 | cabal sdist all 34 | cabal haddock --haddock-for-hackage --enable-doc --builddir=dist-newstyle/haddock all 35 | 36 | upload_package webgear-core 37 | upload_package webgear-server 38 | upload_package webgear-swagger 39 | upload_package webgear-swagger-ui 40 | upload_package webgear-openapi 41 | -------------------------------------------------------------------------------- /stack.yaml: -------------------------------------------------------------------------------- 1 | resolver: nightly-2025-04-18 2 | 3 | packages: 4 | - ./webgear-core 5 | - ./webgear-server 6 | - ./webgear-swagger 7 | - ./webgear-swagger-ui 8 | - ./webgear-openapi 9 | - ./webgear-benchmarks 10 | 11 | allow-newer: true 12 | 13 | extra-deps: 14 | - insert-ordered-containers-0.2.6@sha256:8f46527a04f92e1a1b11fb45633f85d2dd73c2ab7b5de13ccf504c8f98a079f1,2358 15 | - openapi3-3.2.4@sha256:780f50a7538a02a83ea21db26f5c69578800c5f6895baecb98013b69b0d0f1f8,4943 16 | - swagger2-2.8.9@sha256:8434f71bf8017c1421d85ee8021e3f56f45f15c8ba50fff55f7329ace4cb0076,4518 17 | -------------------------------------------------------------------------------- /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/topics/lock_files 5 | 6 | packages: 7 | - completed: 8 | hackage: insert-ordered-containers-0.2.6@sha256:8f46527a04f92e1a1b11fb45633f85d2dd73c2ab7b5de13ccf504c8f98a079f1,2358 9 | pantry-tree: 10 | sha256: d0124c42db056e67a9bb7b198570c39d1d1bd574ebc93be1fbf214504b12ba97 11 | size: 542 12 | original: 13 | hackage: insert-ordered-containers-0.2.6@sha256:8f46527a04f92e1a1b11fb45633f85d2dd73c2ab7b5de13ccf504c8f98a079f1,2358 14 | - completed: 15 | hackage: openapi3-3.2.4@sha256:780f50a7538a02a83ea21db26f5c69578800c5f6895baecb98013b69b0d0f1f8,4943 16 | pantry-tree: 17 | sha256: 6bb5197e8825b35ee83642f1065849ad3a4301287c48e67a9d6135cba885ee2b 18 | size: 2263 19 | original: 20 | hackage: openapi3-3.2.4@sha256:780f50a7538a02a83ea21db26f5c69578800c5f6895baecb98013b69b0d0f1f8,4943 21 | - completed: 22 | hackage: swagger2-2.8.9@sha256:8434f71bf8017c1421d85ee8021e3f56f45f15c8ba50fff55f7329ace4cb0076,4518 23 | pantry-tree: 24 | sha256: 730792e758e42b95ee322bcb0d67c53eaba89fdc7f68184157ef5cb755e1aa1f 25 | size: 2192 26 | original: 27 | hackage: swagger2-2.8.9@sha256:8434f71bf8017c1421d85ee8021e3f56f45f15c8ba50fff55f7329ace4cb0076,4518 28 | snapshots: 29 | - completed: 30 | sha256: 906572cba5fc56ab1eb3f9884acf5cbf22faefd67aa6abef3fe0dce992b964c8 31 | size: 681591 32 | url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/nightly/2025/4/18.yaml 33 | original: nightly-2025-04-18 34 | -------------------------------------------------------------------------------- /webgear-benchmarks/src/Scotty.hs: -------------------------------------------------------------------------------- 1 | module Scotty (application) where 2 | 3 | import qualified Data.ByteString.Lazy as LBS 4 | import qualified Data.Text.Lazy as LText 5 | import qualified Data.Text.Lazy.Encoding as LText 6 | import qualified Network.HTTP.Types as HTTP 7 | import Network.Wai 8 | import Web.Scotty 9 | 10 | application :: IO Application 11 | application = scottyApp $ do 12 | get "/hello" $ do 13 | setHeader "Content-Type" "text/plain" 14 | text "Hello World" 15 | 16 | get "/path-var/:word/:count" $ do 17 | word <- pathParam "word" 18 | count <- pathParam "count" 19 | setHeader "Content-Type" "text/plain" 20 | text $ LText.intercalate "," $ replicate count word 21 | 22 | get "/query-param" $ do 23 | word <- queryParam "word" 24 | count <- queryParam "count" 25 | setHeader "Content-Type" "text/plain" 26 | text $ LText.intercalate "," $ replicate count word 27 | 28 | get "/header" $ 29 | header "APIKey" >>= \case 30 | Just apiKey -> do 31 | setHeader "Content-Type" "text/plain" 32 | text apiKey 33 | Nothing -> 34 | status HTTP.badRequest400 35 | 36 | put "/upload" $ do 37 | b <- body 38 | setHeader "Content-Type" "text/plain" 39 | if b == expectedUploadBody 40 | then text "done" 41 | else text "not done" 42 | 43 | post "/download/:input" $ do 44 | input <- pathParam "input" 45 | setHeader "Content-Type" "text/plain" 46 | text $ LText.decodeUtf8 $ LBS.replicate (1024 * 1024) input 47 | 48 | expectedUploadBody :: LBS.ByteString 49 | expectedUploadBody = LBS.replicate (1024 * 1024) 1 50 | -------------------------------------------------------------------------------- /webgear-benchmarks/src/Servant.hs: -------------------------------------------------------------------------------- 1 | module Servant (application) where 2 | 3 | import Control.Monad.Except (throwError) 4 | import qualified Data.ByteString.Lazy as LBS 5 | import Data.Proxy (Proxy (..)) 6 | import qualified Data.Text.Lazy as LText 7 | import qualified Data.Text.Lazy.Encoding as LText 8 | import Data.Word (Word8) 9 | import Network.Wai 10 | import Servant.API 11 | import Servant.Server 12 | 13 | type API = 14 | "hello" :> Get '[PlainText] LText.Text 15 | :<|> "path-var" :> Capture "word" LText.Text :> Capture "count" Int :> Get '[PlainText] LText.Text 16 | :<|> "query-param" :> QueryParam "word" LText.Text :> QueryParam "count" Int :> Get '[PlainText] LText.Text 17 | :<|> "header" :> Header "APIKey" LText.Text :> Get '[PlainText] LText.Text 18 | :<|> "upload" :> ReqBody '[OctetStream] LBS.ByteString :> Put '[PlainText] LText.Text 19 | :<|> "download" :> Capture "input" Word8 :> Post '[PlainText] LText.Text 20 | 21 | application :: Application 22 | application = serve (Proxy :: Proxy API) server 23 | 24 | server :: Server API 25 | server = 26 | helloWorldHandler 27 | :<|> pathVarHandler 28 | :<|> queryParamHandler 29 | :<|> headerHandler 30 | :<|> uploadHandler 31 | :<|> downloadHandler 32 | 33 | helloWorldHandler :: Handler LText.Text 34 | helloWorldHandler = pure "Hello World" 35 | 36 | pathVarHandler :: LText.Text -> Int -> Handler LText.Text 37 | pathVarHandler word count = pure $ LText.intercalate "," $ replicate count word 38 | 39 | queryParamHandler :: Maybe LText.Text -> Maybe Int -> Handler LText.Text 40 | queryParamHandler (Just word) (Just count) = pure $ LText.intercalate "," $ replicate count word 41 | queryParamHandler _ _ = throwError err400 42 | 43 | headerHandler :: Maybe LText.Text -> Handler LText.Text 44 | headerHandler (Just word) = pure word 45 | headerHandler Nothing = throwError err400 46 | 47 | uploadHandler :: LBS.ByteString -> Handler LText.Text 48 | uploadHandler body = 49 | if body == expectedUploadBody 50 | then pure "done" 51 | else pure "not done" 52 | 53 | expectedUploadBody :: LBS.ByteString 54 | expectedUploadBody = LBS.replicate (1024 * 1024) 1 55 | 56 | downloadHandler :: Word8 -> Handler LText.Text 57 | downloadHandler = pure . LText.decodeUtf8 . LBS.replicate (1024 * 1024) 58 | -------------------------------------------------------------------------------- /webgear-benchmarks/src/WebGear.hs: -------------------------------------------------------------------------------- 1 | module WebGear (application) where 2 | 3 | import Data.ByteString (ByteString) 4 | import qualified Data.ByteString as BS 5 | import qualified Data.ByteString.Lazy as LBS 6 | import qualified Data.Text.Lazy as LText 7 | import qualified Data.Text.Lazy.Encoding as LText 8 | import Data.Word (Word8) 9 | import Network.HTTP.Types (StdMethod (..)) 10 | import qualified Network.HTTP.Types as HTTP 11 | import Network.Wai (Application) 12 | import WebGear.Server 13 | 14 | -------------------------------------------------------------------------------- 15 | -- The application server 16 | -------------------------------------------------------------------------------- 17 | application :: Application 18 | application = 19 | toApplication $ 20 | [route| GET /hello |] helloWorldHandler 21 | <+> [route| GET /path-var/word:LText.Text/count:Int |] pathVarHandler 22 | <+> [route| GET /query-param |] queryParamHandler 23 | <+> [route| GET /header |] headerHandler 24 | <+> [route| PUT /upload |] uploadHandler 25 | <+> [route| POST /download/input:Word8 |] downloadHandler 26 | 27 | helloWorldHandler :: (StdHandler h IO) => h (Request `With` ts) Response 28 | helloWorldHandler = proc _request -> do 29 | respondA @LText.Text HTTP.ok200 PlainText -< "Hello World" 30 | 31 | pathVarHandler :: 32 | ( StdHandler h IO 33 | , HaveTraits [PathVar "word" LText.Text, PathVar "count" Int] ts 34 | ) => 35 | h (Request `With` ts) Response 36 | pathVarHandler = proc request -> do 37 | let word = pick @(PathVar "word" LText.Text) $ from request 38 | count = pick @(PathVar "count" Int) $ from request 39 | respondA HTTP.ok200 PlainText -< LText.intercalate "," $ replicate count word 40 | 41 | queryParamHandler :: 42 | ( StdHandler h IO 43 | , Gets h [RequiredQueryParam "word" LText.Text, RequiredQueryParam "count" Int] 44 | ) => 45 | h (Request `With` ts) Response 46 | queryParamHandler = 47 | queryParam @"word" @LText.Text badRequest $ 48 | queryParam @"count" @Int badRequest $ 49 | proc request -> do 50 | let word = pick @(RequiredQueryParam "word" LText.Text) $ from request 51 | count = pick @(RequiredQueryParam "count" Int) $ from request 52 | respondA HTTP.ok200 PlainText -< LText.intercalate "," $ replicate count word 53 | where 54 | badRequest = proc _ -> do 55 | respondA @LText.Text HTTP.badRequest400 PlainText -< "Missing query param" 56 | 57 | headerHandler :: 58 | ( StdHandler h IO 59 | , Get h (RequiredRequestHeader "APIKey" LText.Text) 60 | ) => 61 | h (Request `With` ts) Response 62 | headerHandler = 63 | header @"APIKey" @LText.Text badRequest $ 64 | proc request -> do 65 | let apiKey = pick @(RequiredRequestHeader "APIKey" LText.Text) $ from request 66 | respondA HTTP.ok200 PlainText -< apiKey 67 | where 68 | badRequest = proc _ -> do 69 | respondA @LText.Text HTTP.badRequest400 PlainText -< "Missing header" 70 | 71 | uploadHandler :: 72 | ( StdHandler h IO 73 | , Get h (Body OctetStream ByteString) 74 | ) => 75 | h (Request `With` ts) Response 76 | uploadHandler = 77 | requestBody @ByteString OctetStream badRequest $ 78 | proc request -> do 79 | let body = pick @(Body OctetStream ByteString) $ from request 80 | if body == expectedUploadBody 81 | then respondA @LText.Text HTTP.ok200 PlainText -< "done" 82 | else respondA @LText.Text HTTP.ok200 PlainText -< "not done" 83 | where 84 | badRequest = proc _ -> do 85 | respondA @LText.Text HTTP.badRequest400 PlainText -< "Missing request body" 86 | 87 | expectedUploadBody :: ByteString 88 | expectedUploadBody = BS.replicate (1024 * 1024) 1 89 | 90 | downloadHandler :: 91 | ( StdHandler h IO 92 | , HasTrait (PathVar "input" Word8) ts 93 | ) => 94 | h (Request `With` ts) Response 95 | downloadHandler = 96 | proc request -> do 97 | let input = pick @(PathVar "input" Word8) $ from request 98 | respondA HTTP.ok200 PlainText -< LText.decodeUtf8 $ LBS.replicate (1024 * 1024) input 99 | -------------------------------------------------------------------------------- /webgear-benchmarks/user.json: -------------------------------------------------------------------------------- 1 | {"userId": 1, "userName": "John Doe", "dateOfBirth": "2000-03-01", "gender": "Male", "emailAddress": "john@example.com"} 2 | -------------------------------------------------------------------------------- /webgear-benchmarks/webgear-benchmarks.cabal: -------------------------------------------------------------------------------- 1 | cabal-version: 2.4 2 | name: webgear-benchmarks 3 | version: 1.4.0 4 | description: Benchmarks for webgear 5 | homepage: https://github.com/haskell-webgear/webgear-benchmarks#readme 6 | bug-reports: https://github.com/haskell-webgear/webgear-benchmarks/issues 7 | author: Raghu Kaippully 8 | maintainer: rkaippully@gmail.com 9 | copyright: 2020-2025 Raghu Kaippully 10 | license: MPL-2.0 11 | license-file: LICENSE 12 | build-type: Simple 13 | extra-source-files: README.md 14 | 15 | 16 | source-repository head 17 | type: git 18 | location: https://github.com/haskell-webgear/webgear-benchmarks 19 | 20 | executable benchmarks 21 | default-language: Haskell2010 22 | build-depends: base >=4.17.0.0 && <4.22 23 | , bytestring >=0.11 && <0.13 24 | , criterion >=1.6.1.0 && <1.7 25 | , http-types ==0.12.* 26 | , mtl >=2.2.2 && <2.4 27 | , text >=2.0 && <2.2 28 | , servant ==0.20.2 29 | , servant-server ==0.20.2 30 | , scotty ==0.22 31 | , wai ==3.2.* 32 | , webgear-server ==1.4.0 33 | default-extensions: Arrows 34 | ConstraintKinds 35 | DataKinds 36 | DeriveAnyClass 37 | DeriveGeneric 38 | DerivingVia 39 | FlexibleContexts 40 | GeneralizedNewtypeDeriving 41 | LambdaCase 42 | NamedFieldPuns 43 | OverloadedStrings 44 | QuasiQuotes 45 | RankNTypes 46 | ScopedTypeVariables 47 | TypeApplications 48 | TypeOperators 49 | hs-source-dirs: src 50 | main-is: Main.hs 51 | other-modules: Scotty 52 | , Servant 53 | , WebGear 54 | ghc-options: -O2 55 | -Wall 56 | -Wcompat 57 | -Werror 58 | -Widentities 59 | -Wincomplete-record-updates 60 | -Wincomplete-uni-patterns 61 | -Wmissing-deriving-strategies 62 | -Wmissing-fields 63 | -Wmissing-home-modules 64 | -Wno-unticked-promoted-constructors 65 | -Wpartial-fields 66 | -Wredundant-constraints 67 | -Wunused-packages 68 | -fshow-warning-groups 69 | -rtsopts 70 | -threaded 71 | -------------------------------------------------------------------------------- /webgear-core/CHANGELOG.md: -------------------------------------------------------------------------------- 1 | # Changelog for webgear-core 2 | 3 | ## [Unreleased] 4 | 5 | ## [1.4.0] - 2025-05-19 6 | 7 | ### Added 8 | - Support GHC-9.12 9 | 10 | ### Removed 11 | - Support GHC-9.0, GHC-9.2 12 | 13 | ## [1.3.1] - 2024-11-24 14 | 15 | ### Added 16 | - Support GHC-9.10 17 | 18 | ## [1.3.0] - 2024-06-13 19 | 20 | ### Changed 21 | - Simplify core API (breaking change) (#47) 22 | 23 | ## [1.2.0] - 2024-03-18 24 | 25 | ### Added 26 | - Prerequisite traits (#37) 27 | - acceptMatch middleware (#39) 28 | 29 | ### Changed 30 | - Support for embedding WAI applications in handlers (#36) 31 | 32 | ## [1.1.1] - 2024-01-01 33 | 34 | ### Changed 35 | - Updated dependency bounds and GHC versions (#35) 36 | 37 | ## [1.1.0] - 2023-12-29 38 | 39 | ### Added 40 | - Streaming responses support (#26) 41 | - Support for cookies (#29) 42 | - Support file uploads (#32) 43 | 44 | ### Changed 45 | - Redesign APIs for ease of use (breaking change) (#24) 46 | 47 | ## [1.0.5] - 2023-05-04 48 | 49 | ### Changed 50 | - Update dependency bounds and GHC versions 51 | 52 | ## [1.0.4] - 2022-08-27 53 | 54 | ### Changed 55 | - Update dependency bounds and GHC versions 56 | 57 | ## [1.0.3] - 2022-06-26 58 | 59 | ### Changed 60 | - Upgrade to latest http-api-data (#10) 61 | - Nix flake based development environment 62 | 63 | ## [1.0.2] - 2022-06-11 64 | 65 | ### Changed 66 | - Upgrade to latest GHC versions (#9) 67 | 68 | ## [1.0.1] - 2022-01-09 69 | 70 | ### Changed 71 | - Update dependency bounds (#7) 72 | 73 | ## [1.0.0] - 2022-01-08 74 | 75 | ### Changed 76 | - Extracted webgear-core from webgear-server 77 | - New arrow based API 78 | 79 | [Unreleased]: https://github.com/haskell-webgear/webgear/compare/v1.4.0...HEAD 80 | [1.4.0]: https://github.com/haskell-webgear/webgear/releases/tag/v1.4.0 81 | [1.3.1]: https://github.com/haskell-webgear/webgear/releases/tag/v1.3.1 82 | [1.3.0]: https://github.com/haskell-webgear/webgear/releases/tag/v1.3.0 83 | [1.2.0]: https://github.com/haskell-webgear/webgear/releases/tag/v1.2.0 84 | [1.1.1]: https://github.com/haskell-webgear/webgear/releases/tag/v1.1.1 85 | [1.1.0]: https://github.com/haskell-webgear/webgear/releases/tag/v1.1.0 86 | [1.0.5]: https://github.com/haskell-webgear/webgear/releases/tag/v1.0.5 87 | [1.0.4]: https://github.com/haskell-webgear/webgear/releases/tag/v1.0.4 88 | [1.0.3]: https://github.com/haskell-webgear/webgear/releases/tag/v1.0.3 89 | [1.0.2]: https://github.com/haskell-webgear/webgear/releases/tag/v1.0.2 90 | [1.0.1]: https://github.com/haskell-webgear/webgear/releases/tag/v1.0.1 91 | [1.0.0]: https://github.com/haskell-webgear/webgear/releases/tag/v1.0.0 92 | -------------------------------------------------------------------------------- /webgear-core/README.md: -------------------------------------------------------------------------------- 1 | # WebGear - Core HTTP APIs 2 | 3 | [![Hackage](https://img.shields.io/hackage/v/webgear-core)](https://hackage.haskell.org/package/webgear-core) 4 | 5 | WebGear is a Haskell library for building composable, type-safe HTTP API servers. 6 | 7 | This package defines the core components of WebGear used to define APIs. 8 | -------------------------------------------------------------------------------- /webgear-core/src/WebGear/Core.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -Wno-unused-imports #-} 2 | 3 | {- | WebGear is a library to build composable, type-safe HTTP APIs. 4 | 5 | The modules below have haddock documentation that can be used as 6 | reference material. If you are completely new to WebGear, a good 7 | starting point is the [WebGear User 8 | Guide](https://haskell-webgear.github.io/user_guide/1.0.0/index.html). Example 9 | programs built using WebGear are available under 10 | . 11 | 12 | Importing "WebGear.Core" is a quick way to get everything needed to 13 | build WebGear API specifications. 14 | -} 15 | module WebGear.Core ( 16 | module Control.Arrow, 17 | module WebGear.Core.Trait, 18 | module WebGear.Core.Request, 19 | module WebGear.Core.Response, 20 | module WebGear.Core.Modifiers, 21 | module WebGear.Core.Handler, 22 | module WebGear.Core.Handler.Static, 23 | module WebGear.Core.Traits, 24 | module WebGear.Core.MIMETypes, 25 | ) where 26 | 27 | import Control.Arrow 28 | import qualified Network.Wai as Wai 29 | import WebGear.Core.MIMETypes 30 | 31 | import WebGear.Core.Handler 32 | import WebGear.Core.Handler.Static 33 | import WebGear.Core.Modifiers 34 | import WebGear.Core.Request 35 | import WebGear.Core.Response 36 | import WebGear.Core.Trait 37 | import WebGear.Core.Traits 38 | -------------------------------------------------------------------------------- /webgear-core/src/WebGear/Core/Handler.hs: -------------------------------------------------------------------------------- 1 | {- | 2 | WebGear handlers 3 | -} 4 | module WebGear.Core.Handler ( 5 | Handler (..), 6 | RoutePath (..), 7 | RouteMismatch (..), 8 | Description (..), 9 | Summary (..), 10 | RequestHandler, 11 | Middleware, 12 | routeMismatch, 13 | unwitnessA, 14 | (>->), 15 | (<-<), 16 | ) where 17 | 18 | import Control.Arrow (Arrow, ArrowChoice, ArrowPlus, arr) 19 | import Control.Arrow.Operations (ArrowError (..)) 20 | import Data.String (IsString) 21 | import Data.Text (Text) 22 | import GHC.Exts (IsList (..)) 23 | import WebGear.Core.Request (Request) 24 | import WebGear.Core.Response (Response (..)) 25 | import WebGear.Core.Trait (With (unwitness)) 26 | 27 | -- | Parts of the request path used by the routing machinery 28 | newtype RoutePath = RoutePath [Text] 29 | deriving newtype (Show, Eq) 30 | 31 | instance IsList RoutePath where 32 | type Item RoutePath = Text 33 | fromList = RoutePath 34 | toList (RoutePath ps) = ps 35 | 36 | {- | A handler is an arrow with a monadic context. 37 | 38 | Handlers have the following capabilities: 39 | 40 | * Lift a monadic action into a handler arrow. 41 | * Implement `ArrowChoice` typeclass so that conditionals can be used in arrow code. 42 | * Implement `ArrowPlus` for routing requests to specific handlers. 43 | * Provide contextual documentation elements - description and summary 44 | -} 45 | class (ArrowChoice h, ArrowPlus h, ArrowError RouteMismatch h, Monad m) => Handler h m | h -> m where 46 | -- | Lift a monadic function to a handler arrow 47 | arrM :: (a -> m b) -> h a b 48 | 49 | -- | Consume all remaining path components with an arrow 50 | consumeRoute :: h RoutePath a -> h () a 51 | 52 | -- | Set a description of a part of an API 53 | setDescription :: Description -> h a a 54 | 55 | -- | Set a summary of a part of an API 56 | setSummary :: Summary -> h a a 57 | 58 | -- | A handler arrow from a witnessed request to response. 59 | type RequestHandler h ts = h (Request `With` ts) Response 60 | 61 | -- | A middleware enhances a `RequestHandler` and produces another handler. 62 | type Middleware h tsOut tsIn = RequestHandler h tsIn -> RequestHandler h tsOut 63 | 64 | -- | Description associated with part of an API 65 | newtype Description = Description {getDescription :: Text} 66 | deriving stock (Eq, Ord, Show, Read) 67 | deriving newtype (IsString) 68 | 69 | -- | A summary associated with part of an API 70 | newtype Summary = Summary {getSummary :: Text} 71 | deriving stock (Eq, Ord, Show, Read) 72 | deriving newtype (IsString) 73 | 74 | -- | Indicates that a handler cannot process this route 75 | data RouteMismatch = RouteMismatch 76 | deriving stock (Show, Eq, Ord) 77 | 78 | instance Semigroup RouteMismatch where 79 | RouteMismatch <> RouteMismatch = RouteMismatch 80 | 81 | instance Monoid RouteMismatch where 82 | mempty = RouteMismatch 83 | 84 | -- | Indicates that the request does not match the current handler. 85 | routeMismatch :: (ArrowError RouteMismatch h) => h a b 86 | routeMismatch = proc _a -> raise -< RouteMismatch 87 | {-# INLINE routeMismatch #-} 88 | 89 | -- | Lifts `unwitness` into a handler arrow. 90 | unwitnessA :: (Handler h m) => h (Response `With` ts) Response 91 | unwitnessA = arr unwitness 92 | {-# INLINE unwitnessA #-} 93 | 94 | infixr 1 >->, <-< 95 | 96 | {- | Thread a response through commands from left to right. 97 | 98 | For example, an HTTP 200 response with a body and Content-Type header 99 | can be generated with: 100 | 101 | @ 102 | (ok200 -< ()) 103 | >-> (\resp -> setBody "text/plain" -< (resp, "Hello World")) 104 | >-> (\resp -> unwitnessA -< resp) 105 | @ 106 | -} 107 | (>->) :: (Arrow h) => h (env, stack) a -> h (env, (a, stack)) b -> h (env, stack) b 108 | f >-> g = proc (env, stack) -> do 109 | a <- f -< (env, stack) 110 | g -< (env, (a, stack)) 111 | {-# INLINE (>->) #-} 112 | 113 | {- | Thread a response through commands from right to left. 114 | 115 | For example, an HTTP 200 response with a body and Content-Type header 116 | can be generated with: 117 | 118 | @ 119 | (\resp -> unwitnessA -< resp) 120 | <-< (\resp -> setBody "text/plain" -< (resp, "Hello World")) 121 | <-< (ok200 -< ()) 122 | @ 123 | -} 124 | (<-<) :: (Arrow h) => h (env, (a, stack)) b -> h (env, stack) a -> h (env, stack) b 125 | f <-< g = proc (env, stack) -> do 126 | a <- g -< (env, stack) 127 | f -< (env, (a, stack)) 128 | {-# INLINE (<-<) #-} 129 | -------------------------------------------------------------------------------- /webgear-core/src/WebGear/Core/Handler/Static.hs: -------------------------------------------------------------------------------- 1 | {- | 2 | Handlers for serving static resources 3 | -} 4 | module WebGear.Core.Handler.Static ( 5 | serveStatic, 6 | ) where 7 | 8 | import Control.Arrow (returnA) 9 | import Network.Wai (Request (..)) 10 | import qualified Network.Wai.Application.Static as Wai.Static 11 | import WebGear.Core.Handler (Handler (..), RequestHandler, RoutePath (..)) 12 | import WebGear.Core.Request (toWaiRequest) 13 | import WebGear.Core.Response (Response (ResponseCont)) 14 | import WebGear.Core.Trait (unwitness) 15 | import Prelude hiding (readFile) 16 | 17 | -- | Serve static assets 18 | serveStatic :: (Handler h m) => Wai.Static.StaticSettings -> RequestHandler h ts 19 | serveStatic settings = 20 | proc request -> do 21 | RoutePath pathInfo <- consumeRoute returnA -< () 22 | let waiRequest = toWaiRequest $ unwitness request 23 | returnA -< ResponseCont $ Wai.Static.staticApp settings waiRequest{pathInfo} 24 | -------------------------------------------------------------------------------- /webgear-core/src/WebGear/Core/MIMETypes.hs: -------------------------------------------------------------------------------- 1 | -- | MIME types for HTTP bodies 2 | module WebGear.Core.MIMETypes ( 3 | MIMEType (..), 4 | FormURLEncoded (..), 5 | HTML (..), 6 | JSON (..), 7 | FormData (..), 8 | FormDataResult (..), 9 | OctetStream (..), 10 | PlainText (..), 11 | ) where 12 | 13 | import Data.String (IsString (fromString)) 14 | import Data.Text (Text, unpack) 15 | import qualified Network.HTTP.Media as HTTP 16 | import qualified Network.Wai.Parse as Wai.Parse 17 | 18 | -- | MIME types used in the Accept and Content-Type headers 19 | class MIMEType mt where 20 | mimeType :: mt -> HTTP.MediaType 21 | 22 | -------------------------------------------------------------------------------- 23 | 24 | -- | The application/x-www-form-urlencoded MIME type 25 | data FormURLEncoded = FormURLEncoded 26 | 27 | instance MIMEType FormURLEncoded where 28 | mimeType :: FormURLEncoded -> HTTP.MediaType 29 | mimeType FormURLEncoded = "application/x-www-form-urlencoded" 30 | {-# INLINE mimeType #-} 31 | 32 | -------------------------------------------------------------------------------- 33 | 34 | -- | The text/html MIME type 35 | data HTML = HTML 36 | 37 | instance MIMEType HTML where 38 | mimeType :: HTML -> HTTP.MediaType 39 | mimeType HTML = "text/html" 40 | {-# INLINE mimeType #-} 41 | 42 | -------------------------------------------------------------------------------- 43 | 44 | -- | A JSON MIME type with customizable media type 45 | data JSON 46 | = -- | JSON with a specific media type 47 | JSONMedia Text 48 | | -- | application/json media type 49 | JSON 50 | 51 | instance MIMEType JSON where 52 | mimeType :: JSON -> HTTP.MediaType 53 | mimeType = 54 | \case 55 | JSONMedia mt -> fromString (unpack mt) 56 | JSON -> "application/json" 57 | {-# INLINE mimeType #-} 58 | 59 | -------------------------------------------------------------------------------- 60 | 61 | -- | The multipart/form-data MIME type 62 | data FormData a = FormData 63 | { parseOptions :: Wai.Parse.ParseRequestBodyOptions 64 | , backendOptions :: Wai.Parse.BackEnd a 65 | } 66 | 67 | {- | Result of parsing a multipart/form-data body from a request. 68 | The body can contain both parameters and files. 69 | -} 70 | data FormDataResult a = FormDataResult 71 | { formDataParams :: [Wai.Parse.Param] 72 | , formDataFiles :: [Wai.Parse.File a] 73 | } 74 | 75 | instance MIMEType (FormData a) where 76 | mimeType :: FormData a -> HTTP.MediaType 77 | mimeType _ = "multipart/form-data" 78 | {-# INLINE mimeType #-} 79 | 80 | -------------------------------------------------------------------------------- 81 | 82 | -- | The application/octet-stream MIME type 83 | data OctetStream = OctetStream 84 | 85 | instance MIMEType OctetStream where 86 | mimeType :: OctetStream -> HTTP.MediaType 87 | mimeType OctetStream = "application/octet-stream" 88 | {-# INLINE mimeType #-} 89 | 90 | -------------------------------------------------------------------------------- 91 | 92 | -- | The text/plain MIME type 93 | data PlainText = PlainText 94 | 95 | instance MIMEType PlainText where 96 | mimeType :: PlainText -> HTTP.MediaType 97 | mimeType PlainText = "text/plain" 98 | {-# INLINE mimeType #-} 99 | -------------------------------------------------------------------------------- /webgear-core/src/WebGear/Core/Modifiers.hs: -------------------------------------------------------------------------------- 1 | -- | Various modifiers used by traits 2 | module WebGear.Core.Modifiers ( 3 | Existence (..), 4 | ParseStyle (..), 5 | ) where 6 | 7 | {- | Modifier used to indicate whether a trait is required or 8 | optional. 9 | -} 10 | data Existence = Required | Optional 11 | 12 | {- | Modifier used to indicate whether a trait is parsed strictly or 13 | leniently. 14 | -} 15 | data ParseStyle = Strict | Lenient 16 | -------------------------------------------------------------------------------- /webgear-core/src/WebGear/Core/Request.hs: -------------------------------------------------------------------------------- 1 | {- | 2 | Requests processed by handlers. 3 | -} 4 | module WebGear.Core.Request ( 5 | -- * WebGear Request 6 | Request (..), 7 | remoteHost, 8 | httpVersion, 9 | isSecure, 10 | requestMethod, 11 | pathInfo, 12 | queryString, 13 | requestHeader, 14 | requestHeaders, 15 | requestBodyLength, 16 | getRequestBodyChunk, 17 | getRequestBody, 18 | ) where 19 | 20 | import Data.ByteString (ByteString) 21 | import qualified Data.ByteString.Lazy as LBS 22 | import Data.List (find) 23 | import Data.Text (Text) 24 | import qualified Network.HTTP.Types as HTTP 25 | import Network.Socket (SockAddr) 26 | import qualified Network.Wai as Wai 27 | 28 | -- | A request processed by a handler 29 | newtype Request = Request 30 | { toWaiRequest :: Wai.Request 31 | -- ^ underlying WAI request 32 | } 33 | 34 | -- | Get the value of a request header 35 | requestHeader :: HTTP.HeaderName -> Request -> Maybe ByteString 36 | requestHeader h r = snd <$> find ((== h) . fst) (requestHeaders r) 37 | 38 | -- | See 'Wai.getRequestBodyChunk' 39 | getRequestBodyChunk :: Request -> IO ByteString 40 | getRequestBodyChunk = Wai.getRequestBodyChunk . toWaiRequest 41 | 42 | -- | Returns the entire request body as a lazy bytestring 43 | getRequestBody :: Request -> IO LBS.ByteString 44 | getRequestBody = Wai.lazyRequestBody . toWaiRequest 45 | 46 | -- | See 'Wai.httpVersion' 47 | httpVersion :: Request -> HTTP.HttpVersion 48 | httpVersion = Wai.httpVersion . toWaiRequest 49 | 50 | -- | See 'Wai.isSecure' 51 | isSecure :: Request -> Bool 52 | isSecure = Wai.isSecure . toWaiRequest 53 | 54 | -- | See 'Wai.pathInfo' 55 | pathInfo :: Request -> [Text] 56 | pathInfo = Wai.pathInfo . toWaiRequest 57 | 58 | -- | See 'Wai.queryString' 59 | queryString :: Request -> HTTP.Query 60 | queryString = Wai.queryString . toWaiRequest 61 | 62 | -- | See 'Wai.remoteHost' 63 | remoteHost :: Request -> SockAddr 64 | remoteHost = Wai.remoteHost . toWaiRequest 65 | 66 | -- | See 'Wai.requestBodyLength' 67 | requestBodyLength :: Request -> Wai.RequestBodyLength 68 | requestBodyLength = Wai.requestBodyLength . toWaiRequest 69 | 70 | -- | See 'Wai.requestHeaders' 71 | requestHeaders :: Request -> HTTP.RequestHeaders 72 | requestHeaders = Wai.requestHeaders . toWaiRequest 73 | 74 | -- | See 'Wai.requestMethod' 75 | requestMethod :: Request -> HTTP.Method 76 | requestMethod = Wai.requestMethod . toWaiRequest 77 | -------------------------------------------------------------------------------- /webgear-core/src/WebGear/Core/Response.hs: -------------------------------------------------------------------------------- 1 | {- | 2 | Responses from handlers. 3 | -} 4 | module WebGear.Core.Response ( 5 | -- * Basic Types 6 | Response (..), 7 | ResponseBody (..), 8 | ) where 9 | 10 | import qualified Data.Binary.Builder as B 11 | import Data.ByteString (ByteString) 12 | import qualified Network.HTTP.Types as HTTP 13 | import qualified Network.Wai as Wai 14 | 15 | -- | An HTTP response sent from the server to the client. 16 | data Response 17 | = Response HTTP.Status HTTP.ResponseHeaders ResponseBody 18 | | ResponseRaw (IO ByteString -> (ByteString -> IO ()) -> IO ()) Wai.Response 19 | | ResponseCont ((Wai.Response -> IO Wai.ResponseReceived) -> IO Wai.ResponseReceived) 20 | 21 | -- | HTTP response body 22 | data ResponseBody 23 | = ResponseBodyFile FilePath (Maybe Wai.FilePart) 24 | | ResponseBodyBuilder B.Builder 25 | | ResponseBodyStream Wai.StreamingBody 26 | -------------------------------------------------------------------------------- /webgear-core/src/WebGear/Core/Trait/Auth/Common.hs: -------------------------------------------------------------------------------- 1 | {- | 2 | Common types and functions related to authorization. 3 | -} 4 | module WebGear.Core.Trait.Auth.Common ( 5 | AuthorizationHeader, 6 | Realm (..), 7 | AuthToken (..), 8 | respondUnauthorized, 9 | ) where 10 | 11 | import Data.ByteString (ByteString, drop) 12 | import Data.ByteString.Char8 (break) 13 | import Data.CaseInsensitive (CI, mk, original) 14 | import Data.Proxy (Proxy (..)) 15 | import Data.String (IsString (..)) 16 | import Data.Text (Text) 17 | import Data.Text.Encoding (decodeUtf8, encodeUtf8) 18 | import GHC.TypeLits (KnownSymbol, Symbol, symbolVal) 19 | import Web.HttpApiData (FromHttpApiData (..)) 20 | import WebGear.Core.Handler (Handler, unwitnessA, (>->)) 21 | import WebGear.Core.MIMETypes (PlainText (..)) 22 | import WebGear.Core.Modifiers (Existence (..), ParseStyle (..)) 23 | import WebGear.Core.Response (Response) 24 | import WebGear.Core.Trait (Sets) 25 | import WebGear.Core.Trait.Body (Body, setBody) 26 | import WebGear.Core.Trait.Header (RequestHeader (..), RequiredResponseHeader, setHeader) 27 | import WebGear.Core.Trait.Status (Status, unauthorized401) 28 | import Prelude hiding (break, drop) 29 | 30 | -- | Trait for \"Authorization\" header 31 | type AuthorizationHeader scheme = RequestHeader Optional Lenient "Authorization" (AuthToken scheme) 32 | 33 | -- | The protection space for authentication 34 | newtype Realm = Realm ByteString 35 | deriving newtype (Eq, Ord, Show, Read, IsString) 36 | 37 | -- | The components of Authorization request header 38 | data AuthToken (scheme :: Symbol) = AuthToken 39 | { authScheme :: CI ByteString 40 | -- ^ Authentication scheme 41 | , authToken :: ByteString 42 | -- ^ Authentication token 43 | } 44 | 45 | instance (KnownSymbol scheme) => FromHttpApiData (AuthToken scheme) where 46 | {-# INLINE parseUrlPiece #-} 47 | parseUrlPiece :: Text -> Either Text (AuthToken scheme) 48 | parseUrlPiece = parseHeader . encodeUtf8 49 | 50 | {-# INLINE parseHeader #-} 51 | parseHeader :: ByteString -> Either Text (AuthToken scheme) 52 | parseHeader hdr = 53 | case break (== ' ') hdr of 54 | (scm, tok) -> 55 | let actualScheme = mk scm 56 | expectedScheme = fromString $ symbolVal $ Proxy @scheme 57 | in if actualScheme == expectedScheme 58 | then Right (AuthToken actualScheme (drop 1 tok)) 59 | else Left "scheme mismatch" 60 | 61 | {- | Create a \"401 Unauthorized\" response. 62 | 63 | The response will have a plain text body and an appropriate 64 | \"WWW-Authenticate\" header. 65 | -} 66 | respondUnauthorized :: 67 | ( Handler h m 68 | , Sets 69 | h 70 | [ Status 71 | , RequiredResponseHeader "Content-Type" Text 72 | , RequiredResponseHeader "WWW-Authenticate" Text 73 | , Body PlainText Text 74 | ] 75 | ) => 76 | -- | The authentication scheme 77 | CI ByteString -> 78 | -- | The authentication realm 79 | Realm -> 80 | h a Response 81 | respondUnauthorized scheme (Realm realm) = proc _ -> do 82 | let headerVal = decodeUtf8 $ original scheme <> " realm=\"" <> realm <> "\"" 83 | (unauthorized401 -< ()) 84 | >-> (\resp -> setBody PlainText -< (resp, "Unauthorized" :: Text)) 85 | >-> (\resp -> setHeader @"WWW-Authenticate" -< (resp, headerVal)) 86 | >-> (\resp -> unwitnessA -< resp) 87 | {-# INLINE respondUnauthorized #-} 88 | -------------------------------------------------------------------------------- /webgear-core/src/WebGear/Core/Trait/Cookie.hs: -------------------------------------------------------------------------------- 1 | -- | Traits and middlewares to handle cookies in requests and responses. 2 | module WebGear.Core.Trait.Cookie ( 3 | -- * Traits 4 | Cookie (..), 5 | CookieNotFound (..), 6 | CookieParseError (..), 7 | SetCookie (..), 8 | 9 | -- * Middlewares 10 | cookie, 11 | optionalCookie, 12 | setCookie, 13 | setOptionalCookie, 14 | ) where 15 | 16 | import Control.Arrow (ArrowChoice) 17 | import Data.Kind (Type) 18 | import Data.Text (Text) 19 | import GHC.TypeLits (Symbol) 20 | import qualified Web.Cookie as Cookie 21 | import WebGear.Core.Handler (Middleware) 22 | import WebGear.Core.Modifiers (Existence (..), ParseStyle (..)) 23 | import WebGear.Core.Request (Request) 24 | import WebGear.Core.Response (Response) 25 | import WebGear.Core.Trait ( 26 | Absence, 27 | Attribute, 28 | Get, 29 | HasTrait, 30 | Prerequisite, 31 | Set, 32 | With, 33 | plant, 34 | probe, 35 | ) 36 | import WebGear.Core.Trait.Header (RequestHeader) 37 | 38 | -- | Indicates a missing cookie 39 | data CookieNotFound = CookieNotFound 40 | deriving stock (Read, Show, Eq) 41 | 42 | -- | Error in converting a cookie to the expected type 43 | newtype CookieParseError = CookieParseError Text 44 | deriving stock (Read, Show, Eq) 45 | 46 | -- | Trait for a cookie in HTTP requests 47 | data Cookie (e :: Existence) (name :: Symbol) (val :: Type) = Cookie 48 | 49 | type instance Attribute (Cookie Required name val) Request = val 50 | type instance Absence (Cookie Required name val) = Either CookieNotFound CookieParseError 51 | type instance 52 | Prerequisite (Cookie e name val) ts = 53 | HasTrait (RequestHeader e Strict "Cookie" Text) ts 54 | 55 | type instance Attribute (Cookie Optional name val) Request = Maybe val 56 | type instance Absence (Cookie Optional name val) = CookieParseError 57 | 58 | cookieHandler :: 59 | forall name val e h ts. 60 | ( ArrowChoice h 61 | , Get h (Cookie e name val) 62 | , HasTrait (RequestHeader e Strict "Cookie" Text) ts 63 | ) => 64 | -- | error handler 65 | h (Request `With` ts, Absence (Cookie e name val)) Response -> 66 | Middleware h ts (Cookie e name val : ts) 67 | cookieHandler errorHandler nextHandler = proc request -> do 68 | result <- probe Cookie -< request 69 | case result of 70 | Left err -> errorHandler -< (request, err) 71 | Right val -> nextHandler -< val 72 | {-# INLINE cookieHandler #-} 73 | 74 | {- | Extract a cookie and convert it to a value of type @val@. 75 | 76 | The associated trait attribute has type @val@. 77 | 78 | Example usage: 79 | 80 | > cookie @"name" @Integer errorHandler okHandler 81 | -} 82 | cookie :: 83 | forall name val h ts. 84 | ( ArrowChoice h 85 | , Get h (Cookie Required name val) 86 | , HasTrait (RequestHeader Required Strict "Cookie" Text) ts 87 | ) => 88 | -- | Error handler 89 | h (Request `With` ts, Either CookieNotFound CookieParseError) Response -> 90 | Middleware h ts (Cookie Required name val : ts) 91 | cookie = cookieHandler 92 | {-# INLINE cookie #-} 93 | 94 | {- | Extract an optional cookie and convert it to a value of type @val@. 95 | 96 | The associated trait attribute has type @Maybe val@; a @Nothing@ 97 | value indicates that the cookie is missing from the request. 98 | 99 | Example usage: 100 | 101 | > optionalCookie @"name" @Integer errorHandler okHandler 102 | -} 103 | optionalCookie :: 104 | forall name val h ts. 105 | ( ArrowChoice h 106 | , Get h (Cookie Optional name val) 107 | , HasTrait (RequestHeader Optional Strict "Cookie" Text) ts 108 | ) => 109 | -- | Error handler 110 | h (Request `With` ts, CookieParseError) Response -> 111 | Middleware h ts (Cookie Optional name val : ts) 112 | optionalCookie = cookieHandler 113 | {-# INLINE optionalCookie #-} 114 | 115 | -- | Trait for a cookie in HTTP responses 116 | data SetCookie (e :: Existence) (name :: Symbol) = SetCookie 117 | 118 | type instance Attribute (SetCookie Required name) Response = Cookie.SetCookie 119 | 120 | type instance Attribute (SetCookie Optional name) Response = Maybe Cookie.SetCookie 121 | 122 | {- | Set a cookie value in a response. 123 | 124 | Example usage: 125 | 126 | > response' <- setCookie @"name" -< (response, cookie) 127 | -} 128 | setCookie :: 129 | forall name h ts. 130 | (Set h (SetCookie Required name)) => 131 | h (Response `With` ts, Cookie.SetCookie) (Response `With` (SetCookie Required name : ts)) 132 | setCookie = plant SetCookie 133 | {-# INLINE setCookie #-} 134 | 135 | {- | Set an optional cookie value in a response. 136 | 137 | Setting the cookie to 'Nothing' will remove it from the response if 138 | it was previously set. The cookie will be considered as optional in 139 | all relevant places (such as documentation). 140 | 141 | Example usage: 142 | 143 | > response' <- setOptionalCookie @"name" -< (response, cookie) 144 | -} 145 | setOptionalCookie :: 146 | forall name h ts. 147 | (Set h (SetCookie Optional name)) => 148 | h (Response `With` ts, Maybe Cookie.SetCookie) (Response `With` (SetCookie Optional name : ts)) 149 | setOptionalCookie = plant SetCookie 150 | {-# INLINE setOptionalCookie #-} 151 | -------------------------------------------------------------------------------- /webgear-core/src/WebGear/Core/Trait/Method.hs: -------------------------------------------------------------------------------- 1 | -- | Traits and middlewares to handle HTTP methods. 2 | module WebGear.Core.Trait.Method ( 3 | Method (..), 4 | MethodMismatch (..), 5 | method, 6 | ) where 7 | 8 | import Control.Arrow (ArrowChoice (..), (>>>)) 9 | import Control.Arrow.Operations (ArrowError) 10 | import qualified Network.HTTP.Types as HTTP 11 | import WebGear.Core.Handler (Middleware, RouteMismatch, routeMismatch) 12 | import WebGear.Core.Request (Request) 13 | import WebGear.Core.Trait (Absence, Attribute, Get (..), Prerequisite, probe) 14 | 15 | -- | A trait for capturing the HTTP method of a request 16 | newtype Method = Method HTTP.StdMethod 17 | 18 | -- | Failure to match method against an expected value 19 | data MethodMismatch = MethodMismatch 20 | { expectedMethod :: HTTP.Method 21 | , actualMethod :: HTTP.Method 22 | } 23 | 24 | type instance Attribute Method Request = HTTP.StdMethod 25 | type instance Absence Method = MethodMismatch 26 | type instance Prerequisite Method ts = () 27 | 28 | {- | Check whether the request has a specified HTTP method. 29 | 30 | Example usage: 31 | 32 | > method @GET handler 33 | 34 | If the request does not have the specified method, another handler 35 | will be tried. 36 | 37 | It is also idiomatic to use the template haskell quasiquoter 38 | 'WebGear.Core.Trait.Path.match' or 'WebGear.Core.Trait.Path.route' in 39 | cases where both an HTTP method and a path need to be matched. 40 | -} 41 | method :: 42 | (Get h Method, ArrowChoice h, ArrowError RouteMismatch h) => 43 | HTTP.StdMethod -> 44 | Middleware h ts (Method : ts) 45 | method m nextHandler = probe (Method m) >>> routeMismatch ||| nextHandler 46 | {-# INLINE method #-} 47 | -------------------------------------------------------------------------------- /webgear-core/src/WebGear/Core/Traits.hs: -------------------------------------------------------------------------------- 1 | -- | All the traits supported by WebGear. 2 | module WebGear.Core.Traits ( 3 | module WebGear.Core.Trait.Auth.Basic, 4 | module WebGear.Core.Trait.Auth.JWT, 5 | module WebGear.Core.Trait.Auth.Common, 6 | module WebGear.Core.Trait.Body, 7 | module WebGear.Core.Trait.Cookie, 8 | module WebGear.Core.Trait.Header, 9 | module WebGear.Core.Trait.Method, 10 | module WebGear.Core.Trait.Path, 11 | module WebGear.Core.Trait.QueryParam, 12 | module WebGear.Core.Trait.Status, 13 | StdHandler, 14 | ) where 15 | 16 | import qualified Data.Text as Text 17 | import qualified Data.Text.Lazy as LText 18 | import WebGear.Core.Handler (Handler) 19 | import WebGear.Core.MIMETypes (PlainText) 20 | import WebGear.Core.Trait (Gets, Sets) 21 | import WebGear.Core.Trait.Auth.Basic 22 | import WebGear.Core.Trait.Auth.Common 23 | import WebGear.Core.Trait.Auth.JWT 24 | import WebGear.Core.Trait.Body 25 | import WebGear.Core.Trait.Cookie 26 | import WebGear.Core.Trait.Header 27 | import WebGear.Core.Trait.Method 28 | import WebGear.Core.Trait.Path 29 | import WebGear.Core.Trait.QueryParam 30 | import WebGear.Core.Trait.Status 31 | 32 | {- | Constraints that include a set of common traits for handlers. 33 | 34 | The type variables are: 35 | 36 | * @h@ - The handler arrow 37 | * @m@ - The underlying monad of the handler 38 | -} 39 | type StdHandler h m = 40 | ( Handler h m 41 | , Gets h [Method, Path, PathEnd] 42 | , Sets 43 | h 44 | '[ Status 45 | , Body PlainText String 46 | , Body PlainText Text.Text 47 | , Body PlainText LText.Text 48 | , RequiredResponseHeader "Content-Type" Text.Text 49 | ] 50 | ) 51 | -------------------------------------------------------------------------------- /webgear-core/webgear-core.cabal: -------------------------------------------------------------------------------- 1 | cabal-version: 2.4 2 | 3 | name: webgear-core 4 | version: 1.4.0 5 | synopsis: Composable, type-safe library to build HTTP APIs 6 | description: 7 | WebGear is a library to for building composable, type-safe HTTP APIs. 8 | See the documentation of WebGear.Core module to get started. 9 | homepage: https://github.com/haskell-webgear/webgear#readme 10 | bug-reports: https://github.com/haskell-webgear/webgear/issues 11 | author: Raghu Kaippully 12 | maintainer: rkaippully@gmail.com 13 | copyright: 2020-2025 Raghu Kaippully 14 | license: MPL-2.0 15 | license-file: LICENSE 16 | category: Web 17 | build-type: Simple 18 | extra-source-files: README.md 19 | CHANGELOG.md 20 | 21 | 22 | source-repository head 23 | type: git 24 | location: https://github.com/haskell-webgear/webgear 25 | 26 | 27 | library 28 | default-language: Haskell2010 29 | default-extensions: Arrows 30 | ConstraintKinds 31 | DataKinds 32 | DeriveFunctor 33 | DeriveGeneric 34 | DerivingStrategies 35 | DerivingVia 36 | FlexibleContexts 37 | FlexibleInstances 38 | FunctionalDependencies 39 | GeneralizedNewtypeDeriving 40 | InstanceSigs 41 | KindSignatures 42 | LambdaCase 43 | MultiParamTypeClasses 44 | NamedFieldPuns 45 | OverloadedLists 46 | OverloadedStrings 47 | PolyKinds 48 | RankNTypes 49 | RecordWildCards 50 | ScopedTypeVariables 51 | StandaloneDeriving 52 | TemplateHaskellQuotes 53 | TypeApplications 54 | TypeFamilies 55 | TypeOperators 56 | build-depends: arrows ==0.4.* 57 | , base >=4.17.0.0 && <4.22 58 | , binary >= 0.8.0.0 && <0.9 59 | , bytestring >=0.11.0.0 && <0.13 60 | , case-insensitive ==1.2.* 61 | , cookie >=0.4.5 && <0.6 62 | , http-api-data >=0.5 && <0.7 63 | , http-media ==0.8.* 64 | , http-types ==0.12.* 65 | , jose >=0.10 && <0.12 66 | , network >=3.1.0 && <3.3 67 | , tagged ==0.8.* 68 | , template-haskell >=2.19.0.0 && <2.24 69 | , text >=2.0 && <2.2 70 | , wai ==3.2.* 71 | , wai-app-static ==3.1.* 72 | , wai-extra ==3.1.* 73 | ghc-options: -Wall 74 | -Wcompat 75 | -Widentities 76 | -Wincomplete-record-updates 77 | -Wincomplete-uni-patterns 78 | -Wmissing-deriving-strategies 79 | -Wmissing-fields 80 | -Wmissing-home-modules 81 | -Wno-unticked-promoted-constructors 82 | -Wpartial-fields 83 | -Wredundant-constraints 84 | -Wunused-packages 85 | -fshow-warning-groups 86 | exposed-modules: WebGear.Core 87 | , WebGear.Core.Modifiers 88 | , WebGear.Core.Trait 89 | , WebGear.Core.Request 90 | , WebGear.Core.Response 91 | , WebGear.Core.Handler 92 | , WebGear.Core.MIMETypes 93 | , WebGear.Core.Traits 94 | , WebGear.Core.Trait.Auth.Basic 95 | , WebGear.Core.Trait.Auth.JWT 96 | , WebGear.Core.Trait.Auth.Common 97 | , WebGear.Core.Trait.Body 98 | , WebGear.Core.Trait.Cookie 99 | , WebGear.Core.Trait.Header 100 | , WebGear.Core.Trait.Method 101 | , WebGear.Core.Trait.Path 102 | , WebGear.Core.Trait.QueryParam 103 | , WebGear.Core.Trait.Status 104 | , WebGear.Core.Handler.Static 105 | hs-source-dirs: src 106 | -------------------------------------------------------------------------------- /webgear-example-realworld/README.md: -------------------------------------------------------------------------------- 1 | # WebGear realworld 2 | A medium.com clone (called conduit) specified by https://github.com/gothinkster/realworld. 3 | 4 | Run with: 5 | 6 | ```shell 7 | nix develop 8 | cabal run 9 | ``` 10 | 11 | This starts the app at http://localhost:3000/ 12 | 13 | There are two user accounts already created in the DB: 14 | 15 | - Email: `arya@winterfell.com` Password: `valar_morghulis` 16 | - Email: `jon@winterfell.com` Password: `winter_is_coming` 17 | -------------------------------------------------------------------------------- /webgear-example-realworld/realworld.db: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/haskell-webgear/webgear/ce807d4cacecfb316e0e5c42c53fdd46b6c62c70/webgear-example-realworld/realworld.db -------------------------------------------------------------------------------- /webgear-example-realworld/realworld.jwk: -------------------------------------------------------------------------------- 1 | { 2 | "p": "66FH3ZnC2Mbr_uzZewvyq2CKoVmoTC1BSAlyKZwCx3_LynkiQkUkEae_KhXcu_wryU7GHsdCTfDisW1wL4hl4IARmHaNfhOKuKcCj7M6byeZqJNOOaNxOuM0XKB38wEh2j8IA_1ZIQA24zNyM4BBNxWWcRmpMMtK0qRS82F3vmM", 3 | "kty": "RSA", 4 | "q": "pguCvmVp91hxj9rgFwdjMktY9sXfNXfgwNrOj3gaOgFWPWVQhSerj0hGAgCb8i4IxoLIDjuDXHKOJDHzHMbkR6ZPEGryKqqH1pan7qqyir8XsVmGkUdtls53_vg7pcQfoWVBiFWqXRZSo14WOOGqvoHB71_6kVBqIRNknAvjIHU", 5 | "d": "Hi0ZKvsvU1e3K1kRlfKye9j2A9FgXoVmucl5UCkn5Or-xEkT8nUmRMgHpETUQpolo8Zd4HK3CU5ovplfi4rNs0DFd0526ZAL0QK6vYD5AiJ31Gog9RtVXsx6uxZXE6CxkvxgLVH0s4uQ3Qg77sfnZA3uU4qNbuGwgh9PrxUncyT2THtCD35jxFjcdFhPYH3im8-G2t0EmSXr4jKoudl3inWFOgSbtOihUXkPNFPy5e5gNQzM4sM8RjAq9bYtG3OPpQ0iEYfAi614UnzpJBoNi5dhGm5kUQKceg_f9wfIVWQDPBTGm5KEdGIxXo8A_vruKlairI-Vzqyzo4tmbrO44Q", 6 | "e": "AQAB", 7 | "use": "sig", 8 | "kid": "aVhNluSUmDaHkYvk7xeBcI5Sn7udUtEzCTBtoZj3kuU", 9 | "qi": "IufHlRbkA1baNqNfMXgDlrBz_i0V7qCkOfILyoE2X_KKkwWO3FzGgmkRCXjh5JlY4L6SL7w6C1RQQY5TZd2c0Zt0oGZWwOMDJM3_FIMb4Gd9WgzUtf9e1lpwSNzopxbPs_26h19SRJLsZ9LF9gObqhsg11hAA7DOIpXn59nKFb0", 10 | "dp": "o1WQEH-GfmgdrP-XneDhXYS1dDVHIU75gqrxlQBNOOdQZ9DiO5fb8dUbAVxYP4MFAy10zl8HiimhqqYW7wwYuq9sAwii-jMnpOo4L05pAiYsMJuzzOaMFerrIA4oN62gPr4Um1diEiso4QOHdUXBbyKqv0mva2BwRGWeDpGQxMs", 11 | "alg": "RS256", 12 | "dq": "TuD2-jW5Eixsvjbu72GuCO1sVMaJE6BgH52SNOuMIfQSoNXpW2gOAuIFh9v8OR8PQiZMnR4-eANfbOhholEFjtf9hUIYypX6M8GcAzAJ4wmGWtS5rXguIk7xCCmqREQX9pbge8CeTtxU45DFo73oW9nOZEXHBZMa552L1Ol8uyU", 13 | "n": "mNUs3u3D_KhKIWZCnJzaYeDbnRHjWe6JM_7LkPGtgPebApu9wVjh41HVWjj8voY3guN3EuzCl5IzsdtnNZ7Y8sEaMe62pJQ_Aw62ziO9RaDCzpRnfiVmhXUR9HexsiCMTI_FUNanFSJaOaGw2JZ6Qw2UP3u02cK84-dYhQqndFeJob5QjpNbS4jwdLpbQE8K5AmhqqUr07a_sdC59YgaMWLqLzOp8BoPImWSRx9SfDa9oEZH6Gw5feFi6jFDAQn1_aOCym1rj2xMStOi3i_MWisS5e_AsoFkBuh2AXh4gcLNEq4aI98rm7GaNW2CQ0uTkZWRXUZtKZriJ5galk9jPw" 14 | } -------------------------------------------------------------------------------- /webgear-example-realworld/src/API/Comment.hs: -------------------------------------------------------------------------------- 1 | module API.Comment ( 2 | create, 3 | list, 4 | API.Comment.delete, 5 | ) where 6 | 7 | import API.Common 8 | import qualified Crypto.JWT as JWT 9 | import Data.Coerce (coerce) 10 | import Data.Int (Int64) 11 | import qualified Model.Comment as Model 12 | import Model.Entities (CommentId (..)) 13 | import qualified Network.HTTP.Types as HTTP 14 | import WebGear.Server 15 | 16 | type CreateCommentRequest = Wrapped "comment" Model.CreateCommentPayload 17 | type CommentResponse = Wrapped "comment" Model.CommentRecord 18 | 19 | type PathVarCommentId = PathVar "commentId" Int64 20 | 21 | create :: 22 | ( StdHandler h App 23 | , Gets h [AuthHeader, RequiredAuth, JSONBody CreateCommentRequest] 24 | , Sets h (JSONBodyOrError CommentResponse) 25 | , HasTrait PathVarSlug ts 26 | ) => 27 | JWT.JWK -> 28 | RequestHandler h ts 29 | create jwk = 30 | withDoc "Add a new comment" "Add a comment to an article" $ 31 | requiredTokenAuth jwk $ 32 | jsonRequestBody @CreateCommentRequest badRequestBody $ 33 | proc request -> do 34 | maybeComment <- createComment -< request 35 | case maybeComment of 36 | Nothing -> unwitnessA <<< setDescription (resp404Description "Comment") <<< notFound404 -< () 37 | Just comment -> setDescription okDescription <<< respondJsonA HTTP.ok200 -< Wrapped comment :: CommentResponse 38 | where 39 | createComment = arrM $ \request -> do 40 | let currentUserId = pick @RequiredAuth $ from request 41 | slug = pick @PathVarSlug $ from request 42 | payload = pick @(JSONBody CreateCommentRequest) $ from request 43 | runDBAction $ Model.create currentUserId slug (unwrap payload) 44 | 45 | -------------------------------------------------------------------------------- 46 | 47 | type CommentListResponse = Wrapped "comments" [Model.CommentRecord] 48 | 49 | list :: 50 | ( StdHandler h App 51 | , Gets h [AuthHeader, OptionalAuth] 52 | , Sets h (JSONBodyOrError CommentListResponse) 53 | , HasTrait PathVarSlug ts 54 | ) => 55 | JWT.JWK -> 56 | RequestHandler h ts 57 | list jwk = 58 | withDoc "List comments" "List all comments of an article" $ 59 | optionalTokenAuth jwk $ 60 | proc request -> do 61 | comments <- listComments -< request 62 | setDescription okDescription <<< respondJsonA HTTP.ok200 -< Wrapped comments :: CommentListResponse 63 | where 64 | listComments = arrM $ \request -> do 65 | let maybeCurrentUserId = rightToMaybe $ pick @OptionalAuth $ from request 66 | slug = pick @PathVarSlug $ from request 67 | runDBAction $ Model.list maybeCurrentUserId slug 68 | 69 | -------------------------------------------------------------------------------- 70 | 71 | delete :: 72 | ( StdHandler h App 73 | , Gets h [AuthHeader, RequiredAuth] 74 | , Set h (JSONBody ErrorResponse) 75 | , HaveTraits [PathVarSlug, PathVarCommentId] ts 76 | ) => 77 | JWT.JWK -> 78 | RequestHandler h ts 79 | delete jwk = 80 | withDoc "Delete a comment" "Only an author can delete their comments" $ 81 | requiredTokenAuth jwk $ 82 | unwitnessA 83 | <<< setDescription okDescription 84 | <<< noContent204 85 | <<< deleteComment 86 | where 87 | deleteComment = arrM $ \request -> do 88 | let currentUserId = pick @RequiredAuth $ from request 89 | slug = pick @PathVarSlug $ from request 90 | commentId = pick @PathVarCommentId $ from request 91 | runDBAction $ Model.delete currentUserId slug (coerce @Int64 @CommentId commentId) 92 | -------------------------------------------------------------------------------- /webgear-example-realworld/src/API/Profile.hs: -------------------------------------------------------------------------------- 1 | module API.Profile ( 2 | getByName, 3 | follow, 4 | unfollow, 5 | ) where 6 | 7 | import API.Common 8 | import qualified Crypto.JWT as JWT 9 | import Data.Text (Text) 10 | import qualified Model.Profile as Model 11 | import qualified Network.HTTP.Types as HTTP 12 | import WebGear.Server 13 | 14 | type ProfileResponse = Wrapped "profile" Model.Profile 15 | 16 | type PathVarUsername = PathVar "username" Text 17 | 18 | getByName :: 19 | ( HasTrait PathVarUsername ts 20 | , StdHandler h App 21 | , Gets h [AuthHeader, OptionalAuth] 22 | , Set h (JSONBody ProfileResponse) 23 | ) => 24 | JWT.JWK -> 25 | RequestHandler h ts 26 | getByName jwk = 27 | withDoc "Get a user profile" "Get the profile of a user by name" $ 28 | optionalTokenAuth jwk $ 29 | proc request -> do 30 | maybeProfile <- fetchProfile -< request 31 | case maybeProfile of 32 | Nothing -> unwitnessA <<< setDescription (resp404Description "Profile") <<< notFound404 -< () 33 | Just profile -> setDescription okDescription <<< respondJsonA HTTP.ok200 -< Wrapped profile :: ProfileResponse 34 | where 35 | fetchProfile = arrM $ \request -> do 36 | let maybeCurrentUserId = rightToMaybe $ pick @OptionalAuth $ from request 37 | username = pick @PathVarUsername $ from request 38 | runDBAction $ Model.getByName maybeCurrentUserId username 39 | 40 | follow :: 41 | ( HasTrait PathVarUsername ts 42 | , StdHandler h App 43 | , Gets h [AuthHeader, RequiredAuth] 44 | , Sets h (JSONBodyOrError ProfileResponse) 45 | ) => 46 | JWT.JWK -> 47 | RequestHandler h ts 48 | follow jwk = 49 | withDoc "Follow a user" "" $ 50 | requiredTokenAuth jwk $ 51 | proc request -> do 52 | maybeProfile <- doFollow -< request 53 | case maybeProfile of 54 | Nothing -> unwitnessA <<< setDescription (resp404Description "User") <<< notFound404 -< () 55 | Just profile -> setDescription okDescription <<< respondJsonA HTTP.ok200 -< Wrapped profile :: ProfileResponse 56 | where 57 | doFollow = arrM $ \request -> do 58 | let currentUserId = pick @RequiredAuth $ from request 59 | username = pick @PathVarUsername $ from request 60 | runDBAction $ Model.follow currentUserId username 61 | 62 | unfollow :: 63 | ( HasTrait PathVarUsername ts 64 | , StdHandler h App 65 | , Gets h [AuthHeader, RequiredAuth] 66 | , Sets h (JSONBodyOrError ProfileResponse) 67 | ) => 68 | JWT.JWK -> 69 | RequestHandler h ts 70 | unfollow jwk = 71 | withDoc "Unfollow a user" "" $ 72 | requiredTokenAuth jwk $ 73 | proc request -> do 74 | maybeProfile <- doUnfollow -< request 75 | case maybeProfile of 76 | Nothing -> unwitnessA <<< setDescription (resp404Description "User") <<< notFound404 -< () 77 | Just profile -> setDescription okDescription <<< respondJsonA HTTP.ok200 -< Wrapped profile :: ProfileResponse 78 | where 79 | doUnfollow = arrM $ \request -> do 80 | let currentUserId = pick @RequiredAuth $ from request 81 | username = pick @PathVarUsername $ from request 82 | runDBAction $ Model.unfollow currentUserId username 83 | -------------------------------------------------------------------------------- /webgear-example-realworld/src/API/Tag.hs: -------------------------------------------------------------------------------- 1 | module API.Tag ( 2 | list, 3 | ) where 4 | 5 | import API.Common 6 | import Data.Text (Text) 7 | import qualified Model.Tag as Model 8 | import qualified Network.HTTP.Types as HTTP 9 | import WebGear.Server 10 | 11 | type TagsResponse = Wrapped "tags" [Text] 12 | 13 | list :: 14 | ( StdHandler h App 15 | , Set h (JSONBody TagsResponse) 16 | ) => 17 | RequestHandler h ts 18 | list = 19 | withDoc "Get all tags" "" $ 20 | proc _request -> do 21 | tags <- fetchTags -< () 22 | setDescription okDescription <<< respondJsonA HTTP.ok200 -< Wrapped tags :: TagsResponse 23 | where 24 | fetchTags = arrM $ const $ runDBAction Model.list 25 | -------------------------------------------------------------------------------- /webgear-example-realworld/src/API/UI.hs: -------------------------------------------------------------------------------- 1 | module API.UI where 2 | 3 | import API.Common (App) 4 | import Network.Wai.Application.Static (StaticSettings (..), defaultWebAppSettings) 5 | import WaiAppStatic.Types (unsafeToPiece) 6 | import WebGear.Server 7 | 8 | assets :: (Handler h App) => RequestHandler h ts 9 | assets = 10 | let settings = (defaultWebAppSettings "ui"){ssIndices = unsafeToPiece <$> ["index.html", "index.htm"]} 11 | in serveStatic settings 12 | -------------------------------------------------------------------------------- /webgear-example-realworld/src/API/User.hs: -------------------------------------------------------------------------------- 1 | module API.User ( 2 | create, 3 | login, 4 | current, 5 | update, 6 | ) where 7 | 8 | import API.Common 9 | import Control.Exception.Safe (try) 10 | import qualified Crypto.JWT as JWT 11 | import qualified Database.SQLite.Simple as DB 12 | import qualified Model.User as Model 13 | import qualified Network.HTTP.Types as HTTP 14 | import WebGear.Server 15 | 16 | type CreateUserRequest = Wrapped "user" Model.CreateUserPayload 17 | type UserResponse = Wrapped "user" Model.UserRecord 18 | 19 | create :: 20 | ( StdHandler h App 21 | , Get h (JSONBody CreateUserRequest) 22 | , Sets h (JSONBodyOrError UserResponse) 23 | ) => 24 | JWT.JWK -> 25 | RequestHandler h ts 26 | create jwk = 27 | withDoc "Create new user" "Create a new user in the store" $ 28 | jsonRequestBody @CreateUserRequest badRequestBody $ 29 | proc request -> do 30 | result <- createInDB -< request 31 | case result of 32 | Left e -> handleDBError -< e 33 | Right user -> 34 | setDescription okDescription <<< respondJsonA HTTP.ok200 -< Wrapped user :: UserResponse 35 | where 36 | createInDB = arrM $ \request -> do 37 | let userPayload = pick @(JSONBody CreateUserRequest) $ from request 38 | try $ runDBAction $ Model.create jwk (unwrap userPayload) 39 | 40 | handleDBError :: 41 | (StdHandler h App, Set h (JSONBody ErrorResponse)) => 42 | h DB.SQLError Response 43 | handleDBError = proc e -> 44 | if DB.sqlError e == DB.ErrorConstraint 45 | then 46 | setDescription (dupDescription "user account") <<< respondJsonA HTTP.badRequest400 -< "Another user account exists with these values" :: ErrorResponse 47 | else respondJsonA HTTP.internalServerError500 -< showError e 48 | 49 | -------------------------------------------------------------------------------- 50 | 51 | type LoginUserRequest = Wrapped "user" Model.LoginUserPayload 52 | 53 | login :: 54 | ( StdHandler h App 55 | , Get h (JSONBody LoginUserRequest) 56 | , Sets h (JSONBodyOrError UserResponse) 57 | ) => 58 | JWT.JWK -> 59 | RequestHandler h ts 60 | login jwk = 61 | withDoc "Authenticate a user" "Authenticate a user and return their record" $ 62 | jsonRequestBody @LoginUserRequest badRequestBody $ 63 | proc request -> do 64 | result <- checkCreds -< request 65 | case result of 66 | Nothing -> 67 | setDescription resp403Description <<< respondJsonA HTTP.forbidden403 -< "Invalid credentials" :: ErrorResponse 68 | Just user -> 69 | setDescription okDescription <<< respondJsonA HTTP.ok200 -< Wrapped user :: UserResponse 70 | where 71 | checkCreds = arrM $ \request -> do 72 | let loginPayload = pick @(JSONBody LoginUserRequest) $ from request 73 | runDBAction $ Model.checkCredentials jwk (unwrap loginPayload) 74 | 75 | -------------------------------------------------------------------------------- 76 | 77 | current :: 78 | ( StdHandler h App 79 | , Gets h [AuthHeader, RequiredAuth] 80 | , Sets h (JSONBodyOrError UserResponse) 81 | ) => 82 | JWT.JWK -> 83 | RequestHandler h ts 84 | current jwk = 85 | withDoc "Get current user" "Returns the record of authenticated user" $ 86 | requiredTokenAuth jwk $ 87 | proc request -> do 88 | result <- getAuthUser -< request 89 | case result of 90 | Nothing -> unwitnessA <<< setDescription (resp404Description "User") <<< notFound404 -< () 91 | Just user -> 92 | setDescription okDescription <<< respondJsonA HTTP.ok200 -< Wrapped user :: UserResponse 93 | where 94 | getAuthUser = arrM $ \request -> do 95 | let userId = pick @RequiredAuth $ from request 96 | runDBAction $ Model.getByKey jwk userId 97 | 98 | -------------------------------------------------------------------------------- 99 | 100 | type UpdateUserRequest = Wrapped "user" Model.UpdateUserPayload 101 | 102 | update :: 103 | ( StdHandler h App 104 | , Gets h [AuthHeader, RequiredAuth, JSONBody UpdateUserRequest] 105 | , Sets h (JSONBodyOrError UserResponse) 106 | ) => 107 | JWT.JWK -> 108 | RequestHandler h ts 109 | update jwk = 110 | withDoc "Update current user" "Update the authenticated user" $ 111 | requiredTokenAuth jwk $ 112 | jsonRequestBody @UpdateUserRequest badRequestBody $ 113 | proc request -> do 114 | result <- updateUser -< request 115 | case result of 116 | Left e -> handleDBError -< e 117 | Right Nothing -> unwitnessA <<< setDescription (resp404Description "User") <<< notFound404 -< () 118 | Right (Just user) -> 119 | setDescription okDescription <<< respondJsonA HTTP.ok200 -< Wrapped user :: UserResponse 120 | where 121 | updateUser = arrM $ \request -> do 122 | let userId = pick @RequiredAuth $ from request 123 | userPayload = pick @(JSONBody UpdateUserRequest) $ from request 124 | try $ runDBAction $ Model.update jwk userId (unwrap userPayload) 125 | -------------------------------------------------------------------------------- /webgear-example-realworld/src/Main.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE NoMonomorphismRestriction #-} 2 | 3 | module Main where 4 | 5 | import qualified API.Article as Article 6 | import qualified API.Comment as Comment 7 | import API.Common (App (..), AppEnv (..)) 8 | import qualified API.Profile as Profile 9 | import qualified API.Tag as Tag 10 | import qualified API.UI as UI 11 | import qualified API.User as User 12 | import Control.Monad.Reader (runReaderT) 13 | import qualified Crypto.JWT as JWT 14 | import Data.Aeson (eitherDecode) 15 | import qualified Data.ByteString.Lazy as LBS 16 | import Data.Int (Int64) 17 | import Data.Pool (Pool) 18 | import Data.Text (Text) 19 | import Database.SQLite.Simple (Connection) 20 | import Model.Common (withDBConnectionPool) 21 | import Network.HTTP.Types (StdMethod (..)) 22 | import qualified Network.Wai as Wai 23 | import qualified Network.Wai.Handler.Warp as Warp 24 | import WebGear.OpenApi (toOpenApi) 25 | import WebGear.Server 26 | import WebGear.Swagger.UI (swaggerUI) 27 | 28 | -------------------------------------------------------------------------------- 29 | -- A medium.com clone app specified by https://github.com/gothinkster/realworld 30 | -------------------------------------------------------------------------------- 31 | 32 | application :: Pool Connection -> JWT.JWK -> Wai.Application 33 | application pool jwk = toApplication $ transform appToIO allRoutes 34 | where 35 | allRoutes :: RequestHandler (ServerHandler App) '[] 36 | allRoutes = 37 | appRoutes 38 | <+> [match| /openapi |] (swaggerUI $ toOpenApi @App $ appRoutes) 39 | <+> uiRoutes 40 | 41 | appRoutes = 42 | [route| POST /api/users/login |] (User.login jwk) 43 | <+> [route| POST /api/users |] (User.create jwk) 44 | <+> [route| GET /api/user |] (User.current jwk) 45 | <+> [route| PUT /api/user |] (User.update jwk) 46 | <+> [route| GET /api/profiles/username:Text |] (Profile.getByName jwk) 47 | <+> [route| POST /api/profiles/username:Text/follow |] (Profile.follow jwk) 48 | <+> [route| DELETE /api/profiles/username:Text/follow |] (Profile.unfollow jwk) 49 | <+> [route| POST /api/articles |] (Article.create jwk) 50 | <+> [route| GET /api/articles |] (Article.list jwk) 51 | <+> [route| GET /api/articles/feed |] (Article.feed jwk) 52 | <+> [route| GET /api/articles/slug:Text |] (Article.getBySlug jwk) 53 | <+> [route| PUT /api/articles/slug:Text |] (Article.update jwk) 54 | <+> [route| DELETE /api/articles/slug:Text |] (Article.delete jwk) 55 | <+> [route| POST /api/articles/slug:Text/favorite |] (Article.favorite jwk) 56 | <+> [route| DELETE /api/articles/slug:Text/favorite |] (Article.unfavorite jwk) 57 | <+> [route| POST /api/articles/slug:Text/comments |] (Comment.create jwk) 58 | <+> [route| GET /api/articles/slug:Text/comments |] (Comment.list jwk) 59 | <+> [route| DELETE /api/articles/slug:Text/comments/commentId:Int64 |] (Comment.delete jwk) 60 | <+> [route| GET /api/tags |] Tag.list 61 | 62 | uiRoutes :: RequestHandler (ServerHandler App) '[] 63 | uiRoutes = method GET UI.assets 64 | 65 | appToIO :: App a -> IO a 66 | appToIO = flip runReaderT (AppEnv pool) . unApp 67 | 68 | main :: IO () 69 | main = withDBConnectionPool $ \pool -> do 70 | jwkBS <- LBS.readFile "realworld.jwk" 71 | let jwk = either error id $ eitherDecode jwkBS 72 | Warp.run 3000 (application pool jwk) 73 | -------------------------------------------------------------------------------- /webgear-example-realworld/src/Model/Common.hs: -------------------------------------------------------------------------------- 1 | module Model.Common where 2 | 3 | import Control.Monad.IO.Class (liftIO) 4 | import Control.Monad.Reader (MonadReader (..), ReaderT) 5 | import qualified Data.Aeson as Aeson 6 | import Data.Char (isLower, isUpper, toLower) 7 | import qualified Data.OpenApi as OpenApi 8 | import Data.Pool (Pool, defaultPoolConfig, newPool, withResource) 9 | import Database.SQLite.Simple ( 10 | Connection, 11 | FromRow, 12 | NamedParam, 13 | Query, 14 | close, 15 | executeNamed, 16 | open, 17 | queryNamed, 18 | ) 19 | import Model.Entities (migrateAll) 20 | 21 | -- All DB operations run in this monad 22 | type DBAction a = ReaderT Connection IO a 23 | 24 | withDBConnectionPool :: (Pool Connection -> IO a) -> IO a 25 | withDBConnectionPool f = do 26 | pool <- newPool $ defaultPoolConfig (open "realworld.db") close 300.0 20 27 | withResource pool migrateAll 28 | f pool 29 | 30 | queryNamed :: (FromRow r) => Query -> [NamedParam] -> DBAction [r] 31 | queryNamed q params = do 32 | conn <- ask 33 | liftIO $ Database.SQLite.Simple.queryNamed conn q params 34 | 35 | executeNamed :: Query -> [NamedParam] -> DBAction () 36 | executeNamed q params = do 37 | conn <- ask 38 | liftIO $ Database.SQLite.Simple.executeNamed conn q params 39 | 40 | -- Aeson options to drop the entity name prefix from field names 41 | aesonDropPrefixOptions :: Aeson.Options 42 | aesonDropPrefixOptions = Aeson.defaultOptions{Aeson.fieldLabelModifier = lowerFirst . dropWhile isLower} 43 | 44 | schemaDropPrefixOptions :: OpenApi.SchemaOptions 45 | schemaDropPrefixOptions = OpenApi.defaultSchemaOptions{OpenApi.fieldLabelModifier = lowerFirst . dropWhile isLower} 46 | 47 | lowerFirst :: String -> String 48 | lowerFirst (c : cs) | isUpper c = toLower c : cs 49 | lowerFirst s = s 50 | -------------------------------------------------------------------------------- /webgear-example-realworld/src/Model/Profile.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE QuasiQuotes #-} 2 | 3 | module Model.Profile ( 4 | Profile (..), 5 | getOne, 6 | getByName, 7 | follow, 8 | unfollow, 9 | ) where 10 | 11 | import Control.Exception.Safe (catch, throw) 12 | import Data.Aeson (ToJSON (..), genericToJSON) 13 | import Data.Functor ((<&>)) 14 | import Data.Maybe (fromMaybe, listToMaybe) 15 | import Data.OpenApi (ToSchema (..), genericDeclareNamedSchema) 16 | import Data.Text (Text) 17 | import Database.SQLite.Simple ( 18 | Error (ErrorConstraint), 19 | NamedParam (..), 20 | Query, 21 | SQLError (..), 22 | ) 23 | import Database.SQLite.Simple.QQ (sql) 24 | import Database.SQLite.Simple.Types (Only (..)) 25 | import GHC.Generics (Generic) 26 | import Model.Common 27 | import Model.Entities 28 | 29 | data Profile = Profile 30 | { userUsername :: !Text 31 | , userBio :: !(Maybe Text) 32 | , userImage :: !(Maybe Text) 33 | , userFollowing :: !Bool 34 | } 35 | deriving stock (Generic) 36 | 37 | instance ToJSON Profile where 38 | toJSON = genericToJSON aesonDropPrefixOptions 39 | 40 | instance ToSchema Profile where 41 | declareNamedSchema = genericDeclareNamedSchema schemaDropPrefixOptions 42 | 43 | getOne :: 44 | -- | current user (if any) 45 | Maybe UserId -> 46 | -- | user to get profile of 47 | UserId -> 48 | DBAction (Maybe Profile) 49 | getOne maybeFollowerKey followeeKey = 50 | findProfile 51 | maybeFollowerKey 52 | [sql| SELECT * FROM user WHERE id = :id |] 53 | [":id" := followeeKey] 54 | 55 | findProfile :: 56 | Maybe UserId -> 57 | Query -> 58 | [NamedParam] -> 59 | DBAction (Maybe Profile) 60 | findProfile maybeFollowerKey selector params = do 61 | maybeResult <- listToMaybe <$> queryNamed selector params 62 | traverse mkProfile maybeResult 63 | where 64 | mkProfile :: User -> DBAction Profile 65 | mkProfile User{..} = do 66 | maybeFollowing <- traverse (isFollowing userId) maybeFollowerKey 67 | pure Profile{userFollowing = fromMaybe False maybeFollowing, ..} 68 | 69 | isFollowing :: UserId -> UserId -> DBAction Bool 70 | isFollowing followeeKey followerKey = do 71 | let q :: Query 72 | q = [sql| SELECT COUNT(*) FROM follow WHERE follower = :follower AND followee = :followee |] 73 | 74 | followCount <- queryNamed q [":follower" := followerKey, ":followee" := followeeKey] 75 | pure $ followCount == [Only (1 :: Int)] 76 | 77 | -------------------------------------------------------------------------------- 78 | 79 | getByName :: 80 | -- | current user (if any) 81 | Maybe UserId -> 82 | -- | username to get profile of 83 | Text -> 84 | DBAction (Maybe Profile) 85 | getByName maybeFollowerKey username = 86 | findProfile 87 | maybeFollowerKey 88 | [sql|SELECT * FROM user WHERE username = :username |] 89 | [":username" := username] 90 | 91 | -------------------------------------------------------------------------------- 92 | 93 | follow :: UserId -> Text -> DBAction (Maybe Profile) 94 | follow followerKey followeeUsername = 95 | getUserIdByName followeeUsername >>= \case 96 | Nothing -> pure Nothing 97 | Just followeeKey -> do 98 | let handleDBError :: SQLError -> DBAction () 99 | handleDBError e 100 | | sqlError e == ErrorConstraint = pure () 101 | | otherwise = throw e 102 | 103 | let stmt :: Query 104 | stmt = [sql| INSERT INTO follow (follower, followee) VALUES (:follower, :followee) |] 105 | 106 | params :: [NamedParam] 107 | params = [":follower" := followerKey, ":followee" := followeeKey] 108 | 109 | executeNamed stmt params `catch` handleDBError 110 | getOne (Just followerKey) followeeKey 111 | 112 | getUserIdByName :: Text -> DBAction (Maybe UserId) 113 | getUserIdByName name = do 114 | let q :: Query 115 | q = [sql| SELECT id FROM user WHERE username = :username |] 116 | 117 | params :: [NamedParam] 118 | params = [":username" := name] 119 | 120 | queryNamed q params <&> \case 121 | [Only uid] -> Just uid 122 | _x -> Nothing 123 | 124 | -------------------------------------------------------------------------------- 125 | 126 | unfollow :: UserId -> Text -> DBAction (Maybe Profile) 127 | unfollow followerKey followeeUsername = 128 | getUserIdByName followeeUsername >>= \case 129 | Nothing -> pure Nothing 130 | Just followeeKey -> do 131 | let stmt :: Query 132 | stmt = [sql| DELETE FROM follow WHERE follower = :follower AND followee = :followee |] 133 | 134 | params :: [NamedParam] 135 | params = [":follower" := followerKey, ":followee" := followeeKey] 136 | 137 | executeNamed stmt params 138 | 139 | getOne (Just followerKey) followeeKey 140 | -------------------------------------------------------------------------------- /webgear-example-realworld/src/Model/Tag.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE QuasiQuotes #-} 2 | 3 | module Model.Tag ( 4 | list, 5 | ) where 6 | 7 | import Control.Monad.IO.Class (liftIO) 8 | import Control.Monad.Reader (ask) 9 | import Data.Text (Text) 10 | import Database.SQLite.Simple (Query, fromOnly, queryNamed) 11 | import Database.SQLite.Simple.QQ (sql) 12 | import Model.Common (DBAction) 13 | 14 | list :: DBAction [Text] 15 | list = do 16 | conn <- ask 17 | let q :: Query 18 | q = [sql| SELECT tag.name FROM tag JOIN article_tag ON article_tag.tagid = tag.id |] 19 | results <- liftIO $ queryNamed conn q [] 20 | pure $ fromOnly <$> results 21 | -------------------------------------------------------------------------------- /webgear-example-realworld/ui/README.md: -------------------------------------------------------------------------------- 1 | # ember-realworld 2 | This UI component is built from the ember-realworld app located at https://github.com/gothinkster/ember-realworld. 3 | Licensed under MIT license. 4 | -------------------------------------------------------------------------------- /webgear-example-realworld/ui/assets/ember-realworld-d41d8cd98f00b204e9800998ecf8427e.css: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/haskell-webgear/webgear/ce807d4cacecfb316e0e5c42c53fdd46b6c62c70/webgear-example-realworld/ui/assets/ember-realworld-d41d8cd98f00b204e9800998ecf8427e.css -------------------------------------------------------------------------------- /webgear-example-realworld/ui/assets/ember.ico: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/haskell-webgear/webgear/ce807d4cacecfb316e0e5c42c53fdd46b6c62c70/webgear-example-realworld/ui/assets/ember.ico -------------------------------------------------------------------------------- /webgear-example-realworld/ui/assets/vendor-d41d8cd98f00b204e9800998ecf8427e.css: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/haskell-webgear/webgear/ce807d4cacecfb316e0e5c42c53fdd46b6c62c70/webgear-example-realworld/ui/assets/vendor-d41d8cd98f00b204e9800998ecf8427e.css -------------------------------------------------------------------------------- /webgear-example-realworld/ui/index.html: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 | 6 | Conduit 7 | 8 | 9 | 10 | 11 | 12 | 13 | 14 | 15 | 16 | 17 | 18 | 19 | 20 | 21 | 22 | 23 | 24 | 25 | 26 | 27 | 28 | 29 | -------------------------------------------------------------------------------- /webgear-example-realworld/webgear-example-realworld.cabal: -------------------------------------------------------------------------------- 1 | cabal-version: 2.4 2 | name: webgear-example-realworld 3 | version: 1.4.0 4 | description: Please see the README at 5 | homepage: https://github.com/haskell-webgear/webgear/webgear-example-realworld#readme 6 | bug-reports: https://github.com/haskell-webgear/webgear/issues 7 | author: Raghu Kaippully 8 | maintainer: rkaippully@gmail.com 9 | copyright: 2020-2025 Raghu Kaippully 10 | license: MPL-2.0 11 | license-file: LICENSE 12 | build-type: Simple 13 | extra-source-files: README.md 14 | 15 | 16 | source-repository head 17 | type: git 18 | location: https://github.com/haskell-webgear/webgear-example-realworld 19 | 20 | executable realworld 21 | default-language: Haskell2010 22 | build-depends: aeson 23 | , base 24 | , bytestring 25 | , crypton 26 | , http-api-data 27 | , http-types 28 | , jose 29 | , lens 30 | , monad-time 31 | , mtl 32 | , openapi3 33 | , random 34 | , resource-pool 35 | , safe-exceptions 36 | , sqlite-simple 37 | , text 38 | , time 39 | , uri-encode 40 | , wai 41 | , wai-app-static 42 | , warp 43 | , webgear-openapi 44 | , webgear-server 45 | , webgear-swagger-ui 46 | default-extensions: Arrows 47 | BlockArguments 48 | DataKinds 49 | DeriveAnyClass 50 | DeriveGeneric 51 | DerivingStrategies 52 | DuplicateRecordFields 53 | FlexibleContexts 54 | FlexibleInstances 55 | GeneralizedNewtypeDeriving 56 | KindSignatures 57 | LambdaCase 58 | MultiParamTypeClasses 59 | NamedFieldPuns 60 | OverloadedStrings 61 | QuasiQuotes 62 | RecordWildCards 63 | ScopedTypeVariables 64 | TypeApplications 65 | TypeOperators 66 | ghc-options: -Wall 67 | -Wcompat 68 | -Werror 69 | -Widentities 70 | -Wincomplete-record-updates 71 | -Wincomplete-uni-patterns 72 | -Wmissing-deriving-strategies 73 | -Wmissing-fields 74 | -Wmissing-home-modules 75 | -Wno-unticked-promoted-constructors 76 | -Wpartial-fields 77 | -Wredundant-constraints 78 | -Wunused-packages 79 | -fshow-warning-groups 80 | -rtsopts 81 | -threaded 82 | -with-rtsopts=-N 83 | hs-source-dirs: src 84 | main-is: Main.hs 85 | other-modules: API.Article 86 | , API.Comment 87 | , API.Common 88 | , API.Profile 89 | , API.Tag 90 | , API.UI 91 | , API.User 92 | , Model.Entities 93 | , Model.Article 94 | , Model.Comment 95 | , Model.Profile 96 | , Model.Tag 97 | , Model.User 98 | , Model.Common 99 | -------------------------------------------------------------------------------- /webgear-example-users/README.md: -------------------------------------------------------------------------------- 1 | # WebGear Examples - User 2 | This is a basic CRUD app that operates on user resources. 3 | 4 | # Building and running 5 | 6 | ```shell 7 | nix run .#webgear-example-users-ghc${GHC_VERSION} 8 | ``` 9 | 10 | Or, if you'd like to get a development environment: 11 | 12 | ```shell 13 | nix develop 14 | cabal run webgear-example-users 15 | ``` 16 | 17 | Run postman tests (from another shell): 18 | 19 | ```shell 20 | nix develop 21 | newman run postman-collection.json 22 | ``` 23 | -------------------------------------------------------------------------------- /webgear-example-users/webgear-example-users.cabal: -------------------------------------------------------------------------------- 1 | cabal-version: 2.4 2 | name: webgear-example-users 3 | version: 1.4.0 4 | description: Please see the README at 5 | homepage: https://github.com/haskell-webgear/webgear/webgear-example-users#readme 6 | bug-reports: https://github.com/haskell-webgear/webgear/issues 7 | author: Raghu Kaippully 8 | maintainer: rkaippully@gmail.com 9 | copyright: 2020-2025 Raghu Kaippully 10 | license: MPL-2.0 11 | license-file: LICENSE 12 | build-type: Simple 13 | extra-source-files: README.md 14 | 15 | 16 | source-repository head 17 | type: git 18 | location: https://github.com/haskell-webgear/webgear 19 | 20 | executable users 21 | default-language: Haskell2010 22 | build-depends: aeson 23 | , base 24 | , bytestring 25 | , hashable 26 | , http-api-data 27 | , http-types 28 | , mtl 29 | , text 30 | , time 31 | , unordered-containers 32 | , wai 33 | , warp 34 | , webgear-server 35 | ghc-options: -Wall 36 | -Wincomplete-record-updates 37 | -Wincomplete-uni-patterns 38 | -Wno-unticked-promoted-constructors 39 | -Wredundant-constraints 40 | -rtsopts 41 | -threaded 42 | -with-rtsopts=-N 43 | main-is: Main.hs 44 | hs-source-dirs: src 45 | -------------------------------------------------------------------------------- /webgear-openapi/CHANGELOG.md: -------------------------------------------------------------------------------- 1 | # Changelog for webgear-openapi 2 | 3 | ## [Unreleased] 4 | 5 | ## [1.4.0] - 2025-05-19 6 | 7 | ### Added 8 | - Support GHC-9.12 9 | 10 | ### Removed 11 | - Support GHC-9.0, GHC-9.2 12 | 13 | ## [1.3.1] - 2024-11-24 14 | 15 | ### Added 16 | - Support GHC-9.10 17 | 18 | ## [1.3.0] - 2024-06-13 19 | 20 | ### Changed 21 | - Simplify core API (breaking change) (#47) 22 | - Reimplement Swagger/OpenAPI internals (#45) 23 | 24 | ## [1.2.0] - 2024-03-18 25 | 26 | ### Added 27 | - Prerequisite traits (#37) 28 | 29 | ## [1.1.1] - 2024-01-01 30 | 31 | ### Changed 32 | - Updated dependency bounds and GHC versions (#35) 33 | 34 | ## [1.1.0] - 2023-12-29 35 | 36 | ### Added 37 | - Streaming responses support (#26) 38 | - Support for cookies (#29) 39 | - Support file uploads (#32) 40 | 41 | ### Changed 42 | - Redesign APIs for ease of use (breaking change) (#24) 43 | 44 | ## [1.0.5] - 2023-05-04 45 | 46 | ### Changed 47 | - Update dependency bounds and GHC versions 48 | 49 | ## [1.0.4] - 2022-08-27 50 | 51 | ### Changed 52 | - Update dependency bounds and GHC versions 53 | 54 | ## [1.0.3] - 2022-06-26 55 | 56 | ### Changed 57 | - Nix flake based development environment 58 | 59 | ## [1.0.2] - 2022-06-11 60 | 61 | ### Changed 62 | - Upgrade to latest GHC versions (#9) 63 | 64 | ## [1.0.1] - 2022-01-09 65 | 66 | ### Changed 67 | - Update dependency bounds (#7) 68 | 69 | ## [1.0.0] - 2022-01-08 70 | 71 | ### Added 72 | - First version of webgear-openapi 73 | 74 | [Unreleased]: https://github.com/haskell-webgear/webgear/compare/v1.4.0...HEAD 75 | [1.4.0]: https://github.com/haskell-webgear/webgear/releases/tag/v1.4.0 76 | [1.3.1]: https://github.com/haskell-webgear/webgear/releases/tag/v1.3.1 77 | [1.3.0]: https://github.com/haskell-webgear/webgear/releases/tag/v1.3.0 78 | [1.2.0]: https://github.com/haskell-webgear/webgear/releases/tag/v1.2.0 79 | [1.1.1]: https://github.com/haskell-webgear/webgear/releases/tag/v1.1.1 80 | [1.1.0]: https://github.com/haskell-webgear/webgear/releases/tag/v1.1.0 81 | [1.0.5]: https://github.com/haskell-webgear/webgear/releases/tag/v1.0.5 82 | [1.0.4]: https://github.com/haskell-webgear/webgear/releases/tag/v1.0.4 83 | [1.0.3]: https://github.com/haskell-webgear/webgear/releases/tag/v1.0.3 84 | [1.0.2]: https://github.com/haskell-webgear/webgear/releases/tag/v1.0.2 85 | [1.0.1]: https://github.com/haskell-webgear/webgear/releases/tag/v1.0.1 86 | [1.0.0]: https://github.com/haskell-webgear/webgear/releases/tag/v1.0.0 87 | -------------------------------------------------------------------------------- /webgear-openapi/README.md: -------------------------------------------------------------------------------- 1 | # WebGear - HTTP API server 2 | 3 | [![Hackage](https://img.shields.io/hackage/v/webgear-openapi)](https://hackage.haskell.org/package/webgear-openapi) 4 | 5 | WebGear is a Haskell library for building composable, type-safe HTTP APIs. This package helps to generate OpenAPI 6 | specifications from WebGear API specifications. 7 | -------------------------------------------------------------------------------- /webgear-openapi/src/WebGear/OpenApi.hs: -------------------------------------------------------------------------------- 1 | {- | Main module for WebGear OpenAPI support. 2 | 3 | Import this module to get all required types and functions for 4 | generating OpenAPI documentation. Alternatively, import individual 5 | modules under @WebGear.OpenApi@. 6 | 7 | Typical usage to generate OpenAPI: 8 | 9 | @ 10 | import WebGear.OpenApi 11 | import Data.OpenApi (OpenApi) 12 | 13 | myHandler :: Handler h m => RequestHandler h '[] 14 | myHandler = .... 15 | 16 | documentation :: OpenApi 17 | documentation = toOpenApi myHandler 18 | @ 19 | -} 20 | module WebGear.OpenApi ( 21 | module WebGear.Core, 22 | module WebGear.OpenApi.Handler, 23 | ) where 24 | 25 | import WebGear.Core 26 | import WebGear.OpenApi.Handler 27 | import WebGear.OpenApi.Traits () 28 | -------------------------------------------------------------------------------- /webgear-openapi/src/WebGear/OpenApi/Trait/Auth.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -Wno-orphans #-} 2 | 3 | -- | Functions and instances for authentication 4 | module WebGear.OpenApi.Trait.Auth (addSecurityScheme) where 5 | 6 | import Control.Lens ((&), (.~), (<>~)) 7 | import Control.Monad.State.Strict (MonadState) 8 | import Data.OpenApi ( 9 | Definitions, 10 | NamedSchema, 11 | OpenApi, 12 | Schema, 13 | SecurityDefinitions (..), 14 | SecurityRequirement (..), 15 | SecurityScheme, 16 | ToSchema (..), 17 | allOperations, 18 | components, 19 | description, 20 | security, 21 | securitySchemes, 22 | ) 23 | import Data.OpenApi.Declare (Declare) 24 | import Data.Proxy (Proxy (..)) 25 | import Data.Text (Text) 26 | import GHC.TypeLits (KnownSymbol) 27 | import WebGear.Core.Handler (Description (..)) 28 | import WebGear.Core.Trait.Auth.Common (AuthToken) 29 | import WebGear.OpenApi.Handler (Documentation (..), consumeDescription) 30 | 31 | instance (KnownSymbol scheme) => ToSchema (AuthToken scheme) where 32 | declareNamedSchema :: Proxy (AuthToken scheme) -> Declare (Definitions Schema) NamedSchema 33 | declareNamedSchema _ = declareNamedSchema $ Proxy @String 34 | 35 | addSecurityScheme :: (MonadState Documentation m) => Text -> SecurityScheme -> OpenApi -> m OpenApi 36 | addSecurityScheme schemeName scheme doc = do 37 | desc <- consumeDescription 38 | let scheme' = scheme & description .~ fmap getDescription desc 39 | secSchemes = SecurityDefinitions [(schemeName, scheme')] 40 | secReqs = [SecurityRequirement [(schemeName, [])]] :: [SecurityRequirement] 41 | pure $ 42 | doc 43 | & components . securitySchemes <>~ secSchemes 44 | & allOperations . security <>~ secReqs 45 | -------------------------------------------------------------------------------- /webgear-openapi/src/WebGear/OpenApi/Trait/Auth/Basic.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -Wno-orphans #-} 2 | 3 | -- | OpenApi implementation of `BasicAuth'` trait. 4 | module WebGear.OpenApi.Trait.Auth.Basic where 5 | 6 | import Data.OpenApi 7 | import Data.Proxy (Proxy (..)) 8 | import Data.String (fromString) 9 | import GHC.TypeLits (KnownSymbol, symbolVal) 10 | import WebGear.Core.Request (Request) 11 | import WebGear.Core.Trait (Absence, Attribute, Get (..), With) 12 | import WebGear.Core.Trait.Auth.Basic (BasicAuth' (..)) 13 | import WebGear.OpenApi.Handler (OpenApiHandler (..)) 14 | import WebGear.OpenApi.Trait.Auth (addSecurityScheme) 15 | 16 | instance (KnownSymbol scheme) => Get (OpenApiHandler m) (BasicAuth' x scheme m e a) where 17 | {-# INLINE getTrait #-} 18 | getTrait :: 19 | BasicAuth' x scheme m e a -> 20 | OpenApiHandler m (Request `With` ts) (Either (Absence (BasicAuth' x scheme m e a)) (Attribute (BasicAuth' x scheme m e a) Request)) 21 | getTrait _ = 22 | let schemeName = "http" <> fromString (symbolVal (Proxy @scheme)) 23 | scheme = 24 | SecurityScheme 25 | { _securitySchemeType = SecuritySchemeHttp HttpSchemeBasic 26 | , _securitySchemeDescription = Nothing 27 | } 28 | in OpenApiHandler $ addSecurityScheme schemeName scheme 29 | -------------------------------------------------------------------------------- /webgear-openapi/src/WebGear/OpenApi/Trait/Auth/JWT.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -Wno-orphans #-} 2 | 3 | -- | OpenApi implementation of 'JWTAuth'' trait. 4 | module WebGear.OpenApi.Trait.Auth.JWT where 5 | 6 | import Data.OpenApi 7 | import Data.String (fromString) 8 | import Data.Typeable (Proxy (..)) 9 | import GHC.TypeLits (KnownSymbol, symbolVal) 10 | import WebGear.Core.Request (Request) 11 | import WebGear.Core.Trait (Absence, Attribute, Get (..), With) 12 | import WebGear.Core.Trait.Auth.JWT (JWTAuth' (..)) 13 | import WebGear.OpenApi.Handler (OpenApiHandler (..)) 14 | import WebGear.OpenApi.Trait.Auth (addSecurityScheme) 15 | 16 | instance (KnownSymbol scheme) => Get (OpenApiHandler m) (JWTAuth' x scheme m e a) where 17 | {-# INLINE getTrait #-} 18 | getTrait :: 19 | JWTAuth' x scheme m e a -> 20 | OpenApiHandler m (Request `With` ts) (Either (Absence (JWTAuth' x scheme m e a)) (Attribute (JWTAuth' x scheme m e a) Request)) 21 | getTrait _ = 22 | let schemeName = "http" <> fromString (symbolVal (Proxy @scheme)) 23 | scheme = 24 | SecurityScheme 25 | { _securitySchemeType = SecuritySchemeHttp (HttpSchemeBearer (Just "JWT")) 26 | , _securitySchemeDescription = Nothing 27 | } 28 | in OpenApiHandler $ addSecurityScheme schemeName scheme 29 | -------------------------------------------------------------------------------- /webgear-openapi/src/WebGear/OpenApi/Trait/Body.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -Wno-orphans #-} 2 | 3 | -- | OpenApi implementation of 'Body' trait. 4 | module WebGear.OpenApi.Trait.Body where 5 | 6 | import Control.Lens ((%~), (&), (.~), (<>~), (?~), (^.)) 7 | import Control.Monad.State.Strict (MonadState) 8 | import qualified Data.HashMap.Strict.InsOrd as Map 9 | import Data.OpenApi ( 10 | Definitions, 11 | MediaTypeObject, 12 | OpenApi, 13 | Referenced (..), 14 | RequestBody, 15 | Response, 16 | Schema, 17 | ToSchema, 18 | allOperations, 19 | components, 20 | content, 21 | declareSchemaRef, 22 | description, 23 | paths, 24 | requestBody, 25 | responses, 26 | schema, 27 | schemas, 28 | ) 29 | import Data.OpenApi.Declare (runDeclare) 30 | import Data.OpenApi.Internal.Utils (swaggerMappend) 31 | import Data.Proxy (Proxy (..)) 32 | import Data.Text (Text) 33 | import GHC.Exts (fromList) 34 | import Network.HTTP.Media.MediaType (MediaType) 35 | import WebGear.Core.Handler (Description (..)) 36 | import WebGear.Core.MIMETypes (MIMEType (..)) 37 | import WebGear.Core.Request (Request) 38 | import qualified WebGear.Core.Response as WG 39 | import WebGear.Core.Trait (Get (..), Set (..), With) 40 | import WebGear.Core.Trait.Body (Body (..), UnknownContentBody (..)) 41 | import WebGear.OpenApi.Handler ( 42 | Documentation (..), 43 | OpenApiHandler (..), 44 | addRootPath, 45 | consumeDescription, 46 | ) 47 | 48 | instance (ToSchema val, MIMEType mt) => Get (OpenApiHandler m) (Body mt val) where 49 | {-# INLINE getTrait #-} 50 | getTrait :: Body mt val -> OpenApiHandler m (Request `With` ts) (Either Text val) 51 | getTrait (Body mt) = 52 | OpenApiHandler $ \doc -> do 53 | desc <- consumeDescription 54 | let mediaType = mimeType mt 55 | (defs, ref) = runDeclare (declareSchemaRef $ Proxy @val) mempty 56 | body = 57 | (mempty @RequestBody) 58 | & content .~ fromList [(mediaType, mempty @MediaTypeObject & schema ?~ ref)] 59 | & description .~ fmap getDescription desc 60 | pure $ 61 | doc 62 | & allOperations . requestBody ?~ Inline body 63 | & components . schemas %~ (<> defs) 64 | 65 | instance (ToSchema val, MIMEType mt) => Set (OpenApiHandler m) (Body mt val) where 66 | {-# INLINE setTrait #-} 67 | setTrait :: 68 | Body mt val -> 69 | (WG.Response `With` ts -> WG.Response -> val -> WG.Response `With` (Body mt val : ts)) -> 70 | OpenApiHandler m (WG.Response `With` ts, val) (WG.Response `With` (Body mt val : ts)) 71 | setTrait (Body mt) _ = 72 | let mediaType = mimeType mt 73 | (defs, ref) = runDeclare (declareSchemaRef $ Proxy @val) mempty 74 | body = mempty @MediaTypeObject & schema ?~ ref 75 | in OpenApiHandler $ addResponseBody defs (fromList [(mediaType, body)]) 76 | 77 | instance Set (OpenApiHandler m) UnknownContentBody where 78 | {-# INLINE setTrait #-} 79 | setTrait :: 80 | UnknownContentBody -> 81 | (WG.Response `With` ts -> WG.Response -> WG.ResponseBody -> WG.Response `With` (UnknownContentBody : ts)) -> 82 | OpenApiHandler m (WG.Response `With` ts, WG.ResponseBody) (WG.Response `With` (UnknownContentBody : ts)) 83 | setTrait UnknownContentBody _ = OpenApiHandler $ addResponseBody mempty mempty 84 | 85 | addResponseBody :: 86 | (MonadState Documentation m) => 87 | Definitions Schema -> 88 | Map.InsOrdHashMap MediaType MediaTypeObject -> 89 | OpenApi -> 90 | m OpenApi 91 | addResponseBody defs mediaTypes doc = do 92 | desc <- consumeDescription 93 | 94 | let addDescription :: Referenced Response -> Referenced Response 95 | addDescription (Ref r) = Ref r 96 | addDescription (Inline r) = 97 | case desc of 98 | Nothing -> Inline r 99 | Just (Description d) -> Inline (r & description .~ d) 100 | 101 | let resp = mempty @Response & content <>~ mediaTypes 102 | doc' = if Map.null (doc ^. paths) then addRootPath doc else doc 103 | 104 | pure $ 105 | doc' 106 | & allOperations . responses . responses %~ Map.map (addDescription . (`swaggerMappend` Inline resp)) 107 | & components . schemas %~ (<> defs) 108 | -------------------------------------------------------------------------------- /webgear-openapi/src/WebGear/OpenApi/Trait/Cookie.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -Wno-orphans #-} 2 | 3 | -- | OpenApi implementation of 'WG.Cookie' and 'WG.SetCookie' traits. 4 | module WebGear.OpenApi.Trait.Cookie () where 5 | 6 | import Data.OpenApi hiding (Response) 7 | import Data.Proxy (Proxy (Proxy)) 8 | import Data.String (fromString) 9 | import Data.Text (Text) 10 | import GHC.TypeLits (KnownSymbol, symbolVal) 11 | import WebGear.Core.Trait (Get (..), Set (..)) 12 | import qualified WebGear.Core.Trait.Cookie as WG 13 | import WebGear.OpenApi.Handler (OpenApiHandler (..)) 14 | import WebGear.OpenApi.Trait.Auth (addSecurityScheme) 15 | 16 | instance (KnownSymbol name) => Get (OpenApiHandler m) (WG.Cookie e name val) where 17 | {-# INLINE getTrait #-} 18 | getTrait WG.Cookie = 19 | OpenApiHandler $ addSecurityScheme cookieName securityScheme 20 | where 21 | cookieName = fromString @Text $ symbolVal $ Proxy @name 22 | 23 | securityScheme :: SecurityScheme 24 | securityScheme = 25 | SecurityScheme 26 | { _securitySchemeType = 27 | SecuritySchemeApiKey 28 | ApiKeyParams 29 | { _apiKeyName = cookieName 30 | , _apiKeyIn = ApiKeyCookie 31 | } 32 | , _securitySchemeDescription = Nothing 33 | } 34 | 35 | -- Response cookie information is not captured by OpenAPI 36 | 37 | instance Set (OpenApiHandler m) (WG.SetCookie e name) where 38 | {-# INLINE setTrait #-} 39 | setTrait WG.SetCookie _ = OpenApiHandler pure 40 | -------------------------------------------------------------------------------- /webgear-openapi/src/WebGear/OpenApi/Trait/Header.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -Wno-orphans #-} 2 | 3 | -- | OpenApi implementation of 'Header' trait. 4 | module WebGear.OpenApi.Trait.Header () where 5 | 6 | import Control.Lens ((%~), (&), (.~), (<>~), (?~)) 7 | import Control.Monad.State.Strict (MonadState) 8 | import qualified Data.HashMap.Strict.InsOrd as Map 9 | import Data.OpenApi ( 10 | Header, 11 | HeaderName, 12 | OpenApi, 13 | Param, 14 | ParamLocation (..), 15 | Referenced (..), 16 | Response, 17 | ToSchema, 18 | allOperations, 19 | description, 20 | headers, 21 | in_, 22 | name, 23 | parameters, 24 | required, 25 | responses, 26 | schema, 27 | toSchema, 28 | ) 29 | import Data.OpenApi.Internal.Utils (swaggerMappend) 30 | import Data.Proxy (Proxy (Proxy)) 31 | import Data.String (fromString) 32 | import Data.Text (Text) 33 | import GHC.TypeLits (KnownSymbol, symbolVal) 34 | import WebGear.Core.Handler (Description (..)) 35 | import WebGear.Core.Modifiers (Existence (..)) 36 | import WebGear.Core.Trait (Get (..), Set (..)) 37 | import qualified WebGear.Core.Trait.Header as WG 38 | import WebGear.OpenApi.Handler (Documentation, OpenApiHandler (..), consumeDescription) 39 | 40 | instance (KnownSymbol name, ToSchema val) => Get (OpenApiHandler m) (WG.RequestHeader Required ps name val) where 41 | {-# INLINE getTrait #-} 42 | getTrait WG.RequestHeader = OpenApiHandler $ addRequestHeader (Proxy @name) (Proxy @val) True 43 | 44 | instance (KnownSymbol name, ToSchema val) => Get (OpenApiHandler m) (WG.RequestHeader Optional ps name val) where 45 | {-# INLINE getTrait #-} 46 | getTrait WG.RequestHeader = OpenApiHandler $ addRequestHeader (Proxy @name) (Proxy @val) False 47 | 48 | instance (KnownSymbol name, ToSchema val) => Set (OpenApiHandler m) (WG.ResponseHeader Required name val) where 49 | {-# INLINE setTrait #-} 50 | setTrait WG.ResponseHeader _ = OpenApiHandler $ addResponseHeader (Proxy @name) (Proxy @val) True 51 | 52 | instance (KnownSymbol name, ToSchema val) => Set (OpenApiHandler m) (WG.ResponseHeader Optional name val) where 53 | {-# INLINE setTrait #-} 54 | setTrait WG.ResponseHeader _ = OpenApiHandler $ addResponseHeader (Proxy @name) (Proxy @val) False 55 | 56 | addRequestHeader :: 57 | forall name val m. 58 | (KnownSymbol name, ToSchema val, MonadState Documentation m) => 59 | Proxy name -> 60 | Proxy val -> 61 | Bool -> 62 | OpenApi -> 63 | m OpenApi 64 | addRequestHeader _ _ isRequired doc = do 65 | desc <- consumeDescription 66 | let param = 67 | (mempty :: Param) 68 | & name .~ fromString @Text (symbolVal $ Proxy @name) 69 | & in_ .~ ParamHeader 70 | & required ?~ isRequired 71 | & schema ?~ Inline (toSchema $ Proxy @val) 72 | & description .~ fmap getDescription desc 73 | pure $ doc & allOperations . parameters <>~ [Inline param] 74 | 75 | addResponseHeader :: 76 | forall name val m. 77 | (KnownSymbol name, ToSchema val, MonadState Documentation m) => 78 | Proxy name -> 79 | Proxy val -> 80 | Bool -> 81 | OpenApi -> 82 | m OpenApi 83 | addResponseHeader _ _ isRequired doc = do 84 | desc <- consumeDescription 85 | let headerName = fromString @HeaderName $ symbolVal $ Proxy @name 86 | header = 87 | mempty @Header 88 | & required ?~ isRequired 89 | & schema ?~ Inline (toSchema $ Proxy @val) 90 | & description .~ fmap getDescription desc 91 | resp = mempty @Response & headers <>~ [(headerName, Inline header)] 92 | pure $ 93 | if headerName == "Content-Type" 94 | then doc 95 | else doc & allOperations . responses . responses %~ Map.map (`swaggerMappend` Inline resp) 96 | -------------------------------------------------------------------------------- /webgear-openapi/src/WebGear/OpenApi/Trait/Method.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -Wno-orphans #-} 2 | 3 | -- | OpenApi implementation of 'Method' trait. 4 | module WebGear.OpenApi.Trait.Method where 5 | 6 | import Control.Lens ((%~), (&)) 7 | import qualified Data.HashMap.Strict.InsOrd as Map 8 | import Data.OpenApi (PathItem (..), paths) 9 | import Network.HTTP.Types (StdMethod (..)) 10 | import WebGear.Core.Trait (Get (..)) 11 | import WebGear.Core.Trait.Method (Method (..)) 12 | import WebGear.OpenApi.Handler (OpenApiHandler (..), addRouteDocumentation) 13 | 14 | instance Get (OpenApiHandler m) Method where 15 | {-# INLINE getTrait #-} 16 | getTrait (Method method) = OpenApiHandler $ \doc -> do 17 | addRouteDocumentation $ doc & paths %~ Map.map (removeOtherMethods method) 18 | 19 | removeOtherMethods :: StdMethod -> PathItem -> PathItem 20 | removeOtherMethods method PathItem{..} = 21 | case method of 22 | GET -> mempty{_pathItemGet, _pathItemSummary, _pathItemDescription, _pathItemServers, _pathItemParameters} 23 | PUT -> mempty{_pathItemPut, _pathItemSummary, _pathItemDescription, _pathItemServers, _pathItemParameters} 24 | POST -> mempty{_pathItemPost, _pathItemSummary, _pathItemDescription, _pathItemServers, _pathItemParameters} 25 | DELETE -> mempty{_pathItemDelete, _pathItemSummary, _pathItemDescription, _pathItemServers, _pathItemParameters} 26 | HEAD -> mempty{_pathItemHead, _pathItemSummary, _pathItemDescription, _pathItemServers, _pathItemParameters} 27 | TRACE -> mempty{_pathItemTrace, _pathItemSummary, _pathItemDescription, _pathItemServers, _pathItemParameters} 28 | OPTIONS -> mempty{_pathItemOptions, _pathItemSummary, _pathItemDescription, _pathItemServers, _pathItemParameters} 29 | PATCH -> mempty{_pathItemPatch, _pathItemSummary, _pathItemDescription, _pathItemServers, _pathItemParameters} 30 | -- OpenApi does not support CONNECT 31 | CONNECT -> mempty{_pathItemSummary, _pathItemDescription, _pathItemServers, _pathItemParameters} 32 | -------------------------------------------------------------------------------- /webgear-openapi/src/WebGear/OpenApi/Trait/Path.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -Wno-orphans #-} 2 | 3 | -- | OpenApi implementation of path traits. 4 | module WebGear.OpenApi.Trait.Path where 5 | 6 | import Control.Lens ((&), (<>~)) 7 | import Data.Data (Proxy (Proxy)) 8 | import Data.OpenApi ( 9 | Param (..), 10 | ParamLocation (ParamPath), 11 | Referenced (Inline), 12 | ToSchema, 13 | allOperations, 14 | parameters, 15 | prependPath, 16 | toSchema, 17 | ) 18 | import Data.String (fromString) 19 | import Data.Text (unpack) 20 | import GHC.TypeLits (KnownSymbol, symbolVal) 21 | import WebGear.Core.Request (Request) 22 | import WebGear.Core.Trait (Get (..), With) 23 | import WebGear.Core.Trait.Path (Path (..), PathEnd (..), PathVar (..), PathVarError (..)) 24 | import WebGear.OpenApi.Handler (OpenApiHandler (..), addRouteDocumentation) 25 | 26 | instance Get (OpenApiHandler m) Path where 27 | {-# INLINE getTrait #-} 28 | getTrait :: Path -> OpenApiHandler m (Request `With` ts) (Either () ()) 29 | getTrait (Path p) = OpenApiHandler $ addRouteDocumentation . prependPath (unpack p) 30 | 31 | instance (KnownSymbol tag, ToSchema val) => Get (OpenApiHandler m) (PathVar tag val) where 32 | {-# INLINE getTrait #-} 33 | getTrait :: PathVar tag val -> OpenApiHandler m (Request `With` ts) (Either PathVarError val) 34 | getTrait PathVar = 35 | let paramName = symbolVal $ Proxy @tag 36 | param = 37 | (mempty :: Param) 38 | { _paramName = fromString paramName 39 | , _paramIn = ParamPath 40 | , _paramRequired = Just True 41 | , _paramSchema = Just $ Inline $ toSchema $ Proxy @val 42 | } 43 | in OpenApiHandler $ \doc -> 44 | addRouteDocumentation $ 45 | prependPath ("{" <> paramName <> "}") doc 46 | & allOperations . parameters <>~ [Inline param] 47 | 48 | instance Get (OpenApiHandler m) PathEnd where 49 | {-# INLINE getTrait #-} 50 | getTrait :: PathEnd -> OpenApiHandler m (Request `With` ts) (Either () ()) 51 | getTrait PathEnd = OpenApiHandler $ addRouteDocumentation . prependPath "/" 52 | -------------------------------------------------------------------------------- /webgear-openapi/src/WebGear/OpenApi/Trait/QueryParam.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -Wno-orphans #-} 2 | 3 | -- | OpenApi implementation of 'QueryParam' trait. 4 | module WebGear.OpenApi.Trait.QueryParam where 5 | 6 | import Control.Lens ((&), (.~), (<>~)) 7 | import Control.Monad.State.Strict (MonadState) 8 | import Data.OpenApi ( 9 | OpenApi, 10 | Param (..), 11 | ParamLocation (ParamQuery), 12 | Referenced (Inline), 13 | ToSchema, 14 | allOperations, 15 | description, 16 | parameters, 17 | toSchema, 18 | ) 19 | import Data.Proxy (Proxy (Proxy)) 20 | import Data.String (fromString) 21 | import GHC.TypeLits (KnownSymbol, symbolVal) 22 | import WebGear.Core.Handler (Description (..)) 23 | import WebGear.Core.Modifiers (Existence (..)) 24 | import WebGear.Core.Trait (Get (..)) 25 | import WebGear.Core.Trait.QueryParam (QueryParam (..)) 26 | import WebGear.OpenApi.Handler (Documentation (..), OpenApiHandler (..), consumeDescription) 27 | 28 | instance (KnownSymbol name, ToSchema val) => Get (OpenApiHandler m) (QueryParam Required ps name val) where 29 | {-# INLINE getTrait #-} 30 | getTrait _ = 31 | let param = 32 | (mempty :: Param) 33 | { _paramName = fromString $ symbolVal $ Proxy @name 34 | , _paramIn = ParamQuery 35 | , _paramRequired = Just True 36 | , _paramSchema = Just $ Inline $ toSchema $ Proxy @val 37 | } 38 | in OpenApiHandler $ addParam param 39 | 40 | instance (KnownSymbol name, ToSchema val) => Get (OpenApiHandler m) (QueryParam Optional ps name val) where 41 | {-# INLINE getTrait #-} 42 | getTrait _ = 43 | let param = 44 | (mempty :: Param) 45 | { _paramName = fromString $ symbolVal $ Proxy @name 46 | , _paramIn = ParamQuery 47 | , _paramRequired = Just False 48 | , _paramSchema = Just $ Inline $ toSchema $ Proxy @val 49 | } 50 | in OpenApiHandler $ addParam param 51 | 52 | addParam :: (MonadState Documentation m) => Param -> OpenApi -> m OpenApi 53 | addParam param doc = do 54 | desc <- consumeDescription 55 | let param' = param & description .~ fmap getDescription desc 56 | pure $ doc & allOperations . parameters <>~ [Inline param'] 57 | -------------------------------------------------------------------------------- /webgear-openapi/src/WebGear/OpenApi/Trait/Status.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -Wno-orphans #-} 2 | 3 | -- | OpenApi implementation of 'Status' trait. 4 | module WebGear.OpenApi.Trait.Status where 5 | 6 | import Control.Applicative ((<|>)) 7 | import Control.Lens (at, mapped, (%~), (&), (.~), (?~), (^.)) 8 | import qualified Data.HashMap.Strict.InsOrd as Map 9 | import Data.Maybe (fromMaybe) 10 | import Data.OpenApi ( 11 | Operation, 12 | PathItem, 13 | Referenced (..), 14 | Response, 15 | delete, 16 | description, 17 | get, 18 | head_, 19 | options, 20 | patch, 21 | paths, 22 | post, 23 | put, 24 | responses, 25 | trace, 26 | ) 27 | import qualified Network.HTTP.Types as HTTP 28 | import WebGear.Core.Handler (Description (..)) 29 | import qualified WebGear.Core.Response as WG 30 | import WebGear.Core.Trait (Set, With, setTrait) 31 | import WebGear.Core.Trait.Status (Status (..)) 32 | import WebGear.OpenApi.Handler (OpenApiHandler (..), addRootPath, consumeDescription) 33 | 34 | instance Set (OpenApiHandler m) Status where 35 | {-# INLINE setTrait #-} 36 | setTrait :: 37 | Status -> 38 | (WG.Response `With` ts -> WG.Response -> HTTP.Status -> WG.Response `With` (Status : ts)) -> 39 | OpenApiHandler m (WG.Response `With` ts, HTTP.Status) (WG.Response `With` (Status : ts)) 40 | setTrait status _ = OpenApiHandler $ \doc -> do 41 | desc <- consumeDescription 42 | let doc' = if Map.null (doc ^. paths) then addRootPath doc else doc 43 | pure $ doc' & paths . mapped %~ setOperation desc status 44 | 45 | setOperation :: Maybe Description -> Status -> PathItem -> PathItem 46 | setOperation desc (Status status) item = 47 | item 48 | & delete %~ updateOperation 49 | & get %~ updateOperation 50 | & head_ %~ updateOperation 51 | & options %~ updateOperation 52 | & patch %~ updateOperation 53 | & post %~ updateOperation 54 | & put %~ updateOperation 55 | & trace %~ updateOperation 56 | where 57 | httpCode = HTTP.statusCode status 58 | 59 | updateOperation :: Maybe Operation -> Maybe Operation 60 | updateOperation Nothing = Just $ mempty @Operation & at httpCode ?~ addDescription emptyResp 61 | updateOperation (Just op) = 62 | let resp = addDescription $ fromMaybe emptyResp $ (op ^. at httpCode) <|> (op ^. at 0) 63 | in Just $ op & responses . responses %~ Map.insert httpCode resp . Map.delete 0 64 | 65 | emptyResp :: Referenced Response 66 | emptyResp = Inline mempty 67 | 68 | addDescription :: Referenced Response -> Referenced Response 69 | addDescription (Ref r) = Ref r 70 | addDescription (Inline r) = 71 | case desc of 72 | Nothing -> Inline r 73 | Just (Description d) -> Inline (r & description .~ d) 74 | -------------------------------------------------------------------------------- /webgear-openapi/src/WebGear/OpenApi/Traits.hs: -------------------------------------------------------------------------------- 1 | {- | OpenAPI implementation of all traits supported by WebGear. 2 | 3 | This modules only exports orphan instances imported from other 4 | modules. Hence the haddock documentation will be empty. 5 | -} 6 | module WebGear.OpenApi.Traits () where 7 | 8 | import WebGear.OpenApi.Trait.Auth () 9 | import WebGear.OpenApi.Trait.Auth.Basic () 10 | import WebGear.OpenApi.Trait.Auth.JWT () 11 | import WebGear.OpenApi.Trait.Body () 12 | import WebGear.OpenApi.Trait.Cookie () 13 | import WebGear.OpenApi.Trait.Header () 14 | import WebGear.OpenApi.Trait.Method () 15 | import WebGear.OpenApi.Trait.Path () 16 | import WebGear.OpenApi.Trait.QueryParam () 17 | import WebGear.OpenApi.Trait.Status () 18 | -------------------------------------------------------------------------------- /webgear-openapi/webgear-openapi.cabal: -------------------------------------------------------------------------------- 1 | cabal-version: 2.4 2 | 3 | name: webgear-openapi 4 | version: 1.4.0 5 | synopsis: Composable, type-safe library to build HTTP API servers 6 | description: 7 | WebGear is a library to for building composable, type-safe HTTP API servers. 8 | This package can be used to generate OpenAPI specifications from WebGear 9 | applications. 10 | homepage: https://github.com/haskell-webgear/webgear#readme 11 | bug-reports: https://github.com/haskell-webgear/webgear/issues 12 | author: Raghu Kaippully 13 | maintainer: rkaippully@gmail.com 14 | copyright: 2020-2025 Raghu Kaippully 15 | license: MPL-2.0 16 | license-file: LICENSE 17 | category: Web 18 | build-type: Simple 19 | extra-source-files: README.md 20 | CHANGELOG.md 21 | 22 | 23 | source-repository head 24 | type: git 25 | location: https://github.com/haskell-webgear/webgear 26 | 27 | 28 | library 29 | exposed-modules: WebGear.OpenApi 30 | , WebGear.OpenApi.Handler 31 | , WebGear.OpenApi.Traits 32 | , WebGear.OpenApi.Trait.Auth 33 | , WebGear.OpenApi.Trait.Auth.Basic 34 | , WebGear.OpenApi.Trait.Auth.JWT 35 | , WebGear.OpenApi.Trait.Body 36 | , WebGear.OpenApi.Trait.Cookie 37 | , WebGear.OpenApi.Trait.Header 38 | , WebGear.OpenApi.Trait.Method 39 | , WebGear.OpenApi.Trait.Path 40 | , WebGear.OpenApi.Trait.QueryParam 41 | , WebGear.OpenApi.Trait.Status 42 | hs-source-dirs: src 43 | default-language: Haskell2010 44 | default-extensions: Arrows 45 | ConstraintKinds 46 | DataKinds 47 | DeriveFunctor 48 | DeriveGeneric 49 | DerivingStrategies 50 | DerivingVia 51 | FlexibleContexts 52 | FlexibleInstances 53 | FunctionalDependencies 54 | GeneralizedNewtypeDeriving 55 | InstanceSigs 56 | KindSignatures 57 | LambdaCase 58 | MultiParamTypeClasses 59 | NamedFieldPuns 60 | OverloadedLists 61 | OverloadedStrings 62 | PolyKinds 63 | RankNTypes 64 | RecordWildCards 65 | ScopedTypeVariables 66 | StandaloneDeriving 67 | TemplateHaskellQuotes 68 | TupleSections 69 | TypeApplications 70 | TypeFamilies 71 | TypeOperators 72 | build-depends: arrows ==0.4.* 73 | , base >=4.17.0.0 && <4.22 74 | , http-media ==0.8.* 75 | , http-types ==0.12.* 76 | , insert-ordered-containers ==0.2.* 77 | , lens >=5.2 && <5.4 78 | , mtl >=2.2 && <2.4 79 | , openapi3 >=3.2.0 && <3.3 80 | , text >=2.0 && <2.2 81 | , webgear-core ^>=1.4.0 82 | ghc-options: -Wall 83 | -Wcompat 84 | -Widentities 85 | -Wincomplete-record-updates 86 | -Wincomplete-uni-patterns 87 | -Wmissing-deriving-strategies 88 | -Wmissing-fields 89 | -Wmissing-home-modules 90 | -Wno-unticked-promoted-constructors 91 | -Wpartial-fields 92 | -Wredundant-constraints 93 | -Wunused-packages 94 | -fshow-warning-groups 95 | -------------------------------------------------------------------------------- /webgear-server/CHANGELOG.md: -------------------------------------------------------------------------------- 1 | # Changelog for webgear-server 2 | 3 | ## [Unreleased] 4 | 5 | ## [1.4.0] - 2025-05-19 6 | 7 | ### Added 8 | - Support GHC-9.12 9 | 10 | ### Removed 11 | - Support GHC-9.0, GHC-9.2 12 | 13 | ## [1.3.1] - 2024-11-24 14 | 15 | ### Added 16 | - Support GHC-9.10 17 | 18 | ## [1.3.0] - 2024-06-13 19 | 20 | ### Changed 21 | - Simplify core API (breaking change) (#47) 22 | 23 | ## [1.2.0] - 2024-03-18 24 | 25 | ### Added 26 | - Prerequisite traits (#37) 27 | 28 | ### Changed 29 | - Removed the dependency on bytestring-conversion package (#38) 30 | - Support for embedding WAI applications in handlers (#36) 31 | 32 | ## [1.1.1] - 2024-01-01 33 | 34 | ### Changed 35 | - Updated dependency bounds and GHC versions (#35) 36 | 37 | ## [1.1.0] - 2023-12-29 38 | 39 | ### Added 40 | - Streaming responses support (#26) 41 | - Support for cookies (#29) 42 | - Support file uploads (#32) 43 | 44 | ### Changed 45 | - Redesign APIs for ease of use (breaking change) (#24) 46 | - Switch ServerHandler to a standard monad transformer stack (breaking change) (#27) 47 | 48 | ## [1.0.5] - 2023-05-04 49 | 50 | ### Changed 51 | - Update dependency bounds and GHC versions 52 | 53 | ## [1.0.4] - 2022-08-27 54 | 55 | ### Changed 56 | - Update dependency bounds and GHC versions 57 | 58 | ## [1.0.3] - 2022-06-26 59 | 60 | ### Changed 61 | - Upgrade to latest http-api-data (#10) 62 | - Nix flake based development environment 63 | 64 | ## [1.0.2] - 2022-06-11 65 | 66 | ### Changed 67 | - Upgrade to latest GHC versions (#9) 68 | 69 | ## [1.0.1] - 2022-01-09 70 | 71 | ### Changed 72 | - Update dependency bounds (#7) 73 | 74 | ## [1.0.0] - 2022-01-08 75 | 76 | ### Changed 77 | - New home at https://github.com/haskell-webgear/webgear 78 | - New arrow based API 79 | 80 | ## [0.2.1] - 2021-01-11 81 | 82 | ### Changed 83 | - Upgrade to latest version of LTS and deps 84 | 85 | ## [0.2.0] - 2020-09-11 86 | 87 | ### Added 88 | - Support GHC 8.10 and 8.6 (#10) 89 | - Added more traits and middlewares (#7) 90 | - Performance benchmarks (#6) 91 | - Set up a website (#13) 92 | 93 | ### Changed 94 | - A lot of refactorings (#20, #21, #22, #23) 95 | 96 | ## [0.1.0] - 2020-08-16 97 | 98 | ### Added 99 | - Support basic traits and middlewares 100 | - Automated tests 101 | - Documentation 102 | 103 | [Unreleased]: https://github.com/haskell-webgear/webgear/compare/v1.4.0...HEAD 104 | [1.4.0]: https://github.com/haskell-webgear/webgear/releases/tag/v1.4.0 105 | [1.3.1]: https://github.com/haskell-webgear/webgear/releases/tag/v1.3.1 106 | [1.3.0]: https://github.com/haskell-webgear/webgear/releases/tag/v1.3.0 107 | [1.2.0]: https://github.com/haskell-webgear/webgear/releases/tag/v1.2.0 108 | [1.1.1]: https://github.com/haskell-webgear/webgear/releases/tag/v1.1.1 109 | [1.1.0]: https://github.com/haskell-webgear/webgear/releases/tag/v1.1.0 110 | [1.0.5]: https://github.com/haskell-webgear/webgear/releases/tag/v1.0.5 111 | [1.0.4]: https://github.com/haskell-webgear/webgear/releases/tag/v1.0.4 112 | [1.0.3]: https://github.com/haskell-webgear/webgear/releases/tag/v1.0.3 113 | [1.0.2]: https://github.com/haskell-webgear/webgear/releases/tag/v1.0.2 114 | [1.0.1]: https://github.com/haskell-webgear/webgear/releases/tag/v1.0.1 115 | [1.0.0]: https://github.com/haskell-webgear/webgear/releases/tag/v1.0.0 116 | [0.2.1]: https://github.com/haskell-webgear/webgear-server/compare/v0.2.0...v0.2.1 117 | [0.2.0]: https://github.com/haskell-webgear/webgear-server/compare/v0.1.0...v0.2.0 118 | [0.1.0]: https://github.com/haskell-webgear/webgear-server/releases/tag/v0.1.0 119 | -------------------------------------------------------------------------------- /webgear-server/README.md: -------------------------------------------------------------------------------- 1 | # WebGear - HTTP API server 2 | 3 | [![Hackage](https://img.shields.io/hackage/v/webgear-server)](https://hackage.haskell.org/package/webgear-server) 4 | 5 | WebGear is a Haskell library for building composable, type-safe HTTP APIs. This package helps to generate 6 | [WAI](https://hackage.haskell.org/package/wai) applications based on WebGear API specifications. 7 | -------------------------------------------------------------------------------- /webgear-server/src/WebGear/Server.hs: -------------------------------------------------------------------------------- 1 | {- | Main module for WebGear server. 2 | 3 | Import this module to get all required types and functions to build a 4 | WebGear server. Alternatively, import individual modules under 5 | @WebGear.Server@. 6 | 7 | Typical usage to implement a server is: 8 | 9 | @ 10 | import WebGear.Server 11 | import Network.Wai (Application) 12 | import qualified Network.Wai.Handler.Warp as Warp 13 | 14 | -- | A monad stack for you application 15 | type App a = .... 16 | 17 | -- | Convert the App monad to IO 18 | runApp :: App a -> IO a 19 | runApp = .... 20 | 21 | -- | Handler for the server 22 | myHandler :: `Handler` h App => `RequestHandler` h '[] 23 | myHandler = .... 24 | 25 | app :: Application 26 | app = `toApplication` (`transform` runApp myHandler) 27 | 28 | main :: IO () 29 | main = Warp.run port app 30 | @ 31 | -} 32 | module WebGear.Server ( 33 | module WebGear.Core, 34 | module WebGear.Server.Handler, 35 | ) where 36 | 37 | import WebGear.Core 38 | import WebGear.Server.Handler 39 | import WebGear.Server.Traits () 40 | -------------------------------------------------------------------------------- /webgear-server/src/WebGear/Server/Trait/Auth/Basic.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE UndecidableInstances #-} 2 | {-# OPTIONS_GHC -Wno-orphans #-} 3 | 4 | -- | Server implementation of the 'BasicAuth'' trait. 5 | module WebGear.Server.Trait.Auth.Basic where 6 | 7 | import Control.Arrow (arr, returnA, (>>>)) 8 | import Data.Bifunctor (first) 9 | import Data.ByteString.Base64 (decodeLenient) 10 | import Data.ByteString.Char8 (intercalate, split) 11 | import Data.Void (Void) 12 | import WebGear.Core.Handler (arrM) 13 | import WebGear.Core.Modifiers 14 | import WebGear.Core.Request (Request) 15 | import WebGear.Core.Trait (Get (..), HasTrait, With, from, pick) 16 | import WebGear.Core.Trait.Auth.Basic ( 17 | BasicAuth' (..), 18 | BasicAuthError (..), 19 | Credentials (..), 20 | Password (..), 21 | Username (..), 22 | ) 23 | import WebGear.Core.Trait.Auth.Common ( 24 | AuthToken (..), 25 | AuthorizationHeader, 26 | ) 27 | import WebGear.Server.Handler (ServerHandler) 28 | 29 | instance (Monad m) => Get (ServerHandler m) (BasicAuth' Required scheme m e a) where 30 | {-# INLINE getTrait #-} 31 | getTrait :: 32 | (HasTrait (AuthorizationHeader scheme) ts) => 33 | BasicAuth' Required scheme m e a -> 34 | ServerHandler m (Request `With` ts) (Either (BasicAuthError e) a) 35 | getTrait BasicAuth'{..} = proc request -> do 36 | let result = pick @(AuthorizationHeader scheme) $ from request 37 | case result of 38 | Nothing -> returnA -< Left BasicAuthHeaderMissing 39 | (Just (Left _)) -> returnA -< Left BasicAuthSchemeMismatch 40 | (Just (Right token)) -> 41 | case parseCreds token of 42 | Left e -> returnA -< Left e 43 | Right c -> validateCreds -< c 44 | where 45 | parseCreds :: AuthToken scheme -> Either (BasicAuthError e) Credentials 46 | parseCreds AuthToken{..} = 47 | case split ':' (decodeLenient authToken) of 48 | [] -> Left BasicAuthCredsBadFormat 49 | u : ps -> Right $ Credentials (Username u) (Password $ intercalate ":" ps) 50 | 51 | validateCreds :: ServerHandler m Credentials (Either (BasicAuthError e) a) 52 | validateCreds = arrM $ \creds -> do 53 | res <- toBasicAttribute creds 54 | pure $ first BasicAuthAttributeError res 55 | 56 | instance (Monad m) => Get (ServerHandler m) (BasicAuth' Optional scheme m e a) where 57 | {-# INLINE getTrait #-} 58 | getTrait :: 59 | (HasTrait (AuthorizationHeader scheme) ts) => 60 | BasicAuth' Optional scheme m e a -> 61 | ServerHandler m (Request `With` ts) (Either Void (Either (BasicAuthError e) a)) 62 | getTrait BasicAuth'{..} = getTrait (BasicAuth'{..} :: BasicAuth' Required scheme m e a) >>> arr Right 63 | -------------------------------------------------------------------------------- /webgear-server/src/WebGear/Server/Trait/Auth/JWT.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE UndecidableInstances #-} 2 | {-# OPTIONS_GHC -Wno-orphans #-} 3 | 4 | -- | Server implementation of the 'JWTAuth'' trait. 5 | module WebGear.Server.Trait.Auth.JWT where 6 | 7 | import Control.Arrow (arr, returnA, (>>>)) 8 | import Control.Monad.Except (MonadError (throwError), runExceptT, withExceptT) 9 | import Control.Monad.Time (MonadTime) 10 | import Control.Monad.Trans (lift) 11 | import qualified Crypto.JWT as JWT 12 | import Data.ByteString.Lazy (fromStrict) 13 | import Data.Void (Void) 14 | import WebGear.Core.Handler (arrM) 15 | import WebGear.Core.Modifiers 16 | import WebGear.Core.Request (Request) 17 | import WebGear.Core.Trait (Get (..), HasTrait, With, from, pick) 18 | import WebGear.Core.Trait.Auth.Common ( 19 | AuthToken (..), 20 | AuthorizationHeader, 21 | ) 22 | import WebGear.Core.Trait.Auth.JWT (JWTAuth' (..), JWTAuthError (..)) 23 | import WebGear.Server.Handler (ServerHandler) 24 | 25 | instance (MonadTime m, Get (ServerHandler m) (AuthorizationHeader scheme)) => Get (ServerHandler m) (JWTAuth' Required scheme m e a) where 26 | {-# INLINE getTrait #-} 27 | getTrait :: 28 | (HasTrait (AuthorizationHeader scheme) ts) => 29 | JWTAuth' Required scheme m e a -> 30 | ServerHandler m (Request `With` ts) (Either (JWTAuthError e) a) 31 | getTrait JWTAuth'{..} = proc request -> do 32 | let result = pick @(AuthorizationHeader scheme) $ from request 33 | case result of 34 | Nothing -> returnA -< Left JWTAuthHeaderMissing 35 | (Just (Left _)) -> returnA -< Left JWTAuthSchemeMismatch 36 | (Just (Right token)) -> 37 | case parseJWT token of 38 | Left e -> returnA -< Left (JWTAuthTokenBadFormat e) 39 | Right jwt -> validateJWT -< jwt 40 | where 41 | parseJWT :: AuthToken scheme -> Either JWT.JWTError JWT.SignedJWT 42 | parseJWT AuthToken{..} = JWT.decodeCompact $ fromStrict authToken 43 | 44 | validateJWT :: ServerHandler m JWT.SignedJWT (Either (JWTAuthError e) a) 45 | validateJWT = arrM $ \jwt -> runExceptT $ do 46 | claims <- withExceptT JWTAuthTokenBadFormat $ JWT.verifyClaims jwtValidationSettings jwkSet jwt 47 | lift (toJWTAttribute claims) >>= either (throwError . JWTAuthAttributeError) pure 48 | 49 | instance (MonadTime m, Get (ServerHandler m) (AuthorizationHeader scheme)) => Get (ServerHandler m) (JWTAuth' Optional scheme m e a) where 50 | {-# INLINE getTrait #-} 51 | getTrait :: 52 | (HasTrait (AuthorizationHeader scheme) ts) => 53 | JWTAuth' Optional scheme m e a -> 54 | ServerHandler m (Request `With` ts) (Either Void (Either (JWTAuthError e) a)) 55 | getTrait JWTAuth'{..} = getTrait (JWTAuth'{..} :: JWTAuth' Required scheme m e a) >>> arr Right 56 | -------------------------------------------------------------------------------- /webgear-server/src/WebGear/Server/Trait/Body.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE UndecidableInstances #-} 2 | {-# OPTIONS_GHC -Wno-orphans #-} 3 | 4 | -- | Server implementation of the `Body` trait. 5 | module WebGear.Server.Trait.Body () where 6 | 7 | import Control.Monad.Trans (lift) 8 | import Data.Text (Text) 9 | import qualified Network.HTTP.Media as HTTP 10 | import qualified Network.HTTP.Types as HTTP 11 | import WebGear.Core.Handler (Handler (..)) 12 | import WebGear.Core.Request (Request (..)) 13 | import WebGear.Core.Response (Response (..), ResponseBody) 14 | import WebGear.Core.Trait (Get (..), Set (..), With, unwitness) 15 | import WebGear.Core.Trait.Body (Body (..), UnknownContentBody (..)) 16 | import WebGear.Server.Handler (ServerHandler (..)) 17 | import WebGear.Server.MIMETypes (BodyRender (..), BodyUnrender (..)) 18 | 19 | instance (Monad m, BodyUnrender m mt val) => Get (ServerHandler m) (Body mt val) where 20 | {-# INLINE getTrait #-} 21 | getTrait :: Body mt val -> ServerHandler m (Request `With` ts) (Either Text val) 22 | getTrait (Body mt) = arrM $ bodyUnrender mt . unwitness 23 | 24 | instance (Monad m, BodyRender m mt val) => Set (ServerHandler m) (Body mt val) where 25 | {-# INLINE setTrait #-} 26 | setTrait :: 27 | Body mt val -> 28 | (Response `With` ts -> Response -> val -> Response `With` (Body mt val : ts)) -> 29 | ServerHandler m (Response `With` ts, val) (Response `With` (Body mt val : ts)) 30 | setTrait (Body mt) f = ServerHandler $ \(wResponse, val) -> do 31 | let response = unwitness wResponse 32 | case response of 33 | Response status hdrs _ -> do 34 | (mediaType, body') <- lift $ lift $ bodyRender mt response val 35 | let response' = Response status (alterContentType mediaType hdrs) body' 36 | pure $ f wResponse response' val 37 | _ -> pure $ f wResponse response val 38 | 39 | alterContentType :: HTTP.MediaType -> HTTP.ResponseHeaders -> HTTP.ResponseHeaders 40 | alterContentType mt = go 41 | where 42 | mtStr = HTTP.renderHeader mt 43 | go [] = [(HTTP.hContentType, mtStr)] 44 | go ((n, v) : hdrs) 45 | | n == HTTP.hContentType = (HTTP.hContentType, mtStr) : hdrs 46 | | otherwise = (n, v) : go hdrs 47 | 48 | instance (Monad m) => Set (ServerHandler m) UnknownContentBody where 49 | {-# INLINE setTrait #-} 50 | setTrait :: 51 | UnknownContentBody -> 52 | (Response `With` ts -> Response -> ResponseBody -> Response `With` (UnknownContentBody : ts)) -> 53 | ServerHandler m (Response `With` ts, ResponseBody) (Response `With` (UnknownContentBody : ts)) 54 | setTrait UnknownContentBody f = ServerHandler $ \(wResponse, body') -> 55 | case unwitness wResponse of 56 | Response status hdrs _ -> pure $ f wResponse (Response status hdrs body') body' 57 | response -> pure $ f wResponse response body' 58 | -------------------------------------------------------------------------------- /webgear-server/src/WebGear/Server/Trait/Method.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -Wno-orphans #-} 2 | 3 | -- | Server implementation of the `Method` trait. 4 | module WebGear.Server.Trait.Method where 5 | 6 | import Control.Arrow (returnA) 7 | import qualified Network.HTTP.Types as HTTP 8 | import WebGear.Core.Request (Request, requestMethod) 9 | import WebGear.Core.Trait (Get (..), With (unwitness), unwitness) 10 | import WebGear.Core.Trait.Method (Method (..), MethodMismatch (..)) 11 | import WebGear.Server.Handler (ServerHandler) 12 | 13 | instance (Monad m) => Get (ServerHandler m) Method where 14 | {-# INLINE getTrait #-} 15 | getTrait :: Method -> ServerHandler m (Request `With` ts) (Either MethodMismatch HTTP.StdMethod) 16 | getTrait (Method method) = proc request -> do 17 | let expectedMethod = HTTP.renderStdMethod method 18 | actualMethod = requestMethod $ unwitness request 19 | if actualMethod == expectedMethod 20 | then returnA -< Right method 21 | else returnA -< Left $ MethodMismatch{..} 22 | -------------------------------------------------------------------------------- /webgear-server/src/WebGear/Server/Trait/Path.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -Wno-orphans #-} 2 | 3 | -- | Server implementation of the path traits. 4 | module WebGear.Server.Trait.Path where 5 | 6 | import Control.Monad.State (get, gets, put) 7 | import qualified Data.List as List 8 | import qualified Data.Text as Text 9 | import Web.HttpApiData (FromHttpApiData (..)) 10 | import WebGear.Core.Handler (RoutePath (..)) 11 | import WebGear.Core.Request (Request) 12 | import WebGear.Core.Trait (Get (..), With) 13 | import WebGear.Core.Trait.Path ( 14 | Path (..), 15 | PathEnd (..), 16 | PathVar (..), 17 | PathVarError (..), 18 | ) 19 | import WebGear.Server.Handler (ServerHandler (..)) 20 | 21 | instance (Monad m) => Get (ServerHandler m) Path where 22 | {-# INLINE getTrait #-} 23 | getTrait :: Path -> ServerHandler m (Request `With` ts) (Either () ()) 24 | getTrait (Path p) = ServerHandler $ const $ do 25 | RoutePath remaining <- get 26 | let expected = filter (/= "") $ Text.splitOn "/" p 27 | case List.stripPrefix expected remaining of 28 | Just ps -> put (RoutePath ps) >> pure (Right ()) 29 | Nothing -> pure (Left ()) 30 | 31 | instance (Monad m, FromHttpApiData val) => Get (ServerHandler m) (PathVar tag val) where 32 | {-# INLINE getTrait #-} 33 | getTrait :: PathVar tag val -> ServerHandler m (Request `With` ts) (Either PathVarError val) 34 | getTrait PathVar = ServerHandler $ const $ do 35 | RoutePath remaining <- get 36 | case remaining of 37 | [] -> pure (Left PathVarNotFound) 38 | (p : ps) -> 39 | case parseUrlPiece p of 40 | Left e -> pure (Left $ PathVarParseError e) 41 | Right val -> put (RoutePath ps) >> pure (Right val) 42 | 43 | instance (Monad m) => Get (ServerHandler m) PathEnd where 44 | {-# INLINE getTrait #-} 45 | getTrait :: PathEnd -> ServerHandler m (Request `With` ts) (Either () ()) 46 | getTrait PathEnd = 47 | ServerHandler $ 48 | const $ 49 | gets 50 | ( \case 51 | RoutePath [] -> Right () 52 | _ -> Left () 53 | ) 54 | -------------------------------------------------------------------------------- /webgear-server/src/WebGear/Server/Trait/QueryParam.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -Wno-orphans #-} 2 | 3 | -- | Server implementation of the `QueryParam` trait. 4 | module WebGear.Server.Trait.QueryParam () where 5 | 6 | import Control.Arrow (arr, returnA, (>>>)) 7 | import Data.List (find) 8 | import Data.Proxy (Proxy (Proxy)) 9 | import Data.String (fromString) 10 | import Data.Text (Text) 11 | import Data.Void (Void) 12 | import GHC.TypeLits (KnownSymbol, symbolVal) 13 | import Network.HTTP.Types (queryToQueryText) 14 | import Web.HttpApiData (FromHttpApiData (..)) 15 | import WebGear.Core.Modifiers 16 | import WebGear.Core.Request (Request, queryString) 17 | import WebGear.Core.Trait (Get (..), With, unwitness) 18 | import WebGear.Core.Trait.QueryParam ( 19 | ParamNotFound (..), 20 | ParamParseError (..), 21 | QueryParam (..), 22 | ) 23 | import WebGear.Server.Handler (ServerHandler) 24 | 25 | extractQueryParam :: 26 | (Monad m, KnownSymbol name, FromHttpApiData val) => 27 | Proxy name -> 28 | ServerHandler m (Request `With` ts) (Maybe (Either Text val)) 29 | extractQueryParam proxy = proc req -> do 30 | let name = fromString $ symbolVal proxy 31 | params = queryToQueryText $ queryString $ unwitness req 32 | returnA -< parseQueryParam <$> (find ((== name) . fst) params >>= snd) 33 | 34 | instance (Monad m, KnownSymbol name, FromHttpApiData val) => Get (ServerHandler m) (QueryParam Required Strict name val) where 35 | {-# INLINE getTrait #-} 36 | getTrait :: 37 | QueryParam Required Strict name val -> 38 | ServerHandler m (Request `With` ts) (Either (Either ParamNotFound ParamParseError) val) 39 | getTrait QueryParam = extractQueryParam (Proxy @name) >>> arr f 40 | where 41 | f = \case 42 | Nothing -> Left $ Left ParamNotFound 43 | Just (Left e) -> Left $ Right $ ParamParseError e 44 | Just (Right x) -> Right x 45 | 46 | instance (Monad m, KnownSymbol name, FromHttpApiData val) => Get (ServerHandler m) (QueryParam Optional Strict name val) where 47 | {-# INLINE getTrait #-} 48 | getTrait :: 49 | QueryParam Optional Strict name val -> 50 | ServerHandler m (Request `With` ts) (Either ParamParseError (Maybe val)) 51 | getTrait QueryParam = extractQueryParam (Proxy @name) >>> arr f 52 | where 53 | f = \case 54 | Nothing -> Right Nothing 55 | Just (Left e) -> Left $ ParamParseError e 56 | Just (Right x) -> Right $ Just x 57 | 58 | instance (Monad m, KnownSymbol name, FromHttpApiData val) => Get (ServerHandler m) (QueryParam Required Lenient name val) where 59 | {-# INLINE getTrait #-} 60 | getTrait :: 61 | QueryParam Required Lenient name val -> 62 | ServerHandler m (Request `With` ts) (Either ParamNotFound (Either Text val)) 63 | getTrait QueryParam = extractQueryParam (Proxy @name) >>> arr f 64 | where 65 | f = \case 66 | Nothing -> Left ParamNotFound 67 | Just (Left e) -> Right $ Left e 68 | Just (Right x) -> Right $ Right x 69 | 70 | instance (Monad m, KnownSymbol name, FromHttpApiData val) => Get (ServerHandler m) (QueryParam Optional Lenient name val) where 71 | {-# INLINE getTrait #-} 72 | getTrait :: 73 | QueryParam Optional Lenient name val -> 74 | ServerHandler m (Request `With` ts) (Either Void (Maybe (Either Text val))) 75 | getTrait QueryParam = extractQueryParam (Proxy @name) >>> arr f 76 | where 77 | f = \case 78 | Nothing -> Right Nothing 79 | Just (Left e) -> Right $ Just $ Left e 80 | Just (Right x) -> Right $ Just $ Right x 81 | -------------------------------------------------------------------------------- /webgear-server/src/WebGear/Server/Trait/Status.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -Wno-orphans #-} 2 | 3 | -- | Server implementation of the `Status` trait. 4 | module WebGear.Server.Trait.Status where 5 | 6 | import Control.Arrow (returnA) 7 | import qualified Network.HTTP.Types.Status as HTTP 8 | import WebGear.Core.Response (Response (..)) 9 | import WebGear.Core.Trait (Set, With, setTrait, unwitness) 10 | import WebGear.Core.Trait.Status (Status (..)) 11 | import WebGear.Server.Handler (ServerHandler) 12 | 13 | instance (Monad m) => Set (ServerHandler m) Status where 14 | {-# INLINE setTrait #-} 15 | setTrait :: 16 | Status -> 17 | (Response `With` ts -> Response -> HTTP.Status -> Response `With` (Status : ts)) -> 18 | ServerHandler m (Response `With` ts, HTTP.Status) (Response `With` (Status : ts)) 19 | setTrait (Status status) f = proc (wResponse, _) -> do 20 | let response' = 21 | case unwitness wResponse of 22 | Response _ hdrs body -> Response status hdrs body 23 | response -> response 24 | returnA -< f wResponse response' status 25 | -------------------------------------------------------------------------------- /webgear-server/src/WebGear/Server/Traits.hs: -------------------------------------------------------------------------------- 1 | {- | Server implementation of all traits supported by WebGear. 2 | 3 | This modules only exports orphan instances imported from other 4 | modules. Hence the haddock documentation will be empty. 5 | -} 6 | module WebGear.Server.Traits () where 7 | 8 | import WebGear.Server.Trait.Auth.Basic () 9 | import WebGear.Server.Trait.Auth.JWT () 10 | import WebGear.Server.Trait.Body () 11 | import WebGear.Server.Trait.Cookie () 12 | import WebGear.Server.Trait.Header () 13 | import WebGear.Server.Trait.Method () 14 | import WebGear.Server.Trait.Path () 15 | import WebGear.Server.Trait.QueryParam () 16 | import WebGear.Server.Trait.Status () 17 | -------------------------------------------------------------------------------- /webgear-server/test/Main.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import Test.Tasty (TestTree, defaultMain, testGroup) 4 | 5 | import Properties (propertyTests) 6 | import Unit (unitTests) 7 | 8 | main :: IO () 9 | main = defaultMain allTests 10 | 11 | allTests :: TestTree 12 | allTests = testGroup "Tests" [unitTests, propertyTests, systemTests] 13 | 14 | systemTests :: TestTree 15 | systemTests = testGroup "System Tests" [] 16 | -------------------------------------------------------------------------------- /webgear-server/test/Properties.hs: -------------------------------------------------------------------------------- 1 | module Properties ( 2 | propertyTests, 3 | ) where 4 | 5 | import Test.Tasty (TestTree, testGroup) 6 | 7 | import qualified Properties.Trait.Auth.Basic as Basic 8 | import qualified Properties.Trait.Body as Body 9 | import qualified Properties.Trait.Header as Header 10 | import qualified Properties.Trait.Method as Method 11 | import qualified Properties.Trait.Path as Path 12 | import qualified Properties.Trait.QueryParam as QueryParam 13 | 14 | propertyTests :: TestTree 15 | propertyTests = 16 | testGroup 17 | "Property Tests" 18 | [ Method.tests 19 | , Path.tests 20 | , Header.tests 21 | , QueryParam.tests 22 | , Body.tests 23 | , Basic.tests 24 | ] 25 | -------------------------------------------------------------------------------- /webgear-server/test/Properties/Trait/Auth/Basic.hs: -------------------------------------------------------------------------------- 1 | module Properties.Trait.Auth.Basic ( 2 | tests, 3 | ) where 4 | 5 | import Control.Arrow (returnA, (>>>)) 6 | import Data.ByteString.Base64 (encode) 7 | import Data.ByteString.Char8 (elem) 8 | import Data.Either (fromRight) 9 | import Data.Functor.Identity (Identity, runIdentity) 10 | import Network.Wai (defaultRequest, requestHeaders) 11 | import Test.QuickCheck ( 12 | Discard (..), 13 | Property, 14 | allProperties, 15 | counterexample, 16 | property, 17 | (.&&.), 18 | (===), 19 | ) 20 | import Test.QuickCheck.Instances () 21 | import Test.Tasty (TestTree) 22 | import Test.Tasty.QuickCheck (testProperties) 23 | import WebGear.Core.Request (Request (..)) 24 | import WebGear.Core.Trait (With, getTrait, probe, wzero) 25 | import WebGear.Core.Trait.Auth.Basic ( 26 | BasicAuth, 27 | BasicAuth' (..), 28 | Credentials (..), 29 | Password (..), 30 | Username (..), 31 | ) 32 | import WebGear.Core.Trait.Auth.Common (AuthorizationHeader) 33 | import WebGear.Core.Trait.Header (RequestHeader (..)) 34 | import WebGear.Server.Handler (ServerHandler, runServerHandler) 35 | import WebGear.Server.Trait.Auth.Basic () 36 | import WebGear.Server.Trait.Header () 37 | import Prelude hiding (elem) 38 | 39 | prop_basicAuth :: Property 40 | prop_basicAuth = property f 41 | where 42 | f (username, password) 43 | | ':' `elem` username = property Discard 44 | | otherwise = 45 | let hval = "Basic " <> encode (username <> ":" <> password) 46 | 47 | mkRequest :: ServerHandler Identity () (Request `With` '[AuthorizationHeader "Basic"]) 48 | mkRequest = proc () -> do 49 | let req = Request $ defaultRequest{requestHeaders = [("Authorization", hval)]} 50 | r <- probe RequestHeader -< wzero req 51 | returnA -< fromRight undefined r 52 | 53 | authCfg :: BasicAuth Identity () Credentials 54 | authCfg = BasicAuth'{toBasicAttribute = pure . Right} 55 | in runIdentity $ do 56 | res <- runServerHandler (mkRequest >>> getTrait authCfg) [""] () 57 | pure $ case res of 58 | Right (Right creds) -> 59 | credentialsUsername creds 60 | === Username username 61 | .&&. credentialsPassword creds 62 | === Password password 63 | e -> counterexample ("Unexpected failure: " <> show e) (property False) 64 | 65 | -- Hack for TH splicing 66 | return [] 67 | 68 | tests :: TestTree 69 | tests = testProperties "Trait.Auth.Basic" $allProperties 70 | -------------------------------------------------------------------------------- /webgear-server/test/Properties/Trait/Body.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -Wno-deprecations #-} 2 | 3 | module Properties.Trait.Body ( 4 | tests, 5 | ) where 6 | 7 | import Control.Monad.IO.Class (MonadIO, liftIO) 8 | import Data.IORef (newIORef, readIORef, writeIORef) 9 | import Data.String (fromString) 10 | import Network.Wai (defaultRequest, requestBody) 11 | import Test.QuickCheck (Property, allProperties, counterexample, property) 12 | import Test.QuickCheck.Instances () 13 | import Test.QuickCheck.Monadic (assert, monadicIO, monitor) 14 | import Test.Tasty (TestTree) 15 | import Test.Tasty.QuickCheck (testProperties) 16 | import WebGear.Core.MIMETypes (JSON (..)) 17 | import WebGear.Core.Request (Request (..)) 18 | import WebGear.Core.Trait (With, getTrait, wzero) 19 | import WebGear.Core.Trait.Body (Body (..)) 20 | import WebGear.Server.Handler (runServerHandler) 21 | import WebGear.Server.Trait.Body () 22 | 23 | jsonBody :: Body JSON t 24 | jsonBody = Body JSON 25 | 26 | bodyToRequest :: (MonadIO m, Show a) => a -> m (Request `With` '[]) 27 | bodyToRequest x = do 28 | body <- liftIO $ newIORef $ Just $ fromString $ show x 29 | let f = readIORef body >>= maybe (pure "") (\s -> writeIORef body Nothing >> pure s) 30 | return $ wzero $ Request $ defaultRequest{requestBody = f} 31 | 32 | prop_emptyRequestBodyFails :: Property 33 | prop_emptyRequestBodyFails = monadicIO $ do 34 | req <- bodyToRequest ("" :: String) 35 | runServerHandler (getTrait (jsonBody @Int)) [""] req >>= \case 36 | Right (Left _) -> assert True 37 | e -> monitor (counterexample $ "Unexpected " <> show e) >> assert False 38 | 39 | prop_validBodyParses :: Property 40 | prop_validBodyParses = property $ \n -> monadicIO $ do 41 | req <- bodyToRequest (n :: Integer) 42 | runServerHandler (getTrait jsonBody) [""] req >>= \case 43 | Right (Right n') -> assert (n == n') 44 | _ -> assert False 45 | 46 | prop_invalidBodyTypeFails :: Property 47 | prop_invalidBodyTypeFails = property $ \n -> monadicIO $ do 48 | req <- bodyToRequest (n :: Integer) 49 | runServerHandler (getTrait (jsonBody @String)) [""] req >>= \case 50 | Right (Left _) -> assert True 51 | _ -> assert False 52 | 53 | -- Hack for TH splicing 54 | return [] 55 | 56 | tests :: TestTree 57 | tests = testProperties "Trait.Body" $allProperties 58 | -------------------------------------------------------------------------------- /webgear-server/test/Properties/Trait/Header.hs: -------------------------------------------------------------------------------- 1 | module Properties.Trait.Header ( 2 | tests, 3 | ) where 4 | 5 | import Data.Functor.Identity (runIdentity) 6 | import Data.String (fromString) 7 | import Data.Text.Encoding (encodeUtf8) 8 | import Network.Wai (defaultRequest, requestHeaders) 9 | import Test.QuickCheck (Property, allProperties, counterexample, property, (===)) 10 | import Test.QuickCheck.Instances () 11 | import Test.Tasty (TestTree) 12 | import Test.Tasty.QuickCheck (testProperties) 13 | import WebGear.Core.Request (Request (..)) 14 | import WebGear.Core.Trait (getTrait, wzero) 15 | import WebGear.Core.Trait.Header (HeaderParseError (..), RequestHeader (..), RequiredRequestHeader) 16 | import WebGear.Server.Handler (runServerHandler) 17 | import WebGear.Server.Trait.Header () 18 | 19 | prop_headerParseError :: Property 20 | prop_headerParseError = property $ \hval -> 21 | let hval' = "test-" <> hval 22 | req = wzero $ Request $ defaultRequest{requestHeaders = [("foo", encodeUtf8 hval')]} 23 | in runIdentity $ do 24 | res <- runServerHandler (getTrait (RequestHeader :: RequiredRequestHeader "foo" Int)) [""] req 25 | pure $ case res of 26 | Right (Left e) -> 27 | e === Right (HeaderParseError $ "could not parse: `" <> hval' <> "' (input does not start with a digit)") 28 | v -> counterexample ("Unexpected result: " <> show v) (property False) 29 | 30 | prop_headerParseSuccess :: Property 31 | prop_headerParseSuccess = property $ \(n :: Int) -> 32 | let req = wzero $ Request $ defaultRequest{requestHeaders = [("foo", fromString $ show n)]} 33 | in runIdentity $ do 34 | res <- runServerHandler (getTrait (RequestHeader :: RequiredRequestHeader "foo" Int)) [""] req 35 | pure $ case res of 36 | Right (Right n') -> n === n' 37 | e -> counterexample ("Unexpected result: " <> show e) (property False) 38 | 39 | -- Hack for TH splicing 40 | return [] 41 | 42 | tests :: TestTree 43 | tests = testProperties "Trait.Header" $allProperties 44 | -------------------------------------------------------------------------------- /webgear-server/test/Properties/Trait/Method.hs: -------------------------------------------------------------------------------- 1 | module Properties.Trait.Method ( 2 | tests, 3 | ) where 4 | 5 | import Data.Functor.Identity (runIdentity) 6 | import Network.HTTP.Types (StdMethod (..), methodGet, renderStdMethod) 7 | import Network.Wai (defaultRequest, requestMethod) 8 | import Test.QuickCheck ( 9 | Arbitrary (arbitrary), 10 | Property, 11 | allProperties, 12 | elements, 13 | property, 14 | (.&&.), 15 | (=/=), 16 | (===), 17 | ) 18 | import Test.Tasty (TestTree) 19 | import Test.Tasty.QuickCheck (testProperties) 20 | import WebGear.Core.Request (Request (..)) 21 | import WebGear.Core.Trait (getTrait, wzero) 22 | import WebGear.Core.Trait.Method (Method (..), MethodMismatch (..)) 23 | import WebGear.Server.Handler (runServerHandler) 24 | import WebGear.Server.Trait.Method () 25 | 26 | newtype MethodWrapper = MethodWrapper StdMethod 27 | deriving stock (Show) 28 | 29 | instance Arbitrary MethodWrapper where 30 | arbitrary = elements $ MethodWrapper <$> [minBound .. maxBound] 31 | 32 | prop_methodMatch :: Property 33 | prop_methodMatch = property $ \(MethodWrapper v) -> 34 | let req = wzero $ Request $ defaultRequest{requestMethod = renderStdMethod v} 35 | in runIdentity $ do 36 | res <- runServerHandler (getTrait (Method GET)) [""] req 37 | pure $ case res of 38 | Right (Right _) -> v === GET 39 | Right (Left e) -> expectedMethod e === methodGet .&&. actualMethod e =/= methodGet 40 | Left _ -> property False 41 | 42 | -- Hack for TH splicing 43 | return [] 44 | 45 | tests :: TestTree 46 | tests = testProperties "Trait.Method" $allProperties 47 | -------------------------------------------------------------------------------- /webgear-server/test/Properties/Trait/Path.hs: -------------------------------------------------------------------------------- 1 | module Properties.Trait.Path ( 2 | tests, 3 | ) where 4 | 5 | import Data.Functor.Identity (runIdentity) 6 | import Data.String (fromString) 7 | import Network.Wai (defaultRequest, pathInfo) 8 | import Test.QuickCheck (Property, allProperties, property, (=/=), (===)) 9 | import Test.QuickCheck.Instances () 10 | import Test.Tasty (TestTree) 11 | import Test.Tasty.QuickCheck (testProperties) 12 | import WebGear.Core.Request (Request (..)) 13 | import WebGear.Core.Trait (getTrait, wzero) 14 | import WebGear.Core.Trait.Path (Path (..), PathVar (..), PathVarError (..)) 15 | import WebGear.Server.Handler (RoutePath (..), runServerHandler) 16 | import WebGear.Server.Trait.Path () 17 | 18 | prop_pathMatch :: Property 19 | prop_pathMatch = property $ \h -> 20 | let rest = ["foo", "bar"] 21 | req = wzero $ Request $ defaultRequest{pathInfo = h : rest} 22 | in runIdentity $ do 23 | res <- runServerHandler (getTrait $ Path "a") (RoutePath $ h : rest) req 24 | pure $ case res of 25 | Right (Right _) -> h === "a" 26 | Right (Left _) -> h =/= "a" 27 | Left _ -> property False 28 | 29 | prop_pathVarMatch :: Property 30 | prop_pathVarMatch = property $ \(n :: Int) -> 31 | let rest = ["foo", "bar"] 32 | p = fromString (show n) : rest 33 | req = wzero $ Request $ defaultRequest{pathInfo = p} 34 | in runIdentity $ do 35 | res <- runServerHandler (getTrait (PathVar @"tag" @Int)) (RoutePath p) req 36 | pure $ case res of 37 | Right (Right n') -> n' === n 38 | _ -> property False 39 | 40 | prop_pathVarParseError :: Property 41 | prop_pathVarParseError = property $ \(p, ps) -> 42 | let p' = "test-" <> p 43 | req = wzero $ Request $ defaultRequest{pathInfo = p' : ps} 44 | in runIdentity $ do 45 | res <- runServerHandler (getTrait (PathVar @"tag" @Int)) (RoutePath $ p' : ps) req 46 | pure $ case res of 47 | Right (Left e) -> e === PathVarParseError ("could not parse: `" <> p' <> "' (input does not start with a digit)") 48 | _ -> property False 49 | 50 | -- Hack for TH splicing 51 | return [] 52 | 53 | tests :: TestTree 54 | tests = testProperties "Trait.Path" $allProperties 55 | -------------------------------------------------------------------------------- /webgear-server/test/Properties/Trait/QueryParam.hs: -------------------------------------------------------------------------------- 1 | module Properties.Trait.QueryParam ( 2 | tests, 3 | ) where 4 | 5 | import Data.Functor.Identity (runIdentity) 6 | import Data.String (fromString) 7 | import Data.Text.Encoding (encodeUtf8) 8 | import Network.Wai (defaultRequest, queryString) 9 | import Test.QuickCheck (Property, allProperties, counterexample, property, (===)) 10 | import Test.QuickCheck.Instances () 11 | import Test.Tasty (TestTree) 12 | import Test.Tasty.QuickCheck (testProperties) 13 | import WebGear.Core.Modifiers (Existence (..), ParseStyle (..)) 14 | import WebGear.Core.Request (Request (..)) 15 | import WebGear.Core.Trait (getTrait, wzero) 16 | import WebGear.Core.Trait.QueryParam (ParamParseError (..), QueryParam (..)) 17 | import WebGear.Server.Handler (runServerHandler) 18 | import WebGear.Server.Trait.QueryParam () 19 | 20 | prop_paramParseError :: Property 21 | prop_paramParseError = property $ \hval -> 22 | let hval' = "test-" <> hval 23 | req = wzero $ Request $ defaultRequest{queryString = [("foo", Just $ encodeUtf8 hval')]} 24 | in runIdentity $ do 25 | res <- runServerHandler (getTrait (QueryParam :: QueryParam Required Strict "foo" Int)) [""] req 26 | pure $ case res of 27 | Right (Left e) -> 28 | e === Right (ParamParseError $ "could not parse: `" <> hval' <> "' (input does not start with a digit)") 29 | v -> counterexample ("Unexpected result: " <> show v) (property False) 30 | 31 | prop_paramParseSuccess :: Property 32 | prop_paramParseSuccess = property $ \(n :: Int) -> 33 | let req = wzero $ Request $ defaultRequest{queryString = [("foo", Just $ fromString $ show n)]} 34 | in runIdentity $ do 35 | res <- runServerHandler (getTrait (QueryParam :: QueryParam Required Strict "foo" Int)) [""] req 36 | pure $ case res of 37 | Right (Right n') -> n === n' 38 | e -> counterexample ("Unexpected result: " <> show e) (property False) 39 | 40 | -- Hack for TH splicing 41 | return [] 42 | 43 | tests :: TestTree 44 | tests = testProperties "Trait.Params" $allProperties 45 | -------------------------------------------------------------------------------- /webgear-server/test/Unit.hs: -------------------------------------------------------------------------------- 1 | module Unit ( 2 | unitTests, 3 | ) where 4 | 5 | import Test.Tasty (TestTree, testGroup) 6 | 7 | import qualified Unit.Trait.Header as Header 8 | import qualified Unit.Trait.Path as Path 9 | 10 | unitTests :: TestTree 11 | unitTests = 12 | testGroup 13 | "Unit Tests" 14 | [ Header.tests 15 | , Path.tests 16 | ] 17 | -------------------------------------------------------------------------------- /webgear-server/test/Unit/Trait/Header.hs: -------------------------------------------------------------------------------- 1 | module Unit.Trait.Header ( 2 | tests, 3 | ) where 4 | 5 | import Data.Functor.Identity (runIdentity) 6 | import Network.Wai (defaultRequest, requestHeaders) 7 | import Test.Tasty (TestTree, testGroup) 8 | import Test.Tasty.HUnit (assertFailure, testCase, (@?=)) 9 | import WebGear.Core.Request (Request (..)) 10 | import WebGear.Core.Trait (getTrait, wzero) 11 | import WebGear.Core.Trait.Header (HeaderNotFound (..), RequestHeader (..), RequiredRequestHeader) 12 | import WebGear.Server.Handler (runServerHandler) 13 | import WebGear.Server.Trait.Header () 14 | 15 | testMissingHeaderFails :: TestTree 16 | testMissingHeaderFails = testCase "Missing header fails Header trait" $ do 17 | let req = wzero $ Request $ defaultRequest{requestHeaders = []} 18 | runIdentity $ do 19 | res <- runServerHandler (getTrait (RequestHeader :: RequiredRequestHeader "foo" Int)) [""] req 20 | pure $ case res of 21 | Right (Left e) -> e @?= Left HeaderNotFound 22 | _ -> assertFailure "unexpected success" 23 | 24 | tests :: TestTree 25 | tests = testGroup "Trait.Header" [testMissingHeaderFails] 26 | -------------------------------------------------------------------------------- /webgear-server/test/Unit/Trait/Path.hs: -------------------------------------------------------------------------------- 1 | module Unit.Trait.Path ( 2 | tests, 3 | ) where 4 | 5 | import Data.Functor.Identity (runIdentity) 6 | import Network.Wai (defaultRequest, pathInfo) 7 | import Test.Tasty (TestTree, testGroup) 8 | import Test.Tasty.HUnit (assertFailure, testCase, (@?=)) 9 | import WebGear.Core.Request (Request (..)) 10 | import WebGear.Core.Trait (getTrait, wzero) 11 | import WebGear.Core.Trait.Path (PathVar (..), PathVarError (..)) 12 | import WebGear.Server.Handler (runServerHandler) 13 | import WebGear.Server.Trait.Path () 14 | 15 | testMissingPathVar :: TestTree 16 | testMissingPathVar = testCase "PathVar match: missing variable" $ do 17 | let req = wzero $ Request $ defaultRequest{pathInfo = []} 18 | runIdentity $ do 19 | res <- runServerHandler (getTrait (PathVar @"tag" @Int)) [] req 20 | pure $ case res of 21 | Right (Left e) -> e @?= PathVarNotFound 22 | _ -> assertFailure "unexpected success" 23 | 24 | tests :: TestTree 25 | tests = testGroup "Trait.Path" [testMissingPathVar] 26 | -------------------------------------------------------------------------------- /webgear-swagger-ui/CHANGELOG.md: -------------------------------------------------------------------------------- 1 | # Changelog for webgear-swagger-ui 2 | 3 | ## [Unreleased] 4 | 5 | ## [1.4.0] - 2025-05-19 6 | 7 | ### Added 8 | - Support GHC-9.12 9 | 10 | ### Removed 11 | - Support GHC-9.0, GHC-9.2 12 | 13 | ## [1.3.1] - 2024-11-24 14 | 15 | ### Added 16 | - Support GHC-9.10 17 | 18 | ## [1.3.0] - 2024-06-13 19 | 20 | ### Changed 21 | - Simplify core API (breaking change) (#47) 22 | 23 | ## [1.2.0] - 2024-03-18 24 | 25 | ### Changed 26 | - Support for embedding WAI applications in handlers (#36) 27 | 28 | ## [1.1.1] - 2024-01-01 29 | 30 | ### Changed 31 | - Updated dependency bounds and GHC versions (#35) 32 | 33 | ## [1.1.0] - 2023-12-29 34 | 35 | ### Added 36 | - First version of webgear-swagger-ui 37 | 38 | [Unreleased]: https://github.com/haskell-webgear/webgear/compare/v1.4.0...HEAD 39 | [1.4.0]: https://github.com/haskell-webgear/webgear/releases/tag/v1.4.0 40 | [1.3.1]: https://github.com/haskell-webgear/webgear/releases/tag/v1.3.1 41 | [1.3.0]: https://github.com/haskell-webgear/webgear/releases/tag/v1.3.0 42 | [1.2.0]: https://github.com/haskell-webgear/webgear/releases/tag/v1.2.0 43 | [1.1.1]: https://github.com/haskell-webgear/webgear/releases/tag/v1.1.1 44 | [1.1.0]: https://github.com/haskell-webgear/webgear/releases/tag/v1.1.0 45 | -------------------------------------------------------------------------------- /webgear-swagger-ui/README.md: -------------------------------------------------------------------------------- 1 | # WebGear - Swagger UI 2 | 3 | [![Hackage](https://img.shields.io/hackage/v/webgear-swagger-ui)](https://hackage.haskell.org/package/webgear-swagger-ui) 4 | 5 | WebGear is a Haskell library for building composable, type-safe HTTP APIs. This package helps to serve swagger UI based 6 | on WebGear API specifications. 7 | 8 | # License 9 | This package is released under [Mozilla Public License 2.0](./LICENSE). It also embeds an unmodified copy of 10 | [swagger-ui-dist](https://github.com/swagger-api/swagger-ui) released under [Apache License 11 | 2.0](https://github.com/swagger-api/swagger-ui/blob/master/LICENSE). 12 | -------------------------------------------------------------------------------- /webgear-swagger-ui/index.html: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 | 6 | Swagger UI 7 | 8 | 9 | 10 | 11 | 12 | 13 | 14 | 15 | 23 | 24 | 25 | 26 |
27 | 28 | 29 | 30 | 31 | 32 | 53 | 54 | 55 | -------------------------------------------------------------------------------- /webgear-swagger-ui/src/WebGear/Swagger/UI.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE QuasiQuotes #-} 2 | 3 | -- | Host swagger-ui based on WebGear API specifications 4 | module WebGear.Swagger.UI ( 5 | swaggerUI, 6 | ) where 7 | 8 | import Control.Arrow ((<+>)) 9 | import Data.ByteString (ByteString) 10 | import Data.Text (Text) 11 | import qualified Network.HTTP.Types as HTTP 12 | import Network.Wai.Application.Static (embeddedSettings) 13 | import WebGear.Core ( 14 | Body, 15 | HTML (..), 16 | JSON (..), 17 | RequestHandler, 18 | RequiredResponseHeader, 19 | Sets, 20 | StdHandler, 21 | UnknownContentBody, 22 | match, 23 | method, 24 | pathEnd, 25 | respondA, 26 | route, 27 | serveStatic, 28 | ) 29 | import qualified WebGear.Swagger.UI.Embedded as Embedded 30 | 31 | {- | An API that hosts a few endpoints for swagger-ui. 32 | 33 | - @/@ - redirects to @/index.html@ 34 | - @/index.html@ - UI entry point for swagger-ui 35 | - @/swagger.json@ - Swagger/OpenAPI specification in json format 36 | - @/...@ - Other UI assets required for swagger-ui 37 | -} 38 | swaggerUI :: 39 | ( StdHandler h m 40 | , Sets 41 | h 42 | [ RequiredResponseHeader "Content-Type" Text 43 | , Body HTML ByteString 44 | , Body JSON apiSpec 45 | , UnknownContentBody 46 | ] 47 | ) => 48 | -- | Swagger 2.0 or OpenAPI 3.x specification 49 | apiSpec -> 50 | RequestHandler h ts 51 | swaggerUI apiSpec = 52 | rootEndpoint 53 | <+> indexHtml 54 | <+> swaggerJson apiSpec 55 | <+> uiAssets 56 | 57 | rootEndpoint :: 58 | ( StdHandler h m 59 | , Sets h [RequiredResponseHeader "Content-Type" Text, Body HTML ByteString] 60 | ) => 61 | RequestHandler h ts 62 | rootEndpoint = method HTTP.GET $ pathEnd serveIndexHtml 63 | 64 | indexHtml :: 65 | ( StdHandler h m 66 | , Sets h [RequiredResponseHeader "Content-Type" Text, Body HTML ByteString] 67 | ) => 68 | RequestHandler h ts 69 | indexHtml = [route| HTTP.GET /index.html |] serveIndexHtml 70 | 71 | serveIndexHtml :: 72 | ( StdHandler h m 73 | , Sets h [RequiredResponseHeader "Content-Type" Text, Body HTML ByteString] 74 | ) => 75 | RequestHandler h ts 76 | serveIndexHtml = proc _request -> 77 | respondA HTTP.ok200 HTML -< Embedded.indexHtmlFile 78 | 79 | swaggerJson :: 80 | ( StdHandler h m 81 | , Sets h [RequiredResponseHeader "Content-Type" Text, Body JSON apiSpec] 82 | ) => 83 | -- | Swagger 2.0 or OpenAPI 3.x specification 84 | apiSpec -> 85 | RequestHandler h ts 86 | swaggerJson apiSpec = 87 | [route| HTTP.GET /swagger.json |] $ 88 | proc _request -> respondA HTTP.ok200 JSON -< apiSpec 89 | 90 | uiAssets :: (StdHandler h m) => RequestHandler h ts 91 | uiAssets = 92 | [match| HTTP.GET / |] $ 93 | serveStatic (embeddedSettings Embedded.uiAssetsDir) 94 | -------------------------------------------------------------------------------- /webgear-swagger-ui/src/WebGear/Swagger/UI/Embedded.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TemplateHaskell #-} 2 | 3 | -- | Embed a swagger-ui distribution in Haskell. 4 | module WebGear.Swagger.UI.Embedded ( 5 | indexHtmlFile, 6 | uiAssetsDir, 7 | ) where 8 | 9 | import Data.ByteString (ByteString) 10 | import qualified Data.FileEmbed as FileEmbed 11 | 12 | -- | Contents of index.html from a swagger-ui distribution 13 | indexHtmlFile :: ByteString 14 | indexHtmlFile = $(FileEmbed.embedFile "index.html") 15 | 16 | -- | UI assets from a swagger-ui distribution indexed by their filename 17 | uiAssetsDir :: [(FilePath, ByteString)] 18 | uiAssetsDir = $(FileEmbed.embedDir "swagger-ui-5.10.5/dist") 19 | -------------------------------------------------------------------------------- /webgear-swagger-ui/swagger-ui-5.10.5/NOTICE: -------------------------------------------------------------------------------- 1 | swagger-ui 2 | Copyright 2020-2021 SmartBear Software Inc. 3 | -------------------------------------------------------------------------------- /webgear-swagger-ui/swagger-ui-5.10.5/dist/favicon-16x16.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/haskell-webgear/webgear/ce807d4cacecfb316e0e5c42c53fdd46b6c62c70/webgear-swagger-ui/swagger-ui-5.10.5/dist/favicon-16x16.png -------------------------------------------------------------------------------- /webgear-swagger-ui/swagger-ui-5.10.5/dist/favicon-32x32.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/haskell-webgear/webgear/ce807d4cacecfb316e0e5c42c53fdd46b6c62c70/webgear-swagger-ui/swagger-ui-5.10.5/dist/favicon-32x32.png -------------------------------------------------------------------------------- /webgear-swagger-ui/swagger-ui-5.10.5/dist/index.css: -------------------------------------------------------------------------------- 1 | html { 2 | box-sizing: border-box; 3 | overflow: -moz-scrollbars-vertical; 4 | overflow-y: scroll; 5 | } 6 | 7 | *, 8 | *:before, 9 | *:after { 10 | box-sizing: inherit; 11 | } 12 | 13 | body { 14 | margin: 0; 15 | background: #fafafa; 16 | } 17 | -------------------------------------------------------------------------------- /webgear-swagger-ui/swagger-ui-5.10.5/dist/oauth2-redirect.html: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | Swagger UI: OAuth2 Redirect 5 | 6 | 7 | 78 | 79 | 80 | -------------------------------------------------------------------------------- /webgear-swagger-ui/swagger-ui-5.10.5/dist/swagger-initializer.js: -------------------------------------------------------------------------------- 1 | window.onload = function() { 2 | // 3 | 4 | // the following lines will be replaced by docker/configurator, when it runs in a docker-container 5 | window.ui = SwaggerUIBundle({ 6 | url: "https://petstore.swagger.io/v2/swagger.json", 7 | dom_id: '#swagger-ui', 8 | deepLinking: true, 9 | presets: [ 10 | SwaggerUIBundle.presets.apis, 11 | SwaggerUIStandalonePreset 12 | ], 13 | plugins: [ 14 | SwaggerUIBundle.plugins.DownloadUrl 15 | ], 16 | layout: "StandaloneLayout" 17 | }); 18 | 19 | // 20 | }; 21 | -------------------------------------------------------------------------------- /webgear-swagger-ui/webgear-swagger-ui.cabal: -------------------------------------------------------------------------------- 1 | cabal-version: 2.4 2 | 3 | name: webgear-swagger-ui 4 | version: 1.4.0 5 | synopsis: Host swagger UI based on WebGear API specifications. 6 | description: 7 | WebGear is a library to for building composable, type-safe HTTP API servers. 8 | This package can be used to serve swagger UI based on WebGear API 9 | specifications. 10 | homepage: https://github.com/haskell-webgear/webgear#readme 11 | bug-reports: https://github.com/haskell-webgear/webgear/issues 12 | author: Raghu Kaippully 13 | maintainer: rkaippully@gmail.com 14 | copyright: 2023-2025 Raghu Kaippully 15 | license: MPL-2.0 16 | license-file: LICENSE 17 | category: Web 18 | build-type: Simple 19 | extra-source-files: README.md 20 | CHANGELOG.md 21 | index.html 22 | swagger-ui-5.10.5/NOTICE 23 | swagger-ui-5.10.5/LICENSE 24 | swagger-ui-5.10.5/dist/swagger-ui-bundle.js.map 25 | swagger-ui-5.10.5/dist/swagger-ui-es-bundle-core.js 26 | swagger-ui-5.10.5/dist/swagger-ui.css 27 | swagger-ui-5.10.5/dist/index.css 28 | swagger-ui-5.10.5/dist/favicon-16x16.png 29 | swagger-ui-5.10.5/dist/swagger-ui.js 30 | swagger-ui-5.10.5/dist/swagger-ui-standalone-preset.js 31 | swagger-ui-5.10.5/dist/swagger-ui-es-bundle.js.map 32 | swagger-ui-5.10.5/dist/favicon-32x32.png 33 | swagger-ui-5.10.5/dist/swagger-ui-es-bundle.js 34 | swagger-ui-5.10.5/dist/swagger-ui.css.map 35 | swagger-ui-5.10.5/dist/swagger-initializer.js 36 | swagger-ui-5.10.5/dist/swagger-ui.js.map 37 | swagger-ui-5.10.5/dist/oauth2-redirect.html 38 | swagger-ui-5.10.5/dist/swagger-ui-es-bundle-core.js.map 39 | swagger-ui-5.10.5/dist/swagger-ui-standalone-preset.js.map 40 | swagger-ui-5.10.5/dist/swagger-ui-bundle.js 41 | 42 | source-repository head 43 | type: git 44 | location: https://github.com/haskell-webgear/webgear 45 | 46 | 47 | library 48 | exposed-modules: WebGear.Swagger.UI 49 | , WebGear.Swagger.UI.Embedded 50 | hs-source-dirs: src 51 | default-language: Haskell2010 52 | build-depends: base >=4.17.0.0 && <4.22 53 | , bytestring >=0.11.0.0 && <0.13 54 | , file-embed ==0.0.* 55 | , http-types ==0.12.* 56 | , text >=2.0 && <2.2 57 | , wai-app-static ==3.1.* 58 | , webgear-core ^>=1.4.0 59 | default-extensions: Arrows 60 | DataKinds 61 | FlexibleContexts 62 | OverloadedStrings 63 | TypeApplications 64 | ghc-options: -Wall 65 | -Wcompat 66 | -Widentities 67 | -Wincomplete-record-updates 68 | -Wincomplete-uni-patterns 69 | -Wmissing-deriving-strategies 70 | -Wmissing-fields 71 | -Wmissing-home-modules 72 | -Wno-unticked-promoted-constructors 73 | -Wpartial-fields 74 | -Wredundant-constraints 75 | -Wunused-packages 76 | -fshow-warning-groups 77 | -------------------------------------------------------------------------------- /webgear-swagger/CHANGELOG.md: -------------------------------------------------------------------------------- 1 | # Changelog for webgear-swagger 2 | 3 | ## [Unreleased] 4 | 5 | ## [1.4.0] - 2025-05-19 6 | 7 | ### Added 8 | - Support GHC-9.12 9 | 10 | ### Removed 11 | - Support GHC-9.0, GHC-9.2 12 | 13 | ## [1.3.1] - 2024-11-24 14 | 15 | ### Added 16 | - Support GHC-9.10 17 | 18 | ## [1.3.0] - 2024-06-13 19 | 20 | ### Changed 21 | - Simplify core API (breaking change) (#47) 22 | - Reimplement Swagger/OpenAPI internals (#45) 23 | 24 | ## [1.2.0] - 2024-03-18 25 | 26 | ### Added 27 | - Prerequisite traits (#37) 28 | 29 | ## [1.1.1] - 2024-01-01 30 | 31 | ### Changed 32 | - Updated dependency bounds and GHC versions (#35) 33 | 34 | ## [1.1.0] - 2023-12-29 35 | 36 | ### Added 37 | - Streaming responses support (#26) 38 | - Support for cookies (#29) 39 | - Support file uploads (#32) 40 | - First version of webgear-swagger 41 | 42 | [Unreleased]: https://github.com/haskell-webgear/webgear/compare/v1.4.0...HEAD 43 | [1.4.0]: https://github.com/haskell-webgear/webgear/releases/tag/v1.4.0 44 | [1.3.1]: https://github.com/haskell-webgear/webgear/releases/tag/v1.3.1 45 | [1.3.0]: https://github.com/haskell-webgear/webgear/releases/tag/v1.3.0 46 | [1.2.0]: https://github.com/haskell-webgear/webgear/releases/tag/v1.2.0 47 | [1.1.1]: https://github.com/haskell-webgear/webgear/releases/tag/v1.1.1 48 | [1.1.0]: https://github.com/haskell-webgear/webgear/releases/tag/v1.1.0 49 | -------------------------------------------------------------------------------- /webgear-swagger/README.md: -------------------------------------------------------------------------------- 1 | # WebGear - HTTP API server 2 | 3 | [![Hackage](https://img.shields.io/hackage/v/webgear-swagger)](https://hackage.haskell.org/package/webgear-swagger) 4 | 5 | WebGear is a Haskell library for building composable, type-safe HTTP APIs. This package helps to generate Swagger 2.0 6 | specifications from WebGear API specifications. 7 | -------------------------------------------------------------------------------- /webgear-swagger/src/WebGear/Swagger.hs: -------------------------------------------------------------------------------- 1 | {- | Main module for WebGear Swagger support. 2 | 3 | Import this module to get all required types and functions for 4 | generating Swagget specifications. Alternatively, import individual 5 | modules under @WebGear.Swagger@. 6 | 7 | Typical usage to generate Swagger specifications: 8 | 9 | @ 10 | import WebGear.Swagger 11 | import Data.Swagger (Swagger) 12 | 13 | myHandler :: Handler h m => RequestHandler h '[] 14 | myHandler = .... 15 | 16 | documentation :: Swagger 17 | documentation = toSwagger myHandler 18 | @ 19 | -} 20 | module WebGear.Swagger ( 21 | module WebGear.Core, 22 | module WebGear.Swagger.Handler, 23 | ) where 24 | 25 | import WebGear.Core 26 | import WebGear.Swagger.Handler 27 | import WebGear.Swagger.Traits () 28 | -------------------------------------------------------------------------------- /webgear-swagger/src/WebGear/Swagger/Trait/Auth.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -Wno-orphans #-} 2 | 3 | -- | Functions and instances for authentication 4 | module WebGear.Swagger.Trait.Auth (addSecurityScheme) where 5 | 6 | import Control.Lens ((&), (.~), (<>~)) 7 | import Control.Monad.State.Strict (MonadState) 8 | import Data.Proxy (Proxy (..)) 9 | import Data.Swagger ( 10 | Definitions, 11 | NamedSchema, 12 | Schema, 13 | SecurityDefinitions (..), 14 | SecurityRequirement (..), 15 | SecurityScheme, 16 | Swagger, 17 | ToSchema (..), 18 | allOperations, 19 | description, 20 | security, 21 | securityDefinitions, 22 | ) 23 | import Data.Swagger.Declare (Declare) 24 | import Data.Text (Text) 25 | import WebGear.Core.Handler (Description (..)) 26 | import WebGear.Core.Trait.Auth.Common (AuthToken) 27 | import WebGear.Swagger.Handler (Documentation (..), consumeDescription) 28 | 29 | instance ToSchema (AuthToken scheme) where 30 | declareNamedSchema :: Proxy (AuthToken scheme) -> Declare (Definitions Schema) NamedSchema 31 | declareNamedSchema _ = declareNamedSchema $ Proxy @String 32 | 33 | addSecurityScheme :: (MonadState Documentation m) => Text -> SecurityScheme -> Swagger -> m Swagger 34 | addSecurityScheme schemeName scheme doc = do 35 | desc <- consumeDescription 36 | let scheme' = scheme & description .~ fmap getDescription desc 37 | secDefs = SecurityDefinitions [(schemeName, scheme')] 38 | secReqs = [SecurityRequirement [(schemeName, [])]] :: [SecurityRequirement] 39 | pure $ 40 | doc 41 | & securityDefinitions <>~ secDefs 42 | & allOperations . security <>~ secReqs 43 | -------------------------------------------------------------------------------- /webgear-swagger/src/WebGear/Swagger/Trait/Auth/Basic.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -Wno-orphans #-} 2 | 3 | -- | Swagger implementation of `BasicAuth'` trait. 4 | module WebGear.Swagger.Trait.Auth.Basic where 5 | 6 | import Data.Proxy (Proxy (..)) 7 | import Data.String (fromString) 8 | import Data.Swagger 9 | import GHC.TypeLits (KnownSymbol, symbolVal) 10 | import WebGear.Core.Request (Request) 11 | import WebGear.Core.Trait (Absence, Attribute, Get (..), With) 12 | import WebGear.Core.Trait.Auth.Basic (BasicAuth' (..)) 13 | import WebGear.Swagger.Handler (SwaggerHandler (..)) 14 | import WebGear.Swagger.Trait.Auth (addSecurityScheme) 15 | 16 | instance (KnownSymbol scheme) => Get (SwaggerHandler m) (BasicAuth' x scheme m e a) where 17 | {-# INLINE getTrait #-} 18 | getTrait :: 19 | BasicAuth' x scheme m e a -> 20 | SwaggerHandler m (Request `With` ts) (Either (Absence (BasicAuth' x scheme m e a)) (Attribute (BasicAuth' x scheme m e a) Request)) 21 | getTrait _ = 22 | let schemeName = "http" <> fromString (symbolVal (Proxy @scheme)) 23 | scheme = 24 | SecurityScheme 25 | { _securitySchemeType = SecuritySchemeBasic 26 | , _securitySchemeDescription = Nothing 27 | } 28 | in SwaggerHandler $ addSecurityScheme schemeName scheme 29 | -------------------------------------------------------------------------------- /webgear-swagger/src/WebGear/Swagger/Trait/Auth/JWT.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -Wno-orphans #-} 2 | 3 | -- | Swagger implementation of 'JWTAuth'' trait. 4 | module WebGear.Swagger.Trait.Auth.JWT where 5 | 6 | import Data.String (fromString) 7 | import Data.Swagger 8 | import Data.Typeable (Proxy (..)) 9 | import GHC.TypeLits (KnownSymbol, symbolVal) 10 | import WebGear.Core.Request (Request) 11 | import WebGear.Core.Trait (Absence, Attribute, Get (..), With) 12 | import WebGear.Core.Trait.Auth.JWT (JWTAuth' (..)) 13 | import WebGear.Swagger.Handler (SwaggerHandler (..)) 14 | import WebGear.Swagger.Trait.Auth (addSecurityScheme) 15 | 16 | instance (KnownSymbol scheme) => Get (SwaggerHandler m) (JWTAuth' x scheme m e a) where 17 | {-# INLINE getTrait #-} 18 | getTrait :: 19 | JWTAuth' x scheme m e a -> 20 | SwaggerHandler m (Request `With` ts) (Either (Absence (JWTAuth' x scheme m e a)) (Attribute (JWTAuth' x scheme m e a) Request)) 21 | getTrait _ = 22 | let schemeName = fromString (symbolVal (Proxy @scheme)) 23 | -- Swagger 2.0 does not support JWT: https://stackoverflow.com/a/32995636 24 | scheme = 25 | SecurityScheme 26 | { _securitySchemeType = 27 | SecuritySchemeApiKey 28 | ( ApiKeyParams 29 | { _apiKeyName = "JWT" 30 | , _apiKeyIn = ApiKeyHeader 31 | } 32 | ) 33 | , _securitySchemeDescription = Just ("Enter the token with the `" <> schemeName <> ": ` prefix") 34 | } 35 | in SwaggerHandler $ addSecurityScheme schemeName scheme 36 | -------------------------------------------------------------------------------- /webgear-swagger/src/WebGear/Swagger/Trait/Body.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -Wno-orphans #-} 2 | 3 | -- | Swagger implementation of 'Body' trait. 4 | module WebGear.Swagger.Trait.Body where 5 | 6 | import Control.Lens ((%~), (&), (.~), (?~), (^.)) 7 | import Control.Monad.State.Strict (MonadState) 8 | import qualified Data.HashMap.Strict.InsOrd as Map 9 | import Data.Proxy (Proxy (..)) 10 | import Data.Swagger ( 11 | Definitions, 12 | MimeList (..), 13 | Param, 14 | ParamAnySchema (..), 15 | Referenced (..), 16 | Response, 17 | Schema, 18 | Swagger, 19 | ToSchema, 20 | allOperations, 21 | consumes, 22 | declareSchemaRef, 23 | definitions, 24 | description, 25 | name, 26 | parameters, 27 | paths, 28 | produces, 29 | required, 30 | responses, 31 | schema, 32 | ) 33 | import Data.Swagger.Declare (runDeclare) 34 | import Data.Swagger.Internal.Utils (swaggerMappend) 35 | import Data.Text (Text) 36 | import WebGear.Core.Handler (Description (..)) 37 | import WebGear.Core.MIMETypes (MIMEType (..)) 38 | import WebGear.Core.Request (Request) 39 | import qualified WebGear.Core.Response as WG 40 | import WebGear.Core.Trait (Get (..), Set (..), With) 41 | import WebGear.Core.Trait.Body (Body (..), UnknownContentBody (..)) 42 | import WebGear.Swagger.Handler ( 43 | Documentation (..), 44 | SwaggerHandler (..), 45 | addRootPath, 46 | consumeDescription, 47 | ) 48 | 49 | instance (ToSchema val, MIMEType mt) => Get (SwaggerHandler m) (Body mt val) where 50 | {-# INLINE getTrait #-} 51 | getTrait :: Body mt val -> SwaggerHandler m (Request `With` ts) (Either Text val) 52 | getTrait (Body mt) = 53 | SwaggerHandler $ \doc -> do 54 | desc <- consumeDescription 55 | let mimeList = MimeList [mimeType mt] 56 | (defs, ref) = runDeclare (declareSchemaRef $ Proxy @val) mempty 57 | body = 58 | (mempty @Param) 59 | & schema .~ ParamBody ref 60 | & required ?~ True 61 | & name .~ "body" 62 | & description .~ fmap getDescription desc 63 | pure $ 64 | doc 65 | & allOperations 66 | %~ ( \op -> 67 | op 68 | & parameters %~ (Inline body :) 69 | & consumes %~ Just . maybe mimeList (<> mimeList) 70 | ) 71 | & definitions %~ (<> defs) 72 | 73 | instance (ToSchema val, MIMEType mt) => Set (SwaggerHandler m) (Body mt val) where 74 | {-# INLINE setTrait #-} 75 | setTrait :: 76 | Body mt val -> 77 | (WG.Response `With` ts -> WG.Response -> val -> WG.Response `With` (Body mt val : ts)) -> 78 | SwaggerHandler m (WG.Response `With` ts, val) (WG.Response `With` (Body mt val : ts)) 79 | setTrait (Body mt) _ = 80 | let mimeList = MimeList [mimeType mt] 81 | (defs, ref) = runDeclare (declareSchemaRef $ Proxy @val) mempty 82 | in SwaggerHandler $ addResponseBody defs mimeList (Just ref) 83 | 84 | instance Set (SwaggerHandler m) UnknownContentBody where 85 | {-# INLINE setTrait #-} 86 | setTrait :: 87 | UnknownContentBody -> 88 | (WG.Response `With` ts -> WG.Response -> WG.ResponseBody -> WG.Response `With` (UnknownContentBody : ts)) -> 89 | SwaggerHandler m (WG.Response `With` ts, WG.ResponseBody) (WG.Response `With` (UnknownContentBody : ts)) 90 | setTrait UnknownContentBody _ = SwaggerHandler $ addResponseBody mempty mempty Nothing 91 | 92 | addResponseBody :: 93 | (MonadState Documentation m) => 94 | Definitions Schema -> 95 | MimeList -> 96 | Maybe (Referenced Schema) -> 97 | Swagger -> 98 | m Swagger 99 | addResponseBody defs mimeList respSchema doc = do 100 | desc <- consumeDescription 101 | 102 | let addDescription :: Referenced Response -> Referenced Response 103 | addDescription (Ref r) = Ref r 104 | addDescription (Inline r) = 105 | case desc of 106 | Nothing -> Inline r 107 | Just (Description d) -> Inline (r & description .~ d) 108 | 109 | let resp = mempty @Response & schema .~ respSchema 110 | doc' = if Map.null (doc ^. paths) then addRootPath doc else doc 111 | 112 | pure $ 113 | doc' 114 | & allOperations 115 | %~ ( \op -> 116 | op 117 | & responses . responses %~ Map.map (addDescription . (`swaggerMappend` Inline resp)) 118 | & produces %~ Just . maybe mimeList (`swaggerMappend` mimeList) 119 | ) 120 | & definitions %~ (<> defs) 121 | -------------------------------------------------------------------------------- /webgear-swagger/src/WebGear/Swagger/Trait/Cookie.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -Wno-orphans #-} 2 | 3 | -- | Swagger implementation of 'WG.Cookie' and 'WG.SetCookie' traits. 4 | module WebGear.Swagger.Trait.Cookie () where 5 | 6 | import WebGear.Core.Trait (Get (..), Set (..)) 7 | import qualified WebGear.Core.Trait.Cookie as WG 8 | import WebGear.Swagger.Handler (SwaggerHandler (..)) 9 | 10 | -- Cookie information is not captured by Swagger 11 | 12 | instance Get (SwaggerHandler m) (WG.Cookie e name val) where 13 | {-# INLINE getTrait #-} 14 | getTrait WG.Cookie = SwaggerHandler pure 15 | 16 | instance Set (SwaggerHandler m) (WG.SetCookie e name) where 17 | {-# INLINE setTrait #-} 18 | setTrait WG.SetCookie _ = SwaggerHandler pure 19 | -------------------------------------------------------------------------------- /webgear-swagger/src/WebGear/Swagger/Trait/Header.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -Wno-orphans #-} 2 | 3 | -- | Swagger implementation of 'Header' trait. 4 | module WebGear.Swagger.Trait.Header () where 5 | 6 | import Control.Lens ((%~), (&), (.~), (<>~), (?~)) 7 | import Control.Monad.State.Strict (MonadState) 8 | import qualified Data.HashMap.Strict.InsOrd as Map 9 | import Data.Proxy (Proxy (Proxy)) 10 | import Data.String (fromString) 11 | import Data.Swagger ( 12 | Header, 13 | HeaderName, 14 | Param, 15 | ParamAnySchema (..), 16 | ParamLocation (..), 17 | ParamOtherSchema (..), 18 | Referenced (..), 19 | Response, 20 | Swagger, 21 | ToParamSchema (..), 22 | allOperations, 23 | description, 24 | headers, 25 | name, 26 | parameters, 27 | required, 28 | responses, 29 | schema, 30 | ) 31 | import Data.Swagger.Internal.Utils (swaggerMappend) 32 | import Data.Text (Text) 33 | import GHC.TypeLits (KnownSymbol, symbolVal) 34 | import WebGear.Core.Handler (Description (..)) 35 | import WebGear.Core.Modifiers (Existence (..)) 36 | import WebGear.Core.Trait (Get (..), Set (..)) 37 | import qualified WebGear.Core.Trait.Header as WG 38 | import WebGear.Swagger.Handler (Documentation, SwaggerHandler (..), consumeDescription) 39 | 40 | instance 41 | ( KnownSymbol name 42 | , ToParamSchema val 43 | ) => 44 | Get (SwaggerHandler m) (WG.RequestHeader Required ps name val) 45 | where 46 | {-# INLINE getTrait #-} 47 | getTrait WG.RequestHeader = SwaggerHandler $ addRequestHeader (Proxy @name) (Proxy @val) True 48 | 49 | instance 50 | ( KnownSymbol name 51 | , ToParamSchema val 52 | ) => 53 | Get (SwaggerHandler m) (WG.RequestHeader Optional ps name val) 54 | where 55 | {-# INLINE getTrait #-} 56 | getTrait WG.RequestHeader = SwaggerHandler $ addRequestHeader (Proxy @name) (Proxy @val) False 57 | 58 | instance (KnownSymbol name) => Set (SwaggerHandler m) (WG.ResponseHeader Required name val) where 59 | {-# INLINE setTrait #-} 60 | setTrait WG.ResponseHeader _ = SwaggerHandler $ addResponseHeader (Proxy @name) (Proxy @val) 61 | 62 | instance (KnownSymbol name) => Set (SwaggerHandler m) (WG.ResponseHeader Optional name val) where 63 | {-# INLINE setTrait #-} 64 | setTrait WG.ResponseHeader _ = SwaggerHandler $ addResponseHeader (Proxy @name) (Proxy @val) 65 | 66 | addRequestHeader :: 67 | forall name val m. 68 | (KnownSymbol name, ToParamSchema val, MonadState Documentation m) => 69 | Proxy name -> 70 | Proxy val -> 71 | Bool -> 72 | Swagger -> 73 | m Swagger 74 | addRequestHeader _ _ isRequired doc = do 75 | desc <- consumeDescription 76 | let param = 77 | (mempty :: Param) 78 | & name .~ fromString @Text (symbolVal $ Proxy @name) 79 | & required ?~ isRequired 80 | & schema 81 | .~ ParamOther 82 | ( ParamOtherSchema 83 | { _paramOtherSchemaIn = ParamHeader 84 | , _paramOtherSchemaAllowEmptyValue = Just (not isRequired) 85 | , _paramOtherSchemaParamSchema = toParamSchema (Proxy @val) 86 | } 87 | ) 88 | & description .~ fmap getDescription desc 89 | pure $ doc & allOperations . parameters <>~ [Inline param] 90 | 91 | addResponseHeader :: 92 | forall name val m. 93 | (KnownSymbol name, MonadState Documentation m) => 94 | Proxy name -> 95 | Proxy val -> 96 | Swagger -> 97 | m Swagger 98 | addResponseHeader _ _ doc = do 99 | desc <- consumeDescription 100 | let headerName = fromString @HeaderName $ symbolVal $ Proxy @name 101 | header = mempty @Header & description .~ fmap getDescription desc 102 | resp = mempty @Response & headers <>~ [(headerName, header)] 103 | pure $ 104 | if headerName == "Content-Type" 105 | then doc 106 | else doc & allOperations . responses . responses %~ Map.map (`swaggerMappend` Inline resp) 107 | -------------------------------------------------------------------------------- /webgear-swagger/src/WebGear/Swagger/Trait/Method.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -Wno-orphans #-} 2 | 3 | -- | Swagger implementation of 'Method' trait. 4 | module WebGear.Swagger.Trait.Method where 5 | 6 | import Control.Lens ((%~), (&)) 7 | import qualified Data.HashMap.Strict.InsOrd as Map 8 | import Data.Swagger (PathItem (..), paths) 9 | import Network.HTTP.Types (StdMethod (..)) 10 | import WebGear.Core.Trait (Get (..)) 11 | import WebGear.Core.Trait.Method (Method (..)) 12 | import WebGear.Swagger.Handler (SwaggerHandler (..), addRouteDocumentation) 13 | 14 | instance Get (SwaggerHandler m) Method where 15 | {-# INLINE getTrait #-} 16 | getTrait (Method method) = SwaggerHandler $ \doc -> do 17 | addRouteDocumentation $ doc & paths %~ Map.map (removeOtherMethods method) 18 | 19 | removeOtherMethods :: StdMethod -> PathItem -> PathItem 20 | removeOtherMethods method PathItem{..} = 21 | case method of 22 | GET -> mempty{_pathItemGet, _pathItemParameters} 23 | PUT -> mempty{_pathItemPut, _pathItemParameters} 24 | POST -> mempty{_pathItemPost, _pathItemParameters} 25 | DELETE -> mempty{_pathItemDelete, _pathItemParameters} 26 | HEAD -> mempty{_pathItemHead, _pathItemParameters} 27 | OPTIONS -> mempty{_pathItemOptions, _pathItemParameters} 28 | PATCH -> mempty{_pathItemPatch, _pathItemParameters} 29 | -- Swagger does not support CONNECT and TRACE 30 | CONNECT -> mempty{_pathItemParameters} 31 | TRACE -> mempty{_pathItemParameters} 32 | -------------------------------------------------------------------------------- /webgear-swagger/src/WebGear/Swagger/Trait/Path.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -Wno-orphans #-} 2 | 3 | -- | Swagger implementation of path traits. 4 | module WebGear.Swagger.Trait.Path where 5 | 6 | import Control.Lens ((&), (<>~)) 7 | import Data.Data (Proxy (Proxy)) 8 | import Data.String (fromString) 9 | import Data.Swagger ( 10 | Param (..), 11 | ParamAnySchema (..), 12 | ParamLocation (ParamPath), 13 | ParamOtherSchema (..), 14 | Referenced (Inline), 15 | allOperations, 16 | parameters, 17 | prependPath, 18 | ) 19 | import Data.Text (unpack) 20 | import GHC.TypeLits (KnownSymbol, symbolVal) 21 | import WebGear.Core.Request (Request) 22 | import WebGear.Core.Trait (Get (..), With) 23 | import WebGear.Core.Trait.Path (Path (..), PathEnd (..), PathVar (..), PathVarError (..)) 24 | import WebGear.Swagger.Handler (SwaggerHandler (..), addRouteDocumentation) 25 | 26 | instance Get (SwaggerHandler m) Path where 27 | {-# INLINE getTrait #-} 28 | getTrait :: Path -> SwaggerHandler m (Request `With` ts) (Either () ()) 29 | getTrait (Path p) = SwaggerHandler $ addRouteDocumentation . prependPath (unpack p) 30 | 31 | instance (KnownSymbol tag) => Get (SwaggerHandler m) (PathVar tag val) where 32 | {-# INLINE getTrait #-} 33 | getTrait :: PathVar tag val -> SwaggerHandler m (Request `With` ts) (Either PathVarError val) 34 | getTrait PathVar = 35 | let paramName = symbolVal $ Proxy @tag 36 | param = 37 | (mempty :: Param) 38 | { _paramName = fromString paramName 39 | , _paramRequired = Just True 40 | , _paramSchema = 41 | ParamOther 42 | ParamOtherSchema 43 | { _paramOtherSchemaIn = ParamPath 44 | , _paramOtherSchemaParamSchema = mempty 45 | , _paramOtherSchemaAllowEmptyValue = Nothing 46 | } 47 | } 48 | in SwaggerHandler $ \doc -> 49 | addRouteDocumentation $ 50 | prependPath ("{" <> paramName <> "}") doc 51 | & allOperations . parameters <>~ [Inline param] 52 | 53 | instance Get (SwaggerHandler m) PathEnd where 54 | {-# INLINE getTrait #-} 55 | getTrait :: PathEnd -> SwaggerHandler m (Request `With` ts) (Either () ()) 56 | getTrait PathEnd = SwaggerHandler $ addRouteDocumentation . prependPath "/" 57 | -------------------------------------------------------------------------------- /webgear-swagger/src/WebGear/Swagger/Trait/QueryParam.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -Wno-orphans #-} 2 | 3 | -- | Swagger implementation of 'QueryParam' trait. 4 | module WebGear.Swagger.Trait.QueryParam where 5 | 6 | import Control.Lens ((&), (.~), (<>~)) 7 | import Control.Monad.State.Strict (MonadState) 8 | import Data.Proxy (Proxy (Proxy)) 9 | import Data.String (fromString) 10 | import Data.Swagger ( 11 | Param (..), 12 | ParamAnySchema (..), 13 | ParamLocation (ParamQuery), 14 | ParamOtherSchema (..), 15 | Referenced (Inline), 16 | Swagger, 17 | allOperations, 18 | description, 19 | parameters, 20 | ) 21 | import GHC.TypeLits (KnownSymbol, symbolVal) 22 | import WebGear.Core.Handler (Description (..)) 23 | import WebGear.Core.Modifiers (Existence (..)) 24 | import WebGear.Core.Trait (Get (..)) 25 | import WebGear.Core.Trait.QueryParam (QueryParam (..)) 26 | import WebGear.Swagger.Handler (Documentation (..), SwaggerHandler (..), consumeDescription) 27 | 28 | instance (KnownSymbol name) => Get (SwaggerHandler m) (QueryParam Required ps name val) where 29 | {-# INLINE getTrait #-} 30 | getTrait _ = 31 | let param = 32 | (mempty :: Param) 33 | { _paramName = fromString $ symbolVal $ Proxy @name 34 | , _paramRequired = Just True 35 | , _paramSchema = 36 | ParamOther 37 | ParamOtherSchema 38 | { _paramOtherSchemaIn = ParamQuery 39 | , _paramOtherSchemaAllowEmptyValue = Just True 40 | , _paramOtherSchemaParamSchema = mempty 41 | } 42 | } 43 | in SwaggerHandler $ addParam param 44 | 45 | instance (KnownSymbol name) => Get (SwaggerHandler m) (QueryParam Optional ps name val) where 46 | {-# INLINE getTrait #-} 47 | getTrait _ = 48 | let param = 49 | (mempty :: Param) 50 | { _paramName = fromString $ symbolVal $ Proxy @name 51 | , _paramRequired = Just False 52 | , _paramSchema = 53 | ParamOther 54 | ParamOtherSchema 55 | { _paramOtherSchemaIn = ParamQuery 56 | , _paramOtherSchemaAllowEmptyValue = Just True 57 | , _paramOtherSchemaParamSchema = mempty 58 | } 59 | } 60 | in SwaggerHandler $ addParam param 61 | 62 | addParam :: (MonadState Documentation m) => Param -> Swagger -> m Swagger 63 | addParam param doc = do 64 | desc <- consumeDescription 65 | let param' = param & description .~ fmap getDescription desc 66 | pure $ doc & allOperations . parameters <>~ [Inline param'] 67 | -------------------------------------------------------------------------------- /webgear-swagger/src/WebGear/Swagger/Trait/Status.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -Wno-orphans #-} 2 | 3 | -- | Swagger implementation of 'Status' trait. 4 | module WebGear.Swagger.Trait.Status where 5 | 6 | import Control.Applicative ((<|>)) 7 | import Control.Lens (at, mapped, (%~), (&), (.~), (?~), (^.)) 8 | import qualified Data.HashMap.Strict.InsOrd as Map 9 | import Data.Maybe (fromMaybe) 10 | import Data.Swagger ( 11 | Operation, 12 | PathItem, 13 | Referenced (..), 14 | Response, 15 | delete, 16 | description, 17 | get, 18 | head_, 19 | options, 20 | patch, 21 | paths, 22 | post, 23 | put, 24 | responses, 25 | ) 26 | import qualified Network.HTTP.Types as HTTP 27 | import WebGear.Core.Handler (Description (..)) 28 | import qualified WebGear.Core.Response as WG 29 | import WebGear.Core.Trait (Set, With, setTrait) 30 | import WebGear.Core.Trait.Status (Status (..)) 31 | import WebGear.Swagger.Handler (SwaggerHandler (..), addRootPath, consumeDescription) 32 | 33 | instance Set (SwaggerHandler m) Status where 34 | {-# INLINE setTrait #-} 35 | setTrait :: 36 | Status -> 37 | (WG.Response `With` ts -> WG.Response -> HTTP.Status -> WG.Response `With` (Status : ts)) -> 38 | SwaggerHandler m (WG.Response `With` ts, HTTP.Status) (WG.Response `With` (Status : ts)) 39 | setTrait status _ = SwaggerHandler $ \doc -> do 40 | desc <- consumeDescription 41 | let doc' = if Map.null (doc ^. paths) then addRootPath doc else doc 42 | pure $ doc' & paths . mapped %~ setOperation desc status 43 | 44 | setOperation :: Maybe Description -> Status -> PathItem -> PathItem 45 | setOperation desc (Status status) item = 46 | item 47 | & delete %~ updateOperation 48 | & get %~ updateOperation 49 | & head_ %~ updateOperation 50 | & options %~ updateOperation 51 | & patch %~ updateOperation 52 | & post %~ updateOperation 53 | & put %~ updateOperation 54 | where 55 | httpCode = HTTP.statusCode status 56 | 57 | updateOperation :: Maybe Operation -> Maybe Operation 58 | updateOperation Nothing = Just $ mempty @Operation & at httpCode ?~ addDescription emptyResp 59 | updateOperation (Just op) = 60 | let resp = addDescription $ fromMaybe emptyResp $ (op ^. at httpCode) <|> (op ^. at 0) 61 | in Just $ op & responses . responses %~ Map.insert httpCode resp . Map.delete 0 62 | 63 | emptyResp :: Referenced Response 64 | emptyResp = Inline mempty 65 | 66 | addDescription :: Referenced Response -> Referenced Response 67 | addDescription (Ref r) = Ref r 68 | addDescription (Inline r) = 69 | case desc of 70 | Nothing -> Inline r 71 | Just (Description d) -> Inline (r & description .~ d) 72 | -------------------------------------------------------------------------------- /webgear-swagger/src/WebGear/Swagger/Traits.hs: -------------------------------------------------------------------------------- 1 | {- | Swagger implementation of all traits supported by WebGear. 2 | 3 | This modules only exports orphan instances imported from other 4 | modules. Hence the haddock documentation will be empty. 5 | -} 6 | module WebGear.Swagger.Traits () where 7 | 8 | import WebGear.Swagger.Trait.Auth () 9 | import WebGear.Swagger.Trait.Auth.Basic () 10 | import WebGear.Swagger.Trait.Auth.JWT () 11 | import WebGear.Swagger.Trait.Body () 12 | import WebGear.Swagger.Trait.Cookie () 13 | import WebGear.Swagger.Trait.Header () 14 | import WebGear.Swagger.Trait.Method () 15 | import WebGear.Swagger.Trait.Path () 16 | import WebGear.Swagger.Trait.QueryParam () 17 | import WebGear.Swagger.Trait.Status () 18 | -------------------------------------------------------------------------------- /webgear-swagger/webgear-swagger.cabal: -------------------------------------------------------------------------------- 1 | cabal-version: 2.4 2 | 3 | name: webgear-swagger 4 | version: 1.4.0 5 | synopsis: Composable, type-safe library to build HTTP API servers 6 | description: 7 | WebGear is a library to for building composable, type-safe HTTP API servers. 8 | This package can be used to generate Swagger 2.0 specifications from WebGear 9 | applications. 10 | homepage: https://github.com/haskell-webgear/webgear#readme 11 | bug-reports: https://github.com/haskell-webgear/webgear/issues 12 | author: Raghu Kaippully 13 | maintainer: rkaippully@gmail.com 14 | copyright: 2023-2025 Raghu Kaippully 15 | license: MPL-2.0 16 | license-file: LICENSE 17 | category: Web 18 | build-type: Simple 19 | extra-source-files: README.md 20 | CHANGELOG.md 21 | 22 | 23 | source-repository head 24 | type: git 25 | location: https://github.com/haskell-webgear/webgear 26 | 27 | 28 | library 29 | exposed-modules: WebGear.Swagger 30 | , WebGear.Swagger.Handler 31 | , WebGear.Swagger.Traits 32 | , WebGear.Swagger.Trait.Auth 33 | , WebGear.Swagger.Trait.Auth.Basic 34 | , WebGear.Swagger.Trait.Auth.JWT 35 | , WebGear.Swagger.Trait.Body 36 | , WebGear.Swagger.Trait.Cookie 37 | , WebGear.Swagger.Trait.Header 38 | , WebGear.Swagger.Trait.Method 39 | , WebGear.Swagger.Trait.Path 40 | , WebGear.Swagger.Trait.QueryParam 41 | , WebGear.Swagger.Trait.Status 42 | hs-source-dirs: src 43 | default-language: Haskell2010 44 | default-extensions: Arrows 45 | ConstraintKinds 46 | DataKinds 47 | DeriveFunctor 48 | DeriveGeneric 49 | DerivingStrategies 50 | DerivingVia 51 | FlexibleContexts 52 | FlexibleInstances 53 | FunctionalDependencies 54 | GeneralizedNewtypeDeriving 55 | InstanceSigs 56 | KindSignatures 57 | LambdaCase 58 | MultiParamTypeClasses 59 | NamedFieldPuns 60 | OverloadedLists 61 | OverloadedStrings 62 | PolyKinds 63 | RankNTypes 64 | RecordWildCards 65 | ScopedTypeVariables 66 | StandaloneDeriving 67 | TemplateHaskellQuotes 68 | TypeApplications 69 | TypeFamilies 70 | TypeOperators 71 | build-depends: arrows ==0.4.* 72 | , base >=4.17.0.0 && <4.22 73 | , http-types ==0.12.* 74 | , insert-ordered-containers ==0.2.* 75 | , lens >=5.2 && <5.4 76 | , mtl >=2.2 && <2.4 77 | , swagger2 >=2.8 && <2.9 78 | , text >=2.0 && <2.2 79 | , webgear-core ^>=1.4.0 80 | ghc-options: -Wall 81 | -Wcompat 82 | -Widentities 83 | -Wincomplete-record-updates 84 | -Wincomplete-uni-patterns 85 | -Wmissing-deriving-strategies 86 | -Wmissing-fields 87 | -Wmissing-home-modules 88 | -Wno-unticked-promoted-constructors 89 | -Wpartial-fields 90 | -Wredundant-constraints 91 | -Wunused-packages 92 | -fshow-warning-groups 93 | --------------------------------------------------------------------------------