diff --git a/serv.cabal b/serv.cabal index 7f6adab..4cd47b0 100644 --- a/serv.cabal +++ b/serv.cabal @@ -46,6 +46,7 @@ library Serv.Internal.Verb Serv.Server Serv.StatusCode + Serv.Swagger Serv.URI build-depends: base >= 4.7 && < 5 @@ -56,8 +57,10 @@ library , containers , http-media , http-types + , lens , mtl , singletons + , swagger2 , tagged , text , time diff --git a/src/Serv/Internal/Server.hs b/src/Serv/Internal/Server.hs index 59333d7..50a54fc 100644 --- a/src/Serv/Internal/Server.hs +++ b/src/Serv/Internal/Server.hs @@ -201,7 +201,6 @@ handle sH impl = Server $ runServer (badRequestS (Just (unlines ("invalid query:" : errors)))) Right rec -> runServer (handle sH' (impl rec)) - undefined -- runServer (handle sH' (impl _)) -- TODO: These... @@ -250,7 +249,7 @@ handleResponse case (sBody, resp) of (SEmpty, EmptyResponse secretHeaders headers) -> - respondNoBody (StatusCode.httpStatus (fromSing sStatus)) secretHeaders headers + respondNoBody (StatusCode.httpStatus sStatus) secretHeaders headers (SHasBody sCtypes _sTy, ContentResponse secretHeaders headers a) | not includeBody -> do respondNoBody HTTP.ok200 secretHeaders headers @@ -286,7 +285,7 @@ handleResponse return $ WaiResponse $ Wai.responseLBS - (StatusCode.httpStatus (fromSing sStatus)) + (StatusCode.httpStatus sStatus) ( newHeaders ++ secretHeaders ++ HeaderS.encodeHeaders headers diff --git a/src/Serv/Internal/Server/Context.hs b/src/Serv/Internal/Server/Context.hs index 0c3fc0c..71b4aeb 100644 --- a/src/Serv/Internal/Server/Context.hs +++ b/src/Serv/Internal/Server/Context.hs @@ -25,7 +25,6 @@ import Data.Singletons import Data.Singletons.TypeLits import Data.Text (Text) import Data.Text.Encoding (decodeUtf8') -import GHC.TypeLits import qualified Network.HTTP.Types as HTTP import qualified Network.Wai as Wai import Serv.Internal.Api diff --git a/src/Serv/Internal/StatusCode.hs b/src/Serv/Internal/StatusCode.hs index f7c7a37..b1bf0ea 100644 --- a/src/Serv/Internal/StatusCode.hs +++ b/src/Serv/Internal/StatusCode.hs @@ -17,6 +17,7 @@ module Serv.Internal.StatusCode where import Data.Singletons.TH +import Data.Singletons.TypeLits import qualified Network.HTTP.Types.Status as S singletons @@ -163,68 +164,68 @@ type LoopDetected = 'LoopDetected type NotExtended = 'NotExtended type NetworkAuthenticationRequired = 'NetworkAuthenticationRequired -httpStatus :: StatusCode Integer -> S.Status +httpStatus :: forall (sc :: StatusCode Nat) . Sing sc -> S.Status httpStatus c = case c of - CustomStatus int -> S.mkStatus (fromInteger int) "" - - Continue -> S.status100 - SwitchingProtocols -> S.status101 - - Ok -> S.status200 - Created -> S.status201 - Accepted -> S.status202 - NonAuthoritiveInformation -> S.status203 - NoContent -> S.status204 - ResetContent -> S.status205 - PartialContent -> S.status206 - IMUsed -> S.mkStatus 226 "IM Used" - - MultipleChoices -> S.status300 - MovedPermanently -> S.status301 - Found -> S.status302 - SeeOther -> S.status303 - NotModified -> S.status304 - TemporaryRedirect -> S.status307 - PermanentRedirect -> S.status308 - - BadRequest -> S.status400 - Unauthorized -> S.status401 - PaymentRequired -> S.status402 - Forbidden -> S.status403 - NotFound -> S.status404 - MethodNotAllowed -> S.status405 - NotAcceptable -> S.status406 - ProxyAuthenticationRequired -> S.status407 - RequestTimeout -> S.status408 - Conflict -> S.status409 - Gone -> S.status410 - LengthRequired -> S.status411 - PreconditionFailed -> S.status412 - PayloadTooLarge -> S.status413 - RequestURITooLong -> S.status414 - UnsupportedMediaType -> S.status415 - RequestedRangeNotSatisfiable -> S.status416 - ExpectationFailed -> S.status417 - MisdirectedRequest -> S.mkStatus 421 "Misdirected Request" - UnprocessableEntity -> S.mkStatus 422 "Unprocessable Entity" - Locked -> S.mkStatus 423 "Locked" - FailedDependency -> S.mkStatus 424 "Failed Dependency" - UpgradeRequired -> S.mkStatus 426 "Upgrade Required" - PreconditionRequired -> S.status428 - TooManyRequests -> S.status429 - RequestHeaderFieldsTooLarge -> S.status431 - UnavailableForLegalReasons -> S.mkStatus 451 "Unavailable for Legal Reasons" - - InternalServerError -> S.status500 - NotImplemented -> S.status501 - BadGateway -> S.status502 - ServiceUnavailable -> S.status503 - GatewayTimeout -> S.status504 - HTTPVersionNotSupported -> S.status505 - VariantAlsoNegotiates -> S.mkStatus 506 "Variant Also Negotiates" - InsufficientStorage -> S.mkStatus 507 "Insufficient Storage" - LoopDetected -> S.mkStatus 508 "Loop Detected" - NotExtended -> S.mkStatus 510 "Not Extended" - NetworkAuthenticationRequired -> S.status511 + SCustomStatus int -> S.mkStatus (fromInteger (withKnownNat int (natVal int))) "" + + SContinue -> S.status100 + SSwitchingProtocols -> S.status101 + + SOk -> S.status200 + SCreated -> S.status201 + SAccepted -> S.status202 + SNonAuthoritiveInformation -> S.status203 + SNoContent -> S.status204 + SResetContent -> S.status205 + SPartialContent -> S.status206 + SIMUsed -> S.mkStatus 226 "IM Used" + + SMultipleChoices -> S.status300 + SMovedPermanently -> S.status301 + SFound -> S.status302 + SSeeOther -> S.status303 + SNotModified -> S.status304 + STemporaryRedirect -> S.status307 + SPermanentRedirect -> S.status308 + + SBadRequest -> S.status400 + SUnauthorized -> S.status401 + SPaymentRequired -> S.status402 + SForbidden -> S.status403 + SNotFound -> S.status404 + SMethodNotAllowed -> S.status405 + SNotAcceptable -> S.status406 + SProxyAuthenticationRequired -> S.status407 + SRequestTimeout -> S.status408 + SConflict -> S.status409 + SGone -> S.status410 + SLengthRequired -> S.status411 + SPreconditionFailed -> S.status412 + SPayloadTooLarge -> S.status413 + SRequestURITooLong -> S.status414 + SUnsupportedMediaType -> S.status415 + SRequestedRangeNotSatisfiable -> S.status416 + SExpectationFailed -> S.status417 + SMisdirectedRequest -> S.mkStatus 421 "Misdirected Request" + SUnprocessableEntity -> S.mkStatus 422 "Unprocessable Entity" + SLocked -> S.mkStatus 423 "Locked" + SFailedDependency -> S.mkStatus 424 "Failed Dependency" + SUpgradeRequired -> S.mkStatus 426 "Upgrade Required" + SPreconditionRequired -> S.status428 + STooManyRequests -> S.status429 + SRequestHeaderFieldsTooLarge -> S.status431 + SUnavailableForLegalReasons -> S.mkStatus 451 "Unavailable for Legal Reasons" + + SInternalServerError -> S.status500 + SNotImplemented -> S.status501 + SBadGateway -> S.status502 + SServiceUnavailable -> S.status503 + SGatewayTimeout -> S.status504 + SHTTPVersionNotSupported -> S.status505 + SVariantAlsoNegotiates -> S.mkStatus 506 "Variant Also Negotiates" + SInsufficientStorage -> S.mkStatus 507 "Insufficient Storage" + SLoopDetected -> S.mkStatus 508 "Loop Detected" + SNotExtended -> S.mkStatus 510 "Not Extended" + SNetworkAuthenticationRequired -> S.status511 diff --git a/src/Serv/Swagger.hs b/src/Serv/Swagger.hs new file mode 100644 index 0000000..5008663 --- /dev/null +++ b/src/Serv/Swagger.hs @@ -0,0 +1,56 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE ScopedTypeVariables #-} + +-- | Convert Serv Apis to Swagger definitions +module Serv.Swagger where + +import Control.Lens +import Data.Monoid +import Data.Singletons +import Data.Singletons.Prelude +import Data.Singletons.TypeLits +import Data.Swagger +import qualified Network.HTTP.Types.Status as S +import Serv.Internal.Api +import Serv.Internal.StatusCode +import Serv.Internal.Verb + +class HasExample a where + anExample :: Maybe a + +opOfVerb :: forall (v :: Verb) . Sing v -> Lens' PathItem (Maybe Operation) +opOfVerb v = + case v of + SGET -> pathItemGet + SDELETE -> pathItemDelete + SHEAD -> pathItemHead + SOPTIONS -> pathItemOptions + SPATCH -> pathItemPatch + SPOST -> pathItemPost + SPUT-> pathItemPut + +pathItem :: forall (v :: Verb) . Sing v -> Operation -> PathItem +pathItem v op = mempty & opOfVerb v .~ Just op + +swResponses :: forall (rs :: [ (StatusCode Nat, Output Symbol *) ]) . Sing rs -> Responses +swResponses SNil = mempty +swResponses (SCons (STuple2 code out) rest) = + let cont = swResponses rest + statusNum = S.statusCode (httpStatus code) + resp = mempty + in cont & responsesResponses . ix statusNum .~ Inline resp + +swHandler :: forall (h :: Handler Nat Symbol *) . Sing h -> PathItem +swHandler h = + case h of + SMethod verb responses -> + let resps = + mempty + & ix 200 .~ Inline mempty + op = + mempty + & (operationResponses . responsesResponses) .~ resps + in pathItem verb op