diff --git a/shell.nix b/shell.nix index 555b438..690a344 100644 --- a/shell.nix +++ b/shell.nix @@ -9,5 +9,6 @@ pkgs.mkShell { ghc cabal-install ghcid + ormolu ]; } diff --git a/src/Tie/Codegen/Operation.hs b/src/Tie/Codegen/Operation.hs index e513830..748e442 100644 --- a/src/Tie/Codegen/Operation.hs +++ b/src/Tie/Codegen/Operation.hs @@ -9,6 +9,7 @@ module Tie.Codegen.Operation where import qualified Data.Map.Strict as Map +import qualified Debug.Trace import Prettyprinter (Doc, (<+>)) import qualified Prettyprinter as PP import qualified Prettyprinter.Render.Text as PP @@ -185,7 +186,18 @@ codegenApiTypeOperation resolver Operation {..} = do Nothing -> "--" <+> "@" <> toParamName name <> "@" <> PP.line Just comment -> - "--" <+> "@" <> toParamName name <> "@" <+> PP.pretty comment <> PP.line + "--" + <+> "@" + <> toParamName name + <> "@" + <> PP.line + <> codegenMultilineComment comment + <> PP.line + + codegenMultilineComment :: Text -> Doc ann + codegenMultilineComment commentLines = + let comments = fmap ("-- " <>) $ lines commentLines + in PP.cat (fmap PP.pretty comments) codegenRequestBodyComment RequestBody {description} = case description of Nothing -> diff --git a/test/golden/description.yaml b/test/golden/description.yaml new file mode 100644 index 0000000..1f5282e --- /dev/null +++ b/test/golden/description.yaml @@ -0,0 +1,47 @@ +openapi: "3.0.0" +info: + version: 1.0.0 + title: Scarf + license: + name: AllRightsReserved +servers: + - url: https://scarf.sh/api/v1 +paths: + /test: + parameters: + - name: package_query + in: query + required: false + description: > + 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: + + ``` + + package_query=17ea97c0-d350-45ce-9f36-ebb66694196c,558664cd-fece-47f5-a9ca-f30974cf96a5,... + + ``` + + Or if you prefer using package names, you can also pass in + + ``` + + package_query=package_name_1,package_name_2... + + ``` + schema: + type: string + get: + summary: test + operationId: test + responses: + '200': + description: CSV response without schema + content: + application/json: + schema: + description: Undocumented + type: array +components: {} diff --git a/test/golden/description.yaml.out b/test/golden/description.yaml.out new file mode 100644 index 0000000..0c088dc --- /dev/null +++ b/test/golden/description.yaml.out @@ -0,0 +1,512 @@ +Test/Api.hs + +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +module Test.Api where + +import qualified Control.Applicative +import qualified Control.Exception +import qualified Control.Monad +import qualified Control.Monad.IO.Class +import qualified Data.Aeson +import qualified Data.Aeson.Encoding +import qualified Data.Aeson.Types +import qualified Data.Attoparsec.ByteString +import qualified Data.ByteString +import qualified Data.List +import qualified Data.List.NonEmpty +import qualified Data.Map +import qualified Data.Maybe +import qualified Data.Text +import qualified Data.Text.Encoding +import qualified Data.Time +import qualified GHC.Float +import qualified GHC.Int +import qualified GHC.Records +import qualified GHC.Types +import qualified Network.HTTP.Types +import qualified Network.Wai +import qualified Web.HttpApiData + +import Test.Request +import Test.Response + + + + + +import Test.Response.Test + +data Api m = Api { + -- | test + test :: + -- @package_query@ + -- 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: + -- ``` + -- package_query=17ea97c0-d350-45ce-9f36-ebb66694196c,558664cd-fece-47f5-a9ca-f30974cf96a5,... + -- ``` + -- Or if you prefer using package names, you can also pass in + -- ``` + -- package_query=package_name_1,package_name_2... + -- ``` + (Data.Maybe.Maybe (Data.Text.Text)) -> + m TestResponse +} + +application :: (Control.Monad.IO.Class.MonadIO m) => (forall a . Network.Wai.Request -> m a -> IO a) -> Api m -> Network.Wai.Application -> Network.Wai.Application +application run api notFound request respond = + case Network.Wai.pathInfo request of + ["test"] -> + case Network.Wai.requestMethod request of + "GET" -> + optionalQueryParameter "package_query" False (\__package_query request respond -> + run request (do + response <- test api __package_query + Control.Monad.IO.Class.liftIO (respond $! (toResponse response)) + )) request respond + x -> + unsupportedMethod x + + _ -> + notFound request respond + where + unsupportedMethod _ = + respond (Network.Wai.responseBuilder Network.HTTP.Types.status405 [] mempty) +{-# INLINABLE application #-} +--------------------- +Test/Request.hs + +{-# LANGUAGE OverloadedStrings #-} + +module Test.Request + ( -- * Parameters + Style (..), + pathVariable, + requiredQueryParameter, + requiredQueryParameters, + optionalQueryParameter, + optionalQueryParameters, + requiredHeader, + optionalHeader, + + -- * Request body + parseRequestBody, + jsonBodyParser, + formBodyParser, + ) +where + +import qualified Data.Aeson +import qualified Data.Aeson.Types +import Data.Attoparsec.ByteString (eitherResult, parseWith) +import Data.ByteString (ByteString) +import qualified Data.ByteString as ByteString +import qualified Data.ByteString.Builder as Builder +import qualified Data.ByteString.Lazy as LBS +import Data.Coerce (coerce) +import qualified Data.HashMap.Strict as HashMap +import qualified Data.List as List +import qualified Data.List.NonEmpty as NonEmpty +import Data.Maybe (fromMaybe) +import Data.Text (Text) +import qualified Data.Text as Text +import qualified Data.Text.Encoding as Text +import qualified Network.HTTP.Media +import Network.HTTP.Types (HeaderName, hContentType) +import qualified Network.Wai as Wai +import System.IO.Unsafe (unsafeInterleaveIO) +import Web.FormUrlEncoded + ( FromForm, + parseAll, + urlDecodeAsForm, + urlDecodeForm, + ) +import Web.HttpApiData + ( FromHttpApiData, + parseHeader, + parseQueryParam, + parseUrlPiece, + parseUrlPieces, + ) + +pathVariable :: + (FromHttpApiData a) => + -- | Path variable value + Text -> + (a -> Wai.Application) -> + Wai.Application +pathVariable value withVariable = \request respond -> + case parseUrlPiece value of + Left _err -> + respond (Wai.responseBuilder (toEnum 400) [] mempty) + Right x -> + withVariable x request respond +{-# INLINEABLE pathVariable #-} + +data Style + = FormStyle + | CommaDelimitedStyle + | SpaceDelimitedStyle + | PipeDelimitedStyle + +newtype CommaDelimitedValue a = CommaDelimitedValue {unCommaDelimitedValue :: [a]} + +instance (FromHttpApiData a) => FromHttpApiData (CommaDelimitedValue a) where + parseUrlPiece input = do + xs <- parseUrlPieces (Text.splitOn "," input) + pure (CommaDelimitedValue xs) + +newtype SpaceDelimitedValue a = SpaceDelimitedValue {unSpaceDelimitedValue :: [a]} + +instance (FromHttpApiData a) => FromHttpApiData (SpaceDelimitedValue a) where + parseUrlPiece input = do + xs <- parseUrlPieces (Text.splitOn " " input) + pure (SpaceDelimitedValue xs) + +newtype PipeDelimitedValue a = PipeDelimitedValue {unPipeDelimitedValue :: [a]} + +instance (FromHttpApiData a) => FromHttpApiData (PipeDelimitedValue a) where + parseUrlPiece input = do + xs <- parseUrlPieces (Text.splitOn "|" input) + pure (PipeDelimitedValue xs) + +requiredQueryParameters :: + (FromHttpApiData a) => + Style -> + ByteString -> + (NonEmpty.NonEmpty a -> Wai.Application) -> + Wai.Application +requiredQueryParameters style name withParam = + case style of + FormStyle -> \request respond -> + case urlDecodeForm (LBS.fromStrict (ByteString.drop 1 (Wai.rawQueryString request))) of + Left error -> + respond (Wai.responseBuilder (toEnum 400) [] mempty) + Right form -> + case parseAll (Text.decodeUtf8 name) form of + Left _ -> + respond (Wai.responseBuilder (toEnum 400) [] mempty) + Right [] -> + respond (Wai.responseBuilder (toEnum 400) [] mempty) + Right (x : xs) -> + withParam (x NonEmpty.:| xs) request respond + SpaceDelimitedStyle -> + requiredQueryParameter + name + ( \xs -> \request respond -> + case NonEmpty.nonEmpty (unSpaceDelimitedValue xs) of + Nothing -> + respond (Wai.responseBuilder (toEnum 400) [] mempty) + Just xs -> + withParam xs request respond + ) + PipeDelimitedStyle -> + requiredQueryParameter + name + ( \xs -> \request respond -> + case NonEmpty.nonEmpty (unPipeDelimitedValue xs) of + Nothing -> + respond (Wai.responseBuilder (toEnum 400) [] mempty) + Just xs -> + withParam xs request respond + ) + CommaDelimitedStyle -> + requiredQueryParameter + name + ( \xs -> \request respond -> + case NonEmpty.nonEmpty (unCommaDelimitedValue xs) of + Nothing -> + respond (Wai.responseBuilder (toEnum 400) [] mempty) + Just xs -> + withParam xs request respond + ) + +optionalQueryParameters :: + (FromHttpApiData a) => + Style -> + ByteString -> + (Maybe (NonEmpty.NonEmpty a) -> Wai.Application) -> + Wai.Application +optionalQueryParameters style name withParam = + case style of + FormStyle -> \request respond -> + case urlDecodeForm (LBS.fromStrict (ByteString.drop 1 (Wai.rawQueryString request))) of + Left error -> + respond (Wai.responseBuilder (toEnum 400) [] mempty) + Right form -> + case parseAll (Text.decodeUtf8 name) form of + Left _ -> + respond (Wai.responseBuilder (toEnum 400) [] mempty) + Right [] -> + withParam Nothing request respond + Right (x : xs) -> + withParam (Just (x NonEmpty.:| xs)) request respond + SpaceDelimitedStyle -> + optionalQueryParameter + name + False + ( \xs -> + withParam (xs >>= NonEmpty.nonEmpty . unSpaceDelimitedValue) + ) + PipeDelimitedStyle -> + optionalQueryParameter + name + False + ( \xs -> + withParam (xs >>= NonEmpty.nonEmpty . unPipeDelimitedValue) + ) + CommaDelimitedStyle -> + optionalQueryParameter + name + False + ( \xs -> + withParam (xs >>= NonEmpty.nonEmpty . unCommaDelimitedValue) + ) + +requiredQueryParameter :: + (FromHttpApiData a) => + ByteString -> + (a -> Wai.Application) -> + Wai.Application +requiredQueryParameter name withParam = \request respond -> + case List.lookup name (Wai.queryString request) of + Nothing -> + respond (Wai.responseBuilder (toEnum 400) [] ("Missing query parameter: " <> Builder.byteString name)) + Just Nothing -> + respond (Wai.responseBuilder (toEnum 400) [] ("Missing query parameter: " <> Builder.byteString name)) + Just (Just value) -> + case parseQueryParam (Text.decodeUtf8 value) of + Left _err -> + respond (Wai.responseBuilder (toEnum 400) [] ("Unable to recognize query parameter: " <> Builder.byteString name)) + Right x -> + withParam x request respond +{-# INLINEABLE requiredQueryParameter #-} + +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 -> + respond (Wai.responseBuilder (toEnum 400) [] ("Missing query parameter: " <> Builder.byteString name)) + Just (Just value) -> + case parseQueryParam (Text.decodeUtf8 value) of + Left _err -> + respond (Wai.responseBuilder (toEnum 400) [] ("Unable to recognize query parameter: " <> Builder.byteString name)) + Right x -> + withParam (Just x) request respond +{-# INLINEABLE optionalQueryParameter #-} + +optionalHeader :: + (FromHttpApiData a) => + HeaderName -> + (Maybe a -> Wai.Application) -> + Wai.Application +optionalHeader name withHeader = \request respond -> + case List.lookup name (Wai.requestHeaders request) of + Nothing -> + withHeader Nothing request respond + Just value -> + case parseHeader value of + Left _err -> + respond (Wai.responseBuilder (toEnum 400) [] mempty) + Right x -> + withHeader (Just x) request respond +{-# INLINEABLE optionalHeader #-} + +requiredHeader :: + (FromHttpApiData a) => + HeaderName -> + (a -> Wai.Application) -> + Wai.Application +requiredHeader name withHeader = \request respond -> + case List.lookup name (Wai.requestHeaders request) of + Nothing -> + respond (Wai.responseBuilder (toEnum 400) [] mempty) + Just value -> + case parseHeader value of + Left _err -> + respond (Wai.responseBuilder (toEnum 400) [] mempty) + Right x -> + withHeader x request respond +{-# INLINEABLE requiredHeader #-} + +data BodyParser a + = BodyParser + Network.HTTP.Media.MediaType + ((a -> Wai.Application) -> Wai.Application) + +jsonBodyParser :: (Data.Aeson.FromJSON a) => BodyParser a +jsonBodyParser = BodyParser "application/json" parseRequestBodyJSON +{-# INLINE jsonBodyParser #-} + +formBodyParser :: (FromForm a) => BodyParser a +formBodyParser = BodyParser "application/xxx-form-urlencoded" parseRequestBodyForm +{-# INLINE formBodyParser #-} + +parseRequestBody :: [BodyParser a] -> (a -> Wai.Application) -> Wai.Application +parseRequestBody parsers withBody = \request respond -> do + let contentType = + fromMaybe + "application/octet-stream" + (List.lookup hContentType (Wai.requestHeaders request)) + + bodyParser = + Network.HTTP.Media.mapAccept + [(mediaType, parser) | BodyParser mediaType parser <- parsers] + contentType + + case bodyParser of + Just parseBody -> + parseBody withBody request respond + Nothing -> + respond (Wai.responseBuilder (toEnum 415) [] mempty) +{-# INLINE parseRequestBody #-} + +parseRequestBodyJSON :: (Data.Aeson.FromJSON a) => (a -> Wai.Application) -> Wai.Application +parseRequestBodyJSON withBody = \request respond -> do + body <- Wai.lazyRequestBody request + case Data.Aeson.decode' body of + Nothing -> + respond (Wai.responseBuilder (toEnum 400) [] mempty) + Just body -> + withBody body request respond +{-# INLINEABLE parseRequestBodyJSON #-} + +parseRequestBodyForm :: (FromForm a) => (a -> Wai.Application) -> Wai.Application +parseRequestBodyForm withBody = \request respond -> do + body <- Wai.lazyRequestBody request + case urlDecodeAsForm body of + Left _err -> + respond (Wai.responseBuilder (toEnum 400) [] mempty) + Right form -> + withBody form request respond +{-# INLINEABLE parseRequestBodyForm #-} + +--------------------- +Test/Response.hs + +module Test.Response + ( ToResponse (..), + + -- * NDJSON support + NDJSON, + responseNDJSON, + ) +where + +import qualified Data.Aeson +import qualified Data.Aeson.Encoding +import qualified Data.ByteString.Builder +import qualified Network.HTTP.Types +import qualified Network.Wai + +type NDJSON element = ((element -> IO ()) -> IO () -> IO ()) + +responseNDJSON :: (Data.Aeson.ToJSON element) => Network.HTTP.Types.Status -> Network.HTTP.Types.ResponseHeaders -> NDJSON element -> Network.Wai.Response +responseNDJSON status responseHeaders stream = + Network.Wai.responseStream status responseHeaders $ \emit flush -> + stream + ( \element -> + emit + ( Data.Aeson.Encoding.fromEncoding (Data.Aeson.toEncoding element) + <> Data.ByteString.Builder.char7 '\n' + ) + ) + flush + +class ToResponse a where + toResponse :: a -> Network.Wai.Response + +--------------------- +Test/Response/Test.hs + +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +module Test.Response.Test where + +import qualified Control.Applicative +import qualified Control.Exception +import qualified Control.Monad +import qualified Control.Monad.IO.Class +import qualified Data.Aeson +import qualified Data.Aeson.Encoding +import qualified Data.Aeson.Types +import qualified Data.Attoparsec.ByteString +import qualified Data.ByteString +import qualified Data.List +import qualified Data.List.NonEmpty +import qualified Data.Map +import qualified Data.Maybe +import qualified Data.Text +import qualified Data.Text.Encoding +import qualified Data.Time +import qualified GHC.Float +import qualified GHC.Int +import qualified GHC.Records +import qualified GHC.Types +import qualified Network.HTTP.Types +import qualified Network.Wai +import qualified Web.HttpApiData + + + +import Test.Response + +type TestResponseBody200 = Data.Aeson.Value + +data TestResponse + = TestResponse200 [ TestResponseBody200 ] + deriving (Show) + +instance ToResponse TestResponse where + toResponse (TestResponse200 x) = + Network.Wai.responseBuilder Network.HTTP.Types.status200 ([(Network.HTTP.Types.hContentType, "application/json")]) (Data.Aeson.fromEncoding (Data.Aeson.toEncoding x)) + +instance GHC.Records.HasField "status" TestResponse Network.HTTP.Types.Status where + getField (TestResponse200 {}) = Network.HTTP.Types.status200 +--------------------- +test.cabal + +cabal-version: 3.0 +name: test +version: 0.1.0.0 +library + build-depends: + , aeson + , attoparsec + , base + , bytestring + , containers + , ghc-prim + , http-api-data + , http-media + , http-types + , text + , time + , unordered-containers + , wai + exposed-modules: + Test.Api + Test.Request + Test.Response + Test.Response.Test \ No newline at end of file diff --git a/test/golden/headers.yaml.out b/test/golden/headers.yaml.out index 96fb8b7..d0e7d61 100644 --- a/test/golden/headers.yaml.out +++ b/test/golden/headers.yaml.out @@ -47,7 +47,8 @@ import Test.Response.Test2 data Api m = Api { -- | test test :: - -- @x-next@ How many items to return at one time (max 100) + -- @x-next@ + -- How many items to return at one time (max 100) (Data.Maybe.Maybe (GHC.Int.Int32)) -> m TestResponse, -- | test diff --git a/test/golden/petstore.yaml.out b/test/golden/petstore.yaml.out index e3a26d8..daf617a 100644 --- a/test/golden/petstore.yaml.out +++ b/test/golden/petstore.yaml.out @@ -52,12 +52,14 @@ data Api m = Api { m CreatePetsResponse, -- | List all pets listPets :: - -- @limit@ How many items to return at one time (max 100) + -- @limit@ + -- How many items to return at one time (max 100) (Data.Maybe.Maybe (GHC.Int.Int32)) -> m ListPetsResponse, -- | Info for a specific pet showPetById :: - -- @petId@ The id of the pet to retrieve + -- @petId@ + -- The id of the pet to retrieve Data.Text.Text -> m ShowPetByIdResponse } diff --git a/test/golden/test1.yaml.out b/test/golden/test1.yaml.out index 62783ef..1ee470e 100644 --- a/test/golden/test1.yaml.out +++ b/test/golden/test1.yaml.out @@ -47,9 +47,11 @@ import Test.Response.GetUser data Api m = Api { -- | Adds a new user createUser :: - -- @id@ Uniquely identifies a user + -- @id@ + -- Uniquely identifies a user GHC.Int.Int -> - -- @name@ Name of a user + -- @name@ + -- Name of a user Data.Text.Text -> -- @page@ GHC.Int.Int -> @@ -59,9 +61,11 @@ data Api m = Api { CreateUserRequestBody -> m CreateUserResponse, getUser :: - -- @id@ Uniquely identifies a user + -- @id@ + -- Uniquely identifies a user GHC.Int.Int -> - -- @name@ Name of a user + -- @name@ + -- Name of a user Data.Text.Text -> -- @page@ GHC.Int.Int ->