From 56c76d587a2977f04fd5d1f949fba5d6393e4546 Mon Sep 17 00:00:00 2001 From: Alex Biehl Date: Wed, 7 Feb 2024 12:23:07 +0100 Subject: [PATCH] structs forms --- README.md | 15 ------ Request.template.hs | 9 ++-- example/generated/Petstore/API/Untitled-1.hs | 6 +++ src/Tie/Codegen/Imports.hs | 4 ++ src/Tie/Codegen/Operation.hs | 4 +- src/Tie/Codegen/Schema.hs | 51 +++++++++++++++++++- src/Tie/Operation.hs | 6 ++- src/Tie/Type.hs | 19 ++++++++ 8 files changed, 89 insertions(+), 25 deletions(-) create mode 100644 example/generated/Petstore/API/Untitled-1.hs diff --git a/README.md b/README.md index e8c14e9..3401195 100644 --- a/README.md +++ b/README.md @@ -50,21 +50,6 @@ $ git clone https://github.com/scarf-sh/tie.git $ cd tie ``` -Then, you need to build it using cabal: - -```bash -$ cabal build exe:tie -``` - -Finally, you can copy the resulting executable to your desired location: - -```bash -$ cp $(cabal exec -- which tie) ~/.local/bin/tie -``` - -Alternatively, instead of manually copying the executable you can install with -cabal: - ```bash $ cabal install . ``` diff --git a/Request.template.hs b/Request.template.hs index a9edfc3..d1eea90 100644 --- a/Request.template.hs +++ b/Request.template.hs @@ -146,10 +146,11 @@ requiredQueryParameters style name withParam = optionalQueryParameters :: (FromHttpApiData a) => Style -> + Bool -> ByteString -> (Maybe (NonEmpty.NonEmpty a) -> Wai.Application) -> Wai.Application -optionalQueryParameters style name withParam = +optionalQueryParameters style allowEmpty name withParam = case style of FormStyle -> \request respond -> case urlDecodeForm (LBS.fromStrict (ByteString.drop 1 (Wai.rawQueryString request))) of @@ -166,21 +167,21 @@ optionalQueryParameters style name withParam = SpaceDelimitedStyle -> optionalQueryParameter name - False + allowEmpty ( \xs -> withParam (xs >>= NonEmpty.nonEmpty . unSpaceDelimitedValue) ) PipeDelimitedStyle -> optionalQueryParameter name - False + allowEmpty ( \xs -> withParam (xs >>= NonEmpty.nonEmpty . unPipeDelimitedValue) ) CommaDelimitedStyle -> optionalQueryParameter name - False + allowEmpty ( \xs -> withParam (xs >>= NonEmpty.nonEmpty . unCommaDelimitedValue) ) diff --git a/example/generated/Petstore/API/Untitled-1.hs b/example/generated/Petstore/API/Untitled-1.hs new file mode 100644 index 0000000..0046826 --- /dev/null +++ b/example/generated/Petstore/API/Untitled-1.hs @@ -0,0 +1,6 @@ +data CreatePackageRequest where + CreatePackageRequest_application_json :: CreatePackage1 -> CreatePackageRequest + CreatePackageRequest_text_xml :: CreatePackage1 -> CreatePackageRequest + +data CreatePackageResponse (status :: Natural) body where + CreatePackageResponse_200_application_json :: CreatePackageResponse 200 diff --git a/src/Tie/Codegen/Imports.hs b/src/Tie/Codegen/Imports.hs index 7bac1a7..a52faf3 100644 --- a/src/Tie/Codegen/Imports.hs +++ b/src/Tie/Codegen/Imports.hs @@ -161,6 +161,10 @@ codegenModuleHeader moduleName = <> "import" <+> "qualified" <+> "Web.HttpApiData" + <> PP.line + <> "import" + <+> "qualified" + <+> "Web.FormUrlEncoded" codegenExtraApiModuleDependencies :: ApiName -> Doc ann codegenExtraApiModuleDependencies apiName = diff --git a/src/Tie/Codegen/Operation.hs b/src/Tie/Codegen/Operation.hs index 10d5939..1be0593 100644 --- a/src/Tie/Codegen/Operation.hs +++ b/src/Tie/Codegen/Operation.hs @@ -363,7 +363,7 @@ codegenQueryParamStyle explode style = case (explode, style) of (False, StyleForm) -> Just "CommaDelimitedStyle" codegenQueryParamGuard :: Param -> PP.Doc ann -> PP.Doc ann -codegenQueryParamGuard Param {name, required, style, explode, schema} continuation +codegenQueryParamGuard Param {name, required, style, explode, schema, allowEmpty} continuation | Just _ <- isArrayType (namedType schema), Just style <- style, Just style <- codegenQueryParamStyle explode style = @@ -394,7 +394,7 @@ codegenQueryParamGuard Param {name, required, style, explode, schema} continuati | otherwise = "optionalQueryParameter" <+> "\"" <> toParamName name <> "\"" - <+> "False" + <+> if allowEmpty then "True" else "False" <+> "(" <> "\\" <> toParamBinder name <+> "request" <+> "respond" diff --git a/src/Tie/Codegen/Schema.hs b/src/Tie/Codegen/Schema.hs index 2e0a130..fa808fc 100644 --- a/src/Tie/Codegen/Schema.hs +++ b/src/Tie/Codegen/Schema.hs @@ -48,6 +48,7 @@ import Tie.Type isOneOfType, namedType, normalizeType, + isFitForFromFormInstance, ) import Prelude hiding (Type) @@ -264,7 +265,7 @@ codegenOneOfType getDiscriminator typName variants = do pure (PP.vsep $ intersperse mempty [decl, toJson, fromJson]) codegenObjectType :: (Monad m) => Name -> ObjectType (Named Type) -> m (Doc ann) -codegenObjectType typName ObjectType {..} +codegenObjectType typName objectType@ObjectType {..} -- for empty, free form objects, just generate a type synonym for Value. | Just FreeForm <- additionalProperties, null properties = @@ -508,7 +509,53 @@ codegenObjectType typName ObjectType {..} ) ) ) - in pure (PP.vsep $ intersperse mempty [decl, toJson, fromJson]) + + parseFormForm form fieldName fieldType + | Just {} <- isArrayType (namedType fieldType) = + if is_required then + "Web.FormUrlEncoded.parseAll" <+> "\"" <> toJsonFieldName fieldName <> "\"" <+> form + else + "(" <> "either" <+> "(" <> "const" <+> "(" <> "Right" <+> "Nothing" <> ")" <> ")" <+> "(" <> "Right" <+> "." <+> "Just" <> ")" <+> "(" <> "Web.FormUrlEncoded.parseAll" <+> "\"" <> toJsonFieldName fieldName <> "\"" <+> form <> ")" <> ")" + | Just {} <- isObjectType (namedType fieldType) = + if is_required then + "Web.FormUrlEncoded.fromForm" <+> form + else + "(" <> "either" <+> "(" <> "const" <+> "(" <> "Right" <+> "Nothing" <> ")" <> ")" <+> "(" <> "Right" <+> "." <+> "Just" <> ")" <+> "(" <> "Web.FormUrlEncoded.fromForm" <+> form <> ")" <> ")" + | is_required = + "Web.FormUrlEncoded.parseUnique" <+> "\"" <> toJsonFieldName fieldName <> "\"" <+> form + | otherwise = + "Web.FormUrlEncoded.parseMaybe" <+> "\"" <> toJsonFieldName fieldName <> "\"" <+> form + where + is_required = HashSet.member fieldName requiredProperties + + fromForm + | isFitForFromFormInstance (Object objectType) = + "instance" + <+> "Web.FormUrlEncoded.FromForm" + <+> toDataTypeName typName + <+> "where" + <> PP.line + <> PP.indent + 4 + ( "fromForm" <+> "x" <+> "=" + <> PP.line + <> PP.indent + 4 + ( toConstructorName typName + <> PP.line + <> PP.indent + 4 + ( PP.vsep + [ op <+> parseFormForm "x" fieldName fieldType + | (op, (fieldName, fieldType)) <- zip ("<$>" : repeat "<*>") orderedProperties + ] + ) + ) + ) + | otherwise = + mempty + + in pure (PP.vsep $ intersperse mempty [decl, toJson, fromJson, fromForm]) codegenRequiredOptionalFieldType :: Bool -> Doc ann -> Doc ann codegenRequiredOptionalFieldType True doc = doc diff --git a/src/Tie/Operation.hs b/src/Tie/Operation.hs index 77d84e4..2754bee 100644 --- a/src/Tie/Operation.hs +++ b/src/Tie/Operation.hs @@ -122,7 +122,8 @@ data Param = Param schema :: Named Type, required :: Bool, explode :: Bool, - style :: Maybe Style + style :: Maybe Style, + allowEmpty :: Bool } deriving (Eq, Ord, Show) @@ -423,7 +424,8 @@ paramToParam resolver Errors {..} OpenApi.Param {..} = do | OpenApi.ParamQuery <- _paramIn -> Just StyleForm | otherwise -> Nothing, - schema = typ + schema = typ, + allowEmpty = fromMaybe False _paramAllowEmptyValue } headerToHeader :: diff --git a/src/Tie/Type.hs b/src/Tie/Type.hs index a77eff1..92701d9 100644 --- a/src/Tie/Type.hs +++ b/src/Tie/Type.hs @@ -31,6 +31,7 @@ module Tie.Type isArrayType, isObjectType, isOneOfType, + isFitForFromFormInstance, -- * Normalize types normalizeType, @@ -518,6 +519,24 @@ isArrayType ty = case ty of Array elem -> Just elem _ -> Nothing +-- | Due to techinical reasons we only generate the fromFrom code for certain data types. +-- It's a matter of the instances that http-api-data providers but nothing structural that +-- would prevent us from doing all types. +isFitForFromFormInstance :: Type -> Bool +isFitForFromFormInstance ty + | Just {} <- isOneOfType ty = + False + | Just ty <- isArrayType ty = + isJust (isBasicType (namedType ty)) + | Just objectTy <- isObjectType ty = + isJust (traverse (isBasicType . namedType) objectTy) + | Just {} <- isEnumType ty = + True + | Just {} <- isBasicType ty = + True + | otherwise = + False + -- | Casting a 'Type' to an 'ObjectType', if possible. `isObjectType` looks through -- allOf, oneOf, anyOf to ensure isObjectType :: Type -> Maybe (ObjectType (Named Type))