├── test ├── Main.hs ├── golden │ ├── object-without-type.yaml │ ├── bug-1.yaml │ ├── datetime.yaml │ ├── csv.yaml │ ├── numbers.yaml │ ├── bug-2.yaml │ ├── description.yaml │ ├── additional-properties.yaml │ ├── headers.yaml │ ├── haskell-ext.yaml │ ├── enum-bug.yaml │ ├── oneof.yaml │ ├── enum.yaml │ ├── petstore.yaml │ ├── lists.yaml │ ├── test1.yaml │ ├── bug-1.yaml.out │ ├── object-without-type.yaml.out │ └── description.yaml.out └── Test │ └── Tie │ ├── Operation.hs │ └── Golden.hs ├── .gitignore ├── CHANGELOG.md ├── cabal.project ├── example ├── generated │ ├── Petstore │ │ └── API │ │ │ ├── Response.hs │ │ │ ├── Schemas │ │ │ ├── Pets.hs │ │ │ ├── Error.hs │ │ │ └── Pet.hs │ │ │ ├── Response │ │ │ ├── CreatePets.hs │ │ │ ├── ShowPetById.hs │ │ │ └── ListPets.hs │ │ │ ├── Api.hs │ │ │ └── Request.hs │ └── petstore-api.cabal ├── cabal.project ├── petstore-example.cabal ├── README.md ├── petstore.yaml └── app │ └── Main.hs ├── shell.nix ├── src ├── Tie │ ├── Codegen │ │ ├── Request.hs │ │ ├── Cabal.hs │ │ ├── Imports.hs │ │ ├── Response.hs │ │ └── Operation.hs │ ├── Writer.hs │ ├── Resolve.hs │ └── Name.hs └── Tie.hs ├── .github └── workflows │ ├── lint.yml │ ├── release.yml │ └── ci.yml ├── Response.template.hs ├── default.nix ├── scarf-api.yaml ├── README.md ├── bin └── Main.hs ├── tie.cabal ├── assets └── tie.svg ├── Request.template.hs └── LICENSE /test/Main.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -F -pgmF tasty-discover -optF --tree-display #-} 2 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | dist-newstyle/ 2 | .DS_Store 3 | out/ 4 | cabal.project.local* 5 | *.tar.gz 6 | -------------------------------------------------------------------------------- /CHANGELOG.md: -------------------------------------------------------------------------------- 1 | # Revision history for openapi3-server-gen 2 | 3 | ## 0.1.0.0 -- YYYY-mm-dd 4 | 5 | * First version. Released on an unsuspecting world. 6 | -------------------------------------------------------------------------------- /cabal.project: -------------------------------------------------------------------------------- 1 | packages: . 2 | 3 | source-repository-package 4 | type: git 5 | location: https://github.com/alexbiehl/openapi3.git 6 | tag: c2575dfbbf487c8019201ad1abe2d9b49fdc5685 7 | 8 | index-state: 2024-05-28T00:00:00Z 9 | -------------------------------------------------------------------------------- /example/generated/Petstore/API/Response.hs: -------------------------------------------------------------------------------- 1 | module Petstore.API.Response 2 | ( ToResponse (..), 3 | ) 4 | where 5 | 6 | import qualified Network.Wai 7 | 8 | class ToResponse a where 9 | toResponse :: a -> Network.Wai.Response 10 | -------------------------------------------------------------------------------- /example/cabal.project: -------------------------------------------------------------------------------- 1 | packages: 2 | -- Include the generated code in the project 3 | ./generated 4 | -- The example package itself 5 | ./ 6 | 7 | -- We pin the index-state for reproducible builds 8 | index-state: 2022-06-12T10:29:35Z -------------------------------------------------------------------------------- /shell.nix: -------------------------------------------------------------------------------- 1 | { pkgs ? import {}}: 2 | let 3 | project = pkgs.haskellPackages.callPackage ./default.nix {}; 4 | in 5 | pkgs.mkShell { 6 | name = project.pname; 7 | version = project.version; 8 | buildInputs = with pkgs; project.env.nativeBuildInputs ++ [ 9 | ghc 10 | cabal-install 11 | ghcid 12 | ormolu 13 | ]; 14 | } 15 | -------------------------------------------------------------------------------- /test/golden/object-without-type.yaml: -------------------------------------------------------------------------------- 1 | openapi: "3.0.0" 2 | info: 3 | version: 1.0.0 4 | title: Scarf 5 | license: 6 | name: AllRightsReserved 7 | servers: 8 | - url: https://scarf.sh/api/v1 9 | paths: 10 | /test: 11 | get: 12 | summary: test 13 | operationId: test 14 | responses: 15 | '200': 16 | description: CSV response without schema 17 | content: 18 | application/json: 19 | schema: 20 | description: Undocumented 21 | components: {} -------------------------------------------------------------------------------- /test/golden/bug-1.yaml: -------------------------------------------------------------------------------- 1 | openapi: "3.0.0" 2 | info: 3 | version: 1.0.0 4 | title: Scarf 5 | license: 6 | name: AllRightsReserved 7 | servers: 8 | - url: https://scarf.sh/api/v1 9 | paths: 10 | /test: 11 | get: 12 | summary: test 13 | operationId: test 14 | responses: 15 | '200': 16 | description: CSV response without schema 17 | content: 18 | application/json: 19 | schema: 20 | description: Undocumented 21 | type: array 22 | components: {} -------------------------------------------------------------------------------- /example/generated/petstore-api.cabal: -------------------------------------------------------------------------------- 1 | cabal-version: 3.0 2 | name: petstore-api 3 | version: 0.1.0.0 4 | library 5 | build-depends: 6 | , aeson 7 | , attoparsec 8 | , base 9 | , bytestring 10 | , ghc-prim 11 | , http-api-data 12 | , http-types 13 | , text 14 | , time 15 | , wai 16 | exposed-modules: 17 | Petstore.API.Api 18 | Petstore.API.Request 19 | Petstore.API.Response 20 | Petstore.API.Response.CreatePets 21 | Petstore.API.Response.ListPets 22 | Petstore.API.Response.ShowPetById 23 | Petstore.API.Schemas.Error 24 | Petstore.API.Schemas.Pet 25 | Petstore.API.Schemas.Pets -------------------------------------------------------------------------------- /test/Test/Tie/Operation.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | module Test.Tie.Operation where 4 | 5 | import Test.Hspec (Spec, context, it, shouldBe) 6 | import Test.Tasty.Hspec 7 | import Tie.Operation (PathSegment (..), parsePath) 8 | 9 | spec_parsePath :: Spec 10 | spec_parsePath = do 11 | it "parses /users/create" $ 12 | parsePath "/users/create" `shouldBe` [StaticSegment "users", StaticSegment "create"] 13 | it "parses /users/{id}" $ 14 | parsePath "/users/{id}" `shouldBe` [StaticSegment "users", VariableSegment "id"] 15 | it "parses /users/{id}/address" $ 16 | parsePath "/users/{id}/address" `shouldBe` [StaticSegment "users", VariableSegment "id", StaticSegment "address"] 17 | -------------------------------------------------------------------------------- /test/golden/datetime.yaml: -------------------------------------------------------------------------------- 1 | openapi: "3.0.0" 2 | info: 3 | version: 1.0.0 4 | title: Scarf 5 | license: 6 | name: AllRightsReserved 7 | servers: 8 | - url: https://scarf.sh/api/v1 9 | paths: 10 | /test: 11 | get: 12 | summary: test 13 | operationId: test 14 | responses: 15 | '200': 16 | description: Successful response 17 | content: 18 | application/json: 19 | schema: 20 | $ref: "#/components/schemas/Test" 21 | components: 22 | schemas: 23 | Test: 24 | properties: 25 | dateProp: 26 | type: string 27 | format: date 28 | dateTimeProp: 29 | type: string 30 | format: date-time 31 | -------------------------------------------------------------------------------- /test/golden/csv.yaml: -------------------------------------------------------------------------------- 1 | openapi: "3.0.0" 2 | info: 3 | version: 1.0.0 4 | title: Scarf 5 | license: 6 | name: AllRightsReserved 7 | servers: 8 | - url: https://scarf.sh/api/v1 9 | paths: 10 | /test: 11 | get: 12 | summary: test 13 | operationId: test 14 | responses: 15 | '200': 16 | description: CSV response without schema 17 | content: 18 | text/csv: {} 19 | /test2: 20 | get: 21 | summary: test 22 | operationId: test2 23 | responses: 24 | '200': 25 | description: JSON response without schema 26 | content: 27 | application/json: {} 28 | components: 29 | schemas: 30 | Test: 31 | properties: 32 | name: 33 | type: string -------------------------------------------------------------------------------- /src/Tie/Codegen/Request.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | {-# LANGUAGE ScopedTypeVariables #-} 3 | {-# LANGUAGE TemplateHaskell #-} 4 | 5 | module Tie.Codegen.Request (codegenRequestAuxFile) where 6 | 7 | import qualified Data.ByteString as ByteString 8 | import Data.FileEmbed (embedStringFile, makeRelativeToProject) 9 | import qualified Data.Text as Text 10 | import Prettyprinter (Doc, hsep, vsep) 11 | import qualified Prettyprinter.Util as Prettyprinter 12 | import System.IO.Unsafe (unsafePerformIO) 13 | import Tie.Name (Name) 14 | 15 | templateContents :: ByteString 16 | templateContents = $(embedStringFile =<< makeRelativeToProject "Request.template.hs") 17 | 18 | auxTemplate :: Text 19 | auxTemplate = decodeUtf8 templateContents 20 | {-# NOINLINE auxTemplate #-} 21 | 22 | codegenRequestAuxFile :: 23 | -- | Module name 24 | Text -> 25 | Text 26 | codegenRequestAuxFile moduleName = 27 | Text.replace "Tie.Template.Request_" moduleName auxTemplate 28 | -------------------------------------------------------------------------------- /test/golden/numbers.yaml: -------------------------------------------------------------------------------- 1 | openapi: "3.0.0" 2 | info: 3 | version: 1.0.0 4 | title: Scarf 5 | license: 6 | name: AllRightsReserved 7 | servers: 8 | - url: https://scarf.sh/api/v1 9 | paths: 10 | /test: 11 | get: 12 | summary: test 13 | operationId: test 14 | responses: 15 | '200': 16 | description: Successful response 17 | content: 18 | application/json: 19 | schema: 20 | $ref: "#/components/schemas/Test" 21 | components: 22 | schemas: 23 | Test: 24 | properties: 25 | a: 26 | type: integer 27 | format: int32 28 | b: 29 | type: integer 30 | format: int64 31 | c: 32 | type: number 33 | format: double 34 | d: 35 | type: number 36 | format: float 37 | e: 38 | type: number 39 | f: 40 | type: integer 41 | -------------------------------------------------------------------------------- /example/petstore-example.cabal: -------------------------------------------------------------------------------- 1 | cabal-version: 2.4 2 | name: petstore-example 3 | version: 0.1.0.0 4 | 5 | -- A short (one-line) description of the package. 6 | -- synopsis: 7 | 8 | -- A longer description of the package. 9 | -- description: 10 | 11 | -- A URL where users can report bugs. 12 | -- bug-reports: 13 | 14 | -- The license under which the package is released. 15 | -- license: 16 | author: Alex Biehl 17 | maintainer: alex@scarf.sh 18 | 19 | -- A copyright notice. 20 | -- copyright: 21 | -- category: 22 | 23 | executable petstore-example 24 | main-is: Main.hs 25 | 26 | -- Modules included in this executable, other than Main. 27 | -- other-modules: 28 | 29 | -- LANGUAGE extensions used by modules in this package. 30 | -- other-extensions: 31 | build-depends: 32 | , base 33 | , mtl 34 | , petstore-api 35 | , text 36 | , wai 37 | , wai-extra 38 | , warp 39 | 40 | hs-source-dirs: app 41 | default-language: Haskell2010 42 | -------------------------------------------------------------------------------- /.github/workflows/lint.yml: -------------------------------------------------------------------------------- 1 | name: Lint 2 | 3 | # Trigger the workflow on push or pull request, but only for the master branch 4 | on: 5 | pull_request: 6 | push: 7 | branches: [master] 8 | 9 | jobs: 10 | lint: 11 | runs-on: ubuntu-latest 12 | steps: 13 | - uses: actions/checkout@v2 14 | if: github.event.action == 'opened' || github.event.action == 'synchronize' || github.event.ref == 'refs/heads/master' 15 | 16 | - name: Check code is formatted using Ormolu 17 | run: | 18 | curl -L https://github.com/tweag/ormolu/releases/download/0.7.2.0/ormolu-Linux.zip -o ormolu.zip 19 | unzip ormolu.zip 20 | 21 | git ls-files | grep -v 'example/' | grep \.hs | xargs ./ormolu --mode=inplace 22 | 23 | if [[ $(git diff --stat) != '' ]]; then 24 | echo "Lint stage failed, running ormolu has returned changes" 25 | echo "$(git diff)" 26 | exit 1 27 | else 28 | echo "Lint stage succeeded" 29 | exit 0 30 | fi -------------------------------------------------------------------------------- /Response.template.hs: -------------------------------------------------------------------------------- 1 | module Tie.Template.Response_ 2 | ( ToResponse (..), 3 | 4 | -- * NDJSON support 5 | NDJSON, 6 | responseNDJSON, 7 | ) 8 | where 9 | 10 | import qualified Data.Aeson 11 | import qualified Data.Aeson.Encoding 12 | import qualified Data.ByteString.Builder 13 | import qualified Network.HTTP.Types 14 | import qualified Network.Wai 15 | 16 | type NDJSON element = ((element -> IO ()) -> IO () -> IO ()) 17 | 18 | responseNDJSON :: (Data.Aeson.ToJSON element) => Network.HTTP.Types.Status -> Network.HTTP.Types.ResponseHeaders -> NDJSON element -> Network.Wai.Response 19 | responseNDJSON status responseHeaders stream = 20 | Network.Wai.responseStream status responseHeaders $ \emit flush -> 21 | stream 22 | ( \element -> 23 | emit 24 | ( Data.Aeson.Encoding.fromEncoding (Data.Aeson.toEncoding element) 25 | <> Data.ByteString.Builder.char7 '\n' 26 | ) 27 | ) 28 | flush 29 | 30 | class ToResponse a where 31 | toResponse :: a -> Network.Wai.Response 32 | -------------------------------------------------------------------------------- /example/generated/Petstore/API/Schemas/Pets.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE BangPatterns #-} 2 | {-# LANGUAGE DuplicateRecordFields #-} 3 | {-# LANGUAGE OverloadedStrings #-} 4 | {-# LANGUAGE ScopedTypeVariables #-} 5 | {-# LANGUAGE RankNTypes #-} 6 | {-# LANGUAGE RecordWildCards #-} 7 | module Petstore.API.Schemas.Pets where 8 | 9 | import qualified Control.Applicative 10 | import qualified Control.Exception 11 | import qualified Control.Monad 12 | import qualified Control.Monad.IO.Class 13 | import qualified Data.Aeson 14 | import qualified Data.Aeson.Encoding 15 | import qualified Data.Aeson.Parser 16 | import qualified Data.Aeson.Types 17 | import qualified Data.Attoparsec.ByteString 18 | import qualified Data.List 19 | import qualified Data.Maybe 20 | import qualified Data.Text 21 | import qualified Data.Time 22 | import qualified Data.Text.Encoding 23 | import qualified GHC.Float 24 | import qualified GHC.Int 25 | import qualified GHC.Types 26 | import qualified Network.HTTP.Types 27 | import qualified Network.Wai 28 | import qualified Web.HttpApiData 29 | 30 | 31 | 32 | import Petstore.API.Schemas.Pet 33 | 34 | type Pets = [ Pet ] -------------------------------------------------------------------------------- /test/golden/bug-2.yaml: -------------------------------------------------------------------------------- 1 | openapi: "3.0.0" 2 | info: 3 | version: 1.0.0 4 | title: Scarf 5 | license: 6 | name: AllRightsReserved 7 | servers: 8 | - url: https://scarf.sh/api/v1 9 | paths: 10 | /test: 11 | get: 12 | summary: test 13 | operationId: test 14 | responses: 15 | '200': 16 | description: Successful response 17 | content: 18 | application/json: 19 | schema: 20 | $ref: "#/components/schemas/Testee" 21 | components: 22 | schemas: 23 | Testee: 24 | discriminator: 25 | propertyName: type 26 | mapping: 27 | scarf: "#/components/schemas/Test" 28 | oneOf: 29 | - $ref: "#/components/schemas/Test" 30 | 31 | Enum: 32 | type: string 33 | enum: 34 | - a 35 | - b 36 | 37 | Base: 38 | properties: 39 | enum: 40 | $ref: "#/components/schemas/Enum" 41 | 42 | Test: 43 | allOf: 44 | - $ref: "#/components/schemas/Base" 45 | - properties: 46 | name: 47 | type: string 48 | -------------------------------------------------------------------------------- /.github/workflows/release.yml: -------------------------------------------------------------------------------- 1 | name: Release 2 | 3 | on: 4 | push: 5 | tags: 6 | - '*' 7 | 8 | jobs: 9 | build: 10 | runs-on: ${{ matrix.os }} 11 | strategy: 12 | matrix: 13 | os: 14 | - ubuntu-latest 15 | - macos-latest 16 | cabal: 17 | - "3.6.2.0" 18 | ghc: 19 | - "9.2.3" 20 | 21 | steps: 22 | - name: Checkout 23 | uses: actions/checkout@v2 24 | 25 | - name: Setup Haskell 26 | uses: haskell/actions/setup@v1.2 27 | id: setup-haskell-cabal 28 | with: 29 | ghc-version: ${{ matrix.ghc }} 30 | cabal-version: ${{ matrix.cabal }} 31 | 32 | - name: Build 33 | run: cabal install exe:tie --install-method=copy --overwrite-policy=always --installdir=out 34 | 35 | - name: Test 36 | run: ./out/tie --help 37 | 38 | - name: Prepare archive 39 | run: tar -zcvf ./${{ matrix.os }}.tar.gz -C out tie 40 | 41 | - name: Release 42 | uses: softprops/action-gh-release@v1 43 | if: startsWith(github.ref, 'refs/tags/') 44 | with: 45 | files: ./${{ matrix.os }}.tar.gz 46 | -------------------------------------------------------------------------------- /test/Test/Tie/Golden.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | module Test.Tie.Golden (test_Golden_tests) where 4 | 5 | import Data.ByteString.Builder (toLazyByteString) 6 | import Paths_tie (getDataDir) 7 | import System.FilePath (normalise, replaceExtension, ()) 8 | import Test.Tasty (TestTree) 9 | import Test.Tasty.Golden (findByExtension, goldenVsStringDiff) 10 | import Tie (generate, withTestWriter) 11 | 12 | test_Golden_tests :: IO [TestTree] 13 | test_Golden_tests = do 14 | dataDir <- getDataDir 15 | inputs <- findByExtension [".yaml"] (dataDir "test" "golden") 16 | pure 17 | [ goldenVsStringDiff 18 | ("Test " <> input) 19 | (\ref new -> ["diff", "-u", ref, new]) 20 | (replaceExtension input ".yaml.out") 21 | ( do 22 | (_, output) <- withTestWriter $ \writer -> 23 | generate 24 | writer 25 | "test" -- package name 26 | "Test" -- module name 27 | [] -- No extra packages 28 | input 29 | pure (toLazyByteString output) 30 | ) 31 | | input' <- inputs, 32 | let input = normalise input' 33 | ] 34 | -------------------------------------------------------------------------------- /default.nix: -------------------------------------------------------------------------------- 1 | { mkDerivation, aeson, base, bytestring, containers, directory 2 | , filepath, hspec, http-media, insert-ordered-containers, lens, lib 3 | , mtl, openapi3, optparse-applicative, prettyprinter, relude, tasty 4 | , tasty-discover, tasty-golden, tasty-hspec, tasty-hunit, text 5 | , unordered-containers, yaml 6 | }: 7 | mkDerivation { 8 | pname = "tie"; 9 | version = "0.1.0.0"; 10 | src = ./.; 11 | isLibrary = true; 12 | isExecutable = true; 13 | enableSeparateDataOutput = true; 14 | libraryHaskellDepends = [ 15 | aeson base bytestring containers directory filepath http-media 16 | insert-ordered-containers lens mtl openapi3 prettyprinter relude 17 | text unordered-containers yaml 18 | ]; 19 | executableHaskellDepends = [ base optparse-applicative relude ]; 20 | testHaskellDepends = [ 21 | aeson base bytestring containers filepath hspec 22 | insert-ordered-containers openapi3 prettyprinter relude tasty 23 | tasty-golden tasty-hspec tasty-hunit text yaml 24 | ]; 25 | testToolDepends = [ tasty-discover ]; 26 | description = "Tie allows generation of Haskell server stubs from OpenAPI (v 3.x) specifications."; 27 | license = lib.licenses.asl20; 28 | } 29 | -------------------------------------------------------------------------------- /scarf-api.yaml: -------------------------------------------------------------------------------- 1 | openapi: "3.0.0" 2 | info: 3 | version: 1.0.0 4 | title: Scarf 5 | license: 6 | name: AllRightsReserved 7 | servers: 8 | - url: https://scarf.sh/api/v1 9 | paths: 10 | /packages: 11 | get: 12 | summary: List all packages 13 | operationId: listPackages 14 | tags: 15 | - packages 16 | responses: 17 | '200': 18 | description: An array of packages 19 | content: 20 | application/json: 21 | schema: 22 | $ref: "#/components/schemas/Packages" 23 | /packages2: 24 | get: 25 | summary: List all packages 26 | operationId: listPackages2 27 | tags: 28 | - packages 29 | responses: 30 | '200': 31 | description: An array of Inlines 32 | content: 33 | application/json: 34 | schema: 35 | $ref: "#/components/schemas/Inline" 36 | 37 | components: 38 | schemas: 39 | Package: 40 | properties: 41 | name: 42 | type: string 43 | Packages: 44 | oneOf: 45 | - $ref: "#/components/schemas/Package" 46 | Inline: 47 | properties: 48 | value: 49 | oneOf: 50 | - type: integer 51 | - type: string 52 | - $ref: "#/components/schemas/Package" -------------------------------------------------------------------------------- /test/golden/description.yaml: -------------------------------------------------------------------------------- 1 | openapi: "3.0.0" 2 | info: 3 | version: 1.0.0 4 | title: Scarf 5 | license: 6 | name: AllRightsReserved 7 | servers: 8 | - url: https://scarf.sh/api/v1 9 | paths: 10 | /test: 11 | parameters: 12 | - name: package_query 13 | in: query 14 | required: false 15 | description: > 16 | Use this query parameter to filter for the packages thats suits your use case. 17 | It can be used by passing in either package names or package ids. 18 | To query for multiple packages you can pass in comma separated values. 19 | For example: 20 | 21 | ``` 22 | 23 | package_query=17ea97c0-d350-45ce-9f36-ebb66694196c,558664cd-fece-47f5-a9ca-f30974cf96a5,... 24 | 25 | ``` 26 | 27 | Or if you prefer using package names, you can also pass in 28 | 29 | ``` 30 | 31 | package_query=package_name_1,package_name_2... 32 | 33 | ``` 34 | schema: 35 | type: string 36 | get: 37 | summary: test 38 | operationId: test 39 | responses: 40 | '200': 41 | description: CSV response without schema 42 | content: 43 | application/json: 44 | schema: 45 | description: Undocumented 46 | type: array 47 | components: {} 48 | -------------------------------------------------------------------------------- /test/golden/additional-properties.yaml: -------------------------------------------------------------------------------- 1 | openapi: "3.0.0" 2 | info: 3 | version: 1.0.0 4 | title: Swagger Petstore 5 | license: 6 | name: MIT 7 | servers: 8 | - url: http://petstore.swagger.io/v1 9 | paths: 10 | /pets: 11 | get: 12 | summary: List all pets 13 | operationId: listPets 14 | responses: 15 | '200': 16 | description: A paged array of pets 17 | content: 18 | application/json: 19 | schema: 20 | $ref: "#/components/schemas/Pets" 21 | /pets2: 22 | get: 23 | summary: List all pets 24 | operationId: listPets2 25 | responses: 26 | '200': 27 | description: A paged array of pets 28 | content: 29 | application/json: 30 | schema: 31 | type: object 32 | additionalProperties: 33 | type: object 34 | required: 35 | - name 36 | - count 37 | properties: 38 | name: 39 | type: string 40 | count: 41 | type: integer 42 | components: 43 | schemas: 44 | Pet: 45 | type: object 46 | required: 47 | - id 48 | - name 49 | properties: 50 | id: 51 | type: integer 52 | format: int64 53 | name: 54 | type: string 55 | tag: 56 | type: string 57 | Pets: 58 | type: object 59 | additionalProperties: 60 | $ref: '#/components/schemas/Pet' 61 | -------------------------------------------------------------------------------- /example/generated/Petstore/API/Response/CreatePets.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE BangPatterns #-} 2 | {-# LANGUAGE DuplicateRecordFields #-} 3 | {-# LANGUAGE OverloadedStrings #-} 4 | {-# LANGUAGE ScopedTypeVariables #-} 5 | {-# LANGUAGE RankNTypes #-} 6 | {-# LANGUAGE RecordWildCards #-} 7 | module Petstore.API.Response.CreatePets where 8 | 9 | import qualified Control.Applicative 10 | import qualified Control.Exception 11 | import qualified Control.Monad 12 | import qualified Control.Monad.IO.Class 13 | import qualified Data.Aeson 14 | import qualified Data.Aeson.Encoding 15 | import qualified Data.Aeson.Parser 16 | import qualified Data.Aeson.Types 17 | import qualified Data.Attoparsec.ByteString 18 | import qualified Data.List 19 | import qualified Data.Maybe 20 | import qualified Data.Text 21 | import qualified Data.Time 22 | import qualified Data.Text.Encoding 23 | import qualified GHC.Float 24 | import qualified GHC.Int 25 | import qualified GHC.Types 26 | import qualified Network.HTTP.Types 27 | import qualified Network.Wai 28 | import qualified Web.HttpApiData 29 | 30 | import Petstore.API.Schemas.Error 31 | 32 | import Petstore.API.Response 33 | 34 | data CreatePetsResponse 35 | = CreatePetsResponse201 36 | | CreatePetsDefaultResponse Network.HTTP.Types.Status Error 37 | deriving (Show) 38 | 39 | instance ToResponse CreatePetsResponse where 40 | toResponse (CreatePetsResponse201) = 41 | Network.Wai.responseBuilder (toEnum 201) ([]) mempty 42 | toResponse (CreatePetsDefaultResponse status x) = 43 | Network.Wai.responseBuilder status ([(Network.HTTP.Types.hContentType, "application/json")]) (Data.Aeson.fromEncoding (Data.Aeson.toEncoding x)) -------------------------------------------------------------------------------- /.github/workflows/ci.yml: -------------------------------------------------------------------------------- 1 | name: CI 2 | 3 | on: 4 | workflow_dispatch: 5 | pull_request: 6 | types: [synchronize, opened, reopened] 7 | push: 8 | branches: [main] 9 | schedule: 10 | # additionally run once per week (At 00:00 on Sunday) to maintain cache 11 | - cron: '0 0 * * 0' 12 | 13 | jobs: 14 | cabal: 15 | name: ${{ matrix.os }} / ghc ${{ matrix.ghc }} 16 | runs-on: ${{ matrix.os }} 17 | strategy: 18 | matrix: 19 | os: [ubuntu-latest] 20 | cabal: ["3.6.2.0"] 21 | ghc: 22 | - "9.0.2" 23 | - "9.2.3" 24 | 25 | steps: 26 | - uses: actions/checkout@v2 27 | 28 | - uses: haskell/actions/setup@v1.2 29 | id: setup-haskell-cabal 30 | name: Setup Haskell 31 | with: 32 | ghc-version: ${{ matrix.ghc }} 33 | cabal-version: ${{ matrix.cabal }} 34 | 35 | - name: Configure 36 | run: | 37 | cabal configure -O0 --enable-tests --enable-benchmarks --enable-documentation --test-show-details=direct --write-ghc-environment-files=always 38 | 39 | - name: Freeze 40 | run: | 41 | cabal freeze 42 | 43 | - uses: actions/cache@v2 44 | name: Cache ~/.cabal/store 45 | with: 46 | path: ${{ steps.setup-haskell-cabal.outputs.cabal-store }} 47 | key: ${{ runner.os }}-${{ matrix.ghc }}-${{ hashFiles('cabal.project.freeze') }}-1 48 | 49 | - name: Install dependencies 50 | run: | 51 | cabal build all --only-dependencies 52 | 53 | - name: Build 54 | run: | 55 | cabal build all 56 | 57 | - name: Test 58 | run: | 59 | cabal test all 60 | 61 | - name: Documentation 62 | run: | 63 | cabal haddock 64 | -------------------------------------------------------------------------------- /src/Tie/Codegen/Cabal.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | module Tie.Codegen.Cabal (codegenCabalFile) where 4 | 5 | import qualified Data.Set as Set 6 | import Prettyprinter (Doc, (<+>)) 7 | import qualified Prettyprinter as PP 8 | 9 | codegenCabalFile :: Text -> [Text] -> [Text] -> Doc ann 10 | codegenCabalFile packageName exposedModules extraPackages = 11 | let packages = 12 | Set.toList . Set.fromList $ 13 | [ "aeson", 14 | "attoparsec", 15 | "base", 16 | "bytestring", 17 | "containers", 18 | "ghc-prim", 19 | "http-api-data", 20 | "http-media", 21 | "http-types", 22 | "text", 23 | "time", 24 | "unordered-containers", 25 | "wai" 26 | ] 27 | ++ extraPackages 28 | in PP.vsep 29 | [ "cabal-version:" <+> "3.0", 30 | "name:" <+> PP.pretty packageName, 31 | "version:" <+> "0.1.0.0", 32 | "library" 33 | <> PP.line 34 | <> PP.indent 35 | 2 36 | ( PP.vsep 37 | [ "build-depends:" 38 | <> PP.line 39 | <> PP.indent 40 | 2 41 | ( PP.vsep (map (\x -> "," <+> PP.pretty x) packages) 42 | ), 43 | "exposed-modules:" 44 | <> PP.line 45 | <> PP.indent 46 | 2 47 | ( PP.vsep 48 | (map PP.pretty exposedModules) 49 | ) 50 | ] 51 | ) 52 | ] 53 | -------------------------------------------------------------------------------- /test/golden/headers.yaml: -------------------------------------------------------------------------------- 1 | openapi: "3.0.0" 2 | info: 3 | version: 1.0.0 4 | title: Scarf 5 | license: 6 | name: AllRightsReserved 7 | servers: 8 | - url: https://scarf.sh/api/v1 9 | paths: 10 | /test: 11 | get: 12 | summary: test 13 | operationId: test 14 | parameters: 15 | - name: x-next 16 | in: header 17 | description: How many items to return at one time (max 100) 18 | required: false 19 | schema: 20 | type: integer 21 | format: int32 22 | responses: 23 | '200': 24 | description: Successful response 25 | content: 26 | application/json: 27 | schema: 28 | $ref: "#/components/schemas/Test" 29 | /test1: 30 | get: 31 | summary: test 32 | operationId: test1 33 | responses: 34 | '201': 35 | description: Successfully created package 36 | headers: 37 | Location: 38 | description: The package details URL 39 | schema: 40 | type: string 41 | /test2: 42 | get: 43 | summary: test 44 | operationId: test2 45 | responses: 46 | '201': 47 | description: Successfully created package 48 | headers: 49 | Location: 50 | required: true 51 | description: The package details URL 52 | schema: 53 | type: string 54 | components: 55 | schemas: 56 | Test: 57 | properties: 58 | dateProp: 59 | type: string 60 | format: date 61 | dateTimeProp: 62 | type: string 63 | format: date-time 64 | -------------------------------------------------------------------------------- /test/golden/haskell-ext.yaml: -------------------------------------------------------------------------------- 1 | openapi: "3.0.0" 2 | info: 3 | version: 1.0.0 4 | title: Scarf 5 | license: 6 | name: AllRightsReserved 7 | servers: 8 | - url: https://scarf.sh/api/v1 9 | paths: 10 | /test/{xx}: 11 | parameters: 12 | - name: xx 13 | required: true 14 | in: path 15 | schema: 16 | type: string 17 | x-tie-haskell-type: Scarf.Hashids.Hashid GHC.Types.Int32 18 | get: 19 | summary: test 20 | operationId: test 21 | responses: 22 | '200': 23 | description: Successful response 24 | content: 25 | application/json: 26 | schema: 27 | $ref: "#/components/schemas/Test" 28 | post: 29 | operationId: test2 30 | summary: test2 31 | requestBody: 32 | x-tie-haskell-request-body-as-stream: true 33 | description: Some nice request body 34 | content: 35 | application/json: 36 | schema: # Request body contents 37 | properties: 38 | nise: 39 | type: string 40 | responses: 41 | '201': 42 | description: Successful response 43 | 44 | components: 45 | schemas: 46 | Test: 47 | properties: 48 | test1: 49 | type: string 50 | x-tie-haskell-type: Scarf.Hashids.Hashid Int32 51 | test2: 52 | type: string 53 | x-tie-haskell-name: abcdef 54 | '$test3': 55 | type: array 56 | x-tie-haskell-name: test3 57 | items: 58 | type: object 59 | properties: 60 | name: 61 | type: string 62 | value: 63 | type: string 64 | -------------------------------------------------------------------------------- /example/generated/Petstore/API/Response/ShowPetById.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE BangPatterns #-} 2 | {-# LANGUAGE DuplicateRecordFields #-} 3 | {-# LANGUAGE OverloadedStrings #-} 4 | {-# LANGUAGE ScopedTypeVariables #-} 5 | {-# LANGUAGE RankNTypes #-} 6 | {-# LANGUAGE RecordWildCards #-} 7 | module Petstore.API.Response.ShowPetById where 8 | 9 | import qualified Control.Applicative 10 | import qualified Control.Exception 11 | import qualified Control.Monad 12 | import qualified Control.Monad.IO.Class 13 | import qualified Data.Aeson 14 | import qualified Data.Aeson.Encoding 15 | import qualified Data.Aeson.Parser 16 | import qualified Data.Aeson.Types 17 | import qualified Data.Attoparsec.ByteString 18 | import qualified Data.List 19 | import qualified Data.Maybe 20 | import qualified Data.Text 21 | import qualified Data.Time 22 | import qualified Data.Text.Encoding 23 | import qualified GHC.Float 24 | import qualified GHC.Int 25 | import qualified GHC.Types 26 | import qualified Network.HTTP.Types 27 | import qualified Network.Wai 28 | import qualified Web.HttpApiData 29 | 30 | import Petstore.API.Schemas.Error 31 | import Petstore.API.Schemas.Pet 32 | 33 | import Petstore.API.Response 34 | 35 | data ShowPetByIdResponse 36 | = ShowPetByIdResponse200 Pet 37 | | ShowPetByIdDefaultResponse Network.HTTP.Types.Status Error 38 | deriving (Show) 39 | 40 | instance ToResponse ShowPetByIdResponse where 41 | toResponse (ShowPetByIdResponse200 x) = 42 | Network.Wai.responseBuilder (toEnum 200) ([(Network.HTTP.Types.hContentType, "application/json")]) (Data.Aeson.fromEncoding (Data.Aeson.toEncoding x)) 43 | toResponse (ShowPetByIdDefaultResponse status x) = 44 | Network.Wai.responseBuilder status ([(Network.HTTP.Types.hContentType, "application/json")]) (Data.Aeson.fromEncoding (Data.Aeson.toEncoding x)) -------------------------------------------------------------------------------- /example/README.md: -------------------------------------------------------------------------------- 1 | 2 | Hi! This is a full top-to-bottom example for using Tie. 3 | 4 | # Run the example with Cabal 5 | 6 | Run the following command from the `example/` directory of the Tie repository: 7 | 8 | ```bash 9 | $ cabal run 10 | ``` 11 | 12 | This will build and launch a webserver on port 8080. 13 | 14 | # Re-generate the api code 15 | 16 | Run the following command from the `example/` directory of the Tie repository: 17 | 18 | ```bash 19 | $ tie --output generated --module-name Petstore.API --package-name petstore-api petstore.yaml 20 | ``` 21 | 22 | This will generate a Cabal package into the `generated` directory. 23 | 24 | # Structure of the generated code 25 | 26 | The generated code will placed in [`generated`](generated). The modules are placed under the `Petstore.API` (`PetStore/API`) Haskell module namespace. 27 | 28 | - [`generated/Petstore/API/Api.hs`](generated/Petstore/API/Api.hs) contains the API definition 29 | for the Petstore. This file is derived from the operations defined in the OpenAPI specification. 30 | In particular, the operation names are derived from the `operationId` property of the Operations 31 | as defined in the specification. 32 | 33 | - [`generated/Petstore/API/Schemas`](generated/Petstore/API/Schemas) is where the schema 34 | definitions are being placed by Tie. You can find the definition for `Pet` and `Pets` as well as 35 | `Error` in here. 36 | 37 | - [`generated/Petstore/API/Response`](generated/Petstore/API/Response) is where Tie places the 38 | response types for the individual operations. You will find a Haskell module for each operation 39 | in the OpenAPI specification here. 40 | 41 | - [`app/Main.hs`](app/Main.hs) is the entry point of the example Petstore application. It provides 42 | an implementation for the generated `Api` type and spins up a Warp webserver. 43 | -------------------------------------------------------------------------------- /example/generated/Petstore/API/Schemas/Error.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE BangPatterns #-} 2 | {-# LANGUAGE DuplicateRecordFields #-} 3 | {-# LANGUAGE OverloadedStrings #-} 4 | {-# LANGUAGE ScopedTypeVariables #-} 5 | {-# LANGUAGE RankNTypes #-} 6 | {-# LANGUAGE RecordWildCards #-} 7 | module Petstore.API.Schemas.Error where 8 | 9 | import qualified Control.Applicative 10 | import qualified Control.Exception 11 | import qualified Control.Monad 12 | import qualified Control.Monad.IO.Class 13 | import qualified Data.Aeson 14 | import qualified Data.Aeson.Encoding 15 | import qualified Data.Aeson.Parser 16 | import qualified Data.Aeson.Types 17 | import qualified Data.Attoparsec.ByteString 18 | import qualified Data.List 19 | import qualified Data.Maybe 20 | import qualified Data.Text 21 | import qualified Data.Time 22 | import qualified Data.Text.Encoding 23 | import qualified GHC.Float 24 | import qualified GHC.Int 25 | import qualified GHC.Types 26 | import qualified Network.HTTP.Types 27 | import qualified Network.Wai 28 | import qualified Web.HttpApiData 29 | 30 | 31 | 32 | 33 | 34 | data Error = Error 35 | { 36 | code :: GHC.Int.Int32, 37 | message :: Data.Text.Text 38 | } 39 | deriving (Show) 40 | 41 | instance Data.Aeson.ToJSON Error where 42 | toJSON Error {..} = Data.Aeson.object 43 | [ 44 | "code" Data.Aeson..= code, 45 | "message" Data.Aeson..= message 46 | ] 47 | 48 | toEncoding Error {..} = Data.Aeson.Encoding.pairs 49 | ( Data.Aeson.Encoding.pair "code" (Data.Aeson.toEncoding code) <> 50 | Data.Aeson.Encoding.pair "message" (Data.Aeson.toEncoding message) 51 | ) 52 | 53 | instance Data.Aeson.FromJSON Error where 54 | parseJSON = Data.Aeson.withObject "Error" $ \o -> 55 | Error 56 | <$> o Data.Aeson..: "code" 57 | <*> o Data.Aeson..: "message" -------------------------------------------------------------------------------- /example/generated/Petstore/API/Response/ListPets.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE BangPatterns #-} 2 | {-# LANGUAGE DuplicateRecordFields #-} 3 | {-# LANGUAGE OverloadedStrings #-} 4 | {-# LANGUAGE ScopedTypeVariables #-} 5 | {-# LANGUAGE RankNTypes #-} 6 | {-# LANGUAGE RecordWildCards #-} 7 | module Petstore.API.Response.ListPets where 8 | 9 | import qualified Control.Applicative 10 | import qualified Control.Exception 11 | import qualified Control.Monad 12 | import qualified Control.Monad.IO.Class 13 | import qualified Data.Aeson 14 | import qualified Data.Aeson.Encoding 15 | import qualified Data.Aeson.Parser 16 | import qualified Data.Aeson.Types 17 | import qualified Data.Attoparsec.ByteString 18 | import qualified Data.List 19 | import qualified Data.Maybe 20 | import qualified Data.Text 21 | import qualified Data.Time 22 | import qualified Data.Text.Encoding 23 | import qualified GHC.Float 24 | import qualified GHC.Int 25 | import qualified GHC.Types 26 | import qualified Network.HTTP.Types 27 | import qualified Network.Wai 28 | import qualified Web.HttpApiData 29 | 30 | import Petstore.API.Schemas.Error 31 | import Petstore.API.Schemas.Pets 32 | 33 | import Petstore.API.Response 34 | 35 | data ListPetsResponse 36 | = ListPetsResponse200 Pets (Data.Maybe.Maybe (Data.Text.Text)) 37 | | ListPetsDefaultResponse Network.HTTP.Types.Status Error 38 | deriving (Show) 39 | 40 | instance ToResponse ListPetsResponse where 41 | toResponse (ListPetsResponse200 x __x_next) = 42 | Network.Wai.responseBuilder (toEnum 200) ([("x-next", Web.HttpApiData.toHeader __x_next) | Just __x_next <- [__x_next]] ++ [(Network.HTTP.Types.hContentType, "application/json")]) (Data.Aeson.fromEncoding (Data.Aeson.toEncoding x)) 43 | toResponse (ListPetsDefaultResponse status x) = 44 | Network.Wai.responseBuilder status ([(Network.HTTP.Types.hContentType, "application/json")]) (Data.Aeson.fromEncoding (Data.Aeson.toEncoding x)) -------------------------------------------------------------------------------- /example/generated/Petstore/API/Schemas/Pet.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE BangPatterns #-} 2 | {-# LANGUAGE DuplicateRecordFields #-} 3 | {-# LANGUAGE OverloadedStrings #-} 4 | {-# LANGUAGE ScopedTypeVariables #-} 5 | {-# LANGUAGE RankNTypes #-} 6 | {-# LANGUAGE RecordWildCards #-} 7 | module Petstore.API.Schemas.Pet where 8 | 9 | import qualified Control.Applicative 10 | import qualified Control.Exception 11 | import qualified Control.Monad 12 | import qualified Control.Monad.IO.Class 13 | import qualified Data.Aeson 14 | import qualified Data.Aeson.Encoding 15 | import qualified Data.Aeson.Parser 16 | import qualified Data.Aeson.Types 17 | import qualified Data.Attoparsec.ByteString 18 | import qualified Data.List 19 | import qualified Data.Maybe 20 | import qualified Data.Text 21 | import qualified Data.Time 22 | import qualified Data.Text.Encoding 23 | import qualified GHC.Float 24 | import qualified GHC.Int 25 | import qualified GHC.Types 26 | import qualified Network.HTTP.Types 27 | import qualified Network.Wai 28 | import qualified Web.HttpApiData 29 | 30 | 31 | 32 | 33 | 34 | data Pet = Pet 35 | { 36 | id :: GHC.Int.Int64, 37 | name :: Data.Text.Text, 38 | tag :: (Data.Maybe.Maybe (Data.Text.Text)) 39 | } 40 | deriving (Show) 41 | 42 | instance Data.Aeson.ToJSON Pet where 43 | toJSON Pet {..} = Data.Aeson.object 44 | [ 45 | "id" Data.Aeson..= id, 46 | "name" Data.Aeson..= name, 47 | "tag" Data.Aeson..= tag 48 | ] 49 | 50 | toEncoding Pet {..} = Data.Aeson.Encoding.pairs 51 | ( Data.Aeson.Encoding.pair "id" (Data.Aeson.toEncoding id) <> 52 | Data.Aeson.Encoding.pair "name" (Data.Aeson.toEncoding name) <> 53 | Data.Aeson.Encoding.pair "tag" (Data.Aeson.toEncoding tag) 54 | ) 55 | 56 | instance Data.Aeson.FromJSON Pet where 57 | parseJSON = Data.Aeson.withObject "Pet" $ \o -> 58 | Pet 59 | <$> o Data.Aeson..: "id" 60 | <*> o Data.Aeson..: "name" 61 | <*> o Data.Aeson..:? "tag" -------------------------------------------------------------------------------- /test/golden/enum-bug.yaml: -------------------------------------------------------------------------------- 1 | openapi: "3.0.0" 2 | info: 3 | version: 2.0.0 4 | title: Scarf API 5 | license: 6 | name: MIT 7 | servers: 8 | - url: http://api.scarf.sh 9 | paths: 10 | /v2/{entity}/packages: 11 | parameters: 12 | - "$ref": "#/components/parameters/entity" 13 | get: 14 | operationId: dummy 15 | summary: Dummy route 16 | responses: 17 | '200': 18 | description: Dummy response 19 | content: 20 | application/json: 21 | schema: 22 | "$ref": "#/components/schemas/Package" 23 | components: 24 | parameters: 25 | entity: 26 | name: entity 27 | in: path 28 | required: true 29 | schema: 30 | type: string 31 | schemas: 32 | PackageType: 33 | type: string 34 | enum: 35 | - docker 36 | - file 37 | - python 38 | - npm 39 | PackageBase: 40 | type: object 41 | required: 42 | - id 43 | - name 44 | - short_description 45 | - type 46 | properties: 47 | id: 48 | type: string 49 | name: 50 | type: string 51 | short_description: 52 | type: string 53 | long_description: 54 | type: string 55 | website: 56 | type: string 57 | type: 58 | "$ref": "#/components/schemas/PackageType" 59 | FilePackage: 60 | 61 | allOf: 62 | - "$ref": "#/components/schemas/PackageBase" 63 | - required: 64 | - incoming_path 65 | - outgoing_url 66 | properties: 67 | incoming_path: 68 | type: string 69 | outgoing_url: 70 | type: string 71 | DockerPackage: 72 | required: 73 | - image 74 | - backend_registry 75 | allOf: 76 | - "$ref": "#/components/schemas/PackageBase" 77 | - properties: 78 | image: 79 | type: string 80 | backend_registry: 81 | type: string 82 | Package: 83 | oneOf: 84 | - "$ref": "#/components/schemas/FilePackage" 85 | - "$ref": "#/components/schemas/DockerPackage" 86 | -------------------------------------------------------------------------------- /src/Tie/Writer.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE GADTs #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | {-# LANGUAGE RankNTypes #-} 4 | 5 | module Tie.Writer 6 | ( Writer, 7 | fileWriter, 8 | withTestWriter, 9 | ) 10 | where 11 | 12 | import Data.ByteString.Builder (Builder, hPutBuilder) 13 | import Data.Text.Lazy.Encoding (encodeUtf8Builder) 14 | import Prettyprinter (Doc, (<+>)) 15 | import qualified Prettyprinter as PP 16 | import qualified Prettyprinter.Render.Text as PP 17 | import System.Directory (createDirectoryIfMissing) 18 | import System.FilePath (takeDirectory, ()) 19 | import System.IO (IOMode (WriteMode), withBinaryFile) 20 | 21 | -- | Abstraction for storing generated code on disk. 22 | type Writer m = forall ann. FilePath -> Doc ann -> m () 23 | 24 | -- | Renders a 'Doc' to a 'Builder' - ready to be written to disk. 25 | -- TODO move somewhere else 26 | render :: Doc ann -> Builder 27 | render = 28 | encodeUtf8Builder . PP.renderLazy . PP.layoutPretty PP.defaultLayoutOptions 29 | 30 | -- | Renders 'Doc's to a file just as you would expect. Writes files relative 31 | -- to the given output directory. 32 | fileWriter :: (MonadIO m) => FilePath -> Writer m 33 | fileWriter outputDirectory path doc = liftIO $ do 34 | let fullPath = outputDirectory path 35 | createDirectoryIfMissing True (takeDirectory fullPath) 36 | withBinaryFile fullPath WriteMode $ \file -> 37 | Data.ByteString.Builder.hPutBuilder file (render doc) 38 | 39 | -- | Collects all the FilePath and Doc pairs and returns them concatenated 40 | -- in one output 41 | withTestWriter :: (MonadIO m) => (Writer m -> m a) -> m (a, Builder) 42 | withTestWriter action = do 43 | ref <- liftIO (newIORef []) 44 | result <- action $ \file doc -> 45 | liftIO (modifyIORef' ref ((file, PP.unAnnotate doc) :)) 46 | docs <- liftIO (readIORef ref) 47 | pure (result, renderOneBigFile (sortOn fst docs)) 48 | where 49 | renderOneBigFile docs = 50 | render $ 51 | PP.concatWith 52 | (\x y -> x <> PP.line <> "---------------------" <> PP.line <> y) 53 | [ PP.vsep 54 | [ PP.pretty (toText file), 55 | mempty, 56 | doc 57 | ] 58 | | (file, doc) <- docs 59 | ] 60 | -------------------------------------------------------------------------------- /src/Tie/Resolve.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE GADTs #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | {-# LANGUAGE RankNTypes #-} 4 | {-# LANGUAGE RecordWildCards #-} 5 | 6 | module Tie.Resolve 7 | ( Resolvable, 8 | Resolver, 9 | newResolver, 10 | resolve, 11 | ) 12 | where 13 | 14 | import qualified Data.HashMap.Strict as HashMap 15 | import qualified Data.HashMap.Strict.InsOrd as InsOrd 16 | import qualified Data.OpenApi as OpenApi 17 | import qualified Data.Text as Text 18 | 19 | -- | Resolve an 'OpenApi.Reference' to the underlying component. 20 | newtype Resolver m = Resolver 21 | { resolve :: forall a. (Resolvable a) => OpenApi.Referenced a -> m a 22 | } 23 | 24 | newResolver :: 25 | (Applicative m) => 26 | OpenApi.Components -> 27 | (forall a. OpenApi.Reference -> m a) -> 28 | Resolver m 29 | newResolver components notFound = 30 | Resolver (resolveComponent components notFound) 31 | 32 | resolveComponent :: 33 | (Applicative m, Resolvable a) => 34 | -- | Inventory of components we can resolve to 35 | OpenApi.Components -> 36 | -- | What to do in case a 'OpenApi.Reference' is not found 37 | (OpenApi.Reference -> m a) -> 38 | -- | 'OpenApi.Reference' to resolve 39 | OpenApi.Referenced a -> 40 | m a 41 | resolveComponent components notFound = \referenced -> do 42 | case referenced of 43 | OpenApi.Inline a -> 44 | pure a 45 | OpenApi.Ref reference 46 | | Just a <- 47 | InsOrd.lookup 48 | (OpenApi.getReference reference) 49 | (resolvables components) -> 50 | pure a 51 | | otherwise -> do 52 | notFound reference 53 | 54 | -- | Helper class helping to dispatch from 'OpenApi.Referenced' to component type @a@. 55 | class Resolvable a where 56 | -- | Resolves the `OpenApi.Components` to the given corresponding `Definitions`. 57 | resolvables :: 58 | OpenApi.Components -> 59 | OpenApi.Definitions a 60 | 61 | instance Resolvable OpenApi.Schema where 62 | resolvables = OpenApi._componentsSchemas 63 | 64 | instance Resolvable OpenApi.Response where 65 | resolvables = OpenApi._componentsResponses 66 | 67 | instance Resolvable OpenApi.Param where 68 | resolvables = OpenApi._componentsParameters 69 | 70 | instance Resolvable OpenApi.Example where 71 | resolvables = OpenApi._componentsExamples 72 | 73 | instance Resolvable OpenApi.RequestBody where 74 | resolvables = OpenApi._componentsRequestBodies 75 | 76 | instance Resolvable OpenApi.Header where 77 | resolvables = OpenApi._componentsHeaders 78 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 |

