From bac00ff5028829e5f3aaa02dbea4be2851063dce Mon Sep 17 00:00:00 2001 From: Joseph Abrahamson Date: Sat, 13 Feb 2016 22:38:27 -0500 Subject: [PATCH 1/7] eliminate real-valued status codes --- src/Serv/Internal/Server.hs | 4 +- src/Serv/Internal/StatusCode.hs | 124 ++++++++++++++++---------------- 2 files changed, 64 insertions(+), 64 deletions(-) diff --git a/src/Serv/Internal/Server.hs b/src/Serv/Internal/Server.hs index 59333d7..bf2cb77 100644 --- a/src/Serv/Internal/Server.hs +++ b/src/Serv/Internal/Server.hs @@ -250,7 +250,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 +286,7 @@ handleResponse return $ WaiResponse $ Wai.responseLBS - (StatusCode.httpStatus (fromSing sStatus)) + (StatusCode.httpStatus sStatus) ( newHeaders ++ secretHeaders ++ HeaderS.encodeHeaders headers diff --git a/src/Serv/Internal/StatusCode.hs b/src/Serv/Internal/StatusCode.hs index f7c7a37..7a185ec 100644 --- a/src/Serv/Internal/StatusCode.hs +++ b/src/Serv/Internal/StatusCode.hs @@ -163,68 +163,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 (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 From 4ede1d4aa6e3b6f634bb12edbc21ded320d0349f Mon Sep 17 00:00:00 2001 From: Joseph Abrahamson Date: Sat, 13 Feb 2016 22:39:35 -0500 Subject: [PATCH 2/7] proper imports for singleton status codes --- src/Serv/Internal/StatusCode.hs | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/src/Serv/Internal/StatusCode.hs b/src/Serv/Internal/StatusCode.hs index 7a185ec..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 @@ -166,7 +167,7 @@ type NetworkAuthenticationRequired = 'NetworkAuthenticationRequired httpStatus :: forall (sc :: StatusCode Nat) . Sing sc -> S.Status httpStatus c = case c of - SCustomStatus int -> S.mkStatus (withKnownNat int (natVal int)) "" + SCustomStatus int -> S.mkStatus (fromInteger (withKnownNat int (natVal int))) "" SContinue -> S.status100 SSwitchingProtocols -> S.status101 From 0f78ecced1382ac881b8b229d58f8ff058ca4149 Mon Sep 17 00:00:00 2001 From: Joseph Abrahamson Date: Sat, 13 Feb 2016 23:43:25 -0500 Subject: [PATCH 3/7] remove typelits dep from context --- src/Serv/Internal/Server/Context.hs | 1 - 1 file changed, 1 deletion(-) 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 From d2adb8331c94145ee048932cd558b2515c991c9f Mon Sep 17 00:00:00 2001 From: Joseph Abrahamson Date: Wed, 10 Feb 2016 00:52:02 -0500 Subject: [PATCH 4/7] fix: eliminate 'undefined' breaking queries - left an 'undefined' - pedantic compilation caught it! - I love warnings --- src/Serv/Internal/Server.hs | 1 - 1 file changed, 1 deletion(-) diff --git a/src/Serv/Internal/Server.hs b/src/Serv/Internal/Server.hs index bf2cb77..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... From 1bea5b2ab29933b97aac2c4ed03ddd021e4697d9 Mon Sep 17 00:00:00 2001 From: Joseph Abrahamson Date: Tue, 9 Feb 2016 16:10:49 -0500 Subject: [PATCH 5/7] initial steps in adding Swagger --- serv.cabal | 2 ++ src/Serv/Swagger.hs | 5 +++++ 2 files changed, 7 insertions(+) create mode 100644 src/Serv/Swagger.hs diff --git a/serv.cabal b/serv.cabal index 7f6adab..4d8539b 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 @@ -58,6 +59,7 @@ library , http-types , mtl , singletons + , swagger2 , tagged , text , time diff --git a/src/Serv/Swagger.hs b/src/Serv/Swagger.hs new file mode 100644 index 0000000..47eecdd --- /dev/null +++ b/src/Serv/Swagger.hs @@ -0,0 +1,5 @@ + +-- | Convert Serv Apis to Swagger definitions +module Serv.Swagger where + +import Data.Swagger From 0feae34e86f019064e87825d4287df3c3a833ee1 Mon Sep 17 00:00:00 2001 From: Joseph Abrahamson Date: Sat, 13 Feb 2016 22:36:27 -0500 Subject: [PATCH 6/7] wip --- serv.cabal | 1 + src/Serv/Swagger.hs | 46 ++++++++++++++++++++++++++++++++++++++++++++- 2 files changed, 46 insertions(+), 1 deletion(-) diff --git a/serv.cabal b/serv.cabal index 4d8539b..4cd47b0 100644 --- a/serv.cabal +++ b/serv.cabal @@ -57,6 +57,7 @@ library , containers , http-media , http-types + , lens , mtl , singletons , swagger2 diff --git a/src/Serv/Swagger.hs b/src/Serv/Swagger.hs index 47eecdd..c2677b8 100644 --- a/src/Serv/Swagger.hs +++ b/src/Serv/Swagger.hs @@ -1,5 +1,49 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE ScopedTypeVariables #-} -- | Convert Serv Apis to Swagger definitions module Serv.Swagger where -import Data.Swagger +import Control.Lens +import Data.Monoid +import Data.Singletons +import Data.Singletons.Prelude.List +import Data.Singletons.TypeLits +import Data.Swagger +import Serv.Internal.Api +import Serv.Internal.StatusCode +import Serv.Internal.Verb + +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 rs = mempty & responsesResponses .~ makeRs rs where +-- makeRs SNil = mempty +-- makeRs (SCons (STuple2 code out) rest) = rest & ix + +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 From c01d5fdd87671f9305c3c0040111cb4710637eac Mon Sep 17 00:00:00 2001 From: Joseph Abrahamson Date: Sat, 13 Feb 2016 23:43:05 -0500 Subject: [PATCH 7/7] wip --- src/Serv/Swagger.hs | 17 ++++++++++++----- 1 file changed, 12 insertions(+), 5 deletions(-) diff --git a/src/Serv/Swagger.hs b/src/Serv/Swagger.hs index c2677b8..5008663 100644 --- a/src/Serv/Swagger.hs +++ b/src/Serv/Swagger.hs @@ -10,13 +10,17 @@ module Serv.Swagger where import Control.Lens import Data.Monoid import Data.Singletons -import Data.Singletons.Prelude.List +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 @@ -31,10 +35,13 @@ opOfVerb v = 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 rs = mempty & responsesResponses .~ makeRs rs where --- makeRs SNil = mempty --- makeRs (SCons (STuple2 code out) rest) = rest & ix +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 =