scarf-sh/tie
1
1
Fork 0
mirror of https://github.com/scarf-sh/tie.git synced 2024-11-23 02:56:59 +03:00
Code Issues Packages Projects Releases Wiki Activity

Simplify code generation by introducing helper code

Browse Source
This commit is contained in:
Alex Biehl 2022-03-02 09:36:08 +01:00
parent 61135dc28a
commit c0ba255931
15 changed files with 854 additions and 190 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

98
Request.template.hs Normal file
View File

@ -0,0 +1,98 @@
{-# LANGUAGE OverloadedStrings #-}
module Tie.Template.Request_
( pathVariable,
requiredQueryParameter,
optionalQueryParameter,
parseRequestBodyJSON,
)
where
import Data.Aeson (FromJSON, parseJSON)
import qualified Data.Aeson.Parser
import qualified Data.Aeson.Types
import Data.Attoparsec.ByteString (eitherResult, parseWith)
import Data.ByteString (ByteString)
import qualified Data.ByteString as ByteString
import qualified Data.List as List
import Data.Text (Text)
import qualified Data.Text as Text
import qualified Data.Text.Encoding as Text
import qualified Network.Wai as Wai
import Web.HttpApiData
( FromHttpApiData,
parseQueryParam,
parseUrlPiece,
)
pathVariable ::
FromHttpApiData a =>
-- | Path variable value
Text ->
(a -> Wai.Application) ->
Wai.Application
pathVariable value withVariable = \request respond ->
case parseUrlPiece value of
Left err ->
undefined
Right x ->
withVariable x request respond
requiredQueryParameter ::
FromHttpApiData a =>
ByteString ->
(a -> Wai.Application) ->
Wai.Application
requiredQueryParameter name withParam = \request respond ->
case List.lookup name (Wai.queryString request) of
Nothing ->
undefined
Just Nothing ->
undefined
Just (Just value) ->
case parseQueryParam (Text.decodeUtf8 value) of
Left err ->
undefined
Right x ->
withParam x request respond
optionalQueryParameter ::
FromHttpApiData a =>
ByteString ->
-- | Allow empty, e.g. "x="
Bool ->
(Maybe a -> Wai.Application) ->
Wai.Application
optionalQueryParameter name allowEmpty withParam = \request respond ->
case List.lookup name (Wai.queryString request) of
Nothing ->
withParam Nothing request respond
Just Nothing
| allowEmpty ->
withParam Nothing request respond
| otherwise ->
undefined
Just (Just value) ->
case parseQueryParam (Text.decodeUtf8 value) of
Left err ->
undefined
Right x ->
withParam (Just x) request respond
parseRequestBodyJSON :: FromJSON a => (a -> Wai.Application) -> Wai.Application
parseRequestBodyJSON withBody = \request respond ->
case List.lookup "Content-Type" (Wai.requestHeaders request) of
Just "application/json" -> do
result <- parseWith (Wai.getRequestBodyChunk request) Data.Aeson.Parser.json' mempty
case eitherResult result of
Left err ->
undefined
Right value ->
case Data.Aeson.Types.parseEither Data.Aeson.parseJSON value of
Left err ->
undefined
Right body ->
withBody body request respond
_ ->
-- unsupported media type
undefined

13
src/Tie.hs
View File

@ -15,6 +15,7 @@ import qualified Data.OpenApi as OpenApi
import qualified Data.Set as Set
import Data.Yaml (decodeFileThrow)
import Prettyprinter (Doc, vsep)
import Prettyprinter.Internal (unsafeTextWithoutNewlines)
import Tie.Codegen.Cabal (codegenCabalFile)
import Tie.Codegen.Imports
( codegenExtraApiModuleDependencies,
@ -27,6 +28,7 @@ import Tie.Codegen.Operation
( codegenOperation,
codegenOperations,
)
import Tie.Codegen.Request (codegenRequestAuxFile)
import Tie.Codegen.Response (codegenResponseAuxFile, codegenResponses)
import Tie.Codegen.Schema (codegenSchema)
import Tie.Name
@ -38,6 +40,8 @@ import Tie.Name
inlineArrayElementTypeName,
inlineObjectTypeName,
inlineVariantTypeName,
requestHaskellFileName,
requestHaskellModuleName,
responseHaskellFileName,
responseHaskellModuleName,
toOperationHaskellFileName,
@ -218,6 +222,12 @@ generate write packageName apiName inputFile = do
codegenResponseAuxFile
]
-- Generate auxliary definitions in Request.hs
let path = requestHaskellFileName apiName
write path $
unsafeTextWithoutNewlines $
codegenRequestAuxFile (requestHaskellModuleName apiName)
-- Generate a single Api.hs module containing the server for the api
-- Normalize operations, to give all anonymous types a name
@ -267,7 +277,8 @@ generate write packageName apiName inputFile = do
map (toSchemaHaskellModuleName apiName) allReferencedSchemas
++ foldMap (map (toResponseHaskellModuleName apiName) . operationResponseDependencies) operations
++ [ apiHaskellModuleName apiName,
responseHaskellModuleName apiName
responseHaskellModuleName apiName,
requestHaskellModuleName apiName
]
path = cabalFileName packageName

1
src/Tie/Codegen/Cabal.hs
View File

@ -22,6 +22,7 @@ codegenCabalFile packageName exposedModules =
[ "," <+> "aeson",
"," <+> "attoparsec",
"," <+> "base",
"," <+> "bytestring",
"," <+> "exceptions",
"," <+> "ghc-prim",
"," <+> "http-api-data",

8
src/Tie/Codegen/Imports.hs
View File

@ -11,12 +11,13 @@ module Tie.Codegen.Imports
)
where
import Prettyprinter (Doc, (<+>))
import Prettyprinter (Doc, vsep, (<+>))
import qualified Prettyprinter as PP
import qualified Prettyprinter.Render.Text as PP
import Tie.Name
( ApiName,
Name,
requestHaskellModuleName,
responseHaskellModuleName,
toResponseHaskellModuleName,
toSchemaHaskellModuleName,
@ -75,7 +76,10 @@ codegenModuleHeader moduleName =
codegenExtraApiModuleDependencies :: ApiName -> Doc ann
codegenExtraApiModuleDependencies apiName =
"import" <+> PP.pretty (responseHaskellModuleName apiName)
vsep
[ "import" <+> PP.pretty (requestHaskellModuleName apiName),
"import" <+> PP.pretty (responseHaskellModuleName apiName)
]
codegenExtraResponseModuleDependencies :: ApiName -> Doc ann
codegenExtraResponseModuleDependencies apiName =

114
src/Tie/Codegen/Operation.hs
View File

@ -223,14 +223,9 @@ codegenPathGuard path continuation =
codegenPathParamGuard :: Param -> PP.Doc ann -> PP.Doc ann
codegenPathParamGuard Param {name} continuation =
"case" <+> "Web.HttpApiData.parseUrlPiece" <+> toParamBinder name <+> "of" <> PP.line
<> PP.indent
4
( "Left" <+> "_" <+> "->" <+> "invalidRequest" <+> "\"" <> toParamName name <> "\"" <> PP.line
<> "Right" <+> toParamBinder name <+> "->"
<> PP.line
<> PP.indent 4 continuation
)
"pathVariable" <+> toParamBinder name <+> "(" <> "\\" <> toParamBinder name <+> "request" <+> "respond" <+> "->" <> PP.line
<> PP.indent 4 continuation
<> ")" <+> "request" <+> "respond"
codegenPathPattern :: Path -> PP.Doc ann
codegenPathPattern path =
@ -262,31 +257,12 @@ codegenMethodGuard methodBodies =
codegenRequestBodyGuard :: Maybe RequestBody -> PP.Doc ann -> PP.Doc ann
codegenRequestBodyGuard requestBody continuation = case requestBody of
Nothing -> continuation
Nothing ->
continuation
Just _body ->
"do"
<+> PP.align
( "result" <+> "<-" <+> "Data.Attoparsec.ByteString.parseWith" <+> "(" <> "Network.Wai.getRequestBodyChunk" <+> "request" <> ")" <+> "Data.Aeson.Parser.json'" <+> "mempty" <> PP.line
<> "case" <+> "Data.Attoparsec.ByteString.eitherResult" <+> "result" <+> "of"
<> PP.line
<> PP.indent
4
( "Left" <+> "err" <+> "->" <+> "invalidRequest" <+> "err" <> PP.line
<> "Right" <+> "bodyValue" <+> "->"
<> PP.line
<> PP.indent
4
( "case" <+> "Data.Aeson.Types.parseEither" <+> "Data.Aeson.parseJSON" <+> "bodyValue" <+> "of" <> PP.line
<> PP.indent
4
( "Left" <+> "err" <+> "->" <+> "invalidRequest" <+> "err" <> PP.line
<> "Right" <+> "body" <+> "->"
<> PP.line
<> PP.indent 4 continuation
)
)
)
)
"parseRequestBodyJSON" <+> "(" <> "\\" <> "body" <+> "request" <+> "respond" <+> "->" <> PP.line
<> PP.indent 4 continuation
<> ")" <+> "request" <+> "respond"
codegenQueryParamsGuard :: [Param] -> PP.Doc ann -> PP.Doc ann
codegenQueryParamsGuard params continuation =
@ -298,72 +274,10 @@ codegenQueryParamsGuard params continuation =
codegenQueryParamGuard :: Param -> PP.Doc ann -> PP.Doc ann
codegenQueryParamGuard Param {name, required} continuation
| required =
"case" <+> "Control.Monad.join" <+> "(" <> "fmap" <+> "(" <> "fmap" <+> "(" <> "Web.HttpApiData.parseUrlPiece" <+> "." <+> "Data.Text.Encoding.decodeUtf8" <> ")" <> ")" <+> "("
<> "Data.List.lookup" <+> "\""
<> toParamName name
<> "\"" <+> "("
<> "Network.Wai.queryString" <+> "request"
<> ")"
<> ")"
<> ")" <+> "of"
<> PP.line
<> PP.indent
4
( "Nothing" <+> "->" <> PP.line
<> PP.indent
4
( "invalidRequest" <+> "\"request body\""
)
<> PP.line
<> "Just" <+> "("
<> "Left" <+> "err"
<> ")" <+> "->"
<> PP.line
<> PP.indent
4
( "invalidRequest" <+> "\"request body\""
)
<> PP.line
<> "Just" <+> "("
<> "Right" <+> toParamBinder name
<> ")" <+> "->"
<> PP.line
<> PP.indent
4
( continuation
)
)
"requiredQueryParameter" <+> "\"" <> toParamName name <> "\"" <+> "(" <> "\\" <> toParamBinder name <+> "request" <+> "respond" <+> "->" <> PP.line
<> PP.indent 4 continuation
<> ")" <+> "request" <+> "respond"
| otherwise =
"case" <+> "Control.Monad.join" <+> "(" <> "fmap" <+> "(" <> "fmap" <+> "(" <> "Web.HttpApiData.parseUrlPiece" <+> "." <+> "Data.Text.Encoding.decodeUtf8" <> ")" <> ")" <+> "("
<> "Data.List.lookup" <+> "\""
<> toParamName name
<> "\"" <+> "("
<> "Network.Wai.queryString" <+> "request"
<> ")"
<> ")"
<> ")" <+> "of"
<> PP.line
<> PP.indent
4
( "Just" <+> "(" <> "Left" <+> "err" <> ")" <+> "->" <> PP.line
<> PP.indent
4
( "invalidRequest" <+> "err"
)
<> PP.line
<> "_x" <+> "->"
<> PP.line
<> PP.indent
4
( "let" <+> "!" <> toParamBinder name <+> "=" <+> "fmap" <+> "(" <> "\\"
<> "("
<> "Right" <+> "_x"
<> ")" <+> "->" <+> "_x"
<> ")" <+> "_x" <+> "in"
<> PP.line
<> PP.indent
4
( continuation
)
)
)
"optionalQueryParameter" <+> "\"" <> toParamName name <> "\"" <+> "False" <+> "(" <> "\\" <> toParamBinder name <+> "request" <+> "respond" <+> "->" <> PP.line
<> PP.indent 4 continuation
<> ")" <+> "request" <+> "respond"

25
src/Tie/Codegen/Request.hs Normal file
View File

@ -0,0 +1,25 @@
{-# LANGUAGE OverloadedStrings #-}
module Tie.Codegen.Request (codegenRequestAuxFile) where
import qualified Data.ByteString as ByteString
import qualified Data.Text as Text
import Paths_tie (getDataFileName)
import Prettyprinter (Doc, hsep, vsep)
import qualified Prettyprinter.Util as Prettyprinter
import System.IO.Unsafe (unsafePerformIO)
import Tie.Name (Name)
auxTemplate :: Text
auxTemplate = unsafePerformIO $ do
file <- getDataFileName "Request.template.hs"
contents <- ByteString.readFile file
pure (decodeUtf8 contents)
{-# NOINLINE auxTemplate #-}
codegenRequestAuxFile ::
-- | Module name
Text ->
Text
codegenRequestAuxFile moduleName =
Text.replace "Tie.Template.Request_" moduleName auxTemplate

3
src/Tie/Codegen/Response.hs
View File

@ -38,8 +38,7 @@ import Tie.Resolve (Resolver)
-- | Generate code for the responses of an 'Operation'.
codegenResponses :: Monad m => Resolver m -> Operation -> m (Doc ann)
codegenResponses resolver Operation {..} = do
let
responseHeaderTypes Response {headers} =
let responseHeaderTypes Response {headers} =
PP.hsep (map codegenHeaderSchema headers)
decl =

10
src/Tie/Name.hs
View File

@ -30,6 +30,8 @@ module Tie.Name
toEnumConstructorName,
apiHaskellModuleName,
apiHaskellFileName,
requestHaskellModuleName,
requestHaskellFileName,
responseHaskellModuleName,
responseHaskellFileName,
inlineObjectTypeName,
@ -72,6 +74,14 @@ apiHaskellFileName :: ApiName -> FilePath
apiHaskellFileName apiName =
haskellModuleToFilePath apiName <> "/Api.hs"
requestHaskellModuleName :: ApiName -> Text
requestHaskellModuleName apiName =
apiName <> ".Request"
requestHaskellFileName :: ApiName -> FilePath
requestHaskellFileName apiName =
haskellModuleToFilePath apiName <> "/Request.hs"
responseHaskellModuleName :: ApiName -> Text
responseHaskellModuleName apiName =
apiName <> ".Response"

105
test/golden/datetime.yaml.out
View File

@ -26,6 +26,7 @@ import qualified Network.HTTP.Types
import qualified Network.Wai
import qualified Web.HttpApiData
import Test.Request
import Test.Response
import Test.Schemas.Test
@ -59,6 +60,108 @@ application run api notFound request respond =
invalidRequest _ =
respond (Network.Wai.responseBuilder (toEnum 400) [] mempty)
---------------------
Test/Request.hs
{-# LANGUAGE OverloadedStrings #-}
module Test.Request
( pathVariable,
requiredQueryParameter,
optionalQueryParameter,
parseRequestBodyJSON,
)
where
import Data.Aeson (FromJSON, parseJSON)
import qualified Data.Aeson.Parser
import qualified Data.Aeson.Types
import Data.Attoparsec.ByteString (eitherResult, parseWith)
import Data.ByteString (ByteString)
import qualified Data.ByteString as ByteString
import qualified Data.List as List
import Data.Text (Text)
import qualified Data.Text as Text
import qualified Data.Text.Encoding as Text
import qualified Network.Wai as Wai
import Web.HttpApiData
( FromHttpApiData,
parseQueryParam,
parseUrlPiece,
)
pathVariable ::
FromHttpApiData a =>
-- | Path variable value
Text ->
(a -> Wai.Application) ->
Wai.Application
pathVariable value withVariable = \request respond ->
case parseUrlPiece value of
Left err ->
undefined
Right x ->
withVariable x request respond
requiredQueryParameter ::
FromHttpApiData a =>
ByteString ->
(a -> Wai.Application) ->
Wai.Application
requiredQueryParameter name withParam = \request respond ->
case List.lookup name (Wai.queryString request) of
Nothing ->
undefined
Just Nothing ->
undefined
Just (Just value) ->
case parseQueryParam (Text.decodeUtf8 value) of
Left err ->
undefined
Right x ->
withParam x request respond
optionalQueryParameter ::
FromHttpApiData a =>
ByteString ->
-- | Allow empty, e.g. "x="
Bool ->
(Maybe a -> Wai.Application) ->
Wai.Application
optionalQueryParameter name allowEmpty withParam = \request respond ->
case List.lookup name (Wai.queryString request) of
Nothing ->
withParam Nothing request respond
Just Nothing
| allowEmpty ->
withParam Nothing request respond
| otherwise ->
undefined
Just (Just value) ->
case parseQueryParam (Text.decodeUtf8 value) of
Left err ->
undefined
Right x ->
withParam (Just x) request respond
parseRequestBodyJSON :: FromJSON a => (a -> Wai.Application) -> Wai.Application
parseRequestBodyJSON withBody = \request respond ->
case List.lookup "Content-Type" (Wai.requestHeaders request) of
Just "application/json" -> do
result <- parseWith (Wai.getRequestBodyChunk request) Data.Aeson.Parser.json' mempty
case eitherResult result of
Left err ->
undefined
Right value ->
case Data.Aeson.Types.parseEither Data.Aeson.parseJSON value of
Left err ->
undefined
Right body ->
withBody body request respond
_ ->
-- unsupported media type
undefined
---------------------
Test/Response.hs
{-# LANGUAGE BangPatterns #-}
@ -196,6 +299,7 @@ library
, aeson
, attoparsec
, base
, bytestring
, exceptions
, ghc-prim
, http-api-data
@ -205,6 +309,7 @@ library
, wai
exposed-modules:
Test.Api
Test.Request
Test.Response
Test.Response.Test
Test.Schemas.Test

105
test/golden/enum.yaml.out
View File

@ -26,6 +26,7 @@ import qualified Network.HTTP.Types
import qualified Network.Wai
import qualified Web.HttpApiData
import Test.Request
import Test.Response
import Test.Schemas.Package
@ -74,6 +75,108 @@ application run api notFound request respond =
invalidRequest _ =
respond (Network.Wai.responseBuilder (toEnum 400) [] mempty)
---------------------
Test/Request.hs
{-# LANGUAGE OverloadedStrings #-}
module Test.Request
( pathVariable,
requiredQueryParameter,
optionalQueryParameter,
parseRequestBodyJSON,
)
where
import Data.Aeson (FromJSON, parseJSON)
import qualified Data.Aeson.Parser
import qualified Data.Aeson.Types
import Data.Attoparsec.ByteString (eitherResult, parseWith)
import Data.ByteString (ByteString)
import qualified Data.ByteString as ByteString
import qualified Data.List as List
import Data.Text (Text)
import qualified Data.Text as Text
import qualified Data.Text.Encoding as Text
import qualified Network.Wai as Wai
import Web.HttpApiData
( FromHttpApiData,
parseQueryParam,
parseUrlPiece,
)
pathVariable ::
FromHttpApiData a =>
-- | Path variable value
Text ->
(a -> Wai.Application) ->
Wai.Application
pathVariable value withVariable = \request respond ->
case parseUrlPiece value of
Left err ->
undefined
Right x ->
withVariable x request respond
requiredQueryParameter ::
FromHttpApiData a =>
ByteString ->
(a -> Wai.Application) ->
Wai.Application
requiredQueryParameter name withParam = \request respond ->
case List.lookup name (Wai.queryString request) of
Nothing ->
undefined
Just Nothing ->
undefined
Just (Just value) ->
case parseQueryParam (Text.decodeUtf8 value) of
Left err ->
undefined
Right x ->
withParam x request respond
optionalQueryParameter ::
FromHttpApiData a =>
ByteString ->
-- | Allow empty, e.g. "x="
Bool ->
(Maybe a -> Wai.Application) ->
Wai.Application
optionalQueryParameter name allowEmpty withParam = \request respond ->
case List.lookup name (Wai.queryString request) of
Nothing ->
withParam Nothing request respond
Just Nothing
| allowEmpty ->
withParam Nothing request respond
| otherwise ->
undefined
Just (Just value) ->
case parseQueryParam (Text.decodeUtf8 value) of
Left err ->
undefined
Right x ->
withParam (Just x) request respond
parseRequestBodyJSON :: FromJSON a => (a -> Wai.Application) -> Wai.Application
parseRequestBodyJSON withBody = \request respond ->
case List.lookup "Content-Type" (Wai.requestHeaders request) of
Just "application/json" -> do
result <- parseWith (Wai.getRequestBodyChunk request) Data.Aeson.Parser.json' mempty
case eitherResult result of
Left err ->
undefined
Right value ->
case Data.Aeson.Types.parseEither Data.Aeson.parseJSON value of
Left err ->
undefined
Right body ->
withBody body request respond
_ ->
-- unsupported media type
undefined
---------------------
Test/Response.hs
{-# LANGUAGE BangPatterns #-}
@ -273,6 +376,7 @@ library
, aeson
, attoparsec
, base
, bytestring
, exceptions
, ghc-prim
, http-api-data
@ -282,6 +386,7 @@ library
, wai
exposed-modules:
Test.Api
Test.Request
Test.Response
Test.Response.ListPackages
Test.Schemas.Package

105
test/golden/lists.yaml.out
View File

@ -26,6 +26,7 @@ import qualified Network.HTTP.Types
import qualified Network.Wai
import qualified Web.HttpApiData
import Test.Request
import Test.Response
import Test.Schemas.Packages
@ -89,6 +90,108 @@ application run api notFound request respond =
invalidRequest _ =
respond (Network.Wai.responseBuilder (toEnum 400) [] mempty)
---------------------
Test/Request.hs
{-# LANGUAGE OverloadedStrings #-}
module Test.Request
( pathVariable,
requiredQueryParameter,
optionalQueryParameter,
parseRequestBodyJSON,
)
where
import Data.Aeson (FromJSON, parseJSON)
import qualified Data.Aeson.Parser
import qualified Data.Aeson.Types
import Data.Attoparsec.ByteString (eitherResult, parseWith)
import Data.ByteString (ByteString)
import qualified Data.ByteString as ByteString
import qualified Data.List as List
import Data.Text (Text)
import qualified Data.Text as Text
import qualified Data.Text.Encoding as Text
import qualified Network.Wai as Wai
import Web.HttpApiData
( FromHttpApiData,
parseQueryParam,
parseUrlPiece,
)
pathVariable ::
FromHttpApiData a =>
-- | Path variable value
Text ->
(a -> Wai.Application) ->
Wai.Application
pathVariable value withVariable = \request respond ->
case parseUrlPiece value of
Left err ->
undefined
Right x ->
withVariable x request respond
requiredQueryParameter ::
FromHttpApiData a =>
ByteString ->
(a -> Wai.Application) ->
Wai.Application
requiredQueryParameter name withParam = \request respond ->
case List.lookup name (Wai.queryString request) of
Nothing ->
undefined
Just Nothing ->
undefined
Just (Just value) ->
case parseQueryParam (Text.decodeUtf8 value) of
Left err ->
undefined
Right x ->
withParam x request respond
optionalQueryParameter ::
FromHttpApiData a =>
ByteString ->
-- | Allow empty, e.g. "x="
Bool ->
(Maybe a -> Wai.Application) ->
Wai.Application
optionalQueryParameter name allowEmpty withParam = \request respond ->
case List.lookup name (Wai.queryString request) of
Nothing ->
withParam Nothing request respond
Just Nothing
| allowEmpty ->
withParam Nothing request respond
| otherwise ->
undefined
Just (Just value) ->
case parseQueryParam (Text.decodeUtf8 value) of
Left err ->
undefined
Right x ->
withParam (Just x) request respond
parseRequestBodyJSON :: FromJSON a => (a -> Wai.Application) -> Wai.Application
parseRequestBodyJSON withBody = \request respond ->
case List.lookup "Content-Type" (Wai.requestHeaders request) of
Just "application/json" -> do
result <- parseWith (Wai.getRequestBodyChunk request) Data.Aeson.Parser.json' mempty
case eitherResult result of
Left err ->
undefined
Right value ->
case Data.Aeson.Types.parseEither Data.Aeson.parseJSON value of
Left err ->
undefined
Right body ->
withBody body request respond
_ ->
-- unsupported media type
undefined
---------------------
Test/Response.hs
{-# LANGUAGE BangPatterns #-}
@ -394,6 +497,7 @@ library
, aeson
, attoparsec
, base
, bytestring
, exceptions
, ghc-prim
, http-api-data
@ -403,6 +507,7 @@ library
, wai
exposed-modules:
Test.Api
Test.Request
Test.Response
Test.Response.ListPackages
Test.Response.ListPackages2

105
test/golden/oneof.yaml.out
View File

@ -26,6 +26,7 @@ import qualified Network.HTTP.Types
import qualified Network.Wai
import qualified Web.HttpApiData
import Test.Request
import Test.Response
import Test.Schemas.Packages
@ -89,6 +90,108 @@ application run api notFound request respond =
invalidRequest _ =
respond (Network.Wai.responseBuilder (toEnum 400) [] mempty)
---------------------
Test/Request.hs
{-# LANGUAGE OverloadedStrings #-}
module Test.Request
( pathVariable,
requiredQueryParameter,
optionalQueryParameter,
parseRequestBodyJSON,
)
where
import Data.Aeson (FromJSON, parseJSON)
import qualified Data.Aeson.Parser
import qualified Data.Aeson.Types
import Data.Attoparsec.ByteString (eitherResult, parseWith)
import Data.ByteString (ByteString)
import qualified Data.ByteString as ByteString
import qualified Data.List as List
import Data.Text (Text)
import qualified Data.Text as Text
import qualified Data.Text.Encoding as Text
import qualified Network.Wai as Wai
import Web.HttpApiData
( FromHttpApiData,
parseQueryParam,
parseUrlPiece,
)
pathVariable ::
FromHttpApiData a =>
-- | Path variable value
Text ->
(a -> Wai.Application) ->
Wai.Application
pathVariable value withVariable = \request respond ->
case parseUrlPiece value of
Left err ->
undefined
Right x ->
withVariable x request respond
requiredQueryParameter ::
FromHttpApiData a =>
ByteString ->
(a -> Wai.Application) ->
Wai.Application
requiredQueryParameter name withParam = \request respond ->
case List.lookup name (Wai.queryString request) of
Nothing ->
undefined
Just Nothing ->
undefined
Just (Just value) ->
case parseQueryParam (Text.decodeUtf8 value) of
Left err ->
undefined
Right x ->
withParam x request respond
optionalQueryParameter ::
FromHttpApiData a =>
ByteString ->
-- | Allow empty, e.g. "x="
Bool ->
(Maybe a -> Wai.Application) ->
Wai.Application
optionalQueryParameter name allowEmpty withParam = \request respond ->
case List.lookup name (Wai.queryString request) of
Nothing ->
withParam Nothing request respond
Just Nothing
| allowEmpty ->
withParam Nothing request respond
| otherwise ->
undefined
Just (Just value) ->
case parseQueryParam (Text.decodeUtf8 value) of
Left err ->
undefined
Right x ->
withParam (Just x) request respond
parseRequestBodyJSON :: FromJSON a => (a -> Wai.Application) -> Wai.Application
parseRequestBodyJSON withBody = \request respond ->
case List.lookup "Content-Type" (Wai.requestHeaders request) of
Just "application/json" -> do
result <- parseWith (Wai.getRequestBodyChunk request) Data.Aeson.Parser.json' mempty
case eitherResult result of
Left err ->
undefined
Right value ->
case Data.Aeson.Types.parseEither Data.Aeson.parseJSON value of
Left err ->
undefined
Right body ->
withBody body request respond
_ ->
-- unsupported media type
undefined
---------------------
Test/Response.hs
{-# LANGUAGE BangPatterns #-}
@ -499,6 +602,7 @@ library
, aeson
, attoparsec
, base
, bytestring
, exceptions
, ghc-prim
, http-api-data
@ -508,6 +612,7 @@ library
, wai
exposed-modules:
Test.Api
Test.Request
Test.Response
Test.Response.ListPackages
Test.Response.ListPackages2

139
test/golden/petstore.yaml.out
View File

@ -26,6 +26,7 @@ import qualified Network.HTTP.Types
import qualified Network.Wai
import qualified Web.HttpApiData
import Test.Request
import Test.Response
import Test.Schemas.Error
@ -65,30 +66,24 @@ application run api notFound request respond =
Control.Monad.IO.Class.liftIO (respond (toResponse response))
)
"GET" ->
case Control.Monad.join (fmap (fmap (Web.HttpApiData.parseUrlPiece . Data.Text.Encoding.decodeUtf8)) (Data.List.lookup "limit" (Network.Wai.queryString request))) of
Just (Left err) ->
invalidRequest err
_x ->
let !limit = fmap (\(Right _x) -> _x) _x in
run request (do
response <- Control.Monad.Catch.handle pure (listPets api limit )
Control.Monad.IO.Class.liftIO (respond (toResponse response))
)
optionalQueryParameter "limit" False (\limit request respond ->
run request (do
response <- Control.Monad.Catch.handle pure (listPets api limit )
Control.Monad.IO.Class.liftIO (respond (toResponse response))
)) request respond
x ->
unsupportedMethod x
[ "pets", petId ] ->
case Web.HttpApiData.parseUrlPiece petId of
Left _ -> invalidRequest "petId"
Right petId ->
case Network.Wai.requestMethod request of
"GET" ->
run request (do
response <- Control.Monad.Catch.handle pure (showPetById api petId )
Control.Monad.IO.Class.liftIO (respond (toResponse response))
)
x ->
unsupportedMethod x
pathVariable petId (\petId request respond ->
case Network.Wai.requestMethod request of
"GET" ->
run request (do
response <- Control.Monad.Catch.handle pure (showPetById api petId )
Control.Monad.IO.Class.liftIO (respond (toResponse response))
)
x ->
unsupportedMethod x) request respond
_ ->
notFound request respond
@ -98,6 +93,108 @@ application run api notFound request respond =
invalidRequest _ =
respond (Network.Wai.responseBuilder (toEnum 400) [] mempty)
---------------------
Test/Request.hs
{-# LANGUAGE OverloadedStrings #-}
module Test.Request
( pathVariable,
requiredQueryParameter,
optionalQueryParameter,
parseRequestBodyJSON,
)
where
import Data.Aeson (FromJSON, parseJSON)
import qualified Data.Aeson.Parser
import qualified Data.Aeson.Types
import Data.Attoparsec.ByteString (eitherResult, parseWith)
import Data.ByteString (ByteString)
import qualified Data.ByteString as ByteString
import qualified Data.List as List
import Data.Text (Text)
import qualified Data.Text as Text
import qualified Data.Text.Encoding as Text
import qualified Network.Wai as Wai
import Web.HttpApiData
( FromHttpApiData,
parseQueryParam,
parseUrlPiece,
)
pathVariable ::
FromHttpApiData a =>
-- | Path variable value
Text ->
(a -> Wai.Application) ->
Wai.Application
pathVariable value withVariable = \request respond ->
case parseUrlPiece value of
Left err ->
undefined
Right x ->
withVariable x request respond
requiredQueryParameter ::
FromHttpApiData a =>
ByteString ->
(a -> Wai.Application) ->
Wai.Application
requiredQueryParameter name withParam = \request respond ->
case List.lookup name (Wai.queryString request) of
Nothing ->
undefined
Just Nothing ->
undefined
Just (Just value) ->
case parseQueryParam (Text.decodeUtf8 value) of
Left err ->
undefined
Right x ->
withParam x request respond
optionalQueryParameter ::
FromHttpApiData a =>
ByteString ->
-- | Allow empty, e.g. "x="
Bool ->
(Maybe a -> Wai.Application) ->
Wai.Application
optionalQueryParameter name allowEmpty withParam = \request respond ->
case List.lookup name (Wai.queryString request) of
Nothing ->
withParam Nothing request respond
Just Nothing
| allowEmpty ->
withParam Nothing request respond
| otherwise ->
undefined
Just (Just value) ->
case parseQueryParam (Text.decodeUtf8 value) of
Left err ->
undefined
Right x ->
withParam (Just x) request respond
parseRequestBodyJSON :: FromJSON a => (a -> Wai.Application) -> Wai.Application
parseRequestBodyJSON withBody = \request respond ->
case List.lookup "Content-Type" (Wai.requestHeaders request) of
Just "application/json" -> do
result <- parseWith (Wai.getRequestBodyChunk request) Data.Aeson.Parser.json' mempty
case eitherResult result of
Left err ->
undefined
Right value ->
case Data.Aeson.Types.parseEither Data.Aeson.parseJSON value of
Left err ->
undefined
Right body ->
withBody body request respond
_ ->
-- unsupported media type
undefined
---------------------
Test/Response.hs
{-# LANGUAGE BangPatterns #-}
@ -423,6 +520,7 @@ library
, aeson
, attoparsec
, base
, bytestring
, exceptions
, ghc-prim
, http-api-data
@ -432,6 +530,7 @@ library
, wai
exposed-modules:
Test.Api
Test.Request
Test.Response
Test.Response.CreatePets
Test.Response.ListPets

207
test/golden/test1.yaml.out
View File

@ -26,6 +26,7 @@ import qualified Network.HTTP.Types
import qualified Network.Wai
import qualified Web.HttpApiData
import Test.Request
import Test.Response
import Test.Schemas.Vehicle
@ -64,54 +65,26 @@ application :: (Control.Monad.Catch.MonadCatch m, Control.Monad.IO.Class.MonadIO
application run api notFound request respond =
case Network.Wai.pathInfo request of
[ "users", id, "create", name ] ->
case Web.HttpApiData.parseUrlPiece id of
Left _ -> invalidRequest "id"
Right id ->
case Web.HttpApiData.parseUrlPiece name of
Left _ -> invalidRequest "name"
Right name ->
case Network.Wai.requestMethod request of
"POST" ->
case Control.Monad.join (fmap (fmap (Web.HttpApiData.parseUrlPiece . Data.Text.Encoding.decodeUtf8)) (Data.List.lookup "page" (Network.Wai.queryString request))) of
Nothing ->
invalidRequest "request body"
Just (Left err) ->
invalidRequest "request body"
Just (Right page) ->
case Control.Monad.join (fmap (fmap (Web.HttpApiData.parseUrlPiece . Data.Text.Encoding.decodeUtf8)) (Data.List.lookup "offset" (Network.Wai.queryString request))) of
Just (Left err) ->
invalidRequest err
_x ->
let !offset = fmap (\(Right _x) -> _x) _x in
do result <- Data.Attoparsec.ByteString.parseWith (Network.Wai.getRequestBodyChunk request) Data.Aeson.Parser.json' mempty
case Data.Attoparsec.ByteString.eitherResult result of
Left err -> invalidRequest err
Right bodyValue ->
case Data.Aeson.Types.parseEither Data.Aeson.parseJSON bodyValue of
Left err -> invalidRequest err
Right body ->
run request (do
response <- Control.Monad.Catch.handle pure (createUser api id name page offset body)
Control.Monad.IO.Class.liftIO (respond (toResponse response))
)
"GET" ->
case Control.Monad.join (fmap (fmap (Web.HttpApiData.parseUrlPiece . Data.Text.Encoding.decodeUtf8)) (Data.List.lookup "page" (Network.Wai.queryString request))) of
Nothing ->
invalidRequest "request body"
Just (Left err) ->
invalidRequest "request body"
Just (Right page) ->
case Control.Monad.join (fmap (fmap (Web.HttpApiData.parseUrlPiece . Data.Text.Encoding.decodeUtf8)) (Data.List.lookup "offset" (Network.Wai.queryString request))) of
Just (Left err) ->
invalidRequest err
_x ->
let !offset = fmap (\(Right _x) -> _x) _x in
run request (do
response <- Control.Monad.Catch.handle pure (getUser api id name page offset )
Control.Monad.IO.Class.liftIO (respond (toResponse response))
)
x ->
unsupportedMethod x
pathVariable id (\id request respond ->
pathVariable name (\name request respond ->
case Network.Wai.requestMethod request of
"POST" ->
requiredQueryParameter "page" (\page request respond ->
optionalQueryParameter "offset" False (\offset request respond ->
parseRequestBodyJSON (\body request respond ->
run request (do
response <- Control.Monad.Catch.handle pure (createUser api id name page offset body)
Control.Monad.IO.Class.liftIO (respond (toResponse response))
)) request respond) request respond) request respond
"GET" ->
requiredQueryParameter "page" (\page request respond ->
optionalQueryParameter "offset" False (\offset request respond ->
run request (do
response <- Control.Monad.Catch.handle pure (getUser api id name page offset )
Control.Monad.IO.Class.liftIO (respond (toResponse response))
)) request respond) request respond
x ->
unsupportedMethod x) request respond) request respond
_ ->
notFound request respond
@ -121,6 +94,108 @@ application run api notFound request respond =
invalidRequest _ =
respond (Network.Wai.responseBuilder (toEnum 400) [] mempty)
---------------------
Test/Request.hs
{-# LANGUAGE OverloadedStrings #-}
module Test.Request
( pathVariable,
requiredQueryParameter,
optionalQueryParameter,
parseRequestBodyJSON,
)
where
import Data.Aeson (FromJSON, parseJSON)
import qualified Data.Aeson.Parser
import qualified Data.Aeson.Types
import Data.Attoparsec.ByteString (eitherResult, parseWith)
import Data.ByteString (ByteString)
import qualified Data.ByteString as ByteString
import qualified Data.List as List
import Data.Text (Text)
import qualified Data.Text as Text
import qualified Data.Text.Encoding as Text
import qualified Network.Wai as Wai
import Web.HttpApiData
( FromHttpApiData,
parseQueryParam,
parseUrlPiece,
)
pathVariable ::
FromHttpApiData a =>
-- | Path variable value
Text ->
(a -> Wai.Application) ->
Wai.Application
pathVariable value withVariable = \request respond ->
case parseUrlPiece value of
Left err ->
undefined
Right x ->
withVariable x request respond
requiredQueryParameter ::
FromHttpApiData a =>
ByteString ->
(a -> Wai.Application) ->
Wai.Application
requiredQueryParameter name withParam = \request respond ->
case List.lookup name (Wai.queryString request) of
Nothing ->
undefined
Just Nothing ->
undefined
Just (Just value) ->
case parseQueryParam (Text.decodeUtf8 value) of
Left err ->
undefined
Right x ->
withParam x request respond
optionalQueryParameter ::
FromHttpApiData a =>
ByteString ->
-- | Allow empty, e.g. "x="
Bool ->
(Maybe a -> Wai.Application) ->
Wai.Application
optionalQueryParameter name allowEmpty withParam = \request respond ->
case List.lookup name (Wai.queryString request) of
Nothing ->
withParam Nothing request respond
Just Nothing
| allowEmpty ->
withParam Nothing request respond
| otherwise ->
undefined
Just (Just value) ->
case parseQueryParam (Text.decodeUtf8 value) of
Left err ->
undefined
Right x ->
withParam (Just x) request respond
parseRequestBodyJSON :: FromJSON a => (a -> Wai.Application) -> Wai.Application
parseRequestBodyJSON withBody = \request respond ->
case List.lookup "Content-Type" (Wai.requestHeaders request) of
Just "application/json" -> do
result <- parseWith (Wai.getRequestBodyChunk request) Data.Aeson.Parser.json' mempty
case eitherResult result of
Left err ->
undefined
Right value ->
case Data.Aeson.Types.parseEither Data.Aeson.parseJSON value of
Left err ->
undefined
Right body ->
withBody body request respond
_ ->
-- unsupported media type
undefined
---------------------
Test/Response.hs
{-# LANGUAGE BangPatterns #-}
@ -465,23 +540,6 @@ instance Data.Aeson.FromJSON PackageIdOneOf4 where
<*> o Data.Aeson..:? "list"
<*> o Data.Aeson..: "name"
newtype PackageIdOneOf4List = PackageIdOneOf4List
{
cool :: Data.Maybe.Maybe (Data.Text.Text)
}
deriving (Show)
instance Data.Aeson.ToJSON PackageIdOneOf4List where
toJSON PackageIdOneOf4List {..} = Data.Aeson.object
[
"cool" Data.Aeson..= cool
]
instance Data.Aeson.FromJSON PackageIdOneOf4List where
parseJSON = Data.Aeson.withObject "PackageIdOneOf4List" $ \o ->
PackageIdOneOf4List
<$> o Data.Aeson..:? "cool"
data PackageIdOneOf4Enum
= PackageIdOneOf4EnumA
| PackageIdOneOf4EnumB
@ -499,6 +557,23 @@ instance Data.Aeson.FromJSON PackageIdOneOf4Enum where
"B" -> pure PackageIdOneOf4EnumB
_ -> fail "invalid enum value"
newtype PackageIdOneOf4List = PackageIdOneOf4List
{
cool :: Data.Maybe.Maybe (Data.Text.Text)
}
deriving (Show)
instance Data.Aeson.ToJSON PackageIdOneOf4List where
toJSON PackageIdOneOf4List {..} = Data.Aeson.object
[
"cool" Data.Aeson..= cool
]
instance Data.Aeson.FromJSON PackageIdOneOf4List where
parseJSON = Data.Aeson.withObject "PackageIdOneOf4List" $ \o ->
PackageIdOneOf4List
<$> o Data.Aeson..:? "cool"
data PackageId
= PackageIdPlane Plane
| PackageIdCar Car
@ -655,6 +730,7 @@ library
, aeson
, attoparsec
, base
, bytestring
, exceptions
, ghc-prim
, http-api-data
@ -664,6 +740,7 @@ library
, wai
exposed-modules:
Test.Api
Test.Request
Test.Response
Test.Response.CreateUser
Test.Response.GetUser

6
tie.cabal
View File

@ -26,16 +26,22 @@ version: 0.1.0.0
extra-source-files: CHANGELOG.md
data-files:
Request.template.hs
test/golden/**/*.yaml
test/golden/**/*.out
library
autogen-modules: Paths_tie
other-modules: Paths_tie
exposed-modules: Tie
Tie.Resolve
Tie.Type
Tie.Operation
Tie.Codegen.Imports
Tie.Codegen.Operation
Tie.Codegen.Request
Tie.Codegen.Response
Tie.Codegen.Schema
Tie.Name