2 | 3 | 4 |

5 | 6 | Tie allows generation of Haskell server stubs from 7 | [OpenAPI (v 3.x) specifications](https://swagger.io/specification/). 8 | 9 | If you are looking for a generator for Haskell client code, check out the 10 | [Haskell-OpenAPI-Client-Code-Generator](https://github.com/Haskell-OpenAPI-Code-Generator/Haskell-OpenAPI-Client-Code-Generator) 11 | project. 12 | 13 | ## Usage 14 | 15 | ``` 16 | $ tie --help 17 | tie - openapi3 server code generator 18 | 19 | Usage: tie [-o|--output DIR] [--module-name MODULE] [--package-name PACKAGE] 20 | [--extra-package PACKAGE] FILE 21 | 22 | Generate a Haskell server from an OpenAPI3 specification 23 | 24 | Available options: 25 | -o,--output DIR The directory output (default: "out") 26 | --module-name MODULE Name of the generated top level module 27 | (default: "OpenAPI") 28 | --package-name PACKAGE Name of the generated cabal project 29 | (default: "open-api") 30 | --extra-package PACKAGE Extra packages to include in the generated cabal 31 | project 32 | FILE OpenAPI specification file 33 | -h,--help Show this help text 34 | ``` 35 | 36 | ## Example 37 | 38 | See [`example/`](/example) for the ubiquitous OpenAPI Petstore example. 39 | 40 | ## Installation 41 | 42 | ### Building from source 43 | 44 | Below are the steps to install Tie using the Cabal build tool. 45 | 46 | First, you need to clone the repository 47 | 48 | ```bash 49 | $ git clone https://github.com/scarf-sh/tie.git 50 | $ cd tie 51 | ``` 52 | 53 | Then, you need to build it using cabal: 54 | 55 | ```bash 56 | $ cabal build exe:tie 57 | ``` 58 | 59 | Y ou can install the executable with using: 60 | 61 | ```bash 62 | $ cabal install . 63 | ``` 64 | 65 | ## Formatting 66 | 67 | To pass the lint workflow run 68 | 69 | ``` 70 | $ git ls-files | grep -v 'example/' | grep \.hs | xargs ./ormolu --mode=inplace 71 | ``` 72 | 73 | to format the Haskell files accordingly using Ormolu. 74 | 75 | ## Community & Contact 76 | 77 | Feel free to join on us on our 78 | [community Slack](https://tinyurl.com/scarf-community-slack) (`#tie` channel)! 79 | 80 | ## License 81 | 82 | This program is under the terms of the [Apache License v2.0](/LICENSE). 83 | 84 | ## Authors 85 | 86 | Tie is originally made and currently sponsored by [Scarf](https://scarf.sh) 87 | among other [contributors](https://github.com/scarf-sh/tie/graphs/contributors). 88 | -------------------------------------------------------------------------------- /test/golden/oneof.yaml: -------------------------------------------------------------------------------- 1 | openapi: "3.0.0" 2 | info: 3 | version: 1.0.0 4 | title: Scarf 5 | license: 6 | name: AllRightsReserved 7 | servers: 8 | - url: https://scarf.sh/api/v1 9 | paths: 10 | /packages: 11 | get: 12 | summary: List all packages 13 | operationId: listPackages 14 | tags: 15 | - packages 16 | responses: 17 | '200': 18 | description: An array of packages 19 | content: 20 | application/json: 21 | schema: 22 | $ref: "#/components/schemas/PetOrPackage" 23 | /packages2: 24 | get: 25 | summary: List all packages 26 | operationId: listPackages2 27 | tags: 28 | - packages 29 | responses: 30 | '200': 31 | description: An array of Inlines 32 | content: 33 | application/json: 34 | schema: 35 | $ref: "#/components/schemas/Inline" 36 | /packages3: 37 | get: 38 | summary: List all packages 39 | operationId: listPackages3 40 | tags: 41 | - packages 42 | responses: 43 | '200': 44 | description: An array of Inlines 45 | content: 46 | application/json: 47 | schema: 48 | $ref: "#/components/schemas/Inline2" 49 | components: 50 | schemas: 51 | Package: 52 | properties: 53 | enum_field_name: 54 | type: string 55 | enum: [Name1, Name2, Name3] 56 | one_of_field_name: 57 | oneOf: 58 | - type: string 59 | - type: array 60 | items: 61 | type: string 62 | type: 63 | type: string 64 | Pet: 65 | properties: 66 | type: 67 | type: string 68 | PetOrPackage: 69 | oneOf: 70 | - $ref: "#/components/schemas/Pet" 71 | - $ref: "#/components/schemas/Package" 72 | discriminator: 73 | propertyName: type 74 | mapping: 75 | pet: "#/components/schemas/Pet" 76 | package: "#/components/schemas/Package" 77 | Packages: 78 | oneOf: 79 | - $ref: "#/components/schemas/Package" 80 | - $ref: "#/components/schemas/Package" 81 | Inline: 82 | properties: 83 | value: 84 | oneOf: 85 | - type: integer 86 | - type: string 87 | - $ref: "#/components/schemas/Package" 88 | Inline2: 89 | properties: 90 | value: 91 | oneOf: 92 | - type: integer 93 | - type: string 94 | - oneOf: 95 | - type: number 96 | - $ref: "#/components/schemas/Package" 97 | -------------------------------------------------------------------------------- /bin/Main.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | {-# LANGUAGE RecordWildCards #-} 3 | 4 | module Main (main) where 5 | 6 | import Data.Version (showVersion) 7 | import Options.Applicative 8 | ( Parser, 9 | auto, 10 | execParser, 11 | flag, 12 | fullDesc, 13 | header, 14 | help, 15 | helper, 16 | info, 17 | infoOption, 18 | long, 19 | metavar, 20 | option, 21 | progDesc, 22 | short, 23 | showDefault, 24 | str, 25 | strArgument, 26 | strOption, 27 | switch, 28 | value, 29 | ) 30 | import Paths_tie (version) 31 | import System.Environment (getArgs) 32 | import Tie (fileWriter, generate) 33 | import Prelude hiding (Option) 34 | 35 | data Input = Input 36 | { outputDirectory :: FilePath, 37 | moduleName :: Text, 38 | packageName :: Text, 39 | extraPackages :: [Text], 40 | inputFile :: FilePath 41 | } 42 | 43 | options :: Parser Input 44 | options = 45 | Input 46 | <$> option 47 | str 48 | ( long "output" 49 | <> short 'o' 50 | <> metavar "DIR" 51 | <> showDefault 52 | <> value "out" 53 | <> help "The directory output" 54 | ) 55 | <*> option 56 | str 57 | ( long "module-name" 58 | <> metavar "MODULE" 59 | <> showDefault 60 | <> value "OpenAPI" 61 | <> help "Name of the generated top level module" 62 | ) 63 | <*> option 64 | str 65 | ( long "package-name" 66 | <> metavar "PACKAGE" 67 | <> showDefault 68 | <> value "open-api" 69 | <> help "Name of the generated cabal project" 70 | ) 71 | <*> many 72 | ( option 73 | str 74 | ( long "extra-package" 75 | <> metavar "PACKAGE" 76 | <> help "Extra packages to include in the generated cabal project" 77 | ) 78 | ) 79 | <*> strArgument 80 | ( metavar "FILE" 81 | <> help "OpenAPI specification file" 82 | ) 83 | 84 | versioner :: Parser (a -> a) 85 | versioner = 86 | infoOption 87 | ("tie " <> showVersion version) 88 | ( long "version" 89 | <> help "Print Tie version" 90 | ) 91 | 92 | main :: IO () 93 | main = do 94 | Input {..} <- 95 | execParser $ 96 | info 97 | (helper <*> versioner <*> options) 98 | ( fullDesc 99 | <> progDesc "Generate a Haskell server from an OpenAPI3 specification" 100 | <> header "tie - openapi3 server code generator" 101 | ) 102 | generate 103 | (fileWriter outputDirectory) 104 | packageName 105 | moduleName 106 | extraPackages 107 | inputFile 108 | -------------------------------------------------------------------------------- /test/golden/enum.yaml: -------------------------------------------------------------------------------- 1 | openapi: "3.0.0" 2 | info: 3 | version: 1.0.0 4 | title: Scarf 5 | license: 6 | name: AllRightsReserved 7 | servers: 8 | - url: https://scarf.sh/api/v1 9 | paths: 10 | /packages: 11 | get: 12 | summary: List all packages 13 | operationId: listPackages 14 | tags: 15 | - packages 16 | responses: 17 | '200': 18 | description: An array of packages 19 | content: 20 | application/json: 21 | schema: 22 | $ref: "#/components/schemas/Package" 23 | /packages2: 24 | get: 25 | summary: List all packages 26 | operationId: listPackages2 27 | tags: 28 | - packages 29 | responses: 30 | '200': 31 | description: An inline enumeration 32 | content: 33 | application/json: 34 | schema: 35 | type: string 36 | enum: 37 | - A 38 | - B 39 | - C 40 | /packages3: 41 | parameters: 42 | - name: order 43 | in: query 44 | required: false 45 | schema: 46 | type: string 47 | enum: 48 | - asc 49 | - desc 50 | get: 51 | summary: List all packages 52 | operationId: listPackages3 53 | tags: 54 | - packages 55 | responses: 56 | '201': 57 | description: Cool! 58 | /packages4: 59 | parameters: 60 | - "$ref": "#/components/parameters/order" 61 | get: 62 | summary: List all packages 63 | operationId: listPackages4 64 | tags: 65 | - packages 66 | responses: 67 | '201': 68 | description: Cool! 69 | /packages5/{time_range}: 70 | parameters: 71 | - "$ref": "#/components/parameters/time_range" 72 | get: 73 | summary: List all packages 74 | operationId: listPackages5 75 | tags: 76 | - packages 77 | responses: 78 | '201': 79 | description: Cool! 80 | components: 81 | parameters: 82 | order: 83 | name: order 84 | in: query 85 | required: false 86 | schema: 87 | "$ref": "#/components/schemas/Order" 88 | time_range: 89 | name: time_range 90 | in: path 91 | required: true 92 | schema: 93 | '$ref': '#/components/schemas/InsightsTimeRange' 94 | schemas: 95 | InsightsTimeRange: 96 | type: string 97 | enum: 98 | - last-week 99 | - last-month 100 | - last-year 101 | Order: 102 | type: string 103 | enum: 104 | - asc 105 | - desc 106 | Package: 107 | type: string 108 | enum: 109 | - DOCKER 110 | - PYTHON 111 | - NPM 112 | Packages: 113 | type: array 114 | items: 115 | $ref: "#/components/schemas/Package" 116 | -------------------------------------------------------------------------------- /tie.cabal: -------------------------------------------------------------------------------- 1 | cabal-version: 3.0 2 | name: tie 3 | version: 0.2.0.0 4 | synopsis: 5 | Tie allows generation of Haskell server stubs from 6 | OpenAPI (v 3.x) specifications. 7 | 8 | bug-reports: https://github.com/scarf-sh/tie/issues 9 | package-url: https://github.com/scarf-sh/tie 10 | license: Apache-2.0 11 | license-file: LICENSE 12 | author: Alex Biehl (alex@scarf.sh) 13 | maintainer: alex@scarf.sh, engineering@scarf.sh 14 | copyright: (c) 2022 Scarf Systems 15 | category: 16 | extra-source-files: 17 | CHANGELOG.md 18 | Response.template.hs 19 | Request.template.hs 20 | 21 | source-repository head 22 | type: git 23 | location: https://github.com/scarf-sh/tie 24 | 25 | library 26 | autogen-modules: Paths_tie 27 | other-modules: Paths_tie 28 | exposed-modules: 29 | Tie 30 | Tie.Codegen.Cabal 31 | Tie.Codegen.Imports 32 | Tie.Codegen.Operation 33 | Tie.Codegen.Request 34 | Tie.Codegen.Response 35 | Tie.Codegen.Schema 36 | Tie.Name 37 | Tie.Operation 38 | Tie.Resolve 39 | Tie.Type 40 | Tie.Writer 41 | 42 | build-depends: 43 | , aeson 44 | , base 45 | , bytestring 46 | , containers 47 | , directory 48 | , filepath 49 | , file-embed 50 | , http-media 51 | , insert-ordered-containers 52 | , lens 53 | , mtl 54 | , openapi3 55 | , prettyprinter 56 | , relude 57 | , text 58 | , unordered-containers 59 | , yaml 60 | 61 | mixins: 62 | base hiding (Prelude), 63 | relude (Relude as Prelude), 64 | relude 65 | 66 | hs-source-dirs: src 67 | default-language: Haskell2010 68 | 69 | executable tie 70 | other-modules: Paths_tie 71 | build-depends: 72 | , base 73 | , optparse-applicative 74 | , relude 75 | , tie 76 | 77 | mixins: 78 | base hiding (Prelude), 79 | relude (Relude as Prelude), 80 | relude 81 | 82 | main-is: Main.hs 83 | hs-source-dirs: bin 84 | default-language: Haskell2010 85 | 86 | test-suite tie-tests 87 | type: exitcode-stdio-1.0 88 | main-is: Main.hs 89 | autogen-modules: Paths_tie 90 | other-modules: Paths_tie 91 | other-modules: 92 | Test.Tie.Golden 93 | Test.Tie.Operation 94 | 95 | build-depends: 96 | , aeson 97 | , base 98 | , bytestring 99 | , containers 100 | , filepath 101 | , file-embed 102 | , hspec 103 | , insert-ordered-containers 104 | , openapi3 105 | , prettyprinter 106 | , relude 107 | , tasty 108 | , tasty-golden 109 | , tasty-hspec 110 | , tasty-hunit 111 | , text 112 | , tie 113 | , yaml 114 | 115 | mixins: 116 | base hiding (Prelude), 117 | relude (Relude as Prelude), 118 | relude 119 | 120 | build-tool-depends: tasty-discover:tasty-discover -any 121 | hs-source-dirs: test 122 | -------------------------------------------------------------------------------- /example/petstore.yaml: -------------------------------------------------------------------------------- 1 | openapi: "3.0.0" 2 | info: 3 | version: 1.0.0 4 | title: Swagger Petstore 5 | license: 6 | name: MIT 7 | servers: 8 | - url: http://petstore.swagger.io/v1 9 | paths: 10 | /pets: 11 | get: 12 | summary: List all pets 13 | operationId: listPets 14 | tags: 15 | - pets 16 | parameters: 17 | - name: limit 18 | in: query 19 | description: How many items to return at one time (max 100) 20 | required: false 21 | schema: 22 | type: integer 23 | format: int32 24 | responses: 25 | '200': 26 | description: A paged array of pets 27 | headers: 28 | x-next: 29 | description: A link to the next page of responses 30 | schema: 31 | type: string 32 | content: 33 | application/json: 34 | schema: 35 | $ref: "#/components/schemas/Pets" 36 | default: 37 | description: unexpected error 38 | content: 39 | application/json: 40 | schema: 41 | $ref: "#/components/schemas/Error" 42 | post: 43 | summary: Create a pet 44 | operationId: createPets 45 | tags: 46 | - pets 47 | responses: 48 | '201': 49 | description: Null response 50 | default: 51 | description: unexpected error 52 | content: 53 | application/json: 54 | schema: 55 | $ref: "#/components/schemas/Error" 56 | /pets/{petId}: 57 | get: 58 | summary: Info for a specific pet 59 | operationId: showPetById 60 | tags: 61 | - pets 62 | parameters: 63 | - name: petId 64 | in: path 65 | required: true 66 | description: The id of the pet to retrieve 67 | schema: 68 | type: string 69 | responses: 70 | '200': 71 | description: Expected response to a valid request 72 | content: 73 | application/json: 74 | schema: 75 | $ref: "#/components/schemas/Pet" 76 | default: 77 | description: unexpected error 78 | content: 79 | application/json: 80 | schema: 81 | $ref: "#/components/schemas/Error" 82 | components: 83 | schemas: 84 | Pet: 85 | type: object 86 | required: 87 | - id 88 | - name 89 | properties: 90 | id: 91 | type: integer 92 | format: int64 93 | name: 94 | type: string 95 | tag: 96 | type: string 97 | Pets: 98 | type: array 99 | items: 100 | $ref: "#/components/schemas/Pet" 101 | Error: 102 | type: object 103 | required: 104 | - code 105 | - message 106 | properties: 107 | code: 108 | type: integer 109 | format: int32 110 | message: 111 | type: string -------------------------------------------------------------------------------- /test/golden/petstore.yaml: -------------------------------------------------------------------------------- 1 | openapi: "3.0.0" 2 | info: 3 | version: 1.0.0 4 | title: Swagger Petstore 5 | license: 6 | name: MIT 7 | servers: 8 | - url: http://petstore.swagger.io/v1 9 | paths: 10 | /pets: 11 | get: 12 | summary: List all pets 13 | operationId: listPets 14 | tags: 15 | - pets 16 | parameters: 17 | - name: limit 18 | in: query 19 | description: How many items to return at one time (max 100) 20 | required: false 21 | schema: 22 | type: integer 23 | format: int32 24 | responses: 25 | '200': 26 | description: A paged array of pets 27 | headers: 28 | x-next: 29 | description: A link to the next page of responses 30 | schema: 31 | type: string 32 | content: 33 | application/json: 34 | schema: 35 | $ref: "#/components/schemas/Pets" 36 | default: 37 | description: unexpected error 38 | content: 39 | application/json: 40 | schema: 41 | $ref: "#/components/schemas/Error" 42 | post: 43 | summary: Create a pet 44 | operationId: createPets 45 | tags: 46 | - pets 47 | responses: 48 | '201': 49 | description: Null response 50 | default: 51 | description: unexpected error 52 | content: 53 | application/json: 54 | schema: 55 | $ref: "#/components/schemas/Error" 56 | /pets/{petId}: 57 | get: 58 | summary: Info for a specific pet 59 | operationId: showPetById 60 | tags: 61 | - pets 62 | parameters: 63 | - name: petId 64 | in: path 65 | required: true 66 | description: The id of the pet to retrieve 67 | schema: 68 | type: string 69 | responses: 70 | '200': 71 | description: Expected response to a valid request 72 | content: 73 | application/json: 74 | schema: 75 | $ref: "#/components/schemas/Pet" 76 | default: 77 | description: unexpected error 78 | content: 79 | application/json: 80 | schema: 81 | $ref: "#/components/schemas/Error" 82 | components: 83 | schemas: 84 | Pet: 85 | type: object 86 | required: 87 | - id 88 | - name 89 | properties: 90 | id: 91 | type: integer 92 | format: int64 93 | name: 94 | type: string 95 | tag: 96 | type: string 97 | Pets: 98 | type: array 99 | items: 100 | $ref: "#/components/schemas/Pet" 101 | Error: 102 | type: object 103 | required: 104 | - code 105 | - message 106 | properties: 107 | code: 108 | type: integer 109 | format: int32 110 | message: 111 | type: string -------------------------------------------------------------------------------- /test/golden/lists.yaml: -------------------------------------------------------------------------------- 1 | openapi: "3.0.0" 2 | info: 3 | version: 1.0.0 4 | title: Scarf 5 | license: 6 | name: AllRightsReserved 7 | servers: 8 | - url: https://scarf.sh/api/v1 9 | paths: 10 | /packages: 11 | get: 12 | summary: List all packages 13 | operationId: listPackages 14 | tags: 15 | - packages 16 | responses: 17 | '200': 18 | description: An array of packages 19 | content: 20 | application/json: 21 | schema: 22 | $ref: "#/components/schemas/Packages" 23 | /packages2: 24 | get: 25 | summary: List all packages 26 | operationId: listPackages2 27 | tags: 28 | - packages 29 | responses: 30 | '200': 31 | description: An inline array of packages 32 | content: 33 | application/json: 34 | schema: 35 | type: array 36 | items: 37 | $ref: "#/components/schemas/Package" 38 | /packages3: 39 | get: 40 | summary: List all packages 41 | operationId: listPackages3 42 | tags: 43 | - packages 44 | responses: 45 | '200': 46 | description: An inline array of packages 47 | content: 48 | application/json: 49 | schema: 50 | type: array 51 | items: 52 | $ref: "#/components/schemas/Inline" 53 | 54 | /packages4: 55 | get: 56 | parameters: 57 | - in: query 58 | required: true 59 | name: id 60 | explode: false 61 | style: form 62 | schema: 63 | type: array 64 | items: 65 | type: string 66 | summary: List all packages 67 | operationId: listPackages4 68 | tags: 69 | - packages 70 | responses: 71 | '200': 72 | description: An inline array of packages 73 | content: 74 | application/json: 75 | schema: 76 | type: array 77 | items: 78 | $ref: "#/components/schemas/Inline" 79 | 80 | /packages5: 81 | get: 82 | parameters: 83 | - in: query 84 | required: true 85 | name: id 86 | explode: true 87 | style: form 88 | schema: 89 | type: array 90 | items: 91 | type: string 92 | summary: List all packages 93 | operationId: listPackages5 94 | tags: 95 | - packages 96 | responses: 97 | '200': 98 | description: An inline array of packages 99 | content: 100 | application/json: 101 | schema: 102 | type: array 103 | items: 104 | $ref: "#/components/schemas/Inline" 105 | 106 | components: 107 | schemas: 108 | Package: 109 | properties: 110 | name: 111 | type: string 112 | Packages: 113 | type: array 114 | items: 115 | $ref: "#/components/schemas/Package" 116 | Inline: 117 | type: array 118 | items: 119 | properties: 120 | name: 121 | type: string 122 | -------------------------------------------------------------------------------- /example/generated/Petstore/API/Api.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE BangPatterns #-} 2 | {-# LANGUAGE DuplicateRecordFields #-} 3 | {-# LANGUAGE OverloadedStrings #-} 4 | {-# LANGUAGE ScopedTypeVariables #-} 5 | {-# LANGUAGE RankNTypes #-} 6 | {-# LANGUAGE RecordWildCards #-} 7 | module Petstore.API.Api where 8 | 9 | import qualified Control.Applicative 10 | import qualified Control.Exception 11 | import qualified Control.Monad 12 | import qualified Control.Monad.IO.Class 13 | import qualified Data.Aeson 14 | import qualified Data.Aeson.Encoding 15 | import qualified Data.Aeson.Parser 16 | import qualified Data.Aeson.Types 17 | import qualified Data.Attoparsec.ByteString 18 | import qualified Data.List 19 | import qualified Data.Maybe 20 | import qualified Data.Text 21 | import qualified Data.Time 22 | import qualified Data.Text.Encoding 23 | import qualified GHC.Float 24 | import qualified GHC.Int 25 | import qualified GHC.Types 26 | import qualified Network.HTTP.Types 27 | import qualified Network.Wai 28 | import qualified Web.HttpApiData 29 | 30 | import Petstore.API.Request 31 | import Petstore.API.Response 32 | 33 | 34 | 35 | import Petstore.API.Schemas.Error 36 | import Petstore.API.Schemas.Pet 37 | import Petstore.API.Schemas.Pets 38 | 39 | import Petstore.API.Response.CreatePets 40 | import Petstore.API.Response.ListPets 41 | import Petstore.API.Response.ShowPetById 42 | 43 | data Api m = Api { 44 | -- | Create a pet 45 | createPets :: 46 | m CreatePetsResponse, 47 | -- | List all pets 48 | listPets :: 49 | -- @limit@ How many items to return at one time (max 100) 50 | (Data.Maybe.Maybe (GHC.Int.Int32)) -> 51 | m ListPetsResponse, 52 | -- | Info for a specific pet 53 | showPetById :: 54 | -- @petId@ The id of the pet to retrieve 55 | Data.Text.Text -> 56 | m ShowPetByIdResponse 57 | } 58 | 59 | application :: (Control.Monad.IO.Class.MonadIO m) => (forall a . Network.Wai.Request -> m a -> IO a) -> Api m -> Network.Wai.Application -> Network.Wai.Application 60 | application run api notFound request respond = 61 | case Network.Wai.pathInfo request of 62 | ["pets"] -> 63 | case Network.Wai.requestMethod request of 64 | "GET" -> 65 | optionalQueryParameter "limit" False (\__limit request respond -> 66 | run request (do 67 | response <- listPets api __limit 68 | Control.Monad.IO.Class.liftIO (respond $! (toResponse response)) 69 | )) request respond 70 | "POST" -> 71 | run request (do 72 | response <- createPets api 73 | Control.Monad.IO.Class.liftIO (respond $! (toResponse response)) 74 | ) 75 | x -> 76 | unsupportedMethod x 77 | 78 | ["pets", __petId] -> 79 | pathVariable __petId (\__petId request respond -> 80 | case Network.Wai.requestMethod request of 81 | "GET" -> 82 | run request (do 83 | response <- showPetById api __petId 84 | Control.Monad.IO.Class.liftIO (respond $! (toResponse response)) 85 | ) 86 | x -> 87 | unsupportedMethod x) request respond 88 | 89 | _ -> 90 | notFound request respond 91 | where 92 | unsupportedMethod _ = 93 | respond (Network.Wai.responseBuilder (toEnum 405) [] mempty) 94 | {-# INLINABLE application #-} -------------------------------------------------------------------------------- /assets/tie.svg: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 | 6 | 7 | 8 | -------------------------------------------------------------------------------- /src/Tie/Codegen/Imports.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE NamedFieldPuns #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | {-# LANGUAGE RecordWildCards #-} 4 | 5 | module Tie.Codegen.Imports 6 | ( codegenModuleHeader, 7 | codegenSchemaDependencies, 8 | codegenResponseDependencies, 9 | codegenExtraApiModuleDependencies, 10 | codegenExtraResponseModuleDependencies, 11 | codegenExternalHaskellDependencies, 12 | ) 13 | where 14 | 15 | import Prettyprinter (Doc, vsep, (<+>)) 16 | import qualified Prettyprinter as PP 17 | import qualified Prettyprinter.Render.Text as PP 18 | import Tie.Name 19 | ( ApiName, 20 | Name, 21 | requestHaskellModuleName, 22 | responseHaskellModuleName, 23 | toResponseHaskellModuleName, 24 | toSchemaHaskellModuleName, 25 | ) 26 | 27 | codegenModuleHeader :: Text -> Doc ann 28 | codegenModuleHeader moduleName = 29 | let languageExtensions :: [Text] 30 | languageExtensions = 31 | sort 32 | [ "BangPatterns", 33 | "DataKinds", 34 | "DuplicateRecordFields", 35 | "OverloadedStrings", 36 | "ScopedTypeVariables", 37 | "RankNTypes", 38 | "RecordWildCards" 39 | ] 40 | 41 | imports :: [Text] 42 | imports = 43 | sort 44 | [ "Control.Applicative", 45 | "Control.Exception", 46 | "Control.Monad", 47 | "Control.Monad.IO.Class", 48 | "Data.Aeson", 49 | "Data.Aeson.Types", 50 | "Data.Aeson.Encoding", 51 | "Data.Attoparsec.ByteString", 52 | "Data.ByteString", 53 | "Data.List", 54 | "Data.List.NonEmpty", 55 | "Data.Map", 56 | "Data.Maybe", 57 | "Data.Text", 58 | "Data.Time", 59 | "Data.Text.Encoding", 60 | "GHC.Float", 61 | "GHC.Int", 62 | "GHC.Records", 63 | "GHC.Types", 64 | "Network.HTTP.Types", 65 | "Network.Wai", 66 | "Web.HttpApiData" 67 | ] 68 | in PP.vcat $ 69 | ( map 70 | (\extension -> "{-#" <+> "LANGUAGE" <+> PP.pretty extension <+> "#-}") 71 | languageExtensions 72 | ) 73 | ++ ["module" <+> PP.pretty moduleName <+> "where", ""] 74 | ++ ( map 75 | (\import_ -> "import" <+> "qualified" <+> PP.pretty import_) 76 | imports 77 | ) 78 | 79 | codegenExtraApiModuleDependencies :: ApiName -> Doc ann 80 | codegenExtraApiModuleDependencies apiName = 81 | vsep 82 | [ "import" <+> PP.pretty (requestHaskellModuleName apiName), 83 | "import" <+> PP.pretty (responseHaskellModuleName apiName) 84 | ] 85 | 86 | codegenExtraResponseModuleDependencies :: ApiName -> Doc ann 87 | codegenExtraResponseModuleDependencies apiName = 88 | "import" <+> PP.pretty (responseHaskellModuleName apiName) 89 | 90 | codegenSchemaDependencies :: ApiName -> [Name] -> Doc ann 91 | codegenSchemaDependencies apiName dependencies = 92 | PP.vsep 93 | [ "import" <+> PP.pretty (toSchemaHaskellModuleName apiName dependency) 94 | | dependency <- dependencies 95 | ] 96 | 97 | codegenResponseDependencies :: ApiName -> [Name] -> Doc ann 98 | codegenResponseDependencies apiName dependencies = 99 | PP.vsep 100 | [ "import" <+> PP.pretty (toResponseHaskellModuleName apiName dependency) 101 | | dependency <- dependencies 102 | ] 103 | 104 | codegenExternalHaskellDependencies :: [Text] -> Doc ann 105 | codegenExternalHaskellDependencies dependencies = 106 | PP.vsep 107 | [ "import" <+> "qualified" <+> PP.pretty dependency 108 | | dependency <- dependencies 109 | ] 110 | -------------------------------------------------------------------------------- /example/app/Main.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE NamedFieldPuns #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | {-# LANGUAGE RecordWildCards #-} 4 | 5 | module Main (main) where 6 | 7 | import qualified Control.Concurrent.MVar 8 | import Control.Exception (onException) 9 | import Control.Monad.State.Strict (StateT, get, put, runStateT) 10 | import Data.Int (Int32) 11 | import Data.List (find) 12 | import Data.Text (Text) 13 | import qualified Data.Text as Text 14 | import qualified Network.Wai 15 | import qualified Network.Wai.Handler.Warp 16 | import qualified Network.Wai.Middleware.RequestLogger 17 | import qualified Petstore.API.Api as Petstore 18 | import qualified Petstore.API.Response.CreatePets as Petstore 19 | import qualified Petstore.API.Response.ListPets as Petstore 20 | import qualified Petstore.API.Response.ShowPetById as Petstore 21 | import qualified Petstore.API.Schemas.Error as Petstore 22 | import qualified Petstore.API.Schemas.Pet as Petstore 23 | import qualified Petstore.API.Schemas.Pets as Petstore 24 | 25 | main :: IO () 26 | main = do 27 | -- This tiny example stores the application state in one, central MVar 28 | petsRef <- Control.Concurrent.MVar.newMVar [] 29 | let port = 8080 30 | putStrLn ("Running Petstore on port " <> show port) 31 | Network.Wai.Handler.Warp.run port $ 32 | Network.Wai.Middleware.RequestLogger.logStdoutDev $ 33 | Petstore.application 34 | (runHandler petsRef) 35 | petstore 36 | -- In case the route can not be found in the petstore, we return 37 | -- a 404 error 38 | ( \_request respond -> 39 | respond (Network.Wai.responseLBS (toEnum 404) [] "Not found") 40 | ) 41 | 42 | -- | Runs a handler into IO 43 | runHandler :: 44 | -- | Our global state MVar 45 | Control.Concurrent.MVar.MVar Petstore.Pets -> 46 | -- | The Wai request that matched the handler 47 | Network.Wai.Request -> 48 | -- | The handler itself 49 | StateT Petstore.Pets IO a -> 50 | IO a 51 | runHandler stateRef _request action = do 52 | state <- Control.Concurrent.MVar.takeMVar stateRef 53 | (result, newState) <- 54 | runStateT action state 55 | `onException` Control.Concurrent.MVar.putMVar stateRef state 56 | Control.Concurrent.MVar.putMVar stateRef newState 57 | pure result 58 | 59 | -- | The API implementation. 60 | petstore :: Petstore.Api (StateT Petstore.Pets IO) 61 | petstore = 62 | Petstore.Api {createPets, listPets, showPetById} 63 | 64 | createPets :: StateT Petstore.Pets IO Petstore.CreatePetsResponse 65 | createPets = do 66 | -- Set a few hardcoded pets to the state 67 | put 68 | [ Petstore.Pet 69 | { id = 1, 70 | name = "Mila", 71 | tag = Just "🐶" 72 | }, 73 | Petstore.Pet 74 | { id = 2, 75 | name = "바다거북", 76 | tag = Just "🐢" 77 | }, 78 | Petstore.Pet 79 | { id = 3, 80 | name = "Edda", 81 | tag = Just "🐶" 82 | } 83 | ] 84 | pure Petstore.CreatePetsResponse201 85 | 86 | listPets :: Maybe Int32 -> StateT Petstore.Pets IO Petstore.ListPetsResponse 87 | listPets limit = do 88 | allPets <- get 89 | let pets = take (maybe maxBound fromIntegral limit) allPets 90 | pure (Petstore.ListPetsResponse200 pets Nothing) 91 | 92 | showPetById :: Text -> StateT Petstore.Pets IO Petstore.ShowPetByIdResponse 93 | showPetById petId = do 94 | allPets <- get 95 | case find 96 | (\Petstore.Pet {id} -> Text.pack (show id) == petId) 97 | allPets of 98 | Nothing -> 99 | pure $ 100 | Petstore.ShowPetByIdDefaultResponse 101 | (toEnum 404) 102 | ( Petstore.Error 103 | { code = 1, 104 | message = "Pet not found" 105 | } 106 | ) 107 | Just pet -> 108 | pure $ 109 | Petstore.ShowPetByIdResponse200 pet 110 | -------------------------------------------------------------------------------- /test/golden/test1.yaml: -------------------------------------------------------------------------------- 1 | openapi: "3.0.0" 2 | info: 3 | version: 1.0.0 4 | title: simple_violation_bool 5 | license: 6 | name: MIT 7 | description: | 8 | Simple violation in simple_violation_bool module 9 | servers: 10 | - url: https://swagger.io/specification/ 11 | paths: 12 | /users/{id}/create/{name}: 13 | parameters: 14 | - in: path 15 | name: id 16 | description: Uniquely identifies a user 17 | schema: 18 | type: integer 19 | required: true 20 | - in: path 21 | description: Name of a user 22 | name: name 23 | schema: 24 | type: string 25 | required: true 26 | - in: query 27 | required: true 28 | name: page 29 | schema: 30 | type: integer 31 | - in: query 32 | name: offset 33 | schema: 34 | type: integer 35 | get: 36 | operationId: getUser 37 | responses: 38 | '404': 39 | description: xxxx 40 | '200': 41 | description: xxxx 42 | content: 43 | application/json: 44 | schema: # Request body contents 45 | $ref: "#/components/schemas/Vehicle" 46 | post: 47 | operationId: createUser 48 | summary: Adds a new user 49 | requestBody: 50 | description: Some nice request body 51 | content: 52 | application/json: 53 | schema: # Request body contents 54 | properties: 55 | nise: 56 | $ref: "#/components/schemas/NISE" 57 | responses: 58 | '200': 59 | description: xxxx 60 | content: 61 | application/json: 62 | schema: 63 | properties: 64 | name: 65 | type: string 66 | components: 67 | schemas: 68 | Vehicle: 69 | type: object 70 | required: 71 | - id 72 | - type 73 | properties: 74 | id: 75 | type: integer 76 | type: 77 | type: string 78 | model: 79 | type: string 80 | name: 81 | type: string 82 | 83 | Car: 84 | allOf: 85 | - $ref: "#/components/schemas/Vehicle" 86 | - type: object 87 | properties: 88 | type: 89 | enum: 90 | - car 91 | has_4_wheel_drive: 92 | type: boolean 93 | 94 | Plane: 95 | anyOf: 96 | - $ref: "#/components/schemas/Vehicle" 97 | - type: object 98 | properties: 99 | type: 100 | enum: 101 | - plane 102 | car: 103 | $ref: "#/components/schemas/Car" 104 | has_reactor: 105 | type: boolean 106 | nb_passengers: 107 | type: integer 108 | 109 | Error: 110 | required: 111 | - code 112 | - message 113 | properties: 114 | code: 115 | type: integer 116 | format: int32 117 | message: 118 | type: string 119 | 120 | PackageId: 121 | oneOf: 122 | - $ref: "#/components/schemas/Plane" 123 | - $ref: "#/components/schemas/Car" 124 | - type: integer 125 | - required: 126 | - name 127 | - sub 128 | - enum 129 | properties: 130 | name: 131 | type: string 132 | age: 133 | type: integer 134 | enum: 135 | type: string 136 | enum: 137 | - A 138 | - B 139 | list: 140 | type: array 141 | items: 142 | properties: 143 | cool: 144 | type: string 145 | properties: 146 | subProperty: 147 | type: string 148 | NISE: 149 | type: object 150 | title: The Root Schema 151 | required: 152 | - description 153 | - id 154 | - name 155 | - ports 156 | properties: 157 | description: 158 | $ref: "#/components/schemas/PackageId" 159 | id: 160 | type: integer 161 | title: The Id Schema 162 | default: 0 163 | format: int64 164 | schema: 165 | $ref: './violation_schema.yaml#/NISE' 166 | name: 167 | type: string 168 | title: The Name Schema 169 | schema: 170 | $ref: './violation_schema.yaml#/NISE' 171 | ports: 172 | type: array 173 | title: The Ports Schema 174 | schema: 175 | $ref: './violation_schema.yaml#/NISE' 176 | items: 177 | type: integer 178 | title: The items Schema 179 | default: 0 180 | schema: 181 | $ref: './violation_schema.yaml#/NISE' 182 | value: 183 | type: object 184 | title: The Value Schema 185 | properties: 186 | name: 187 | type: string 188 | schema: 189 | $ref: './violation_schema.yaml#/NISE' 190 | 191 | 192 | -------------------------------------------------------------------------------- /example/generated/Petstore/API/Request.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | module Petstore.API.Request 4 | ( pathVariable, 5 | requiredQueryParameter, 6 | optionalQueryParameter, 7 | requiredHeader, 8 | optionalHeader, 9 | parseRequestBody, 10 | jsonBodyParser, 11 | formBodyParser, 12 | ) 13 | where 14 | 15 | import Data.Aeson (FromJSON, parseJSON) 16 | import qualified Data.Aeson.Parser 17 | import qualified Data.Aeson.Types 18 | import Data.Attoparsec.ByteString (eitherResult, parseWith) 19 | import Data.ByteString (ByteString) 20 | import qualified Data.ByteString as ByteString 21 | import qualified Data.ByteString.Lazy as LBS 22 | import qualified Data.List as List 23 | import Data.Maybe (fromMaybe) 24 | import Data.Text (Text) 25 | import qualified Data.Text as Text 26 | import qualified Data.Text.Encoding as Text 27 | import Network.HTTP.Types (HeaderName, hContentType) 28 | import qualified Network.Wai as Wai 29 | import System.IO.Unsafe (unsafeInterleaveIO) 30 | import Web.FormUrlEncoded (FromForm, urlDecodeAsForm) 31 | import Web.HttpApiData 32 | ( FromHttpApiData, 33 | parseHeader, 34 | parseQueryParam, 35 | parseUrlPiece, 36 | ) 37 | 38 | pathVariable :: 39 | FromHttpApiData a => 40 | -- | Path variable value 41 | Text -> 42 | (a -> Wai.Application) -> 43 | Wai.Application 44 | pathVariable value withVariable = \request respond -> 45 | case parseUrlPiece value of 46 | Left _err -> 47 | respond (Wai.responseBuilder (toEnum 400) [] mempty) 48 | Right x -> 49 | withVariable x request respond 50 | {-# INLINEABLE pathVariable #-} 51 | 52 | requiredQueryParameter :: 53 | FromHttpApiData a => 54 | ByteString -> 55 | (a -> Wai.Application) -> 56 | Wai.Application 57 | requiredQueryParameter name withParam = \request respond -> 58 | case List.lookup name (Wai.queryString request) of 59 | Nothing -> 60 | respond (Wai.responseBuilder (toEnum 400) [] mempty) 61 | Just Nothing -> 62 | respond (Wai.responseBuilder (toEnum 400) [] mempty) 63 | Just (Just value) -> 64 | case parseQueryParam (Text.decodeUtf8 value) of 65 | Left _err -> 66 | respond (Wai.responseBuilder (toEnum 400) [] mempty) 67 | Right x -> 68 | withParam x request respond 69 | {-# INLINEABLE requiredQueryParameter #-} 70 | 71 | optionalQueryParameter :: 72 | FromHttpApiData a => 73 | ByteString -> 74 | -- | Allow empty, e.g. "x=" 75 | Bool -> 76 | (Maybe a -> Wai.Application) -> 77 | Wai.Application 78 | optionalQueryParameter name allowEmpty withParam = \request respond -> 79 | case List.lookup name (Wai.queryString request) of 80 | Nothing -> 81 | withParam Nothing request respond 82 | Just Nothing 83 | | allowEmpty -> 84 | withParam Nothing request respond 85 | | otherwise -> 86 | respond (Wai.responseBuilder (toEnum 400) [] mempty) 87 | Just (Just value) -> 88 | case parseQueryParam (Text.decodeUtf8 value) of 89 | Left _err -> 90 | respond (Wai.responseBuilder (toEnum 400) [] mempty) 91 | Right x -> 92 | withParam (Just x) request respond 93 | {-# INLINEABLE optionalQueryParameter #-} 94 | 95 | optionalHeader :: 96 | FromHttpApiData a => 97 | HeaderName -> 98 | (Maybe a -> Wai.Application) -> 99 | Wai.Application 100 | optionalHeader name withHeader = \request respond -> 101 | case List.lookup name (Wai.requestHeaders request) of 102 | Nothing -> 103 | withHeader Nothing request respond 104 | Just value -> 105 | case parseHeader value of 106 | Left _err -> 107 | respond (Wai.responseBuilder (toEnum 400) [] mempty) 108 | Right x -> 109 | withHeader (Just x) request respond 110 | {-# INLINEABLE optionalHeader #-} 111 | 112 | requiredHeader :: 113 | FromHttpApiData a => 114 | HeaderName -> 115 | (a -> Wai.Application) -> 116 | Wai.Application 117 | requiredHeader name withHeader = \request respond -> 118 | case List.lookup name (Wai.requestHeaders request) of 119 | Nothing -> 120 | respond (Wai.responseBuilder (toEnum 400) [] mempty) 121 | Just value -> 122 | case parseHeader value of 123 | Left _err -> 124 | respond (Wai.responseBuilder (toEnum 400) [] mempty) 125 | Right x -> 126 | withHeader x request respond 127 | {-# INLINEABLE requiredHeader #-} 128 | 129 | data BodyParser a = BodyParser ByteString ((a -> Wai.Application) -> Wai.Application) 130 | 131 | jsonBodyParser :: FromJSON a => BodyParser a 132 | jsonBodyParser = BodyParser "application/json" parseRequestBodyJSON 133 | {-# INLINE jsonBodyParser #-} 134 | 135 | formBodyParser :: FromForm a => BodyParser a 136 | formBodyParser = BodyParser "application/xxx-form-urlencoded" parseRequestBodyForm 137 | {-# INLINE formBodyParser #-} 138 | 139 | parseRequestBody :: [BodyParser a] -> (a -> Wai.Application) -> Wai.Application 140 | parseRequestBody parsers withBody = \request respond -> do 141 | let contentType = 142 | fromMaybe 143 | "text/html" 144 | (List.lookup hContentType (Wai.requestHeaders request)) 145 | 146 | bodyParser = 147 | List.find 148 | (\(BodyParser expectedContentType _) -> expectedContentType == contentType) 149 | parsers 150 | 151 | case bodyParser of 152 | Just (BodyParser _ parseBody) -> 153 | parseBody withBody request respond 154 | Nothing -> 155 | respond (Wai.responseBuilder (toEnum 415) [] mempty) 156 | {-# INLINE parseRequestBody #-} 157 | 158 | parseRequestBodyJSON :: FromJSON a => (a -> Wai.Application) -> Wai.Application 159 | parseRequestBodyJSON withBody = \request respond -> do 160 | result <- parseWith (Wai.getRequestBodyChunk request) Data.Aeson.Parser.json' mempty 161 | case eitherResult result of 162 | Left _err -> 163 | respond (Wai.responseBuilder (toEnum 400) [] mempty) 164 | Right value -> 165 | case Data.Aeson.Types.parseEither Data.Aeson.parseJSON value of 166 | Left _err -> 167 | respond (Wai.responseBuilder (toEnum 400) [] mempty) 168 | Right body -> 169 | withBody body request respond 170 | {-# INLINEABLE parseRequestBodyJSON #-} 171 | 172 | parseRequestBodyForm :: FromForm a => (a -> Wai.Application) -> Wai.Application 173 | parseRequestBodyForm withBody = \request respond -> do 174 | -- Reads the body using lazy IO. Not great but it gets us 175 | -- going and is pretty local. 176 | let getBodyBytes :: IO [ByteString] 177 | getBodyBytes = do 178 | chunk <- Wai.getRequestBodyChunk request 179 | case chunk of 180 | "" -> pure [] 181 | _ -> do 182 | rest <- unsafeInterleaveIO getBodyBytes 183 | pure (chunk : rest) 184 | 185 | bytes <- getBodyBytes 186 | case urlDecodeAsForm (LBS.fromChunks bytes) of 187 | Left _err -> 188 | respond (Wai.responseBuilder (toEnum 400) [] mempty) 189 | Right form -> 190 | withBody form request respond 191 | {-# INLINEABLE parseRequestBodyForm #-} 192 | -------------------------------------------------------------------------------- /src/Tie/Name.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | {-# LANGUAGE ScopedTypeVariables #-} 4 | 5 | module Tie.Name 6 | ( PackageName, 7 | ApiName, 8 | Name, 9 | fromText, 10 | cabalFileName, 11 | toDataTypeName, 12 | toOneOfDataTypeName, 13 | toOneOfConstructorName, 14 | toFunctionName, 15 | toConstructorName, 16 | toFieldName, 17 | toJsonFieldName, 18 | toParamName, 19 | toParamBinder, 20 | toApiTypeName, 21 | toSchemaHaskellFileName, 22 | toSchemaHaskellModuleName, 23 | toOperationHaskellFileName, 24 | toOperationHaskellModuleName, 25 | toResponseHaskellFileName, 26 | toResponseHaskellModuleName, 27 | toApiResponseTypeName, 28 | toApiResponseConstructorName, 29 | toApiDefaultResponseConstructorName, 30 | toApiMemberName, 31 | toEnumConstructorName, 32 | apiHaskellModuleName, 33 | apiHaskellFileName, 34 | requestHaskellModuleName, 35 | requestHaskellFileName, 36 | responseHaskellModuleName, 37 | responseHaskellFileName, 38 | inlineObjectTypeName, 39 | additionalPropertiesTypeName, 40 | inlineVariantTypeName, 41 | inlineArrayElementTypeName, 42 | operationParamTypeName, 43 | operationRequestBodyName, 44 | apiResponseConstructorName, 45 | apiDefaultResponseConstructorName, 46 | extractHaskellModule, 47 | ) 48 | where 49 | 50 | import Data.Char (isUpper, toLower, toUpper) 51 | import qualified Data.List as List 52 | import qualified Data.Text as Text 53 | import qualified Prettyprinter as PP 54 | 55 | -- | Name of the API to generate code for 56 | type ApiName = Text 57 | 58 | -- | Cabal package name 59 | type PackageName = Text 60 | 61 | -- | Names identify things in the OpenApi universe. Name's are coming directly 62 | -- from the OpenApi spec. 63 | newtype Name = Name {unName :: Text} 64 | deriving (IsString, Eq, Ord, Show, Hashable) 65 | 66 | fromText :: Text -> Name 67 | fromText = Name 68 | 69 | cabalFileName :: PackageName -> FilePath 70 | cabalFileName packageName = 71 | Text.unpack packageName <> ".cabal" 72 | 73 | apiHaskellModuleName :: ApiName -> Text 74 | apiHaskellModuleName apiName = 75 | apiName <> ".Api" 76 | 77 | apiHaskellFileName :: ApiName -> FilePath 78 | apiHaskellFileName apiName = 79 | haskellModuleToFilePath apiName <> "/Api.hs" 80 | 81 | requestHaskellModuleName :: ApiName -> Text 82 | requestHaskellModuleName apiName = 83 | apiName <> ".Request" 84 | 85 | requestHaskellFileName :: ApiName -> FilePath 86 | requestHaskellFileName apiName = 87 | haskellModuleToFilePath apiName <> "/Request.hs" 88 | 89 | responseHaskellModuleName :: ApiName -> Text 90 | responseHaskellModuleName apiName = 91 | apiName <> ".Response" 92 | 93 | responseHaskellFileName :: ApiName -> FilePath 94 | responseHaskellFileName apiName = 95 | haskellModuleToFilePath apiName <> "/Response.hs" 96 | 97 | toSchemaHaskellModuleName :: ApiName -> Name -> Text 98 | toSchemaHaskellModuleName apiName (Name name) = 99 | Text.pack $ Text.unpack apiName <> ".Schemas." <> capitalizeFirstLetter (Text.unpack name) 100 | 101 | toSchemaHaskellFileName :: ApiName -> Name -> FilePath 102 | toSchemaHaskellFileName apiName (Name name) = 103 | haskellModuleToFilePath apiName <> "/Schemas/" <> capitalizeFirstLetter (Text.unpack name) <> ".hs" 104 | 105 | haskellModuleToFilePath :: ApiName -> FilePath 106 | haskellModuleToFilePath = 107 | Text.unpack . Text.replace "." "/" 108 | 109 | toOperationHaskellModuleName :: ApiName -> Name -> Text 110 | toOperationHaskellModuleName apiName (Name name) = 111 | Text.pack $ Text.unpack apiName <> ".Api." <> capitalizeFirstLetter (Text.unpack name) 112 | 113 | toOperationHaskellFileName :: ApiName -> Name -> FilePath 114 | toOperationHaskellFileName apiName (Name name) = 115 | haskellModuleToFilePath apiName <> "/Api/" <> capitalizeFirstLetter (Text.unpack name) <> ".hs" 116 | 117 | toResponseHaskellModuleName :: ApiName -> Name -> Text 118 | toResponseHaskellModuleName apiName (Name name) = 119 | Text.pack $ Text.unpack apiName <> ".Response." <> capitalizeFirstLetter (Text.unpack name) 120 | 121 | toResponseHaskellFileName :: ApiName -> Name -> FilePath 122 | toResponseHaskellFileName apiName (Name name) = 123 | haskellModuleToFilePath apiName <> "/Response/" <> capitalizeFirstLetter (Text.unpack name) <> ".hs" 124 | 125 | toApiTypeName :: Name -> PP.Doc ann 126 | toApiTypeName = 127 | toDataTypeName 128 | 129 | toJsonFieldName :: Name -> PP.Doc ann 130 | toJsonFieldName = PP.pretty . unName 131 | 132 | toDataTypeName :: Name -> PP.Doc ann 133 | toDataTypeName = 134 | PP.pretty . Text.pack . capitalizeFirstLetter . toCamelCase . Text.unpack . unName 135 | 136 | toOneOfDataTypeName :: Name -> PP.Doc ann 137 | toOneOfDataTypeName = 138 | PP.pretty . Text.pack . capitalizeFirstLetter . toCamelCase . Text.unpack . unName 139 | 140 | toOneOfConstructorName :: Name -> Name -> PP.Doc ann 141 | toOneOfConstructorName (Name oneOfType) (Name variant) = 142 | PP.pretty $ 143 | Text.pack $ 144 | escapeKeyword $ 145 | capitalizeFirstLetter (toCamelCase $ Text.unpack oneOfType) 146 | <> capitalizeFirstLetter (toCamelCase $ Text.unpack variant) 147 | 148 | toConstructorName :: Name -> PP.Doc ann 149 | toConstructorName = toDataTypeName 150 | 151 | toFunctionName :: Name -> PP.Doc ann 152 | toFunctionName = 153 | PP.pretty . Text.pack . escapeKeyword . lowerFirstLetter . toCamelCase . Text.unpack . unName 154 | 155 | toFieldName :: Name -> PP.Doc ann 156 | toFieldName = 157 | PP.pretty . Text.pack . escapeKeyword . lowerFirstLetter . toCamelCase . Text.unpack . unName 158 | 159 | -- | Returns the name as written, should be used within quotes only. 160 | toParamName :: Name -> PP.Doc ann 161 | toParamName = 162 | PP.pretty . filterNUL . unName 163 | where 164 | -- Filter away '\0' to support the weird cookie trick 165 | -- (see test/golden/weird-cookie-trick.yaml) 166 | filterNUL = Text.filter (/= '\0') 167 | 168 | toParamBinder :: Name -> PP.Doc ann 169 | toParamBinder = 170 | PP.pretty . Text.pack . escapeKeyword . lowerFirstLetter . ("__" <>) . Text.unpack . unName 171 | 172 | operationParamTypeName :: Name -> Name -> Name 173 | operationParamTypeName (Name operationName) (Name paramName) = 174 | Name $ 175 | Text.pack $ 176 | escapeKeyword $ 177 | capitalizeFirstLetter (Text.unpack operationName) 178 | <> capitalizeFirstLetter (Text.unpack paramName) 179 | <> "Param" 180 | 181 | operationRequestBodyName :: Name -> Name 182 | operationRequestBodyName (Name operationName) = 183 | Name $ 184 | Text.pack $ 185 | escapeKeyword $ 186 | capitalizeFirstLetter (Text.unpack operationName) 187 | <> "RequestBody" 188 | 189 | toApiMemberName :: Name -> PP.Doc ann 190 | toApiMemberName = 191 | PP.pretty . Text.pack . escapeKeyword . lowerFirstLetter . toCamelCase . Text.unpack . unName 192 | 193 | toApiResponseTypeName :: Name -> PP.Doc ann 194 | toApiResponseTypeName = 195 | PP.pretty . Text.pack . escapeKeyword . (<> "Response") . capitalizeFirstLetter . Text.unpack . unName 196 | 197 | toApiResponseConstructorName :: Name -> Int -> PP.Doc ann 198 | toApiResponseConstructorName name statusCode = 199 | PP.pretty . Text.pack . escapeKeyword . (<> show statusCode) . (<> "Response") . capitalizeFirstLetter . Text.unpack . unName $ name 200 | 201 | apiResponseConstructorName :: Name -> Int -> Name 202 | apiResponseConstructorName name statusCode = 203 | Name . Text.pack . escapeKeyword . (<> show statusCode) . (<> "ResponseBody") . capitalizeFirstLetter . Text.unpack . unName $ name 204 | 205 | toApiDefaultResponseConstructorName :: Name -> PP.Doc ann 206 | toApiDefaultResponseConstructorName name = 207 | PP.pretty . Text.pack . escapeKeyword . (<> "DefaultResponse") . capitalizeFirstLetter . Text.unpack . unName $ name 208 | 209 | apiDefaultResponseConstructorName :: Name -> Name 210 | apiDefaultResponseConstructorName name = 211 | Name . Text.pack . escapeKeyword . (<> "DefaultResponseBody") . capitalizeFirstLetter . Text.unpack . unName $ name 212 | 213 | toEnumConstructorName :: Name -> Text -> PP.Doc ann 214 | toEnumConstructorName (Name typName) variant = 215 | PP.pretty $ 216 | Text.pack $ 217 | escapeKeyword $ 218 | toCamelCase $ 219 | capitalizeFirstLetter (Text.unpack typName) 220 | <> capitalizeFirstLetter (Text.unpack variant) 221 | 222 | -- | Constructs a name for an object defined inline. Based on the containing data 223 | -- type as well as the field name. 224 | inlineObjectTypeName :: Name -> Name -> Name 225 | inlineObjectTypeName (Name parentType) (Name fieldName) = 226 | Name $ 227 | Text.pack $ 228 | escapeKeyword $ 229 | capitalizeFirstLetter (Text.unpack parentType) 230 | <> capitalizeFirstLetter (Text.unpack fieldName) 231 | 232 | -- | Generate a name for additionalProperties type name within an 233 | -- ObjectType. 234 | additionalPropertiesTypeName :: Name -> Name 235 | additionalPropertiesTypeName (Name parentObjectType) = 236 | Name $ 237 | Text.pack $ 238 | escapeKeyword $ 239 | capitalizeFirstLetter (Text.unpack parentObjectType) 240 | <> "AdditionalProperties" 241 | 242 | -- | Construct a name for an inline type in a oneOf. 243 | inlineVariantTypeName :: Name -> Int -> Name 244 | inlineVariantTypeName (Name parentType) ith = 245 | Name $ 246 | Text.pack $ 247 | escapeKeyword $ 248 | capitalizeFirstLetter (Text.unpack parentType) <> "OneOf" <> show ith 249 | 250 | inlineArrayElementTypeName :: Name -> Name 251 | inlineArrayElementTypeName (Name parentType) = 252 | Name $ 253 | Text.pack $ 254 | escapeKeyword $ 255 | capitalizeFirstLetter (Text.unpack parentType) <> "Elem" 256 | 257 | lowerFirstLetter :: String -> String 258 | lowerFirstLetter [] = [] 259 | lowerFirstLetter (x : xs) = toLower x : xs 260 | 261 | capitalizeFirstLetter :: String -> String 262 | capitalizeFirstLetter [] = [] 263 | capitalizeFirstLetter (x : xs) = toUpper x : xs 264 | 265 | escapeKeyword :: String -> String 266 | escapeKeyword input = haskelify $ case input of 267 | "type" -> "type'" 268 | "class" -> "class'" 269 | "where" -> "where'" 270 | "case" -> "case'" 271 | "of" -> "of'" 272 | "data" -> "data'" 273 | "import" -> "import'" 274 | "qualified" -> "qualified'" 275 | "as" -> "as'" 276 | "instance" -> "instance'" 277 | "module" -> "module'" 278 | "pattern" -> "pattern'" 279 | _ -> input 280 | 281 | haskelify :: String -> String 282 | haskelify = concatMap escape 283 | where 284 | escape c = case c of 285 | '-' -> "_" 286 | '\0' -> "NUL" 287 | _ -> [c] 288 | 289 | toCamelCase :: String -> String 290 | toCamelCase input = 291 | (prefix <>) 292 | . (<> suffix) 293 | . concat 294 | . map (capitalizeFirstLetter . Text.unpack) 295 | . Text.split (\c -> c == '_' || c == '-') 296 | . Text.pack 297 | $ input 298 | where 299 | -- Preserve leading and trailing _ 300 | prefix = takeWhile ('_' ==) input 301 | suffix = takeWhile ('_' ==) (reverse input) 302 | 303 | -- @ 304 | -- extractHaskellModules "Int" = [] 305 | -- extractHaskellModules "GHC.Types.Int" == ["GHC.Types"] 306 | -- extractHaskellModules "Scarf.Hashids.Hashid GHC.Types.Int == ["Scarf.Hashids", "GHC.Types"]" 307 | -- @ 308 | extractHaskellModule :: Text -> [Text] 309 | extractHaskellModule = 310 | let extractModule ty = 311 | case List.init (Text.splitOn "." ty) of 312 | [] -> 313 | [] 314 | xs -> 315 | [Text.intercalate "." xs] 316 | in concatMap extractModule . Text.words 317 | -------------------------------------------------------------------------------- /Request.template.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | module Tie.Template.Request_ 4 | ( -- * Parameters 5 | Style (..), 6 | pathVariable, 7 | requiredQueryParameter, 8 | requiredQueryParameters, 9 | optionalQueryParameter, 10 | optionalQueryParameters, 11 | requiredHeader, 12 | optionalHeader, 13 | 14 | -- * Request body 15 | parseRequestBody, 16 | jsonBodyParser, 17 | formBodyParser, 18 | ) 19 | where 20 | 21 | import qualified Data.Aeson 22 | import qualified Data.Aeson.Types 23 | import Data.Attoparsec.ByteString (eitherResult, parseWith) 24 | import Data.ByteString (ByteString) 25 | import qualified Data.ByteString as ByteString 26 | import qualified Data.ByteString.Builder as Builder 27 | import qualified Data.ByteString.Lazy as LBS 28 | import Data.Coerce (coerce) 29 | import qualified Data.HashMap.Strict as HashMap 30 | import qualified Data.List as List 31 | import qualified Data.List.NonEmpty as NonEmpty 32 | import Data.Maybe (fromMaybe) 33 | import Data.Text (Text) 34 | import qualified Data.Text as Text 35 | import qualified Data.Text.Encoding as Text 36 | import qualified Network.HTTP.Media 37 | import Network.HTTP.Types (HeaderName, hContentType) 38 | import qualified Network.Wai as Wai 39 | import System.IO.Unsafe (unsafeInterleaveIO) 40 | import Web.FormUrlEncoded 41 | ( FromForm, 42 | parseAll, 43 | urlDecodeAsForm, 44 | urlDecodeForm, 45 | ) 46 | import Web.HttpApiData 47 | ( FromHttpApiData, 48 | parseHeader, 49 | parseQueryParam, 50 | parseUrlPiece, 51 | parseUrlPieces, 52 | ) 53 | 54 | pathVariable :: 55 | (FromHttpApiData a) => 56 | -- | Path variable value 57 | Text -> 58 | (a -> Wai.Application) -> 59 | Wai.Application 60 | pathVariable value withVariable = \request respond -> 61 | case parseUrlPiece value of 62 | Left _err -> 63 | respond (Wai.responseBuilder (toEnum 400) [] mempty) 64 | Right x -> 65 | withVariable x request respond 66 | {-# INLINEABLE pathVariable #-} 67 | 68 | data Style 69 | = FormStyle 70 | | CommaDelimitedStyle 71 | | SpaceDelimitedStyle 72 | | PipeDelimitedStyle 73 | 74 | newtype CommaDelimitedValue a = CommaDelimitedValue {unCommaDelimitedValue :: [a]} 75 | 76 | instance (FromHttpApiData a) => FromHttpApiData (CommaDelimitedValue a) where 77 | parseUrlPiece input = do 78 | xs <- parseUrlPieces (Text.splitOn "," input) 79 | pure (CommaDelimitedValue xs) 80 | 81 | newtype SpaceDelimitedValue a = SpaceDelimitedValue {unSpaceDelimitedValue :: [a]} 82 | 83 | instance (FromHttpApiData a) => FromHttpApiData (SpaceDelimitedValue a) where 84 | parseUrlPiece input = do 85 | xs <- parseUrlPieces (Text.splitOn " " input) 86 | pure (SpaceDelimitedValue xs) 87 | 88 | newtype PipeDelimitedValue a = PipeDelimitedValue {unPipeDelimitedValue :: [a]} 89 | 90 | instance (FromHttpApiData a) => FromHttpApiData (PipeDelimitedValue a) where 91 | parseUrlPiece input = do 92 | xs <- parseUrlPieces (Text.splitOn "|" input) 93 | pure (PipeDelimitedValue xs) 94 | 95 | requiredQueryParameters :: 96 | (FromHttpApiData a) => 97 | Style -> 98 | ByteString -> 99 | (NonEmpty.NonEmpty a -> Wai.Application) -> 100 | Wai.Application 101 | requiredQueryParameters style name withParam = 102 | case style of 103 | FormStyle -> \request respond -> 104 | case urlDecodeForm (LBS.fromStrict (ByteString.drop 1 (Wai.rawQueryString request))) of 105 | Left error -> 106 | respond (Wai.responseBuilder (toEnum 400) [] mempty) 107 | Right form -> 108 | case parseAll (Text.decodeUtf8 name) form of 109 | Left _ -> 110 | respond (Wai.responseBuilder (toEnum 400) [] mempty) 111 | Right [] -> 112 | respond (Wai.responseBuilder (toEnum 400) [] mempty) 113 | Right (x : xs) -> 114 | withParam (x NonEmpty.:| xs) request respond 115 | SpaceDelimitedStyle -> 116 | requiredQueryParameter 117 | name 118 | ( \xs -> \request respond -> 119 | case NonEmpty.nonEmpty (unSpaceDelimitedValue xs) of 120 | Nothing -> 121 | respond (Wai.responseBuilder (toEnum 400) [] mempty) 122 | Just xs -> 123 | withParam xs request respond 124 | ) 125 | PipeDelimitedStyle -> 126 | requiredQueryParameter 127 | name 128 | ( \xs -> \request respond -> 129 | case NonEmpty.nonEmpty (unPipeDelimitedValue xs) of 130 | Nothing -> 131 | respond (Wai.responseBuilder (toEnum 400) [] mempty) 132 | Just xs -> 133 | withParam xs request respond 134 | ) 135 | CommaDelimitedStyle -> 136 | requiredQueryParameter 137 | name 138 | ( \xs -> \request respond -> 139 | case NonEmpty.nonEmpty (unCommaDelimitedValue xs) of 140 | Nothing -> 141 | respond (Wai.responseBuilder (toEnum 400) [] mempty) 142 | Just xs -> 143 | withParam xs request respond 144 | ) 145 | 146 | optionalQueryParameters :: 147 | (FromHttpApiData a) => 148 | Style -> 149 | ByteString -> 150 | (Maybe (NonEmpty.NonEmpty a) -> Wai.Application) -> 151 | Wai.Application 152 | optionalQueryParameters style name withParam = 153 | case style of 154 | FormStyle -> \request respond -> 155 | case urlDecodeForm (LBS.fromStrict (ByteString.drop 1 (Wai.rawQueryString request))) of 156 | Left error -> 157 | respond (Wai.responseBuilder (toEnum 400) [] mempty) 158 | Right form -> 159 | case parseAll (Text.decodeUtf8 name) form of 160 | Left _ -> 161 | respond (Wai.responseBuilder (toEnum 400) [] mempty) 162 | Right [] -> 163 | withParam Nothing request respond 164 | Right (x : xs) -> 165 | withParam (Just (x NonEmpty.:| xs)) request respond 166 | SpaceDelimitedStyle -> 167 | optionalQueryParameter 168 | name 169 | False 170 | ( \xs -> 171 | withParam (xs >>= NonEmpty.nonEmpty . unSpaceDelimitedValue) 172 | ) 173 | PipeDelimitedStyle -> 174 | optionalQueryParameter 175 | name 176 | False 177 | ( \xs -> 178 | withParam (xs >>= NonEmpty.nonEmpty . unPipeDelimitedValue) 179 | ) 180 | CommaDelimitedStyle -> 181 | optionalQueryParameter 182 | name 183 | False 184 | ( \xs -> 185 | withParam (xs >>= NonEmpty.nonEmpty . unCommaDelimitedValue) 186 | ) 187 | 188 | requiredQueryParameter :: 189 | (FromHttpApiData a) => 190 | ByteString -> 191 | (a -> Wai.Application) -> 192 | Wai.Application 193 | requiredQueryParameter name withParam = \request respond -> 194 | case List.lookup name (Wai.queryString request) of 195 | Nothing -> 196 | respond (Wai.responseBuilder (toEnum 400) [] ("Missing query parameter: " <> Builder.byteString name)) 197 | Just Nothing -> 198 | respond (Wai.responseBuilder (toEnum 400) [] ("Missing query parameter: " <> Builder.byteString name)) 199 | Just (Just value) -> 200 | case parseQueryParam (Text.decodeUtf8 value) of 201 | Left _err -> 202 | respond (Wai.responseBuilder (toEnum 400) [] ("Unable to recognize query parameter: " <> Builder.byteString name)) 203 | Right x -> 204 | withParam x request respond 205 | {-# INLINEABLE requiredQueryParameter #-} 206 | 207 | optionalQueryParameter :: 208 | (FromHttpApiData a) => 209 | ByteString -> 210 | -- | Allow empty, e.g. "x=" 211 | Bool -> 212 | (Maybe a -> Wai.Application) -> 213 | Wai.Application 214 | optionalQueryParameter name allowEmpty withParam = \request respond -> 215 | case List.lookup name (Wai.queryString request) of 216 | Nothing -> 217 | withParam Nothing request respond 218 | Just Nothing 219 | | allowEmpty -> 220 | withParam Nothing request respond 221 | | otherwise -> 222 | respond (Wai.responseBuilder (toEnum 400) [] ("Missing query parameter: " <> Builder.byteString name)) 223 | Just (Just value) -> 224 | case parseQueryParam (Text.decodeUtf8 value) of 225 | Left _err -> 226 | respond (Wai.responseBuilder (toEnum 400) [] ("Unable to recognize query parameter: " <> Builder.byteString name)) 227 | Right x -> 228 | withParam (Just x) request respond 229 | {-# INLINEABLE optionalQueryParameter #-} 230 | 231 | optionalHeader :: 232 | (FromHttpApiData a) => 233 | HeaderName -> 234 | (Maybe a -> Wai.Application) -> 235 | Wai.Application 236 | optionalHeader name withHeader = \request respond -> 237 | case List.lookup name (Wai.requestHeaders request) of 238 | Nothing -> 239 | withHeader Nothing request respond 240 | Just value -> 241 | case parseHeader value of 242 | Left _err -> 243 | respond (Wai.responseBuilder (toEnum 400) [] mempty) 244 | Right x -> 245 | withHeader (Just x) request respond 246 | {-# INLINEABLE optionalHeader #-} 247 | 248 | requiredHeader :: 249 | (FromHttpApiData a) => 250 | HeaderName -> 251 | (a -> Wai.Application) -> 252 | Wai.Application 253 | requiredHeader name withHeader = \request respond -> 254 | case List.lookup name (Wai.requestHeaders request) of 255 | Nothing -> 256 | respond (Wai.responseBuilder (toEnum 400) [] mempty) 257 | Just value -> 258 | case parseHeader value of 259 | Left _err -> 260 | respond (Wai.responseBuilder (toEnum 400) [] mempty) 261 | Right x -> 262 | withHeader x request respond 263 | {-# INLINEABLE requiredHeader #-} 264 | 265 | data BodyParser a 266 | = BodyParser 267 | Network.HTTP.Media.MediaType 268 | ((a -> Wai.Application) -> Wai.Application) 269 | 270 | jsonBodyParser :: (Data.Aeson.FromJSON a) => BodyParser a 271 | jsonBodyParser = BodyParser "application/json" parseRequestBodyJSON 272 | {-# INLINE jsonBodyParser #-} 273 | 274 | formBodyParser :: (FromForm a) => BodyParser a 275 | formBodyParser = BodyParser "application/xxx-form-urlencoded" parseRequestBodyForm 276 | {-# INLINE formBodyParser #-} 277 | 278 | parseRequestBody :: [BodyParser a] -> (a -> Wai.Application) -> Wai.Application 279 | parseRequestBody parsers withBody = \request respond -> do 280 | let contentType = 281 | fromMaybe 282 | "application/octet-stream" 283 | (List.lookup hContentType (Wai.requestHeaders request)) 284 | 285 | bodyParser = 286 | Network.HTTP.Media.mapAccept 287 | [(mediaType, parser) | BodyParser mediaType parser <- parsers] 288 | contentType 289 | 290 | case bodyParser of 291 | Just parseBody -> 292 | parseBody withBody request respond 293 | Nothing -> 294 | respond (Wai.responseBuilder (toEnum 415) [] mempty) 295 | {-# INLINE parseRequestBody #-} 296 | 297 | parseRequestBodyJSON :: (Data.Aeson.FromJSON a) => (a -> Wai.Application) -> Wai.Application 298 | parseRequestBodyJSON withBody = \request respond -> do 299 | body <- Wai.lazyRequestBody request 300 | case Data.Aeson.decode' body of 301 | Nothing -> 302 | respond (Wai.responseBuilder (toEnum 400) [] mempty) 303 | Just body -> 304 | withBody body request respond 305 | {-# INLINEABLE parseRequestBodyJSON #-} 306 | 307 | parseRequestBodyForm :: (FromForm a) => (a -> Wai.Application) -> Wai.Application 308 | parseRequestBodyForm withBody = \request respond -> do 309 | body <- Wai.lazyRequestBody request 310 | case urlDecodeAsForm body of 311 | Left _err -> 312 | respond (Wai.responseBuilder (toEnum 400) [] mempty) 313 | Right form -> 314 | withBody form request respond 315 | {-# INLINEABLE parseRequestBodyForm #-} 316 | -------------------------------------------------------------------------------- /src/Tie.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE NamedFieldPuns #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | {-# LANGUAGE RankNTypes #-} 4 | 5 | module Tie 6 | ( generate, 7 | Writer, 8 | fileWriter, 9 | withTestWriter, 10 | ) 11 | where 12 | 13 | import qualified Data.HashMap.Strict.InsOrd as InsOrd 14 | import qualified Data.HashSet as HashSet 15 | import qualified Data.OpenApi as OpenApi 16 | import qualified Data.Set as Set 17 | import Data.Yaml (decodeFileThrow) 18 | import Prettyprinter (Doc, vsep) 19 | import Prettyprinter.Internal (unsafeTextWithoutNewlines) 20 | import Tie.Codegen.Cabal (codegenCabalFile) 21 | import Tie.Codegen.Imports 22 | ( codegenExternalHaskellDependencies, 23 | codegenExtraApiModuleDependencies, 24 | codegenExtraResponseModuleDependencies, 25 | codegenModuleHeader, 26 | codegenResponseDependencies, 27 | codegenSchemaDependencies, 28 | ) 29 | import Tie.Codegen.Operation 30 | ( codegenOperation, 31 | codegenOperations, 32 | ) 33 | import Tie.Codegen.Request (codegenRequestAuxFile) 34 | import Tie.Codegen.Response (codegenResponseAuxFile, codegenResponses) 35 | import Tie.Codegen.Schema (codegenSchema) 36 | import Tie.Name 37 | ( Name, 38 | additionalPropertiesTypeName, 39 | apiHaskellFileName, 40 | apiHaskellModuleName, 41 | cabalFileName, 42 | fromText, 43 | inlineArrayElementTypeName, 44 | inlineObjectTypeName, 45 | inlineVariantTypeName, 46 | requestHaskellFileName, 47 | requestHaskellModuleName, 48 | responseHaskellFileName, 49 | responseHaskellModuleName, 50 | toOperationHaskellFileName, 51 | toResponseHaskellFileName, 52 | toResponseHaskellModuleName, 53 | toSchemaHaskellFileName, 54 | toSchemaHaskellModuleName, 55 | ) 56 | import Tie.Operation 57 | ( Operation (..), 58 | errors, 59 | normalizeOperation, 60 | operationExternalDependencies, 61 | operationResponseDependencies, 62 | operationSchemaDependencies, 63 | pathItemsToOperation, 64 | ) 65 | import Tie.Resolve (newResolver) 66 | import Tie.Type 67 | ( Named, 68 | Type, 69 | namedTypeDependencies, 70 | normalizeType, 71 | schemaToType, 72 | transitiveDependencies, 73 | typeDependencies, 74 | typeExternalDependencies, 75 | ) 76 | import Tie.Writer (Writer, fileWriter, withTestWriter) 77 | import Prelude hiding (Type) 78 | 79 | -- | Our own version of nubOrd that both nubs and sorts 80 | nubOrd :: (Ord a) => [a] -> [a] 81 | nubOrd = Set.toList . Set.fromList 82 | 83 | -- | Read an OpenAPI spec. Throws in case it can not 84 | -- be read or deserialized. 85 | readOpenApiSpec :: 86 | (MonadIO m) => 87 | FilePath -> 88 | m OpenApi.OpenApi 89 | readOpenApiSpec filePath = 90 | liftIO (decodeFileThrow filePath) 91 | 92 | -- | Extracts all the schemas form an 'OpenApi.OpenApi'. 93 | specSchemas :: OpenApi.OpenApi -> [(Text, OpenApi.Schema)] 94 | specSchemas = 95 | InsOrd.toList . OpenApi._componentsSchemas . OpenApi._openApiComponents 96 | 97 | specPaths :: OpenApi.OpenApi -> [(FilePath, OpenApi.PathItem)] 98 | specPaths = 99 | InsOrd.toList . OpenApi._openApiPaths 100 | 101 | specComponents :: OpenApi.OpenApi -> OpenApi.Components 102 | specComponents = 103 | OpenApi._openApiComponents 104 | 105 | -- | Normalizes a 'Type' by extracting the contained inline type 106 | -- definitions. 107 | normalize :: (Monad m) => Name -> Type -> m (Type, [(Name, Type)]) 108 | normalize = 109 | normalizeType 110 | ( \enclosingType fieldName -> 111 | pure (inlineObjectTypeName enclosingType fieldName) 112 | ) 113 | ( \enclosingType -> 114 | pure (additionalPropertiesTypeName enclosingType) 115 | ) 116 | ( \enclosingType ith -> 117 | pure (inlineVariantTypeName enclosingType ith) 118 | ) 119 | ( \enclosingType -> 120 | pure (inlineArrayElementTypeName enclosingType) 121 | ) 122 | 123 | -- | Expands a list of inline definitions until it reaches a fixed point. 124 | -- The invariant of the returned list is that there are no non-primitive 125 | -- unnamed types left: 126 | -- forall x. normalize x == [] 127 | -- where x is an element of the result of normalizedTypes 128 | normalizeTypes :: (Monad m) => [(Name, Type)] -> m [(Name, Type)] 129 | normalizeTypes types = 130 | concat 131 | <$> traverse 132 | ( \(name, type_) -> do 133 | (normalizedType, inlineDefinitions) <- normalize name type_ 134 | normalizedTypes <- normalizeTypes inlineDefinitions 135 | pure ((name, normalizedType) : normalizedTypes) 136 | ) 137 | types 138 | 139 | generate :: 140 | (MonadIO m) => 141 | Writer m -> 142 | -- | Package name 143 | Text -> 144 | -- | Module name 145 | Text -> 146 | -- | Extra cabal packages 147 | [Text] -> 148 | FilePath -> 149 | m () 150 | generate write packageName apiName extraPackages inputFile = do 151 | openApi <- readOpenApiSpec inputFile 152 | 153 | -- Helper to resolve components in the spec. 154 | let resolver = 155 | newResolver 156 | (specComponents openApi) 157 | (\ref -> error ("could not resolve reference " <> show ref)) 158 | 159 | -- Extract all the Operations from the spec 160 | operations' <- 161 | pathItemsToOperation 162 | resolver 163 | errors 164 | (specPaths openApi) 165 | let operations = 166 | sortOn 167 | (\Operation {name} -> name) 168 | operations' 169 | 170 | -- Only extract the direct, shallow dependencies. This is used to get a precise 171 | -- import list for the api and schema modules. 172 | let shallow :: Named Type -> [Name] 173 | shallow = 174 | namedTypeDependencies 175 | 176 | -- Deeply traverse a type and extracts all dependencies. Used to get a list 177 | -- of all the things we have to generate. 178 | let transitive :: Named Type -> [Name] 179 | transitive = 180 | transitiveDependencies 181 | 182 | -- Transitive closure of all the referenced Schemas 183 | let allReferencedSchemas :: HashSet.HashSet Name 184 | allReferencedSchemas = 185 | HashSet.fromList $ 186 | foldMap (operationSchemaDependencies transitive) operations 187 | 188 | -- Walk through all the available Schemas and generate code for the 189 | -- referenced ones. 190 | for_ (specSchemas openApi) $ \(name, schema) -> do 191 | let name' = fromText name 192 | path = toSchemaHaskellFileName apiName name' 193 | header = codegenModuleHeader (toSchemaHaskellModuleName apiName name') 194 | when (name' `HashSet.member` allReferencedSchemas) $ do 195 | type_ <- schemaToType resolver schema 196 | let schemaDependencyCode = 197 | codegenSchemaDependencies apiName $ 198 | nubOrd (typeDependencies shallow type_) 199 | externalDependencyCode = 200 | codegenExternalHaskellDependencies $ 201 | nubOrd (typeExternalDependencies type_) 202 | -- Extract inline dependencies after dependency analysis. We 203 | -- will generate the code for the inline dependencies in the 204 | -- same file 205 | (normedType, inlineDependencies) <- 206 | normalize name' type_ 207 | codeForInlineDependencies <- 208 | traverse (uncurry codegenSchema) inlineDependencies 209 | -- Generate code for the schema 210 | output <- 211 | codegenSchema name' normedType 212 | write path $ 213 | vsep $ 214 | intersperse mempty $ 215 | concat 216 | [ [ header, 217 | externalDependencyCode, 218 | schemaDependencyCode 219 | ], 220 | codeForInlineDependencies, 221 | [output] 222 | ] 223 | 224 | -- For each Operation, generate data types for the responses. 225 | for_ operations $ \operation@Operation {name} -> do 226 | let path = toResponseHaskellFileName apiName name 227 | header = codegenModuleHeader (toResponseHaskellModuleName apiName name) 228 | importsCode = 229 | codegenSchemaDependencies apiName $ 230 | nubOrd (operationSchemaDependencies shallow operation) 231 | (operation, inlineDefinitions) <- 232 | normalizeOperation operation 233 | -- normalizeOperation doesn't recurse into transitive inline definitions, 234 | -- we apply normalizeTypes explicitly to normalize transitive inline definitions 235 | -- explicitly 236 | normalizedInlineDefinitions <- 237 | normalizeTypes inlineDefinitions 238 | codeForInlineDefinitions <- 239 | traverse (uncurry codegenSchema) normalizedInlineDefinitions 240 | responsesCode <- 241 | codegenResponses 242 | resolver 243 | (responseHaskellModuleName apiName) 244 | operation 245 | write path $ 246 | vsep $ 247 | intersperse mempty $ 248 | concat 249 | [ [ header, 250 | importsCode, 251 | codegenExtraResponseModuleDependencies apiName 252 | ], 253 | codeForInlineDefinitions, 254 | [responsesCode] 255 | ] 256 | 257 | -- Generate auxliary definitions in Response.hs 258 | let path = responseHaskellFileName apiName 259 | write path $ 260 | unsafeTextWithoutNewlines $ 261 | codegenResponseAuxFile (responseHaskellModuleName apiName) 262 | 263 | -- Generate auxliary definitions in Request.hs 264 | let path = requestHaskellFileName apiName 265 | write path $ 266 | unsafeTextWithoutNewlines $ 267 | codegenRequestAuxFile (requestHaskellModuleName apiName) 268 | 269 | -- Generate a single Api.hs module containing the server for the api 270 | 271 | -- Normalize operations, to give all anonymous types a name 272 | normalizedOperations <- 273 | traverse 274 | (fmap fst . normalizeOperation) 275 | operations 276 | 277 | -- Generate operations code form the normalized representation 278 | -- Careful: We still want the imports and dependencies be dependent 279 | -- only 280 | operationsCode <- 281 | codegenOperations 282 | resolver 283 | normalizedOperations 284 | 285 | let path = apiHaskellFileName apiName 286 | 287 | header = 288 | codegenModuleHeader (apiHaskellModuleName apiName) 289 | schemaDependencyCode = 290 | codegenSchemaDependencies apiName $ 291 | nubOrd $ 292 | concatMap 293 | (operationSchemaDependencies shallow) 294 | operations 295 | externalDependencyCode = 296 | codegenExternalHaskellDependencies $ 297 | nubOrd $ 298 | concatMap 299 | operationExternalDependencies 300 | operations 301 | responseDependencyCode = 302 | codegenResponseDependencies apiName $ 303 | nubOrd $ 304 | concatMap 305 | operationResponseDependencies 306 | operations 307 | 308 | write path $ 309 | vsep $ 310 | intersperse 311 | mempty 312 | [ header, 313 | codegenExtraApiModuleDependencies apiName, 314 | externalDependencyCode, 315 | schemaDependencyCode, 316 | responseDependencyCode, 317 | operationsCode 318 | ] 319 | 320 | -- Last but not least, generate the Cabal file 321 | let allReferencedModules :: [Text] 322 | allReferencedModules = 323 | nubOrd $ 324 | map (toSchemaHaskellModuleName apiName) (toList allReferencedSchemas) 325 | ++ foldMap (map (toResponseHaskellModuleName apiName) . operationResponseDependencies) operations 326 | ++ [ apiHaskellModuleName apiName, 327 | responseHaskellModuleName apiName, 328 | requestHaskellModuleName apiName 329 | ] 330 | 331 | path = cabalFileName packageName 332 | write path (codegenCabalFile packageName allReferencedModules extraPackages) 333 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | 2 | Apache License 3 | Version 2.0, January 2004 4 | http://www.apache.org/licenses/ 5 | 6 | TERMS AND CONDITIONS FOR USE, REPRODUCTION, AND DISTRIBUTION 7 | 8 | 1. Definitions. 9 | 10 | "License" shall mean the terms and conditions for use, reproduction, 11 | and distribution as defined by Sections 1 through 9 of this document. 12 | 13 | "Licensor" shall mean the copyright owner or entity authorized by 14 | the copyright owner that is granting the License. 15 | 16 | "Legal Entity" shall mean the union of the acting entity and all 17 | other entities that control, are controlled by, or are under common 18 | control with that entity. For the purposes of this definition, 19 | "control" means (i) the power, direct or indirect, to cause the 20 | direction or management of such entity, whether by contract or 21 | otherwise, or (ii) ownership of fifty percent (50%) or more of the 22 | outstanding shares, or (iii) beneficial ownership of such entity. 23 | 24 | "You" (or "Your") shall mean an individual or Legal Entity 25 | exercising permissions granted by this License. 26 | 27 | "Source" form shall mean the preferred form for making modifications, 28 | including but not limited to software source code, documentation 29 | source, and configuration files. 30 | 31 | "Object" form shall mean any form resulting from mechanical 32 | transformation or translation of a Source form, including but 33 | not limited to compiled object code, generated documentation, 34 | and conversions to other media types. 35 | 36 | "Work" shall mean the work of authorship, whether in Source or 37 | Object form, made available under the License, as indicated by a 38 | copyright notice that is included in or attached to the work 39 | (an example is provided in the Appendix below). 40 | 41 | "Derivative Works" shall mean any work, whether in Source or Object 42 | form, that is based on (or derived from) the Work and for which the 43 | editorial revisions, annotations, elaborations, or other modifications 44 | represent, as a whole, an original work of authorship. For the purposes 45 | of this License, Derivative Works shall not include works that remain 46 | separable from, or merely link (or bind by name) to the interfaces of, 47 | the Work and Derivative Works thereof. 48 | 49 | "Contribution" shall mean any work of authorship, including 50 | the original version of the Work and any modifications or additions 51 | to that Work or Derivative Works thereof, that is intentionally 52 | submitted to Licensor for inclusion in the Work by the copyright owner 53 | or by an individual or Legal Entity authorized to submit on behalf of 54 | the copyright owner. For the purposes of this definition, "submitted" 55 | means any form of electronic, verbal, or written communication sent 56 | to the Licensor or its representatives, including but not limited to 57 | communication on electronic mailing lists, source code control systems, 58 | and issue tracking systems that are managed by, or on behalf of, the 59 | Licensor for the purpose of discussing and improving the Work, but 60 | excluding communication that is conspicuously marked or otherwise 61 | designated in writing by the copyright owner as "Not a Contribution." 62 | 63 | "Contributor" shall mean Licensor and any individual or Legal Entity 64 | on behalf of whom a Contribution has been received by Licensor and 65 | subsequently incorporated within the Work. 66 | 67 | 2. Grant of Copyright License. Subject to the terms and conditions of 68 | this License, each Contributor hereby grants to You a perpetual, 69 | worldwide, non-exclusive, no-charge, royalty-free, irrevocable 70 | copyright license to reproduce, prepare Derivative Works of, 71 | publicly display, publicly perform, sublicense, and distribute the 72 | Work and such Derivative Works in Source or Object form. 73 | 74 | 3. Grant of Patent License. Subject to the terms and conditions of 75 | this License, each Contributor hereby grants to You a perpetual, 76 | worldwide, non-exclusive, no-charge, royalty-free, irrevocable 77 | (except as stated in this section) patent license to make, have made, 78 | use, offer to sell, sell, import, and otherwise transfer the Work, 79 | where such license applies only to those patent claims licensable 80 | by such Contributor that are necessarily infringed by their 81 | Contribution(s) alone or by combination of their Contribution(s) 82 | with the Work to which such Contribution(s) was submitted. If You 83 | institute patent litigation against any entity (including a 84 | cross-claim or counterclaim in a lawsuit) alleging that the Work 85 | or a Contribution incorporated within the Work constitutes direct 86 | or contributory patent infringement, then any patent licenses 87 | granted to You under this License for that Work shall terminate 88 | as of the date such litigation is filed. 89 | 90 | 4. Redistribution. You may reproduce and distribute copies of the 91 | Work or Derivative Works thereof in any medium, with or without 92 | modifications, and in Source or Object form, provided that You 93 | meet the following conditions: 94 | 95 | (a) You must give any other recipients of the Work or 96 | Derivative Works a copy of this License; and 97 | 98 | (b) You must cause any modified files to carry prominent notices 99 | stating that You changed the files; and 100 | 101 | (c) You must retain, in the Source form of any Derivative Works 102 | that You distribute, all copyright, patent, trademark, and 103 | attribution notices from the Source form of the Work, 104 | excluding those notices that do not pertain to any part of 105 | the Derivative Works; and 106 | 107 | (d) If the Work includes a "NOTICE" text file as part of its 108 | distribution, then any Derivative Works that You distribute must 109 | include a readable copy of the attribution notices contained 110 | within such NOTICE file, excluding those notices that do not 111 | pertain to any part of the Derivative Works, in at least one 112 | of the following places: within a NOTICE text file distributed 113 | as part of the Derivative Works; within the Source form or 114 | documentation, if provided along with the Derivative Works; or, 115 | within a display generated by the Derivative Works, if and 116 | wherever such third-party notices normally appear. The contents 117 | of the NOTICE file are for informational purposes only and 118 | do not modify the License. You may add Your own attribution 119 | notices within Derivative Works that You distribute, alongside 120 | or as an addendum to the NOTICE text from the Work, provided 121 | that such additional attribution notices cannot be construed 122 | as modifying the License. 123 | 124 | You may add Your own copyright statement to Your modifications and 125 | may provide additional or different license terms and conditions 126 | for use, reproduction, or distribution of Your modifications, or 127 | for any such Derivative Works as a whole, provided Your use, 128 | reproduction, and distribution of the Work otherwise complies with 129 | the conditions stated in this License. 130 | 131 | 5. Submission of Contributions. Unless You explicitly state otherwise, 132 | any Contribution intentionally submitted for inclusion in the Work 133 | by You to the Licensor shall be under the terms and conditions of 134 | this License, without any additional terms or conditions. 135 | Notwithstanding the above, nothing herein shall supersede or modify 136 | the terms of any separate license agreement you may have executed 137 | with Licensor regarding such Contributions. 138 | 139 | 6. Trademarks. This License does not grant permission to use the trade 140 | names, trademarks, service marks, or product names of the Licensor, 141 | except as required for reasonable and customary use in describing the 142 | origin of the Work and reproducing the content of the NOTICE file. 143 | 144 | 7. Disclaimer of Warranty. Unless required by applicable law or 145 | agreed to in writing, Licensor provides the Work (and each 146 | Contributor provides its Contributions) on an "AS IS" BASIS, 147 | WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or 148 | implied, including, without limitation, any warranties or conditions 149 | of TITLE, NON-INFRINGEMENT, MERCHANTABILITY, or FITNESS FOR A 150 | PARTICULAR PURPOSE. You are solely responsible for determining the 151 | appropriateness of using or redistributing the Work and assume any 152 | risks associated with Your exercise of permissions under this License. 153 | 154 | 8. Limitation of Liability. In no event and under no legal theory, 155 | whether in tort (including negligence), contract, or otherwise, 156 | unless required by applicable law (such as deliberate and grossly 157 | negligent acts) or agreed to in writing, shall any Contributor be 158 | liable to You for damages, including any direct, indirect, special, 159 | incidental, or consequential damages of any character arising as a 160 | result of this License or out of the use or inability to use the 161 | Work (including but not limited to damages for loss of goodwill, 162 | work stoppage, computer failure or malfunction, or any and all 163 | other commercial damages or losses), even if such Contributor 164 | has been advised of the possibility of such damages. 165 | 166 | 9. Accepting Warranty or Additional Liability. While redistributing 167 | the Work or Derivative Works thereof, You may choose to offer, 168 | and charge a fee for, acceptance of support, warranty, indemnity, 169 | or other liability obligations and/or rights consistent with this 170 | License. However, in accepting such obligations, You may act only 171 | on Your own behalf and on Your sole responsibility, not on behalf 172 | of any other Contributor, and only if You agree to indemnify, 173 | defend, and hold each Contributor harmless for any liability 174 | incurred by, or claims asserted against, such Contributor by reason 175 | of your accepting any such warranty or additional liability. 176 | 177 | END OF TERMS AND CONDITIONS 178 | 179 | APPENDIX: How to apply the Apache License to your work. 180 | 181 | To apply the Apache License to your work, attach the following 182 | boilerplate notice, with the fields enclosed by brackets "[]" 183 | replaced with your own identifying information. (Don't include 184 | the brackets!) The text should be enclosed in the appropriate 185 | comment syntax for the file format. We also recommend that a 186 | file or class name and description of purpose be included on the 187 | same "printed page" as the copyright notice for easier 188 | identification within third-party archives. 189 | 190 | Copyright [yyyy] [name of copyright owner] 191 | 192 | Licensed under the Apache License, Version 2.0 (the "License"); 193 | you may not use this file except in compliance with the License. 194 | You may obtain a copy of the License at 195 | 196 | http://www.apache.org/licenses/LICENSE-2.0 197 | 198 | Unless required by applicable law or agreed to in writing, software 199 | distributed under the License is distributed on an "AS IS" BASIS, 200 | WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. 201 | See the License for the specific language governing permissions and 202 | limitations under the License. 203 | -------------------------------------------------------------------------------- /src/Tie/Codegen/Response.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE NamedFieldPuns #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | {-# LANGUAGE RecordWildCards #-} 4 | {-# LANGUAGE TemplateHaskell #-} 5 | {-# LANGUAGE TypeApplications #-} 6 | 7 | module Tie.Codegen.Response 8 | ( codegenResponses, 9 | codegenResponseAuxFile, 10 | ) 11 | where 12 | 13 | import qualified Data.ByteString as ByteString 14 | import Data.FileEmbed (embedStringFile, makeRelativeToProject) 15 | import Data.List (lookup) 16 | import qualified Data.Text as Text 17 | import Network.HTTP.Media (renderHeader) 18 | import Prettyprinter (Doc, (<+>)) 19 | import qualified Prettyprinter as PP 20 | import qualified Prettyprinter.Render.Text as PP 21 | import System.IO.Unsafe (unsafePerformIO) 22 | import Tie.Codegen.Schema 23 | ( codegenFieldType, 24 | codegenHeaderSchema, 25 | codegenParamSchema, 26 | ) 27 | import Tie.Name 28 | ( Name, 29 | toApiDefaultResponseConstructorName, 30 | toApiMemberName, 31 | toApiResponseConstructorName, 32 | toApiResponseTypeName, 33 | toParamBinder, 34 | toParamName, 35 | ) 36 | import Tie.Operation 37 | ( Header (..), 38 | Operation (..), 39 | Param (..), 40 | Path, 41 | PathSegment (..), 42 | RequestBody (..), 43 | Response (..), 44 | ) 45 | import Tie.Resolve (Resolver) 46 | 47 | -- | Generate code for the responses of an 'Operation'. 48 | codegenResponses :: 49 | (Monad m) => 50 | Resolver m -> 51 | -- | Aux. Response module name TODO make this a proper type 52 | Text -> 53 | Operation -> 54 | m (Doc ann) 55 | codegenResponses resolver responseModuleName Operation {..} = do 56 | let responseBodyType Response {responseContent} 57 | -- We treat JSON responses specially 58 | | Just jsonContent <- lookup "application/json" responseContent = 59 | [maybe "Data.Aeson.Value" codegenFieldType jsonContent] 60 | | Just jsonLdContent <- lookup "application/x-ndjson" responseContent = 61 | ["(" <> PP.pretty responseModuleName <> "." <> "NDJSON" <+> maybe "Data.Aeson.Value" codegenFieldType jsonLdContent <> ")"] 62 | -- Everything else we use a Network.Wai.StreamingBody type 63 | | not (null responseContent) = 64 | ["Network.Wai.StreamingBody"] 65 | -- Otherwise, no response body present 66 | | otherwise = 67 | [] 68 | 69 | responseHeaderTypes Response {headers} = 70 | map codegenHeaderSchema headers 71 | 72 | -- Since we insert StreamingBody for mime types that we don't know, 73 | -- we have to generate Show instances for those types! 74 | canDeriveStockShowInstanceForResponse Response {responseContent} 75 | | Just _ <- lookup "application/json" responseContent = 76 | True 77 | | Just _ <- lookup "application/x-ndjson" responseContent = 78 | False 79 | | not (null responseContent) = 80 | False 81 | | otherwise = 82 | True 83 | 84 | requiresCustomShowInstance = 85 | not $ 86 | all 87 | canDeriveStockShowInstanceForResponse 88 | (maybeToList defaultResponse ++ map snd responses) 89 | 90 | decl = 91 | "data" 92 | <+> toApiResponseTypeName name 93 | <> PP.line 94 | <> PP.indent 95 | 4 96 | ( PP.vsep $ 97 | [ PP.hsep $ 98 | concat 99 | [ [op, toApiResponseConstructorName name statusCode], 100 | responseBodyType response, 101 | responseHeaderTypes response 102 | ] 103 | | (op, (statusCode, response)) <- zip ("=" : repeat "|") responses 104 | ] 105 | ++ [ PP.hsep $ 106 | concat 107 | [ ["|", toApiDefaultResponseConstructorName name, "Network.HTTP.Types.Status"], 108 | responseBodyType response, 109 | responseHeaderTypes response 110 | ] 111 | | Just response <- [defaultResponse] 112 | ] 113 | ++ [ "deriving" <+> "(" <> "Show" <> ")" 114 | | not requiresCustomShowInstance 115 | ] 116 | ) 117 | 118 | toResponseInstance = 119 | codegenToResponses responseModuleName name responses defaultResponse 120 | 121 | hasStatusInstance = 122 | codegenHasStatusField name responses defaultResponse 123 | 124 | showInstance = 125 | "instance" 126 | <+> "Show" 127 | <+> toApiResponseTypeName name 128 | <+> "where" 129 | <> PP.line 130 | <> PP.indent 131 | 4 132 | ( "show" <+> "_" <+> "=" <+> "\"" <> toApiResponseTypeName name <+> "{}" <> "\"" 133 | ) 134 | 135 | pure 136 | ( PP.vsep $ 137 | intersperse mempty $ 138 | [decl, toResponseInstance, hasStatusInstance] ++ [showInstance | requiresCustomShowInstance] 139 | ) 140 | 141 | codegenHasStatusField :: 142 | Name -> 143 | [(Int, Response)] -> 144 | Maybe Response -> 145 | Doc ann 146 | codegenHasStatusField operationName responses defaultResponse = 147 | "instance" 148 | <+> "GHC.Records.HasField" 149 | <+> "\"status\"" 150 | <+> toApiResponseTypeName operationName 151 | <+> "Network.HTTP.Types.Status" 152 | <+> "where" 153 | <> PP.line 154 | <> PP.indent 155 | 4 156 | ( PP.vsep $ 157 | [ "getField" 158 | <+> "(" 159 | <> toApiResponseConstructorName operationName statusCode 160 | <+> "{}" 161 | <> ")" 162 | <+> "=" 163 | <+> "Network.HTTP.Types.status" 164 | <> PP.pretty statusCode 165 | | (statusCode, _response) <- responses 166 | ] 167 | ++ [ "getField" 168 | <+> "(" 169 | <> PP.hsep 170 | ( concat 171 | [ [toApiDefaultResponseConstructorName operationName, "status"], 172 | ( case response of 173 | Response {responseContent = _ : _} -> ["_"] 174 | _ -> [] 175 | ), 176 | ["_" | Header {name} <- headers] 177 | ] 178 | ) 179 | <> ")" 180 | <+> "=" 181 | <+> "status" 182 | | Just response@Response {headers} <- [defaultResponse] 183 | ] 184 | ) 185 | 186 | codegenToResponses :: 187 | -- | Aux. Response module name TODO make this a proper type 188 | Text -> 189 | Name -> 190 | [(Int, Response)] -> 191 | Maybe Response -> 192 | Doc ann 193 | codegenToResponses responseModuleName operationName responses defaultResponse = 194 | let hasBody response = case response of 195 | Response {responseContent = _ : _} -> True 196 | _ -> False 197 | 198 | bodyBinder response 199 | | hasBody response = ["x"] 200 | | otherwise = [] 201 | 202 | waiResponse Response {responseContent} 203 | | Just _ <- lookup "application/json" responseContent = 204 | -- JSON is very easy to turn into Builders! 205 | "Network.Wai.responseBuilder" 206 | | Just _ <- lookup "application/x-ndjson" responseContent = 207 | PP.pretty responseModuleName <> "." <> "responseNDJSON" 208 | | not (null responseContent) = 209 | -- Tie doesn't know about the content type of this response, 210 | -- uses a Stream instaed 211 | "Network.Wai.responseStream" 212 | | otherwise = 213 | -- For empty response bodies we pass mempty 214 | "Network.Wai.responseBuilder" 215 | 216 | bodySerialize Response {responseContent} 217 | | Just _ <- lookup "application/json" responseContent = 218 | "(" <> "Data.Aeson.fromEncoding" <+> "(" <> "Data.Aeson.toEncoding" <+> "x" <> ")" <> ")" 219 | | Just _ <- lookup "application/x-ndjson" responseContent = 220 | "x" 221 | | not (null responseContent) = 222 | "x" 223 | | otherwise = 224 | "mempty" 225 | 226 | responseHeaders response@Response {responseContent, headers} = 227 | let contentType 228 | | Just _ <- lookup "application/json" responseContent = 229 | ["(Network.HTTP.Types.hContentType, \"application/json\")"] 230 | | Just _ <- lookup "application/x-ndjson" responseContent = 231 | ["(Network.HTTP.Types.hContentType, \"application/x-ndjson\")"] 232 | | (unknownMediaType, _) : _ <- responseContent = 233 | ["(Network.HTTP.Types.hContentType, \"" <> PP.pretty @Text (decodeUtf8 (renderHeader unknownMediaType)) <> "\")"] 234 | | otherwise = 235 | [] 236 | 237 | requiredHeaders = 238 | [ "(\"" <> toParamName name <> "\"," <+> "Web.HttpApiData.toHeader" <+> toParamBinder name <> ")" 239 | | Header {name, required = True} <- headers 240 | ] 241 | 242 | optionalHeaders = 243 | [ "[" 244 | <> "(\"" 245 | <> toParamName name 246 | <> "\"," 247 | <+> "Web.HttpApiData.toHeader" 248 | <+> toParamBinder name 249 | <> ")" 250 | <+> "|" 251 | <+> "Just" 252 | <+> toParamBinder name 253 | <+> "<-" 254 | <+> "[" 255 | <> toParamBinder name 256 | <> "]" 257 | <> "]" 258 | | Header {name, required = False} <- headers 259 | ] 260 | in "(" 261 | <> PP.concatWith 262 | (\x y -> x <+> "++" <+> y) 263 | ( optionalHeaders 264 | ++ [ "[" 265 | <> PP.concatWith 266 | (\x y -> x <> "," <+> y) 267 | (contentType ++ requiredHeaders) 268 | <> "]" 269 | ] 270 | ) 271 | <> ")" 272 | 273 | decl = 274 | "instance" 275 | <+> "ToResponse" 276 | <+> toApiResponseTypeName operationName 277 | <+> "where" 278 | <> PP.line 279 | <> PP.indent 280 | 4 281 | ( PP.vsep $ 282 | [ "toResponse" 283 | <+> "(" 284 | <> PP.hsep 285 | ( concat 286 | [ [toApiResponseConstructorName operationName statusCode], 287 | bodyBinder response, 288 | [toParamBinder name | Header {name} <- headers] 289 | ] 290 | ) 291 | <> ")" 292 | <+> "=" 293 | <> PP.line 294 | <> PP.indent 295 | 4 296 | ( waiResponse response 297 | <+> "Network.HTTP.Types.status" 298 | <> PP.pretty statusCode 299 | <+> responseHeaders response 300 | <+> bodySerialize response 301 | ) 302 | | (statusCode, response@Response {headers}) <- responses 303 | ] 304 | ++ [ "toResponse" 305 | <+> "(" 306 | <> PP.hsep 307 | ( concat 308 | [ [toApiDefaultResponseConstructorName operationName, "status"], 309 | bodyBinder response, 310 | [toParamBinder name | Header {name} <- headers] 311 | ] 312 | ) 313 | <> ")" 314 | <+> "=" 315 | <> PP.line 316 | <> PP.indent 317 | 4 318 | ( waiResponse response 319 | <+> "status" 320 | <+> responseHeaders response 321 | <+> bodySerialize response 322 | ) 323 | | Just response@Response {headers} <- [defaultResponse] 324 | ] 325 | ) 326 | in decl 327 | 328 | templateContents :: ByteString 329 | templateContents = $(embedStringFile =<< makeRelativeToProject "Response.template.hs") 330 | 331 | auxTemplate :: Text 332 | auxTemplate = decodeUtf8 templateContents 333 | {-# NOINLINE auxTemplate #-} 334 | 335 | codegenResponseAuxFile :: 336 | -- | Module name 337 | Text -> 338 | Text 339 | codegenResponseAuxFile moduleName = 340 | Text.replace "Tie.Template.Response_" moduleName auxTemplate 341 | -------------------------------------------------------------------------------- /src/Tie/Codegen/Operation.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE NamedFieldPuns #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | {-# LANGUAGE RecordWildCards #-} 4 | 5 | module Tie.Codegen.Operation 6 | ( codegenOperation, 7 | codegenOperations, 8 | ) 9 | where 10 | 11 | import qualified Data.Map.Strict as Map 12 | import qualified Debug.Trace 13 | import Prettyprinter (Doc, (<+>)) 14 | import qualified Prettyprinter as PP 15 | import qualified Prettyprinter.Render.Text as PP 16 | import Tie.Codegen.Schema (codegenFieldType, codegenParamSchema) 17 | import Tie.Name 18 | ( Name, 19 | toApiMemberName, 20 | toApiResponseTypeName, 21 | toParamBinder, 22 | toParamName, 23 | ) 24 | import Tie.Operation 25 | ( Operation (..), 26 | Param (..), 27 | Path, 28 | PathSegment (..), 29 | RequestBody (..), 30 | Response (..), 31 | Style (..), 32 | ) 33 | import Tie.Resolve (Resolver) 34 | import Tie.Type (isArrayType, namedType) 35 | 36 | codegenOperations :: (Monad m) => Resolver m -> [Operation] -> m (PP.Doc ann) 37 | codegenOperations resolver operations = do 38 | let groupedOperations :: Map.Map Path [Operation] 39 | groupedOperations = 40 | Map.fromListWith 41 | (<>) 42 | [ (path, [operation]) 43 | | operation@Operation {path} <- operations 44 | ] 45 | 46 | dataApiDecl <- codegenApiType resolver operations 47 | operationsCode <- traverse (codegenOperation resolver) (Map.elems groupedOperations) 48 | let apiDecl = 49 | -- TODO instead of "application" take name from openapi spec 50 | "application" 51 | <+> "::" 52 | <+> "(" 53 | <> "Control.Monad.IO.Class.MonadIO" 54 | <+> "m" 55 | <> ")" 56 | <+> "=>" 57 | <+> "(" 58 | <> "forall" 59 | <+> "a" 60 | <+> "." 61 | <+> "Network.Wai.Request" 62 | <+> "->" 63 | <+> "m" 64 | <+> "a" 65 | <+> "->" 66 | <+> "IO" 67 | <+> "a" 68 | <> ")" 69 | <+> "->" 70 | <+> "Api" 71 | <+> "m" 72 | <+> "->" 73 | <+> "Network.Wai.Application" 74 | <+> "->" 75 | <+> "Network.Wai.Application" 76 | <> PP.line 77 | <> "application" 78 | <+> "run" 79 | <+> "api" 80 | <+> "notFound" 81 | <+> "request" 82 | <+> "respond" 83 | <+> "=" 84 | <> PP.line 85 | <> PP.indent 86 | 4 87 | ( "case" 88 | <+> "Network.Wai.pathInfo" 89 | <+> "request" 90 | <+> "of" 91 | <> PP.line 92 | <> PP.indent 93 | 4 94 | ( PP.concatWith 95 | (\x y -> x <> PP.line <> PP.line <> y) 96 | ( operationsCode 97 | ++ [ "_" 98 | <+> "->" 99 | <> PP.line 100 | <> PP.indent 4 ("notFound" <+> "request" <+> "respond") 101 | ] 102 | ) 103 | ) 104 | <> PP.line 105 | <> "where" 106 | <> PP.line 107 | <> PP.indent 108 | 4 109 | ( "unsupportedMethod" 110 | <+> "_" 111 | <+> "=" 112 | <> PP.line 113 | <> PP.indent 114 | 4 115 | ( "respond" 116 | <+> "(" 117 | <> "Network.Wai.responseBuilder" 118 | <+> "Network.HTTP.Types.status" 119 | <> "405" 120 | <+> "[]" 121 | <+> "mempty" 122 | <> ")" 123 | ) 124 | ) 125 | ) 126 | 127 | inlineablePragma = 128 | "{-#" <+> "INLINABLE" <+> "application" <+> "#-}" 129 | 130 | pure (dataApiDecl <> PP.line <> PP.line <> apiDecl <> PP.line <> inlineablePragma) 131 | 132 | codegenApiType :: (Monad m) => Resolver m -> [Operation] -> m (PP.Doc ann) 133 | codegenApiType resolver operations = do 134 | operationsFieldsCode <- traverse (codegenApiTypeOperation resolver) operations 135 | let fieldsCode = 136 | PP.concatWith (\x y -> x <> "," <> PP.line <> y) operationsFieldsCode 137 | 138 | dataDecl = 139 | "data" 140 | <+> "Api" 141 | <+> "m" 142 | <+> "=" 143 | <+> "Api" 144 | <+> "{" 145 | <> PP.line 146 | <> PP.indent 4 fieldsCode 147 | <> PP.line 148 | <> "}" 149 | pure dataDecl 150 | 151 | codegenApiTypeOperation :: (Monad m) => Resolver m -> Operation -> m (PP.Doc ann) 152 | codegenApiTypeOperation resolver Operation {..} = do 153 | paramsCode <- 154 | sequence $ 155 | [ codegenParamSchemaAndComment param 156 | | VariableSegment param@Param {summary} <- path 157 | ] 158 | ++ [ codegenParamSchemaAndComment param 159 | | param@Param {summary} <- queryParams 160 | ] 161 | ++ [ codegenParamSchemaAndComment param 162 | | param@Param {summary} <- headerParams 163 | ] 164 | pure $ 165 | codegenApiMemberComment summary 166 | <> toApiMemberName name 167 | <+> "::" 168 | <> PP.line 169 | <> PP.indent 170 | 4 171 | ( PP.concatWith 172 | (\x y -> x <+> "->" <> PP.line <> y) 173 | ( paramsCode 174 | ++ [ codegenRequestBodyComment body <> codegenRequestBodyType body 175 | | Just body <- [requestBody] 176 | ] 177 | ++ ["m" <+> toApiResponseTypeName name] 178 | ) 179 | ) 180 | where 181 | codegenApiMemberComment mcomment = case mcomment of 182 | Nothing -> mempty 183 | Just comment -> "-- |" <+> PP.pretty comment <> PP.line 184 | 185 | codegenParamComment Param {name, summary} = case summary of 186 | Nothing -> 187 | "--" <+> "@" <> toParamName name <> "@" <> PP.line 188 | Just comment -> 189 | "--" 190 | <+> "@" 191 | <> toParamName name 192 | <> "@" 193 | <> PP.line 194 | <> codegenMultilineComment comment 195 | <> PP.line 196 | 197 | codegenMultilineComment :: Text -> Doc ann 198 | codegenMultilineComment commentLines = 199 | let comments = fmap ("-- " <>) $ lines commentLines 200 | in PP.cat (fmap PP.pretty comments) 201 | 202 | codegenRequestBodyComment RequestBody {description} = case description of 203 | Nothing -> 204 | mempty 205 | Just comment -> 206 | "--" <+> PP.pretty comment <> PP.line 207 | 208 | codegenRequestBodyType RequestBody {provideRequestBodyAsStream, jsonRequestBodyContent} 209 | | provideRequestBodyAsStream = "IO" <+> "Data.ByteString.ByteString" 210 | | otherwise = codegenFieldType jsonRequestBodyContent 211 | 212 | codegenParamSchemaAndComment param = do 213 | code <- codegenParamSchema param 214 | pure (codegenParamComment param <> code) 215 | 216 | codegenOperation :: (Monad m) => Resolver m -> [Operation] -> m (PP.Doc ann) 217 | codegenOperation resolver operations@(Operation {path} : _) = 218 | pure $ 219 | codegenPathGuard path $ 220 | codegenMethodGuard 221 | [ ( method, 222 | codegenQueryParamsGuard queryParams $ 223 | codegenHeaderParamsGuard headerParams $ 224 | codegenRequestBodyGuard requestBody $ 225 | ( codegenCallApiMember name path queryParams headerParams requestBody 226 | ) 227 | ) 228 | | operation@Operation 229 | { name, 230 | path, 231 | queryParams, 232 | headerParams, 233 | method, 234 | requestBody 235 | } <- 236 | operations 237 | ] 238 | 239 | codegenCallApiMember :: Name -> Path -> [Param] -> [Param] -> Maybe RequestBody -> PP.Doc ann 240 | codegenCallApiMember operationName path queryParams headerParams requestBody = 241 | "run" 242 | <+> "request" 243 | <+> "(" 244 | <> "do" 245 | <> PP.line 246 | <> PP.indent 247 | 4 248 | ( "response" 249 | <+> "<-" 250 | <+> PP.hsep 251 | ( concat 252 | [ [toApiMemberName operationName, "api"], 253 | [toParamBinder name | VariableSegment Param {name} <- path], 254 | [toParamBinder name | Param {name} <- queryParams], 255 | [toParamBinder name | Param {name} <- headerParams], 256 | ["body" | Just {} <- [requestBody]] 257 | ] 258 | ) 259 | <> PP.line 260 | <> "Control.Monad.IO.Class.liftIO" 261 | <+> "(" 262 | <> "respond" 263 | <+> "$!" 264 | <+> "(" 265 | <> "toResponse" 266 | <+> "response" 267 | <> ")" 268 | <> ")" 269 | ) 270 | <> PP.line 271 | <> ")" 272 | 273 | codegenPathGuard :: Path -> PP.Doc ann -> PP.Doc ann 274 | codegenPathGuard path continuation = 275 | codegenPathPattern path 276 | <+> "->" 277 | <> PP.line 278 | <> PP.indent 279 | 4 280 | ( codegenParamsGuard 281 | codegenPathParamGuard 282 | [param | VariableSegment param <- path] 283 | continuation 284 | ) 285 | 286 | codegenPathPattern :: Path -> PP.Doc ann 287 | codegenPathPattern path = 288 | "[" 289 | <> PP.concatWith 290 | (\x y -> x <> "," <+> y) 291 | (map codegenPathSegmentPattern path) 292 | <> "]" 293 | 294 | codegenPathSegmentPattern :: PathSegment Param -> PP.Doc ann 295 | codegenPathSegmentPattern segment = case segment of 296 | StaticSegment literal -> 297 | "\"" <> PP.pretty literal <> "\"" 298 | VariableSegment Param {name} -> 299 | toParamBinder name 300 | 301 | codegenMethodGuard :: [(Text, PP.Doc ann)] -> PP.Doc ann 302 | codegenMethodGuard methodBodies = 303 | "case" 304 | <+> "Network.Wai.requestMethod" 305 | <+> "request" 306 | <+> "of" 307 | <> PP.line 308 | <> PP.indent 309 | 4 310 | ( PP.vsep $ 311 | [ "\"" <> PP.pretty method <> "\"" <+> "->" <> PP.line <> PP.indent 4 body 312 | | (method, body) <- methodBodies 313 | ] 314 | ++ [ "x" <+> "->" <> PP.line <> PP.indent 4 ("unsupportedMethod" <+> "x") 315 | ] 316 | ) 317 | 318 | codegenRequestBodyGuard :: Maybe RequestBody -> PP.Doc ann -> PP.Doc ann 319 | codegenRequestBodyGuard requestBody continuation = case requestBody of 320 | Nothing -> 321 | continuation 322 | Just RequestBody {provideRequestBodyAsStream = True} -> 323 | "let" 324 | <+> "body" 325 | <+> "=" 326 | <+> "Network.Wai.getRequestBodyChunk" 327 | <+> "request" 328 | <+> "in" 329 | <> PP.line 330 | <> PP.indent 4 ("(" <> continuation <> ")") 331 | Just RequestBody {jsonRequestBodyContent} -> 332 | let parsers = 333 | -- TODO support forms 334 | ["jsonBodyParser"] 335 | 336 | parsersList = 337 | "[" <> PP.concatWith (\x y -> x <> "," <+> y) parsers <> "]" 338 | in "parseRequestBody" 339 | <+> parsersList 340 | <+> "(" 341 | <> "\\" 342 | <> "body" 343 | <+> "request" 344 | <+> "respond" 345 | <+> "->" 346 | <> PP.line 347 | <> PP.indent 4 continuation 348 | <> ")" 349 | <+> "request" 350 | <+> "respond" 351 | 352 | codegenQueryParamsGuard :: [Param] -> PP.Doc ann -> PP.Doc ann 353 | codegenQueryParamsGuard = 354 | codegenParamsGuard codegenQueryParamGuard 355 | 356 | codegenHeaderParamsGuard :: [Param] -> PP.Doc ann -> PP.Doc ann 357 | codegenHeaderParamsGuard = 358 | codegenParamsGuard codegenHeaderGuard 359 | 360 | codegenParamsGuard :: (Param -> PP.Doc ann -> PP.Doc ann) -> [Param] -> PP.Doc ann -> PP.Doc ann 361 | codegenParamsGuard codegenParam params continuation = 362 | foldr 363 | ($) 364 | continuation 365 | [codegenParam param | param <- params] 366 | 367 | codegenPathParamGuard :: Param -> PP.Doc ann -> PP.Doc ann 368 | codegenPathParamGuard Param {name} continuation = 369 | "pathVariable" 370 | <+> toParamBinder name 371 | <+> "(" 372 | <> "\\" 373 | <> toParamBinder name 374 | <+> "request" 375 | <+> "respond" 376 | <+> "->" 377 | <> PP.line 378 | <> PP.indent 4 continuation 379 | <> ")" 380 | <+> "request" 381 | <+> "respond" 382 | 383 | codegenQueryParamStyle :: 384 | -- | Explode? 385 | Bool -> 386 | Style -> 387 | Maybe (PP.Doc ann) 388 | codegenQueryParamStyle explode style = case (explode, style) of 389 | (True, StyleForm) -> Just "FormStyle" 390 | (False, StyleForm) -> Just "CommaDelimitedStyle" 391 | 392 | codegenQueryParamGuard :: Param -> PP.Doc ann -> PP.Doc ann 393 | codegenQueryParamGuard Param {name, required, style, explode, schema} continuation 394 | | Just _ <- isArrayType (namedType schema), 395 | Just style <- style, 396 | Just style <- codegenQueryParamStyle explode style = 397 | (if required then "requiredQueryParameters" else "optionalQueryParameters") 398 | <+> style 399 | <+> "\"" 400 | <> toParamName name 401 | <> "\"" 402 | <+> "(" 403 | <> "\\" 404 | <> toParamBinder name 405 | <+> "request" 406 | <+> "respond" 407 | <+> "->" 408 | <> PP.line 409 | <> PP.indent 4 continuation 410 | <> ")" 411 | <+> "request" 412 | <+> "respond" 413 | | required = 414 | "requiredQueryParameter" 415 | <+> "\"" 416 | <> toParamName name 417 | <> "\"" 418 | <+> "(" 419 | <> "\\" 420 | <> toParamBinder name 421 | <+> "request" 422 | <+> "respond" 423 | <+> "->" 424 | <> PP.line 425 | <> PP.indent 4 continuation 426 | <> ")" 427 | <+> "request" 428 | <+> "respond" 429 | | otherwise = 430 | "optionalQueryParameter" 431 | <+> "\"" 432 | <> toParamName name 433 | <> "\"" 434 | <+> "False" 435 | <+> "(" 436 | <> "\\" 437 | <> toParamBinder name 438 | <+> "request" 439 | <+> "respond" 440 | <+> "->" 441 | <> PP.line 442 | <> PP.indent 4 continuation 443 | <> ")" 444 | <+> "request" 445 | <+> "respond" 446 | 447 | codegenHeaderGuard :: Param -> PP.Doc ann -> PP.Doc ann 448 | codegenHeaderGuard Param {name, required} continuation 449 | | required = 450 | "requiredHeader" 451 | <+> "\"" 452 | <> toParamName name 453 | <> "\"" 454 | <+> "(" 455 | <> "\\" 456 | <> toParamBinder name 457 | <+> "request" 458 | <+> "respond" 459 | <+> "->" 460 | <> PP.line 461 | <> PP.indent 4 continuation 462 | <> ")" 463 | <+> "request" 464 | <+> "respond" 465 | | otherwise = 466 | "optionalHeader" 467 | <+> "\"" 468 | <> toParamName name 469 | <> "\"" 470 | <+> "(" 471 | <> "\\" 472 | <> toParamBinder name 473 | <+> "request" 474 | <+> "respond" 475 | <+> "->" 476 | <> PP.line 477 | <> PP.indent 4 continuation 478 | <> ")" 479 | <+> "request" 480 | <+> "respond" 481 | -------------------------------------------------------------------------------- /test/golden/bug-1.yaml.out: -------------------------------------------------------------------------------- 1 | Test/Api.hs 2 | 3 | {-# LANGUAGE BangPatterns #-} 4 | {-# LANGUAGE DataKinds #-} 5 | {-# LANGUAGE DuplicateRecordFields #-} 6 | {-# LANGUAGE OverloadedStrings #-} 7 | {-# LANGUAGE RankNTypes #-} 8 | {-# LANGUAGE RecordWildCards #-} 9 | {-# LANGUAGE ScopedTypeVariables #-} 10 | module Test.Api where 11 | 12 | import qualified Control.Applicative 13 | import qualified Control.Exception 14 | import qualified Control.Monad 15 | import qualified Control.Monad.IO.Class 16 | import qualified Data.Aeson 17 | import qualified Data.Aeson.Encoding 18 | import qualified Data.Aeson.Types 19 | import qualified Data.Attoparsec.ByteString 20 | import qualified Data.ByteString 21 | import qualified Data.List 22 | import qualified Data.List.NonEmpty 23 | import qualified Data.Map 24 | import qualified Data.Maybe 25 | import qualified Data.Text 26 | import qualified Data.Text.Encoding 27 | import qualified Data.Time 28 | import qualified GHC.Float 29 | import qualified GHC.Int 30 | import qualified GHC.Records 31 | import qualified GHC.Types 32 | import qualified Network.HTTP.Types 33 | import qualified Network.Wai 34 | import qualified Web.HttpApiData 35 | 36 | import Test.Request 37 | import Test.Response 38 | 39 | 40 | 41 | 42 | 43 | import Test.Response.Test 44 | 45 | data Api m = Api { 46 | -- | test 47 | test :: 48 | m TestResponse 49 | } 50 | 51 | application :: (Control.Monad.IO.Class.MonadIO m) => (forall a . Network.Wai.Request -> m a -> IO a) -> Api m -> Network.Wai.Application -> Network.Wai.Application 52 | application run api notFound request respond = 53 | case Network.Wai.pathInfo request of 54 | ["test"] -> 55 | case Network.Wai.requestMethod request of 56 | "GET" -> 57 | run request (do 58 | response <- test api 59 | Control.Monad.IO.Class.liftIO (respond $! (toResponse response)) 60 | ) 61 | x -> 62 | unsupportedMethod x 63 | 64 | _ -> 65 | notFound request respond 66 | where 67 | unsupportedMethod _ = 68 | respond (Network.Wai.responseBuilder Network.HTTP.Types.status405 [] mempty) 69 | {-# INLINABLE application #-} 70 | --------------------- 71 | Test/Request.hs 72 | 73 | {-# LANGUAGE OverloadedStrings #-} 74 | 75 | module Test.Request 76 | ( -- * Parameters 77 | Style (..), 78 | pathVariable, 79 | requiredQueryParameter, 80 | requiredQueryParameters, 81 | optionalQueryParameter, 82 | optionalQueryParameters, 83 | requiredHeader, 84 | optionalHeader, 85 | 86 | -- * Request body 87 | parseRequestBody, 88 | jsonBodyParser, 89 | formBodyParser, 90 | ) 91 | where 92 | 93 | import qualified Data.Aeson 94 | import qualified Data.Aeson.Types 95 | import Data.Attoparsec.ByteString (eitherResult, parseWith) 96 | import Data.ByteString (ByteString) 97 | import qualified Data.ByteString as ByteString 98 | import qualified Data.ByteString.Builder as Builder 99 | import qualified Data.ByteString.Lazy as LBS 100 | import Data.Coerce (coerce) 101 | import qualified Data.HashMap.Strict as HashMap 102 | import qualified Data.List as List 103 | import qualified Data.List.NonEmpty as NonEmpty 104 | import Data.Maybe (fromMaybe) 105 | import Data.Text (Text) 106 | import qualified Data.Text as Text 107 | import qualified Data.Text.Encoding as Text 108 | import qualified Network.HTTP.Media 109 | import Network.HTTP.Types (HeaderName, hContentType) 110 | import qualified Network.Wai as Wai 111 | import System.IO.Unsafe (unsafeInterleaveIO) 112 | import Web.FormUrlEncoded 113 | ( FromForm, 114 | parseAll, 115 | urlDecodeAsForm, 116 | urlDecodeForm, 117 | ) 118 | import Web.HttpApiData 119 | ( FromHttpApiData, 120 | parseHeader, 121 | parseQueryParam, 122 | parseUrlPiece, 123 | parseUrlPieces, 124 | ) 125 | 126 | pathVariable :: 127 | (FromHttpApiData a) => 128 | -- | Path variable value 129 | Text -> 130 | (a -> Wai.Application) -> 131 | Wai.Application 132 | pathVariable value withVariable = \request respond -> 133 | case parseUrlPiece value of 134 | Left _err -> 135 | respond (Wai.responseBuilder (toEnum 400) [] mempty) 136 | Right x -> 137 | withVariable x request respond 138 | {-# INLINEABLE pathVariable #-} 139 | 140 | data Style 141 | = FormStyle 142 | | CommaDelimitedStyle 143 | | SpaceDelimitedStyle 144 | | PipeDelimitedStyle 145 | 146 | newtype CommaDelimitedValue a = CommaDelimitedValue {unCommaDelimitedValue :: [a]} 147 | 148 | instance (FromHttpApiData a) => FromHttpApiData (CommaDelimitedValue a) where 149 | parseUrlPiece input = do 150 | xs <- parseUrlPieces (Text.splitOn "," input) 151 | pure (CommaDelimitedValue xs) 152 | 153 | newtype SpaceDelimitedValue a = SpaceDelimitedValue {unSpaceDelimitedValue :: [a]} 154 | 155 | instance (FromHttpApiData a) => FromHttpApiData (SpaceDelimitedValue a) where 156 | parseUrlPiece input = do 157 | xs <- parseUrlPieces (Text.splitOn " " input) 158 | pure (SpaceDelimitedValue xs) 159 | 160 | newtype PipeDelimitedValue a = PipeDelimitedValue {unPipeDelimitedValue :: [a]} 161 | 162 | instance (FromHttpApiData a) => FromHttpApiData (PipeDelimitedValue a) where 163 | parseUrlPiece input = do 164 | xs <- parseUrlPieces (Text.splitOn "|" input) 165 | pure (PipeDelimitedValue xs) 166 | 167 | requiredQueryParameters :: 168 | (FromHttpApiData a) => 169 | Style -> 170 | ByteString -> 171 | (NonEmpty.NonEmpty a -> Wai.Application) -> 172 | Wai.Application 173 | requiredQueryParameters style name withParam = 174 | case style of 175 | FormStyle -> \request respond -> 176 | case urlDecodeForm (LBS.fromStrict (ByteString.drop 1 (Wai.rawQueryString request))) of 177 | Left error -> 178 | respond (Wai.responseBuilder (toEnum 400) [] mempty) 179 | Right form -> 180 | case parseAll (Text.decodeUtf8 name) form of 181 | Left _ -> 182 | respond (Wai.responseBuilder (toEnum 400) [] mempty) 183 | Right [] -> 184 | respond (Wai.responseBuilder (toEnum 400) [] mempty) 185 | Right (x : xs) -> 186 | withParam (x NonEmpty.:| xs) request respond 187 | SpaceDelimitedStyle -> 188 | requiredQueryParameter 189 | name 190 | ( \xs -> \request respond -> 191 | case NonEmpty.nonEmpty (unSpaceDelimitedValue xs) of 192 | Nothing -> 193 | respond (Wai.responseBuilder (toEnum 400) [] mempty) 194 | Just xs -> 195 | withParam xs request respond 196 | ) 197 | PipeDelimitedStyle -> 198 | requiredQueryParameter 199 | name 200 | ( \xs -> \request respond -> 201 | case NonEmpty.nonEmpty (unPipeDelimitedValue xs) of 202 | Nothing -> 203 | respond (Wai.responseBuilder (toEnum 400) [] mempty) 204 | Just xs -> 205 | withParam xs request respond 206 | ) 207 | CommaDelimitedStyle -> 208 | requiredQueryParameter 209 | name 210 | ( \xs -> \request respond -> 211 | case NonEmpty.nonEmpty (unCommaDelimitedValue xs) of 212 | Nothing -> 213 | respond (Wai.responseBuilder (toEnum 400) [] mempty) 214 | Just xs -> 215 | withParam xs request respond 216 | ) 217 | 218 | optionalQueryParameters :: 219 | (FromHttpApiData a) => 220 | Style -> 221 | ByteString -> 222 | (Maybe (NonEmpty.NonEmpty a) -> Wai.Application) -> 223 | Wai.Application 224 | optionalQueryParameters style name withParam = 225 | case style of 226 | FormStyle -> \request respond -> 227 | case urlDecodeForm (LBS.fromStrict (ByteString.drop 1 (Wai.rawQueryString request))) of 228 | Left error -> 229 | respond (Wai.responseBuilder (toEnum 400) [] mempty) 230 | Right form -> 231 | case parseAll (Text.decodeUtf8 name) form of 232 | Left _ -> 233 | respond (Wai.responseBuilder (toEnum 400) [] mempty) 234 | Right [] -> 235 | withParam Nothing request respond 236 | Right (x : xs) -> 237 | withParam (Just (x NonEmpty.:| xs)) request respond 238 | SpaceDelimitedStyle -> 239 | optionalQueryParameter 240 | name 241 | False 242 | ( \xs -> 243 | withParam (xs >>= NonEmpty.nonEmpty . unSpaceDelimitedValue) 244 | ) 245 | PipeDelimitedStyle -> 246 | optionalQueryParameter 247 | name 248 | False 249 | ( \xs -> 250 | withParam (xs >>= NonEmpty.nonEmpty . unPipeDelimitedValue) 251 | ) 252 | CommaDelimitedStyle -> 253 | optionalQueryParameter 254 | name 255 | False 256 | ( \xs -> 257 | withParam (xs >>= NonEmpty.nonEmpty . unCommaDelimitedValue) 258 | ) 259 | 260 | requiredQueryParameter :: 261 | (FromHttpApiData a) => 262 | ByteString -> 263 | (a -> Wai.Application) -> 264 | Wai.Application 265 | requiredQueryParameter name withParam = \request respond -> 266 | case List.lookup name (Wai.queryString request) of 267 | Nothing -> 268 | respond (Wai.responseBuilder (toEnum 400) [] ("Missing query parameter: " <> Builder.byteString name)) 269 | Just Nothing -> 270 | respond (Wai.responseBuilder (toEnum 400) [] ("Missing query parameter: " <> Builder.byteString name)) 271 | Just (Just value) -> 272 | case parseQueryParam (Text.decodeUtf8 value) of 273 | Left _err -> 274 | respond (Wai.responseBuilder (toEnum 400) [] ("Unable to recognize query parameter: " <> Builder.byteString name)) 275 | Right x -> 276 | withParam x request respond 277 | {-# INLINEABLE requiredQueryParameter #-} 278 | 279 | optionalQueryParameter :: 280 | (FromHttpApiData a) => 281 | ByteString -> 282 | -- | Allow empty, e.g. "x=" 283 | Bool -> 284 | (Maybe a -> Wai.Application) -> 285 | Wai.Application 286 | optionalQueryParameter name allowEmpty withParam = \request respond -> 287 | case List.lookup name (Wai.queryString request) of 288 | Nothing -> 289 | withParam Nothing request respond 290 | Just Nothing 291 | | allowEmpty -> 292 | withParam Nothing request respond 293 | | otherwise -> 294 | respond (Wai.responseBuilder (toEnum 400) [] ("Missing query parameter: " <> Builder.byteString name)) 295 | Just (Just value) -> 296 | case parseQueryParam (Text.decodeUtf8 value) of 297 | Left _err -> 298 | respond (Wai.responseBuilder (toEnum 400) [] ("Unable to recognize query parameter: " <> Builder.byteString name)) 299 | Right x -> 300 | withParam (Just x) request respond 301 | {-# INLINEABLE optionalQueryParameter #-} 302 | 303 | optionalHeader :: 304 | (FromHttpApiData a) => 305 | HeaderName -> 306 | (Maybe a -> Wai.Application) -> 307 | Wai.Application 308 | optionalHeader name withHeader = \request respond -> 309 | case List.lookup name (Wai.requestHeaders request) of 310 | Nothing -> 311 | withHeader Nothing request respond 312 | Just value -> 313 | case parseHeader value of 314 | Left _err -> 315 | respond (Wai.responseBuilder (toEnum 400) [] mempty) 316 | Right x -> 317 | withHeader (Just x) request respond 318 | {-# INLINEABLE optionalHeader #-} 319 | 320 | requiredHeader :: 321 | (FromHttpApiData a) => 322 | HeaderName -> 323 | (a -> Wai.Application) -> 324 | Wai.Application 325 | requiredHeader name withHeader = \request respond -> 326 | case List.lookup name (Wai.requestHeaders request) of 327 | Nothing -> 328 | respond (Wai.responseBuilder (toEnum 400) [] mempty) 329 | Just value -> 330 | case parseHeader value of 331 | Left _err -> 332 | respond (Wai.responseBuilder (toEnum 400) [] mempty) 333 | Right x -> 334 | withHeader x request respond 335 | {-# INLINEABLE requiredHeader #-} 336 | 337 | data BodyParser a 338 | = BodyParser 339 | Network.HTTP.Media.MediaType 340 | ((a -> Wai.Application) -> Wai.Application) 341 | 342 | jsonBodyParser :: (Data.Aeson.FromJSON a) => BodyParser a 343 | jsonBodyParser = BodyParser "application/json" parseRequestBodyJSON 344 | {-# INLINE jsonBodyParser #-} 345 | 346 | formBodyParser :: (FromForm a) => BodyParser a 347 | formBodyParser = BodyParser "application/xxx-form-urlencoded" parseRequestBodyForm 348 | {-# INLINE formBodyParser #-} 349 | 350 | parseRequestBody :: [BodyParser a] -> (a -> Wai.Application) -> Wai.Application 351 | parseRequestBody parsers withBody = \request respond -> do 352 | let contentType = 353 | fromMaybe 354 | "application/octet-stream" 355 | (List.lookup hContentType (Wai.requestHeaders request)) 356 | 357 | bodyParser = 358 | Network.HTTP.Media.mapAccept 359 | [(mediaType, parser) | BodyParser mediaType parser <- parsers] 360 | contentType 361 | 362 | case bodyParser of 363 | Just parseBody -> 364 | parseBody withBody request respond 365 | Nothing -> 366 | respond (Wai.responseBuilder (toEnum 415) [] mempty) 367 | {-# INLINE parseRequestBody #-} 368 | 369 | parseRequestBodyJSON :: (Data.Aeson.FromJSON a) => (a -> Wai.Application) -> Wai.Application 370 | parseRequestBodyJSON withBody = \request respond -> do 371 | body <- Wai.lazyRequestBody request 372 | case Data.Aeson.decode' body of 373 | Nothing -> 374 | respond (Wai.responseBuilder (toEnum 400) [] mempty) 375 | Just body -> 376 | withBody body request respond 377 | {-# INLINEABLE parseRequestBodyJSON #-} 378 | 379 | parseRequestBodyForm :: (FromForm a) => (a -> Wai.Application) -> Wai.Application 380 | parseRequestBodyForm withBody = \request respond -> do 381 | body <- Wai.lazyRequestBody request 382 | case urlDecodeAsForm body of 383 | Left _err -> 384 | respond (Wai.responseBuilder (toEnum 400) [] mempty) 385 | Right form -> 386 | withBody form request respond 387 | {-# INLINEABLE parseRequestBodyForm #-} 388 | 389 | --------------------- 390 | Test/Response.hs 391 | 392 | module Test.Response 393 | ( ToResponse (..), 394 | 395 | -- * NDJSON support 396 | NDJSON, 397 | responseNDJSON, 398 | ) 399 | where 400 | 401 | import qualified Data.Aeson 402 | import qualified Data.Aeson.Encoding 403 | import qualified Data.ByteString.Builder 404 | import qualified Network.HTTP.Types 405 | import qualified Network.Wai 406 | 407 | type NDJSON element = ((element -> IO ()) -> IO () -> IO ()) 408 | 409 | responseNDJSON :: (Data.Aeson.ToJSON element) => Network.HTTP.Types.Status -> Network.HTTP.Types.ResponseHeaders -> NDJSON element -> Network.Wai.Response 410 | responseNDJSON status responseHeaders stream = 411 | Network.Wai.responseStream status responseHeaders $ \emit flush -> 412 | stream 413 | ( \element -> 414 | emit 415 | ( Data.Aeson.Encoding.fromEncoding (Data.Aeson.toEncoding element) 416 | <> Data.ByteString.Builder.char7 '\n' 417 | ) 418 | ) 419 | flush 420 | 421 | class ToResponse a where 422 | toResponse :: a -> Network.Wai.Response 423 | 424 | --------------------- 425 | Test/Response/Test.hs 426 | 427 | {-# LANGUAGE BangPatterns #-} 428 | {-# LANGUAGE DataKinds #-} 429 | {-# LANGUAGE DuplicateRecordFields #-} 430 | {-# LANGUAGE OverloadedStrings #-} 431 | {-# LANGUAGE RankNTypes #-} 432 | {-# LANGUAGE RecordWildCards #-} 433 | {-# LANGUAGE ScopedTypeVariables #-} 434 | module Test.Response.Test where 435 | 436 | import qualified Control.Applicative 437 | import qualified Control.Exception 438 | import qualified Control.Monad 439 | import qualified Control.Monad.IO.Class 440 | import qualified Data.Aeson 441 | import qualified Data.Aeson.Encoding 442 | import qualified Data.Aeson.Types 443 | import qualified Data.Attoparsec.ByteString 444 | import qualified Data.ByteString 445 | import qualified Data.List 446 | import qualified Data.List.NonEmpty 447 | import qualified Data.Map 448 | import qualified Data.Maybe 449 | import qualified Data.Text 450 | import qualified Data.Text.Encoding 451 | import qualified Data.Time 452 | import qualified GHC.Float 453 | import qualified GHC.Int 454 | import qualified GHC.Records 455 | import qualified GHC.Types 456 | import qualified Network.HTTP.Types 457 | import qualified Network.Wai 458 | import qualified Web.HttpApiData 459 | 460 | 461 | 462 | import Test.Response 463 | 464 | type TestResponseBody200 = Data.Aeson.Value 465 | 466 | data TestResponse 467 | = TestResponse200 [ TestResponseBody200 ] 468 | deriving (Show) 469 | 470 | instance ToResponse TestResponse where 471 | toResponse (TestResponse200 x) = 472 | Network.Wai.responseBuilder Network.HTTP.Types.status200 ([(Network.HTTP.Types.hContentType, "application/json")]) (Data.Aeson.fromEncoding (Data.Aeson.toEncoding x)) 473 | 474 | instance GHC.Records.HasField "status" TestResponse Network.HTTP.Types.Status where 475 | getField (TestResponse200 {}) = Network.HTTP.Types.status200 476 | --------------------- 477 | test.cabal 478 | 479 | cabal-version: 3.0 480 | name: test 481 | version: 0.1.0.0 482 | library 483 | build-depends: 484 | , aeson 485 | , attoparsec 486 | , base 487 | , bytestring 488 | , containers 489 | , ghc-prim 490 | , http-api-data 491 | , http-media 492 | , http-types 493 | , text 494 | , time 495 | , unordered-containers 496 | , wai 497 | exposed-modules: 498 | Test.Api 499 | Test.Request 500 | Test.Response 501 | Test.Response.Test -------------------------------------------------------------------------------- /test/golden/object-without-type.yaml.out: -------------------------------------------------------------------------------- 1 | Test/Api.hs 2 | 3 | {-# LANGUAGE BangPatterns #-} 4 | {-# LANGUAGE DataKinds #-} 5 | {-# LANGUAGE DuplicateRecordFields #-} 6 | {-# LANGUAGE OverloadedStrings #-} 7 | {-# LANGUAGE RankNTypes #-} 8 | {-# LANGUAGE RecordWildCards #-} 9 | {-# LANGUAGE ScopedTypeVariables #-} 10 | module Test.Api where 11 | 12 | import qualified Control.Applicative 13 | import qualified Control.Exception 14 | import qualified Control.Monad 15 | import qualified Control.Monad.IO.Class 16 | import qualified Data.Aeson 17 | import qualified Data.Aeson.Encoding 18 | import qualified Data.Aeson.Types 19 | import qualified Data.Attoparsec.ByteString 20 | import qualified Data.ByteString 21 | import qualified Data.List 22 | import qualified Data.List.NonEmpty 23 | import qualified Data.Map 24 | import qualified Data.Maybe 25 | import qualified Data.Text 26 | import qualified Data.Text.Encoding 27 | import qualified Data.Time 28 | import qualified GHC.Float 29 | import qualified GHC.Int 30 | import qualified GHC.Records 31 | import qualified GHC.Types 32 | import qualified Network.HTTP.Types 33 | import qualified Network.Wai 34 | import qualified Web.HttpApiData 35 | 36 | import Test.Request 37 | import Test.Response 38 | 39 | 40 | 41 | 42 | 43 | import Test.Response.Test 44 | 45 | data Api m = Api { 46 | -- | test 47 | test :: 48 | m TestResponse 49 | } 50 | 51 | application :: (Control.Monad.IO.Class.MonadIO m) => (forall a . Network.Wai.Request -> m a -> IO a) -> Api m -> Network.Wai.Application -> Network.Wai.Application 52 | application run api notFound request respond = 53 | case Network.Wai.pathInfo request of 54 | ["test"] -> 55 | case Network.Wai.requestMethod request of 56 | "GET" -> 57 | run request (do 58 | response <- test api 59 | Control.Monad.IO.Class.liftIO (respond $! (toResponse response)) 60 | ) 61 | x -> 62 | unsupportedMethod x 63 | 64 | _ -> 65 | notFound request respond 66 | where 67 | unsupportedMethod _ = 68 | respond (Network.Wai.responseBuilder Network.HTTP.Types.status405 [] mempty) 69 | {-# INLINABLE application #-} 70 | --------------------- 71 | Test/Request.hs 72 | 73 | {-# LANGUAGE OverloadedStrings #-} 74 | 75 | module Test.Request 76 | ( -- * Parameters 77 | Style (..), 78 | pathVariable, 79 | requiredQueryParameter, 80 | requiredQueryParameters, 81 | optionalQueryParameter, 82 | optionalQueryParameters, 83 | requiredHeader, 84 | optionalHeader, 85 | 86 | -- * Request body 87 | parseRequestBody, 88 | jsonBodyParser, 89 | formBodyParser, 90 | ) 91 | where 92 | 93 | import qualified Data.Aeson 94 | import qualified Data.Aeson.Types 95 | import Data.Attoparsec.ByteString (eitherResult, parseWith) 96 | import Data.ByteString (ByteString) 97 | import qualified Data.ByteString as ByteString 98 | import qualified Data.ByteString.Builder as Builder 99 | import qualified Data.ByteString.Lazy as LBS 100 | import Data.Coerce (coerce) 101 | import qualified Data.HashMap.Strict as HashMap 102 | import qualified Data.List as List 103 | import qualified Data.List.NonEmpty as NonEmpty 104 | import Data.Maybe (fromMaybe) 105 | import Data.Text (Text) 106 | import qualified Data.Text as Text 107 | import qualified Data.Text.Encoding as Text 108 | import qualified Network.HTTP.Media 109 | import Network.HTTP.Types (HeaderName, hContentType) 110 | import qualified Network.Wai as Wai 111 | import System.IO.Unsafe (unsafeInterleaveIO) 112 | import Web.FormUrlEncoded 113 | ( FromForm, 114 | parseAll, 115 | urlDecodeAsForm, 116 | urlDecodeForm, 117 | ) 118 | import Web.HttpApiData 119 | ( FromHttpApiData, 120 | parseHeader, 121 | parseQueryParam, 122 | parseUrlPiece, 123 | parseUrlPieces, 124 | ) 125 | 126 | pathVariable :: 127 | (FromHttpApiData a) => 128 | -- | Path variable value 129 | Text -> 130 | (a -> Wai.Application) -> 131 | Wai.Application 132 | pathVariable value withVariable = \request respond -> 133 | case parseUrlPiece value of 134 | Left _err -> 135 | respond (Wai.responseBuilder (toEnum 400) [] mempty) 136 | Right x -> 137 | withVariable x request respond 138 | {-# INLINEABLE pathVariable #-} 139 | 140 | data Style 141 | = FormStyle 142 | | CommaDelimitedStyle 143 | | SpaceDelimitedStyle 144 | | PipeDelimitedStyle 145 | 146 | newtype CommaDelimitedValue a = CommaDelimitedValue {unCommaDelimitedValue :: [a]} 147 | 148 | instance (FromHttpApiData a) => FromHttpApiData (CommaDelimitedValue a) where 149 | parseUrlPiece input = do 150 | xs <- parseUrlPieces (Text.splitOn "," input) 151 | pure (CommaDelimitedValue xs) 152 | 153 | newtype SpaceDelimitedValue a = SpaceDelimitedValue {unSpaceDelimitedValue :: [a]} 154 | 155 | instance (FromHttpApiData a) => FromHttpApiData (SpaceDelimitedValue a) where 156 | parseUrlPiece input = do 157 | xs <- parseUrlPieces (Text.splitOn " " input) 158 | pure (SpaceDelimitedValue xs) 159 | 160 | newtype PipeDelimitedValue a = PipeDelimitedValue {unPipeDelimitedValue :: [a]} 161 | 162 | instance (FromHttpApiData a) => FromHttpApiData (PipeDelimitedValue a) where 163 | parseUrlPiece input = do 164 | xs <- parseUrlPieces (Text.splitOn "|" input) 165 | pure (PipeDelimitedValue xs) 166 | 167 | requiredQueryParameters :: 168 | (FromHttpApiData a) => 169 | Style -> 170 | ByteString -> 171 | (NonEmpty.NonEmpty a -> Wai.Application) -> 172 | Wai.Application 173 | requiredQueryParameters style name withParam = 174 | case style of 175 | FormStyle -> \request respond -> 176 | case urlDecodeForm (LBS.fromStrict (ByteString.drop 1 (Wai.rawQueryString request))) of 177 | Left error -> 178 | respond (Wai.responseBuilder (toEnum 400) [] mempty) 179 | Right form -> 180 | case parseAll (Text.decodeUtf8 name) form of 181 | Left _ -> 182 | respond (Wai.responseBuilder (toEnum 400) [] mempty) 183 | Right [] -> 184 | respond (Wai.responseBuilder (toEnum 400) [] mempty) 185 | Right (x : xs) -> 186 | withParam (x NonEmpty.:| xs) request respond 187 | SpaceDelimitedStyle -> 188 | requiredQueryParameter 189 | name 190 | ( \xs -> \request respond -> 191 | case NonEmpty.nonEmpty (unSpaceDelimitedValue xs) of 192 | Nothing -> 193 | respond (Wai.responseBuilder (toEnum 400) [] mempty) 194 | Just xs -> 195 | withParam xs request respond 196 | ) 197 | PipeDelimitedStyle -> 198 | requiredQueryParameter 199 | name 200 | ( \xs -> \request respond -> 201 | case NonEmpty.nonEmpty (unPipeDelimitedValue xs) of 202 | Nothing -> 203 | respond (Wai.responseBuilder (toEnum 400) [] mempty) 204 | Just xs -> 205 | withParam xs request respond 206 | ) 207 | CommaDelimitedStyle -> 208 | requiredQueryParameter 209 | name 210 | ( \xs -> \request respond -> 211 | case NonEmpty.nonEmpty (unCommaDelimitedValue xs) of 212 | Nothing -> 213 | respond (Wai.responseBuilder (toEnum 400) [] mempty) 214 | Just xs -> 215 | withParam xs request respond 216 | ) 217 | 218 | optionalQueryParameters :: 219 | (FromHttpApiData a) => 220 | Style -> 221 | ByteString -> 222 | (Maybe (NonEmpty.NonEmpty a) -> Wai.Application) -> 223 | Wai.Application 224 | optionalQueryParameters style name withParam = 225 | case style of 226 | FormStyle -> \request respond -> 227 | case urlDecodeForm (LBS.fromStrict (ByteString.drop 1 (Wai.rawQueryString request))) of 228 | Left error -> 229 | respond (Wai.responseBuilder (toEnum 400) [] mempty) 230 | Right form -> 231 | case parseAll (Text.decodeUtf8 name) form of 232 | Left _ -> 233 | respond (Wai.responseBuilder (toEnum 400) [] mempty) 234 | Right [] -> 235 | withParam Nothing request respond 236 | Right (x : xs) -> 237 | withParam (Just (x NonEmpty.:| xs)) request respond 238 | SpaceDelimitedStyle -> 239 | optionalQueryParameter 240 | name 241 | False 242 | ( \xs -> 243 | withParam (xs >>= NonEmpty.nonEmpty . unSpaceDelimitedValue) 244 | ) 245 | PipeDelimitedStyle -> 246 | optionalQueryParameter 247 | name 248 | False 249 | ( \xs -> 250 | withParam (xs >>= NonEmpty.nonEmpty . unPipeDelimitedValue) 251 | ) 252 | CommaDelimitedStyle -> 253 | optionalQueryParameter 254 | name 255 | False 256 | ( \xs -> 257 | withParam (xs >>= NonEmpty.nonEmpty . unCommaDelimitedValue) 258 | ) 259 | 260 | requiredQueryParameter :: 261 | (FromHttpApiData a) => 262 | ByteString -> 263 | (a -> Wai.Application) -> 264 | Wai.Application 265 | requiredQueryParameter name withParam = \request respond -> 266 | case List.lookup name (Wai.queryString request) of 267 | Nothing -> 268 | respond (Wai.responseBuilder (toEnum 400) [] ("Missing query parameter: " <> Builder.byteString name)) 269 | Just Nothing -> 270 | respond (Wai.responseBuilder (toEnum 400) [] ("Missing query parameter: " <> Builder.byteString name)) 271 | Just (Just value) -> 272 | case parseQueryParam (Text.decodeUtf8 value) of 273 | Left _err -> 274 | respond (Wai.responseBuilder (toEnum 400) [] ("Unable to recognize query parameter: " <> Builder.byteString name)) 275 | Right x -> 276 | withParam x request respond 277 | {-# INLINEABLE requiredQueryParameter #-} 278 | 279 | optionalQueryParameter :: 280 | (FromHttpApiData a) => 281 | ByteString -> 282 | -- | Allow empty, e.g. "x=" 283 | Bool -> 284 | (Maybe a -> Wai.Application) -> 285 | Wai.Application 286 | optionalQueryParameter name allowEmpty withParam = \request respond -> 287 | case List.lookup name (Wai.queryString request) of 288 | Nothing -> 289 | withParam Nothing request respond 290 | Just Nothing 291 | | allowEmpty -> 292 | withParam Nothing request respond 293 | | otherwise -> 294 | respond (Wai.responseBuilder (toEnum 400) [] ("Missing query parameter: " <> Builder.byteString name)) 295 | Just (Just value) -> 296 | case parseQueryParam (Text.decodeUtf8 value) of 297 | Left _err -> 298 | respond (Wai.responseBuilder (toEnum 400) [] ("Unable to recognize query parameter: " <> Builder.byteString name)) 299 | Right x -> 300 | withParam (Just x) request respond 301 | {-# INLINEABLE optionalQueryParameter #-} 302 | 303 | optionalHeader :: 304 | (FromHttpApiData a) => 305 | HeaderName -> 306 | (Maybe a -> Wai.Application) -> 307 | Wai.Application 308 | optionalHeader name withHeader = \request respond -> 309 | case List.lookup name (Wai.requestHeaders request) of 310 | Nothing -> 311 | withHeader Nothing request respond 312 | Just value -> 313 | case parseHeader value of 314 | Left _err -> 315 | respond (Wai.responseBuilder (toEnum 400) [] mempty) 316 | Right x -> 317 | withHeader (Just x) request respond 318 | {-# INLINEABLE optionalHeader #-} 319 | 320 | requiredHeader :: 321 | (FromHttpApiData a) => 322 | HeaderName -> 323 | (a -> Wai.Application) -> 324 | Wai.Application 325 | requiredHeader name withHeader = \request respond -> 326 | case List.lookup name (Wai.requestHeaders request) of 327 | Nothing -> 328 | respond (Wai.responseBuilder (toEnum 400) [] mempty) 329 | Just value -> 330 | case parseHeader value of 331 | Left _err -> 332 | respond (Wai.responseBuilder (toEnum 400) [] mempty) 333 | Right x -> 334 | withHeader x request respond 335 | {-# INLINEABLE requiredHeader #-} 336 | 337 | data BodyParser a 338 | = BodyParser 339 | Network.HTTP.Media.MediaType 340 | ((a -> Wai.Application) -> Wai.Application) 341 | 342 | jsonBodyParser :: (Data.Aeson.FromJSON a) => BodyParser a 343 | jsonBodyParser = BodyParser "application/json" parseRequestBodyJSON 344 | {-# INLINE jsonBodyParser #-} 345 | 346 | formBodyParser :: (FromForm a) => BodyParser a 347 | formBodyParser = BodyParser "application/xxx-form-urlencoded" parseRequestBodyForm 348 | {-# INLINE formBodyParser #-} 349 | 350 | parseRequestBody :: [BodyParser a] -> (a -> Wai.Application) -> Wai.Application 351 | parseRequestBody parsers withBody = \request respond -> do 352 | let contentType = 353 | fromMaybe 354 | "application/octet-stream" 355 | (List.lookup hContentType (Wai.requestHeaders request)) 356 | 357 | bodyParser = 358 | Network.HTTP.Media.mapAccept 359 | [(mediaType, parser) | BodyParser mediaType parser <- parsers] 360 | contentType 361 | 362 | case bodyParser of 363 | Just parseBody -> 364 | parseBody withBody request respond 365 | Nothing -> 366 | respond (Wai.responseBuilder (toEnum 415) [] mempty) 367 | {-# INLINE parseRequestBody #-} 368 | 369 | parseRequestBodyJSON :: (Data.Aeson.FromJSON a) => (a -> Wai.Application) -> Wai.Application 370 | parseRequestBodyJSON withBody = \request respond -> do 371 | body <- Wai.lazyRequestBody request 372 | case Data.Aeson.decode' body of 373 | Nothing -> 374 | respond (Wai.responseBuilder (toEnum 400) [] mempty) 375 | Just body -> 376 | withBody body request respond 377 | {-# INLINEABLE parseRequestBodyJSON #-} 378 | 379 | parseRequestBodyForm :: (FromForm a) => (a -> Wai.Application) -> Wai.Application 380 | parseRequestBodyForm withBody = \request respond -> do 381 | body <- Wai.lazyRequestBody request 382 | case urlDecodeAsForm body of 383 | Left _err -> 384 | respond (Wai.responseBuilder (toEnum 400) [] mempty) 385 | Right form -> 386 | withBody form request respond 387 | {-# INLINEABLE parseRequestBodyForm #-} 388 | 389 | --------------------- 390 | Test/Response.hs 391 | 392 | module Test.Response 393 | ( ToResponse (..), 394 | 395 | -- * NDJSON support 396 | NDJSON, 397 | responseNDJSON, 398 | ) 399 | where 400 | 401 | import qualified Data.Aeson 402 | import qualified Data.Aeson.Encoding 403 | import qualified Data.ByteString.Builder 404 | import qualified Network.HTTP.Types 405 | import qualified Network.Wai 406 | 407 | type NDJSON element = ((element -> IO ()) -> IO () -> IO ()) 408 | 409 | responseNDJSON :: (Data.Aeson.ToJSON element) => Network.HTTP.Types.Status -> Network.HTTP.Types.ResponseHeaders -> NDJSON element -> Network.Wai.Response 410 | responseNDJSON status responseHeaders stream = 411 | Network.Wai.responseStream status responseHeaders $ \emit flush -> 412 | stream 413 | ( \element -> 414 | emit 415 | ( Data.Aeson.Encoding.fromEncoding (Data.Aeson.toEncoding element) 416 | <> Data.ByteString.Builder.char7 '\n' 417 | ) 418 | ) 419 | flush 420 | 421 | class ToResponse a where 422 | toResponse :: a -> Network.Wai.Response 423 | 424 | --------------------- 425 | Test/Response/Test.hs 426 | 427 | {-# LANGUAGE BangPatterns #-} 428 | {-# LANGUAGE DataKinds #-} 429 | {-# LANGUAGE DuplicateRecordFields #-} 430 | {-# LANGUAGE OverloadedStrings #-} 431 | {-# LANGUAGE RankNTypes #-} 432 | {-# LANGUAGE RecordWildCards #-} 433 | {-# LANGUAGE ScopedTypeVariables #-} 434 | module Test.Response.Test where 435 | 436 | import qualified Control.Applicative 437 | import qualified Control.Exception 438 | import qualified Control.Monad 439 | import qualified Control.Monad.IO.Class 440 | import qualified Data.Aeson 441 | import qualified Data.Aeson.Encoding 442 | import qualified Data.Aeson.Types 443 | import qualified Data.Attoparsec.ByteString 444 | import qualified Data.ByteString 445 | import qualified Data.List 446 | import qualified Data.List.NonEmpty 447 | import qualified Data.Map 448 | import qualified Data.Maybe 449 | import qualified Data.Text 450 | import qualified Data.Text.Encoding 451 | import qualified Data.Time 452 | import qualified GHC.Float 453 | import qualified GHC.Int 454 | import qualified GHC.Records 455 | import qualified GHC.Types 456 | import qualified Network.HTTP.Types 457 | import qualified Network.Wai 458 | import qualified Web.HttpApiData 459 | 460 | 461 | 462 | import Test.Response 463 | 464 | type TestResponseBody200 = Data.Aeson.Value 465 | 466 | data TestResponse 467 | = TestResponse200 TestResponseBody200 468 | deriving (Show) 469 | 470 | instance ToResponse TestResponse where 471 | toResponse (TestResponse200 x) = 472 | Network.Wai.responseBuilder Network.HTTP.Types.status200 ([(Network.HTTP.Types.hContentType, "application/json")]) (Data.Aeson.fromEncoding (Data.Aeson.toEncoding x)) 473 | 474 | instance GHC.Records.HasField "status" TestResponse Network.HTTP.Types.Status where 475 | getField (TestResponse200 {}) = Network.HTTP.Types.status200 476 | --------------------- 477 | test.cabal 478 | 479 | cabal-version: 3.0 480 | name: test 481 | version: 0.1.0.0 482 | library 483 | build-depends: 484 | , aeson 485 | , attoparsec 486 | , base 487 | , bytestring 488 | , containers 489 | , ghc-prim 490 | , http-api-data 491 | , http-media 492 | , http-types 493 | , text 494 | , time 495 | , unordered-containers 496 | , wai 497 | exposed-modules: 498 | Test.Api 499 | Test.Request 500 | Test.Response 501 | Test.Response.Test -------------------------------------------------------------------------------- /test/golden/description.yaml.out: -------------------------------------------------------------------------------- 1 | Test/Api.hs 2 | 3 | {-# LANGUAGE BangPatterns #-} 4 | {-# LANGUAGE DataKinds #-} 5 | {-# LANGUAGE DuplicateRecordFields #-} 6 | {-# LANGUAGE OverloadedStrings #-} 7 | {-# LANGUAGE RankNTypes #-} 8 | {-# LANGUAGE RecordWildCards #-} 9 | {-# LANGUAGE ScopedTypeVariables #-} 10 | module Test.Api where 11 | 12 | import qualified Control.Applicative 13 | import qualified Control.Exception 14 | import qualified Control.Monad 15 | import qualified Control.Monad.IO.Class 16 | import qualified Data.Aeson 17 | import qualified Data.Aeson.Encoding 18 | import qualified Data.Aeson.Types 19 | import qualified Data.Attoparsec.ByteString 20 | import qualified Data.ByteString 21 | import qualified Data.List 22 | import qualified Data.List.NonEmpty 23 | import qualified Data.Map 24 | import qualified Data.Maybe 25 | import qualified Data.Text 26 | import qualified Data.Text.Encoding 27 | import qualified Data.Time 28 | import qualified GHC.Float 29 | import qualified GHC.Int 30 | import qualified GHC.Records 31 | import qualified GHC.Types 32 | import qualified Network.HTTP.Types 33 | import qualified Network.Wai 34 | import qualified Web.HttpApiData 35 | 36 | import Test.Request 37 | import Test.Response 38 | 39 | 40 | 41 | 42 | 43 | import Test.Response.Test 44 | 45 | data Api m = Api { 46 | -- | test 47 | test :: 48 | -- @package_query@ 49 | -- Use this query parameter to filter for the packages thats suits your use case. It can be used by passing in either package names or package ids. To query for multiple packages you can pass in comma separated values. For example: 50 | -- ``` 51 | -- package_query=17ea97c0-d350-45ce-9f36-ebb66694196c,558664cd-fece-47f5-a9ca-f30974cf96a5,... 52 | -- ``` 53 | -- Or if you prefer using package names, you can also pass in 54 | -- ``` 55 | -- package_query=package_name_1,package_name_2... 56 | -- ``` 57 | (Data.Maybe.Maybe (Data.Text.Text)) -> 58 | m TestResponse 59 | } 60 | 61 | application :: (Control.Monad.IO.Class.MonadIO m) => (forall a . Network.Wai.Request -> m a -> IO a) -> Api m -> Network.Wai.Application -> Network.Wai.Application 62 | application run api notFound request respond = 63 | case Network.Wai.pathInfo request of 64 | ["test"] -> 65 | case Network.Wai.requestMethod request of 66 | "GET" -> 67 | optionalQueryParameter "package_query" False (\__package_query request respond -> 68 | run request (do 69 | response <- test api __package_query 70 | Control.Monad.IO.Class.liftIO (respond $! (toResponse response)) 71 | )) request respond 72 | x -> 73 | unsupportedMethod x 74 | 75 | _ -> 76 | notFound request respond 77 | where 78 | unsupportedMethod _ = 79 | respond (Network.Wai.responseBuilder Network.HTTP.Types.status405 [] mempty) 80 | {-# INLINABLE application #-} 81 | --------------------- 82 | Test/Request.hs 83 | 84 | {-# LANGUAGE OverloadedStrings #-} 85 | 86 | module Test.Request 87 | ( -- * Parameters 88 | Style (..), 89 | pathVariable, 90 | requiredQueryParameter, 91 | requiredQueryParameters, 92 | optionalQueryParameter, 93 | optionalQueryParameters, 94 | requiredHeader, 95 | optionalHeader, 96 | 97 | -- * Request body 98 | parseRequestBody, 99 | jsonBodyParser, 100 | formBodyParser, 101 | ) 102 | where 103 | 104 | import qualified Data.Aeson 105 | import qualified Data.Aeson.Types 106 | import Data.Attoparsec.ByteString (eitherResult, parseWith) 107 | import Data.ByteString (ByteString) 108 | import qualified Data.ByteString as ByteString 109 | import qualified Data.ByteString.Builder as Builder 110 | import qualified Data.ByteString.Lazy as LBS 111 | import Data.Coerce (coerce) 112 | import qualified Data.HashMap.Strict as HashMap 113 | import qualified Data.List as List 114 | import qualified Data.List.NonEmpty as NonEmpty 115 | import Data.Maybe (fromMaybe) 116 | import Data.Text (Text) 117 | import qualified Data.Text as Text 118 | import qualified Data.Text.Encoding as Text 119 | import qualified Network.HTTP.Media 120 | import Network.HTTP.Types (HeaderName, hContentType) 121 | import qualified Network.Wai as Wai 122 | import System.IO.Unsafe (unsafeInterleaveIO) 123 | import Web.FormUrlEncoded 124 | ( FromForm, 125 | parseAll, 126 | urlDecodeAsForm, 127 | urlDecodeForm, 128 | ) 129 | import Web.HttpApiData 130 | ( FromHttpApiData, 131 | parseHeader, 132 | parseQueryParam, 133 | parseUrlPiece, 134 | parseUrlPieces, 135 | ) 136 | 137 | pathVariable :: 138 | (FromHttpApiData a) => 139 | -- | Path variable value 140 | Text -> 141 | (a -> Wai.Application) -> 142 | Wai.Application 143 | pathVariable value withVariable = \request respond -> 144 | case parseUrlPiece value of 145 | Left _err -> 146 | respond (Wai.responseBuilder (toEnum 400) [] mempty) 147 | Right x -> 148 | withVariable x request respond 149 | {-# INLINEABLE pathVariable #-} 150 | 151 | data Style 152 | = FormStyle 153 | | CommaDelimitedStyle 154 | | SpaceDelimitedStyle 155 | | PipeDelimitedStyle 156 | 157 | newtype CommaDelimitedValue a = CommaDelimitedValue {unCommaDelimitedValue :: [a]} 158 | 159 | instance (FromHttpApiData a) => FromHttpApiData (CommaDelimitedValue a) where 160 | parseUrlPiece input = do 161 | xs <- parseUrlPieces (Text.splitOn "," input) 162 | pure (CommaDelimitedValue xs) 163 | 164 | newtype SpaceDelimitedValue a = SpaceDelimitedValue {unSpaceDelimitedValue :: [a]} 165 | 166 | instance (FromHttpApiData a) => FromHttpApiData (SpaceDelimitedValue a) where 167 | parseUrlPiece input = do 168 | xs <- parseUrlPieces (Text.splitOn " " input) 169 | pure (SpaceDelimitedValue xs) 170 | 171 | newtype PipeDelimitedValue a = PipeDelimitedValue {unPipeDelimitedValue :: [a]} 172 | 173 | instance (FromHttpApiData a) => FromHttpApiData (PipeDelimitedValue a) where 174 | parseUrlPiece input = do 175 | xs <- parseUrlPieces (Text.splitOn "|" input) 176 | pure (PipeDelimitedValue xs) 177 | 178 | requiredQueryParameters :: 179 | (FromHttpApiData a) => 180 | Style -> 181 | ByteString -> 182 | (NonEmpty.NonEmpty a -> Wai.Application) -> 183 | Wai.Application 184 | requiredQueryParameters style name withParam = 185 | case style of 186 | FormStyle -> \request respond -> 187 | case urlDecodeForm (LBS.fromStrict (ByteString.drop 1 (Wai.rawQueryString request))) of 188 | Left error -> 189 | respond (Wai.responseBuilder (toEnum 400) [] mempty) 190 | Right form -> 191 | case parseAll (Text.decodeUtf8 name) form of 192 | Left _ -> 193 | respond (Wai.responseBuilder (toEnum 400) [] mempty) 194 | Right [] -> 195 | respond (Wai.responseBuilder (toEnum 400) [] mempty) 196 | Right (x : xs) -> 197 | withParam (x NonEmpty.:| xs) request respond 198 | SpaceDelimitedStyle -> 199 | requiredQueryParameter 200 | name 201 | ( \xs -> \request respond -> 202 | case NonEmpty.nonEmpty (unSpaceDelimitedValue xs) of 203 | Nothing -> 204 | respond (Wai.responseBuilder (toEnum 400) [] mempty) 205 | Just xs -> 206 | withParam xs request respond 207 | ) 208 | PipeDelimitedStyle -> 209 | requiredQueryParameter 210 | name 211 | ( \xs -> \request respond -> 212 | case NonEmpty.nonEmpty (unPipeDelimitedValue xs) of 213 | Nothing -> 214 | respond (Wai.responseBuilder (toEnum 400) [] mempty) 215 | Just xs -> 216 | withParam xs request respond 217 | ) 218 | CommaDelimitedStyle -> 219 | requiredQueryParameter 220 | name 221 | ( \xs -> \request respond -> 222 | case NonEmpty.nonEmpty (unCommaDelimitedValue xs) of 223 | Nothing -> 224 | respond (Wai.responseBuilder (toEnum 400) [] mempty) 225 | Just xs -> 226 | withParam xs request respond 227 | ) 228 | 229 | optionalQueryParameters :: 230 | (FromHttpApiData a) => 231 | Style -> 232 | ByteString -> 233 | (Maybe (NonEmpty.NonEmpty a) -> Wai.Application) -> 234 | Wai.Application 235 | optionalQueryParameters style name withParam = 236 | case style of 237 | FormStyle -> \request respond -> 238 | case urlDecodeForm (LBS.fromStrict (ByteString.drop 1 (Wai.rawQueryString request))) of 239 | Left error -> 240 | respond (Wai.responseBuilder (toEnum 400) [] mempty) 241 | Right form -> 242 | case parseAll (Text.decodeUtf8 name) form of 243 | Left _ -> 244 | respond (Wai.responseBuilder (toEnum 400) [] mempty) 245 | Right [] -> 246 | withParam Nothing request respond 247 | Right (x : xs) -> 248 | withParam (Just (x NonEmpty.:| xs)) request respond 249 | SpaceDelimitedStyle -> 250 | optionalQueryParameter 251 | name 252 | False 253 | ( \xs -> 254 | withParam (xs >>= NonEmpty.nonEmpty . unSpaceDelimitedValue) 255 | ) 256 | PipeDelimitedStyle -> 257 | optionalQueryParameter 258 | name 259 | False 260 | ( \xs -> 261 | withParam (xs >>= NonEmpty.nonEmpty . unPipeDelimitedValue) 262 | ) 263 | CommaDelimitedStyle -> 264 | optionalQueryParameter 265 | name 266 | False 267 | ( \xs -> 268 | withParam (xs >>= NonEmpty.nonEmpty . unCommaDelimitedValue) 269 | ) 270 | 271 | requiredQueryParameter :: 272 | (FromHttpApiData a) => 273 | ByteString -> 274 | (a -> Wai.Application) -> 275 | Wai.Application 276 | requiredQueryParameter name withParam = \request respond -> 277 | case List.lookup name (Wai.queryString request) of 278 | Nothing -> 279 | respond (Wai.responseBuilder (toEnum 400) [] ("Missing query parameter: " <> Builder.byteString name)) 280 | Just Nothing -> 281 | respond (Wai.responseBuilder (toEnum 400) [] ("Missing query parameter: " <> Builder.byteString name)) 282 | Just (Just value) -> 283 | case parseQueryParam (Text.decodeUtf8 value) of 284 | Left _err -> 285 | respond (Wai.responseBuilder (toEnum 400) [] ("Unable to recognize query parameter: " <> Builder.byteString name)) 286 | Right x -> 287 | withParam x request respond 288 | {-# INLINEABLE requiredQueryParameter #-} 289 | 290 | optionalQueryParameter :: 291 | (FromHttpApiData a) => 292 | ByteString -> 293 | -- | Allow empty, e.g. "x=" 294 | Bool -> 295 | (Maybe a -> Wai.Application) -> 296 | Wai.Application 297 | optionalQueryParameter name allowEmpty withParam = \request respond -> 298 | case List.lookup name (Wai.queryString request) of 299 | Nothing -> 300 | withParam Nothing request respond 301 | Just Nothing 302 | | allowEmpty -> 303 | withParam Nothing request respond 304 | | otherwise -> 305 | respond (Wai.responseBuilder (toEnum 400) [] ("Missing query parameter: " <> Builder.byteString name)) 306 | Just (Just value) -> 307 | case parseQueryParam (Text.decodeUtf8 value) of 308 | Left _err -> 309 | respond (Wai.responseBuilder (toEnum 400) [] ("Unable to recognize query parameter: " <> Builder.byteString name)) 310 | Right x -> 311 | withParam (Just x) request respond 312 | {-# INLINEABLE optionalQueryParameter #-} 313 | 314 | optionalHeader :: 315 | (FromHttpApiData a) => 316 | HeaderName -> 317 | (Maybe a -> Wai.Application) -> 318 | Wai.Application 319 | optionalHeader name withHeader = \request respond -> 320 | case List.lookup name (Wai.requestHeaders request) of 321 | Nothing -> 322 | withHeader Nothing request respond 323 | Just value -> 324 | case parseHeader value of 325 | Left _err -> 326 | respond (Wai.responseBuilder (toEnum 400) [] mempty) 327 | Right x -> 328 | withHeader (Just x) request respond 329 | {-# INLINEABLE optionalHeader #-} 330 | 331 | requiredHeader :: 332 | (FromHttpApiData a) => 333 | HeaderName -> 334 | (a -> Wai.Application) -> 335 | Wai.Application 336 | requiredHeader name withHeader = \request respond -> 337 | case List.lookup name (Wai.requestHeaders request) of 338 | Nothing -> 339 | respond (Wai.responseBuilder (toEnum 400) [] mempty) 340 | Just value -> 341 | case parseHeader value of 342 | Left _err -> 343 | respond (Wai.responseBuilder (toEnum 400) [] mempty) 344 | Right x -> 345 | withHeader x request respond 346 | {-# INLINEABLE requiredHeader #-} 347 | 348 | data BodyParser a 349 | = BodyParser 350 | Network.HTTP.Media.MediaType 351 | ((a -> Wai.Application) -> Wai.Application) 352 | 353 | jsonBodyParser :: (Data.Aeson.FromJSON a) => BodyParser a 354 | jsonBodyParser = BodyParser "application/json" parseRequestBodyJSON 355 | {-# INLINE jsonBodyParser #-} 356 | 357 | formBodyParser :: (FromForm a) => BodyParser a 358 | formBodyParser = BodyParser "application/xxx-form-urlencoded" parseRequestBodyForm 359 | {-# INLINE formBodyParser #-} 360 | 361 | parseRequestBody :: [BodyParser a] -> (a -> Wai.Application) -> Wai.Application 362 | parseRequestBody parsers withBody = \request respond -> do 363 | let contentType = 364 | fromMaybe 365 | "application/octet-stream" 366 | (List.lookup hContentType (Wai.requestHeaders request)) 367 | 368 | bodyParser = 369 | Network.HTTP.Media.mapAccept 370 | [(mediaType, parser) | BodyParser mediaType parser <- parsers] 371 | contentType 372 | 373 | case bodyParser of 374 | Just parseBody -> 375 | parseBody withBody request respond 376 | Nothing -> 377 | respond (Wai.responseBuilder (toEnum 415) [] mempty) 378 | {-# INLINE parseRequestBody #-} 379 | 380 | parseRequestBodyJSON :: (Data.Aeson.FromJSON a) => (a -> Wai.Application) -> Wai.Application 381 | parseRequestBodyJSON withBody = \request respond -> do 382 | body <- Wai.lazyRequestBody request 383 | case Data.Aeson.decode' body of 384 | Nothing -> 385 | respond (Wai.responseBuilder (toEnum 400) [] mempty) 386 | Just body -> 387 | withBody body request respond 388 | {-# INLINEABLE parseRequestBodyJSON #-} 389 | 390 | parseRequestBodyForm :: (FromForm a) => (a -> Wai.Application) -> Wai.Application 391 | parseRequestBodyForm withBody = \request respond -> do 392 | body <- Wai.lazyRequestBody request 393 | case urlDecodeAsForm body of 394 | Left _err -> 395 | respond (Wai.responseBuilder (toEnum 400) [] mempty) 396 | Right form -> 397 | withBody form request respond 398 | {-# INLINEABLE parseRequestBodyForm #-} 399 | 400 | --------------------- 401 | Test/Response.hs 402 | 403 | module Test.Response 404 | ( ToResponse (..), 405 | 406 | -- * NDJSON support 407 | NDJSON, 408 | responseNDJSON, 409 | ) 410 | where 411 | 412 | import qualified Data.Aeson 413 | import qualified Data.Aeson.Encoding 414 | import qualified Data.ByteString.Builder 415 | import qualified Network.HTTP.Types 416 | import qualified Network.Wai 417 | 418 | type NDJSON element = ((element -> IO ()) -> IO () -> IO ()) 419 | 420 | responseNDJSON :: (Data.Aeson.ToJSON element) => Network.HTTP.Types.Status -> Network.HTTP.Types.ResponseHeaders -> NDJSON element -> Network.Wai.Response 421 | responseNDJSON status responseHeaders stream = 422 | Network.Wai.responseStream status responseHeaders $ \emit flush -> 423 | stream 424 | ( \element -> 425 | emit 426 | ( Data.Aeson.Encoding.fromEncoding (Data.Aeson.toEncoding element) 427 | <> Data.ByteString.Builder.char7 '\n' 428 | ) 429 | ) 430 | flush 431 | 432 | class ToResponse a where 433 | toResponse :: a -> Network.Wai.Response 434 | 435 | --------------------- 436 | Test/Response/Test.hs 437 | 438 | {-# LANGUAGE BangPatterns #-} 439 | {-# LANGUAGE DataKinds #-} 440 | {-# LANGUAGE DuplicateRecordFields #-} 441 | {-# LANGUAGE OverloadedStrings #-} 442 | {-# LANGUAGE RankNTypes #-} 443 | {-# LANGUAGE RecordWildCards #-} 444 | {-# LANGUAGE ScopedTypeVariables #-} 445 | module Test.Response.Test where 446 | 447 | import qualified Control.Applicative 448 | import qualified Control.Exception 449 | import qualified Control.Monad 450 | import qualified Control.Monad.IO.Class 451 | import qualified Data.Aeson 452 | import qualified Data.Aeson.Encoding 453 | import qualified Data.Aeson.Types 454 | import qualified Data.Attoparsec.ByteString 455 | import qualified Data.ByteString 456 | import qualified Data.List 457 | import qualified Data.List.NonEmpty 458 | import qualified Data.Map 459 | import qualified Data.Maybe 460 | import qualified Data.Text 461 | import qualified Data.Text.Encoding 462 | import qualified Data.Time 463 | import qualified GHC.Float 464 | import qualified GHC.Int 465 | import qualified GHC.Records 466 | import qualified GHC.Types 467 | import qualified Network.HTTP.Types 468 | import qualified Network.Wai 469 | import qualified Web.HttpApiData 470 | 471 | 472 | 473 | import Test.Response 474 | 475 | type TestResponseBody200 = Data.Aeson.Value 476 | 477 | data TestResponse 478 | = TestResponse200 [ TestResponseBody200 ] 479 | deriving (Show) 480 | 481 | instance ToResponse TestResponse where 482 | toResponse (TestResponse200 x) = 483 | Network.Wai.responseBuilder Network.HTTP.Types.status200 ([(Network.HTTP.Types.hContentType, "application/json")]) (Data.Aeson.fromEncoding (Data.Aeson.toEncoding x)) 484 | 485 | instance GHC.Records.HasField "status" TestResponse Network.HTTP.Types.Status where 486 | getField (TestResponse200 {}) = Network.HTTP.Types.status200 487 | --------------------- 488 | test.cabal 489 | 490 | cabal-version: 3.0 491 | name: test 492 | version: 0.1.0.0 493 | library 494 | build-depends: 495 | , aeson 496 | , attoparsec 497 | , base 498 | , bytestring 499 | , containers 500 | , ghc-prim 501 | , http-api-data 502 | , http-media 503 | , http-types 504 | , text 505 | , time 506 | , unordered-containers 507 | , wai 508 | exposed-modules: 509 | Test.Api 510 | Test.Request 511 | Test.Response 512 | Test.Response.Test --------------------------------------------------------------------------------