serv-wai (empty) → 0.2.0.0
raw patch · 12 files changed
+1288/−0 lines, 12 filesdep +HUnitdep +QuickCheckdep +aesonsetup-changed
Dependencies added: HUnit, QuickCheck, aeson, base, bytestring, case-insensitive, containers, http-kinder, http-media, http-types, mmorph, mtl, serv, serv-wai, singletons, tagged, tasty, tasty-ant-xml, tasty-hunit, tasty-quickcheck, text, time, transformers, vinyl, wai, wai-extra
Files
- LICENSE +30/−0
- Setup.hs +2/−0
- serv-wai.cabal +86/−0
- src/Serv/Wai.hs +386/−0
- src/Serv/Wai/Corec.hs +32/−0
- src/Serv/Wai/Error.hs +18/−0
- src/Serv/Wai/Prelude.hs +19/−0
- src/Serv/Wai/Rec.hs +51/−0
- src/Serv/Wai/Response.hs +108/−0
- src/Serv/Wai/Type.hs +389/−0
- test/Examples/Ex1.hs +136/−0
- test/Spec.hs +31/−0
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright Joseph Abrahamson (c) 2015++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * Neither the name of Author name here nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ serv-wai.cabal view
@@ -0,0 +1,86 @@+name: serv-wai+version: 0.2.0.0+synopsis: Dependently typed API servers with Serv+description:+ Implement "Network.Wai" style servers matching "Serv.Api" style API+ descriptions.+ .+ This package offers tools for building lightweight API servers to match APIs+ described using the types from "Serv.Api". You implement endpoints matching+ the API types in whatever monad you desire (providing a "run" function to+ @IO@) and the server is automatically generated from there.+ .+ See the README for more details.++homepage: http://github.com/tel/serv#readme+license: BSD3+license-file: LICENSE+author: Joseph Abrahamson <me@jspha.com>+maintainer: me@jspha.com+copyright: 2015 Joseph Abrahamson+category: Web+build-type: Simple+cabal-version: >=1.10++library+ hs-source-dirs: src+ exposed-modules:++ Serv.Wai+ Serv.Wai.Prelude+ Serv.Wai.Type+ Serv.Wai.Error+ Serv.Wai.Rec+ Serv.Wai.Corec+ Serv.Wai.Response++ build-depends: base >= 4.7 && < 5++ , aeson+ , bytestring+ , case-insensitive+ , containers+ , http-kinder+ , http-media+ , http-types+ , mmorph+ , mtl+ , serv+ , singletons+ , tagged+ , text+ , time+ , transformers+ , vinyl+ , wai++ default-language: Haskell2010++test-suite serv-wai-test+ type: exitcode-stdio-1.0+ hs-source-dirs: test+ main-is: Spec.hs+ other-modules:++ Examples.Ex1++ build-depends: base+ , serv+ , serv-wai++ , HUnit+ , QuickCheck+ , tasty+ , tasty-ant-xml+ , tasty-hunit+ , tasty-quickcheck+ , text+ , wai+ , wai-extra++ ghc-options: -threaded -rtsopts -with-rtsopts=-N+ default-language: Haskell2010++source-repository head+ type: git+ location: https://github.com/tel/serv
+ src/Serv/Wai.hs view
@@ -0,0 +1,386 @@+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}++-- | Build an "implementation" of a given 'Api'-kinded type (e.g. @'Impl'+-- api@) which describes all of the logic for your server and then convert+-- it into a 'Server' value and then an 'Application'.+module Serv.Wai (++ -- * Implement a 'Server'+ server+ , Server++ -- ** Server transformation++ -- | Typically you use 'server' to construct a value @'Server' M@ for+ -- some @M@ specific to your application, either a transformer stack or+ -- an abstract monad constrained by @mtl@-like typeclasses. If @M@ is not+ -- 'IO' then 'serverApplication' cannot be used to build an+ -- 'Application', so instead we must first transform @M@ using a "run"+ -- function applied to 'mapServer'.+ --+ -- For instance, if @M@ is @StateT St IO@ then+ --+ -- @+ -- flip evalStateT s0 :: StateT St IO a -> IO a+ -- @+ --+ -- is a suitable "run" function we could apply+ -- using 'mapServer' to transform @'Server' M@ into @'Server' 'IO'@.++ , mapServer++ -- ** Execute it as an 'Application'+ , serverApplication+ , serverApplication'+ , serverApplication''++ -- * Constraints and Implementations++ -- | In order to call 'server' we must ensure that our @api :: 'Api'@+ -- type is decorated with the appropriate constraints and that the+ -- @'Impl' api@ type properly matches the 'Api'. This is achieved by+ -- analyzing the types with type-level functions, e.g. the closed type+ -- families 'Impl' and 'Constrain'.+ --+ -- NOTE: Closed type families are rather finnicky as to when they+ -- actually evaluate, so the factoring of these type families into+ -- smaller pieces is done by some trial an error.++ , Impl+ , Constrain++ -- ** Detailed constraints and implementations+ , AllImpl+ , AllHandlers+ , ImplHandler++ , ConstrainEndpoint+ , ConstrainHandler+ , ConstrainOutputs+ , ConstrainRespond+ , ConstrainBody++) where++import Control.Monad.Trans+import qualified Data.ByteString.Lazy as Sl+import qualified Data.ByteString as S+import Data.CaseInsensitive (CI)+import Data.Maybe (catMaybes)+import Data.Set (Set)+import qualified Data.Set as Set+import Data.Singletons+import Data.Singletons.Prelude.List+import Data.Singletons.Prelude.Tuple+import Data.Singletons.TypeLits+import Data.Text (Text)+import GHC.Exts+import Network.HTTP.Kinder.Header (AllHeaderDecodes,+ AllHeaderEncodes,+ HeaderDecode (..), HeaderName, Sing (SAccept, SAllow, SContentType),+ headerEncodePair)+import Network.HTTP.Kinder.MediaType (AllMimeEncode,+ negotiatedMimeEncode)+import Network.HTTP.Kinder.Query (AllQueryDecodes)+import Network.HTTP.Kinder.Status (Status)+import qualified Network.HTTP.Kinder.Status as St+import Network.HTTP.Kinder.URI (URIDecode (..))+import Network.HTTP.Kinder.Verb (Verb (..))+import Network.Wai+import Serv.Api+import Serv.Api.Analysis+import Serv.Wai.Corec+import Serv.Wai.Rec+import Serv.Wai.Response+import Serv.Wai.Type++type family Impl (m :: * -> *) api where+ Impl m Abstract = m (Context -> Application)++ Impl m (OneOf apis) = HList (AllImpl m apis)+ Impl m (Endpoint ann hs) = FieldRec (AllHandlers m hs)++ Impl m (Const s :> api) = Impl m api+ Impl m (HeaderAs s v :> api) = Impl m api+ Impl m (Seg s a :> api) = a -> Impl m api+ Impl m (Header n a :> api) = a -> Impl m api+ Impl m (Wildcard :> api) = [Text] -> Impl m api++type family AllImpl m apis where+ AllImpl m '[] = '[]+ AllImpl m (api ': apis) = Impl m api ': AllImpl m apis++type family AllHandlers m hs where+ AllHandlers m '[] = '[]+ AllHandlers m (h ': hs) =+ '(VerbOf h, ImplHandler m h) ': AllHandlers m hs++type family VerbOf h where+ VerbOf (CaptureBody ts a h) = VerbOf h+ VerbOf (CaptureHeaders hs h) = VerbOf h+ VerbOf (CaptureQuery qs h) = VerbOf h+ VerbOf (Method v os) = v++type family ImplHandler m h where+ ImplHandler m (CaptureBody ts a h) = a -> ImplHandler m h+ ImplHandler m (CaptureHeaders hs h) = FieldRec hs -> ImplHandler m h+ ImplHandler m (CaptureQuery qs h) = FieldRec qs -> ImplHandler m h+ ImplHandler m (Method v os) = m (SomeResponse os)++type family Constrain a :: Constraint where+ Constrain Abstract = ()++ Constrain (Endpoint ann hs) = ConstrainEndpoint hs++ Constrain (OneOf '[]) = ()+ Constrain (OneOf (api ': apis)) =+ (Constrain api, Constrain (OneOf apis))+++ Constrain (Const s :> api) = Constrain api+ Constrain (HeaderAs s v :> api) = Constrain api+ Constrain (Seg s a :> api) = (Constrain api, URIDecode a)+ Constrain (Header n a :> api) = (Constrain api, HeaderDecode n a)+ Constrain (Wildcard :> api) = Constrain api++type family ConstrainEndpoint hs :: Constraint where+ ConstrainEndpoint '[] = ()+ ConstrainEndpoint (h ': hs) =+ (ConstrainHandler h, ConstrainEndpoint hs)++type family ConstrainHandler h :: Constraint where+ ConstrainHandler (Method verb os) =+ ConstrainOutputs os+ ConstrainHandler (CaptureBody ctypes a h) =+ ConstrainHandler h -- TODO+ ConstrainHandler (CaptureHeaders hs h) =+ (AllHeaderDecodes hs, ConstrainHandler h)+ ConstrainHandler (CaptureQuery qs h) =+ (AllQueryDecodes qs, ConstrainHandler h)++type family ConstrainOutputs (os :: [(Status, Output *)]) :: Constraint where+ ConstrainOutputs '[] = ()+ ConstrainOutputs ((s ::: r) ': os) = (ConstrainRespond r, ConstrainOutputs os)++type family ConstrainRespond r :: Constraint where+ ConstrainRespond (Respond hs b) = (AllHeaderEncodes hs, ConstrainBody b)++type family ConstrainBody b :: Constraint where+ ConstrainBody Empty = ()+ ConstrainBody (HasBody ts a) = AllMimeEncode a ts++-- | Construct a 'Server' value from an @'Impl' api@ implementation+-- matching the @'Sing' api@ singleton. This is the primary function for+-- the entire package.+server :: (Constrain api, Monad m) => Sing api -> Impl m api -> Server m+server SAbstract mApp = returnServer (fmap Application mApp)+server (SOneOf SNil) RNil = notFound+server (SOneOf (SCons api apis)) (Identity impl :& impls) =+ server api impl `orElse` server (SOneOf apis) impls+server (path :%> api) impl =+ Server $ case path of+ SConst sym -> withKnownSymbol sym $ do+ maySeg <- popSegment+ runServer $ case maySeg of+ Nothing -> notFound+ Just seg+ | seg /= fromString (symbolVal sym) -> notFound+ | otherwise -> server api impl+ SWildcard -> do+ segs <- popAllSegments+ runServer (server api (impl segs))+ SHeaderAs h sExp -> do+ let expected = fromString (withKnownSymbol sExp (symbolVal sExp))+ ok <- expectHeader h expected+ runServer $ if ok+ then server api impl+ else notFound+ SSeg _name _ty -> do+ trySeg <- popSegment+ runServer $ case trySeg of+ Nothing -> notFound+ Just seg ->+ case uriDecode seg of+ Left err -> badRequest (Just err)+ Right val -> server api (impl val)+ SHeader hdr _ty -> do+ tryVal <- getHeader hdr+ runServer $ case tryVal of+ Left err -> badRequest (Just err)+ Right val -> server api (impl val)+server (SEndpoint _ann handlers) impls = Server $ do+ let verbs = augmentVerbs (inspectVerbs handlers)+ isTerminal <- endOfPath+ if not isTerminal+ then runServer notFound+ else do+ mayVerb <- getVerb+ case mayVerb of+ Nothing -> runServer (methodNotAllowed verbs)+ Just verb+ | verb == OPTIONS -> do+ return $+ WaiResponse+ $ responseLBS+ (St.httpStatus St.SOk)+ (catMaybes [headerEncodePair SAllow verbs])+ ""+ | verb `Set.member` verbs -> do+ runServer (handles verbs handlers impls)+ | otherwise -> runServer (methodNotAllowed verbs)++handles+ :: (ConstrainEndpoint hs, Monad m)+ => Set Verb -> Sing hs -> FieldRec (AllHandlers m hs) -> Server m+handles verbs SNil RNil = methodNotAllowed verbs+handles verbs (SCons sHandler sRest) (ElField _verb handler :& implRest) =+ handle sHandler handler+ `orElse`+ handles verbs sRest implRest+handles _ _ _ = bugInGHC++handle :: (ConstrainHandler h, Monad m) => Sing h -> ImplHandler m h -> Server m+handle sH impl = Server $+ case sH of+ SMethod sVerb sAlts -> do+ mayVerb <- getVerb+ let verbProvided = fromSing sVerb+ case mayVerb of+ Nothing -> runServer notFound+ Just verbRequested+ | verbRequested == HEAD -> do+ someResponse <- lift impl+ handleResponse False sAlts someResponse+ | verbRequested == verbProvided -> do+ someResponse <- lift impl+ handleResponse True sAlts someResponse+ | otherwise ->+ runServer notFound -- not methodNotAllowedS because we can't+ -- make that judgement locally.++ SCaptureHeaders sHdrs sH' -> do+ tryHdrs <- extractHeaders sHdrs+ case tryHdrs of+ Left errors ->+ runServer (badRequest (Just (unlines ("invalid headers:" : errors))))+ Right rec ->+ runServer (handle sH' (impl rec))++ SCaptureQuery sQ sH' -> do+ tryQ <- extractQueries sQ+ case tryQ of+ Left errors ->+ runServer (badRequest (Just (unlines ("invalid query:" : errors))))+ Right rec ->+ runServer (handle sH' (impl rec))++ -- TODO: These...++ SCaptureBody _sCTypes _sTy _sH' ->+ undefined -- runServer (handle sH' (impl _))+++extractHeaders+ :: forall m (hs :: [(HeaderName, *)])+ . (AllHeaderDecodes hs, Monad m, Contextual m)+ => Sing hs -> m (Either [String] (FieldRec hs))+extractHeaders SNil = return (Right RNil)+extractHeaders (SCons (STuple2 hdr (_ty :: Sing a)) rest) = do+ tryRec <- extractHeaders rest+ tryHeader <- getHeader hdr+ return $ case (tryRec, tryHeader :: Either String a) of+ (Left errs, Left err) -> Left (err : errs)+ (Left errs, Right _) -> Left errs+ (Right _, Left err) -> Left [err]+ (Right rec, Right val) -> Right (ElField hdr val :& rec)++extractQueries+ :: forall m (qs :: [(Symbol, *)])+ . (AllQueryDecodes qs, Monad m, Contextual m)+ => Sing qs -> m (Either [String] (FieldRec qs))+extractQueries SNil = return (Right RNil)+extractQueries (SCons (STuple2 qsym (_ty :: Sing a)) rest) = do+ tryRec <- extractQueries rest+ tryQuery <- getQuery qsym+ return $ case (tryRec, tryQuery :: Either String a) of+ (Left errs, Left err) -> Left (err : errs)+ (Left errs, Right _) -> Left errs+ (Right _, Left err) -> Left [err]+ (Right rec, Right val) -> Right (ElField qsym val :& rec)++handleResponse+ :: (ConstrainOutputs alts, Monad m, Contextual m)+ => Bool -> Sing alts -> SomeResponse alts -> m ServerResult++handleResponse includeBody (SCons _ sRest) (Skip someResponse) =+ handleResponse includeBody sRest someResponse++handleResponse+ includeBody+ (SCons (STuple2 sStatus (SRespond _sHeaders sBody)) _)+ (Stop resp) =++ case (sBody, resp) of+ (SEmpty, EmptyResponse secretHeaders headers) ->+ return+ $ WaiResponse+ $ responseLBS+ (St.httpStatus sStatus)+ (secretHeaders ++ encodeHeaders headers)+ ""+ (SHasBody sCtypes _sTy, ContentResponse secretHeaders headers a)+ | not includeBody -> do+ return+ $ WaiResponse+ $ responseLBS+ (St.httpStatus sStatus)+ (secretHeaders ++ encodeHeaders headers)+ ""+ | otherwise -> do+ eitAccept <- getHeader SAccept+ let accepts = either (const []) id eitAccept+ case negotiatedMimeEncode sCtypes of+ Nothing ->+ return+ $ WaiResponse+ $ responseLBS (St.httpStatus St.SNotAcceptable) [] ""+ Just nego -> do+ let (mt, body) = nego accepts a+ newHeaders = catMaybes [ headerEncodePair SContentType mt ]+ return+ $ WaiResponse+ $ responseLBS+ (St.httpStatus sStatus)+ ( newHeaders+ ++ secretHeaders+ ++ encodeHeaders headers+ )+ (Sl.fromStrict body)+ _ -> bugInGHC++handleResponse _ _ _ = bugInGHC++-- | Augment the Set of allowed verbs by adding OPTIONS and, as necessary,+-- HEAD.+augmentVerbs :: Set Verb -> Set Verb+augmentVerbs = augHead . augOptions where+ augHead s+ | Set.member GET s = Set.insert HEAD s+ | otherwise = s+ augOptions = Set.insert OPTIONS++encodeHeaders :: AllHeaderEncodes rs => FieldRec rs -> [(CI S.ByteString, S.ByteString)]+encodeHeaders = catMaybes . encodeHeaders'++-- | Convert a record of headers into a raw bytes format+encodeHeaders' :: AllHeaderEncodes rs => FieldRec rs -> [Maybe (CI S.ByteString, S.ByteString)]+encodeHeaders' rec =+ case rec of+ RNil -> []+ ElField s val :& rest ->+ headerEncodePair s val : encodeHeaders' rest
+ src/Serv/Wai/Corec.hs view
@@ -0,0 +1,32 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE TypeOperators #-}++-- | Co-records are sum types over an extensible set of options.+module Serv.Wai.Corec where++-- | A @'Corec' f rs@ is a value @f (r, s)@ for exactly one choice of @r@+-- and @s@ such that @(r, s)@ is an element of @rs@.+data Corec (f :: (k1, k2) -> *) (rs :: [(k1, k2)]) where+ Skip :: Corec f rs -> Corec f ( '(r, s) ': rs )+ Stop :: f '(r, s) -> Corec f ( '(r, s) ': rs )++-- | The judgement @'ElemOf' rs (r, s)@ is satisified when there's an+-- equality between @(r, s)@ and some element of @rs@. More than this,+-- however, we assume that the first match of @r@ in @rs@ will work and+-- then defer matching the @s@ component until later. This helps inference+-- so long as the assumption that @r@ is "index-like" holds+class ElemOf rs x where+ -- | Given a valid variant of a 'Corec' "forget" its identity into the+ -- larger 'Corec'.+ inject :: f x -> Corec f rs++instance {-# OVERLAPS #-} (s' ~ s) => ElemOf ( '(r, s) ': rs ) '(r, s') where+ inject = Stop++instance ElemOf rs '(r, s) => ElemOf ( '(r', s') ': rs) '(r, s) where+ inject = Skip . inject
+ src/Serv/Wai/Error.hs view
@@ -0,0 +1,18 @@++module Serv.Wai.Error where++import Data.Set (Set)+import Network.HTTP.Kinder.Verb++-- | Errors which arise during the "handling" portion of dealing with a response.+data RoutingError+ = NotFound+ | BadRequest (Maybe String)+ | UnsupportedMediaType+ | MethodNotAllowed (Set Verb)++-- | An ignorable error is one which backtracks the routing search+-- instead of forcing a response.+ignorable :: RoutingError -> Bool+ignorable NotFound = True+ignorable _ = False
+ src/Serv/Wai/Prelude.hs view
@@ -0,0 +1,19 @@++-- | Module containing everything you need to build 'Server's.+module Serv.Wai.Prelude (++ module Serv.Api+ , module Serv.Wai+ , module Serv.Wai.Response+ , module Serv.Wai.Rec+ , (&)+ , module Network.HTTP.Kinder++) where++import Data.Function ((&))+import Network.HTTP.Kinder+import Serv.Api+import Serv.Wai+import Serv.Wai.Rec+import Serv.Wai.Response
+ src/Serv/Wai/Rec.hs view
@@ -0,0 +1,51 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE ExplicitNamespaces #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE PolyKinds #-}++-- | Re-exports of useful "Data.Vinyl" 'Rec' types+module Serv.Wai.Rec (++ -- * Specialized records++ -- ** 'FieldRec'+ ElField (..)+ , FieldRec++ -- ** 'HList'+ , Identity (..)+ , HList++ , (=:)+ , Rec (..)+ , (<+>)+ , (++)++ -- * Type-level methods+ , type (++)++) where++import Data.Functor.Identity+import Data.Singletons+import Data.Vinyl.Core+import Data.Vinyl.TypeLevel++-- FieldRec+-- ----------------------------------------------------------------------------++-- | A more kind polymorphic element field than what's normally available+-- in "Data.Vinyl"+data ElField field where+ ElField :: Sing k -> !a -> ElField '(k, a)++-- | A 'FieldRec' is a record of types tagged by some kind of "name".+type FieldRec hs = Rec ElField hs++(=:) :: Sing a -> v -> FieldRec '[ '(a, v) ]+s =: v = ElField s v :& RNil++-- HList+-- ----------------------------------------------------------------------------++type HList = Rec Identity
+ src/Serv/Wai/Response.hs view
@@ -0,0 +1,108 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE TypeOperators #-}++-- | Functions and types for creating a Serv response to match a 'Api.Api'.+-- A value of @'Response' (s, 'Api.Respond' headers body)@ is a response+-- with status code @s :: 'Status'@, response headers @headers ::+-- [(Network.HTTP.Kinder.Header.HeaderName, *)]@ and a body described by+-- @body :: 'Api.Body' *@.+module Serv.Wai.Response (++ -- * Responses+ Response (..)+ , SomeResponse++ -- ** Construction+ , emptyResponse+ , withBody+ , withoutBody+ , withHeader+ , withHeaderQuiet++ -- ** Finalization+ -- | When constructing a response in our server implementation we do not+ -- build specific responses but instead responses which may be one of+ -- many possible server result types (parameterized by status codes). To+ -- represent this we use the 'SomeResponse' type and use 'respond' to+ -- convert from a normal 'Response' to 'SomeResponse'.++ , respond++) where++import Data.Singletons+import Network.HTTP.Kinder.Header (HeaderEncode, headerEncodePair)+import Network.HTTP.Kinder.Status (Status)+import qualified Network.HTTP.Types as HTTP+import qualified Serv.Api as Api+import Serv.Wai.Corec+import Serv.Wai.Rec++-- | A value of type @'Response (status, 'Api.Respond' headers body)@+-- fully describes one response a Serv server might emit.+data Response (x :: (Status, Api.Output *)) where+ ContentResponse+ :: [HTTP.Header] -> FieldRec hs -> a+ -> Response '(s, Api.Respond hs (Api.HasBody ts a))+ EmptyResponse+ :: [HTTP.Header] -> FieldRec hs+ -> Response '(s, Api.Respond hs Api.Empty)++-- | A value of type @'SomeResponse rs'@ is a value of @'Response' (s, r)@+-- such that @(s, r)@ is an element of @rs@.+type SomeResponse rs = Corec Response rs++-- | Forget the details of a specific response making it an approprate+-- response at a given 'Api.Endpoint'+respond :: ElemOf rs '(s, r) => Response '(s, r) -> SomeResponse rs+respond = inject++-- | The empty response at a given status code: no headers, no body.+emptyResponse :: sing s -> Response '(s, Api.Respond '[] Api.Empty)+emptyResponse _ = EmptyResponse [] RNil++-- | Attach a body to an empty 'Response'.+withBody+ :: a -> Response '(s, Api.Respond hs Api.Empty)+ -> Response '(s, Api.Respond hs (Api.HasBody ts a))+withBody a (EmptyResponse secretHeaders headers) =+ ContentResponse secretHeaders headers a++-- | Eliminate a body in a 'Response', returning it to 'Api.Empty'.+withoutBody+ :: Response '(s, Api.Respond hs (Api.HasBody ts a))+ -> Response '(s, Api.Respond hs Api.Empty)+withoutBody (ContentResponse secretHeaders headers _) =+ EmptyResponse secretHeaders headers++-- | Adds a header to a 'Response'+withHeader+ :: Sing name -> value+ -> Response '(s, Api.Respond headers body)+ -> Response '(s, Api.Respond ( '(name, value) ': headers) body)+withHeader s val r = case r of+ ContentResponse secretHeaders headers body ->+ ContentResponse secretHeaders (s =: val <+> headers) body+ EmptyResponse secretHeaders headers ->+ EmptyResponse secretHeaders (s =: val <+> headers)++-- | Unlike 'addHeader', 'addHeaderQuiet' allows you to add headers not+-- explicitly specified in the api specification.+withHeaderQuiet+ :: HeaderEncode name value+ => Sing name -> value+ -> Response '(s, Api.Respond headers body)+ -> Response '(s, Api.Respond headers body)+withHeaderQuiet s value r =+ case headerEncodePair s value of+ Nothing -> r+ Just newHeader ->+ case r of+ ContentResponse secretHeaders headers body ->+ ContentResponse (newHeader : secretHeaders) headers body+ EmptyResponse secretHeaders headers ->+ EmptyResponse (newHeader : secretHeaders) headers
+ src/Serv/Wai/Type.hs view
@@ -0,0 +1,389 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE ExplicitForAll #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-}++-- Types describing a 'Server' which is generated by this package. Build+-- 'Server's, run them, convert them to 'Applications', work with the+-- 'Context' which they accumulate via routing.+module Serv.Wai.Type (++ -- * 'Server's++ -- | The 'Server' type is the core type generated by this module. It's+ -- essentially a 'StateT' monad storing a 'Context' accumulated over the+ -- routing process of the server.++ Server (..)+ , ServerResult (..)++ -- ** Basic 'Server's++ , returnServer+ , notFound+ , badRequest+ , methodNotAllowed+ , orElse++ -- ** Transforming 'Server's+ , mapServer++ -- ** Interpreting 'Server's+ , serverApplication+ , serverApplication'+ , serverApplication''++ -- *** Utilities+ , defaultRoutingErrorResponse+++ -- * 'Context's++ -- | As a 'Server' runs it generates a 'Context' descrbing the routing+ -- and decoding/encoding process so far. The 'Context' provides valuable+ -- information aboue the 'Request' and also about how the implemtation of+ -- the server has examined the 'Request' so far.++ , Context (..)+ , makeContext++ -- * 'Contextual' monads++ -- | 'Server's are just monads within a server-like 'Context'---the+ -- 'Contextual' class abstracts out several operations which we expect to+ -- occur in such a context.+ , Contextual (..)++) where++import Control.Monad.Morph+import Control.Monad.State+import qualified Data.ByteString as S+import qualified Data.ByteString.Lazy as Sl+import qualified Data.CaseInsensitive as CI+import Data.IORef+import Data.Map (Map)+import qualified Data.Map as Map+import Data.Maybe (catMaybes)+import Data.Set (Set)+import Data.Singletons+import Data.Singletons.TypeLits+import Data.String+import Data.Text (Text)+import qualified Data.Text.Encoding as Text+import Network.HTTP.Kinder.Header (HeaderDecode, HeaderName,+ Sing (SAllow), SomeHeaderName,+ headerDecodeBS, headerEncodePair,+ headerName, parseHeaderName)+import Network.HTTP.Kinder.Query (QueryDecode (..),+ QueryKeyState (..))+import qualified Network.HTTP.Kinder.Status as St+import Network.HTTP.Kinder.Verb (Verb, parseVerb)+import Network.HTTP.Types.URI (queryToQueryText)+import Network.Wai+import Serv.Wai.Error (RoutingError)+import qualified Serv.Wai.Error as Error++-- Server+-- ----------------------------------------------------------------------------++-- | A server executing in a given monad. We construct these from 'Api'+-- descriptions and corresponding 'Impl' descriptions for said 'Api's.+-- Ultimately, a 'Server', or at least a 'Server IO', is destined to be+-- transformed into a Wai 'Appliation', but 'Server' tracks around more+-- information useful for interpretation and route finding.+newtype Server m = Server { runServer :: StateT Context m ServerResult }++-- | Inject a monadic result directly into a 'Server'+returnServer :: Monad m => m ServerResult -> Server m+returnServer m = Server (lift m)++-- | Lift an effect transformation on to a Server+mapServer :: Monad m => (forall x . m x -> n x) -> Server m -> Server n+mapServer phi (Server act) = Server (hoist phi act)++-- | 'Server's form a semigroup trying each 'Server' in order and receiving+-- the leftmost one which does not end in an ignorable error.+--+-- Or, with less technical jargon, @m `orElse` n@ acts like @m@ except in the+-- case where @m@ returns an 'Error.ignorable' 'Error.Error' in which case control+-- flows on to @n@.+orElse :: Monad m => Server m -> Server m -> Server m+orElse sa sb = Server $ do+ (a, ctx) <- fork (runServer sa)+ case a of+ RoutingError e+ | Error.ignorable e -> runServer sb+ | otherwise -> restore ctx >> return a+ _ -> restore ctx >> return a++-- | A 'Server' which immediately fails with a 'Error.NotFound' error+notFound :: Monad m => Server m+notFound = Server (return (RoutingError Error.NotFound))++-- | A 'Server' which immediately fails with a 'Error.MethodNotAllowed'+-- error+methodNotAllowed :: Monad m => Set Verb -> Server m+methodNotAllowed verbs =+ Server (return (RoutingError (Error.MethodNotAllowed verbs)))++-- | A 'Server' which immediately fails with a 'Error.BadRequest' error+badRequest :: Monad m => Maybe String -> Server m+badRequest err = Server (return (RoutingError (Error.BadRequest err)))++-- | Converts a @'Server' 'IO'@ into a regular Wai 'Application' value.+serverApplication :: Server IO -> Application+serverApplication server = serverApplication' server (const id)++-- | Converts a @'Server' 'IO'@ into a regular Wai 'Application' value;+-- parameterized on a "response transformer" which allows a final+-- modification of the Wai response using information gathered from the+-- 'Context'. Useful, e.g., for writing final headers.+serverApplication' :: Server IO -> (Context -> Response -> Response) -> Application+serverApplication' server xform = do+ serverApplication'' server $ \ctx res ->+ case res of+ RoutingError err -> xform ctx (defaultRoutingErrorResponse err)+ WaiResponse resp -> xform ctx resp+ _ -> error "Recieved 'Application' value in 'serverApplication'' impl"++-- | Converts a @'Server' 'IO'@ into a regular Wai 'Application' value. The+-- most general of the @serverApplication*@ functions, parameterized on+-- a function interpreting the 'Context' and 'ServerResult' as a Wai+-- 'Response'. As an invariant, the interpreter will never see an+-- 'Application' 'ServerResult'---those are handled by this function.+serverApplication''+ :: Server IO+ -> (Context -> ServerResult -> Response)+ -> Application+serverApplication'' server xform request respond = do+ ctx0 <- makeContext request+ (val, ctx1) <- runStateT (runServer server) ctx0+ case val of+ Application app -> app ctx1 (ctxRequest ctx1) respond+ _ -> respond (xform ctx1 val)++-- | A straightforward way of transforming 'RoutingError' values to Wai+-- 'Response's. Used by default in 'serverApplication''.+defaultRoutingErrorResponse :: RoutingError -> Response+defaultRoutingErrorResponse err =+ case err of+ Error.NotFound ->+ responseLBS (St.httpStatus St.SNotFound) [] ""+ Error.BadRequest e -> do+ let errString = fromString (maybe "" id e)+ responseLBS (St.httpStatus St.SBadRequest) [] (fromString errString)+ Error.UnsupportedMediaType ->+ responseLBS (St.httpStatus St.SUnsupportedMediaType) [] ""+ Error.MethodNotAllowed verbs -> do+ responseLBS+ (St.httpStatus St.SMethodNotAllowed)+ (catMaybes [headerEncodePair SAllow verbs])+ ""++data ServerResult+ = RoutingError RoutingError+ -- ^ Routing errors arise when a routing attempt fails and, depending on the+ -- error, either we should recover and backtrack or resolve the entire response+ -- with that error.+ | WaiResponse Response+ -- ^ If the response is arising from the 'Server' computation itself it will+ -- be transformed automatically into a 'Wai.Response' value we can handle+ -- directly. These are opaque to routing, assumed successes.+ | Application (Context -> Application)+ -- ^ If the application demands an "upgrade" or ties into another server+ -- mechanism then routing at that location will return the (opaque)+ -- 'Application' to continue handling.++-- In Context+-- ----------------------------------------------------------------------------++class Contextual m where+ -- | Run a computation with the current state and return it without+ -- affecting ongoing state in this thread.+ fork :: m a -> m (a, Context)++ -- | Restore a 'Context'.+ restore :: Context -> m ()++ -- | Return the HTTP verb of the current context+ getVerb :: m (Maybe Verb)++ -- | Return 'True' if there are no further path segments+ endOfPath :: m Bool++ -- | Pops a path segment if there are any remaining+ popSegment :: m (Maybe Text)++ -- | Pops all remaining path segments+ popAllSegments :: m [Text]++ -- | Pulls the value of a header, attempting to parse it+ getHeader+ :: forall a (n :: HeaderName)+ . HeaderDecode n a => Sing n -> m (Either String a)++ -- | Asserts that we expect a header to take a given value; returns the+ -- validity of that expectation.+ expectHeader+ :: forall (n :: HeaderName)+ . Sing n -> Text -> m Bool++ -- | Pulls the value of a query parameter, attempting to parse it+ getQuery :: QueryDecode s a => Sing s -> m (Either String a)++-- | (internal) gets the raw header data+getHeaderRaw+ :: forall m (n :: HeaderName)+ . Monad m => Sing n -> StateT Context m (Maybe S.ByteString)+getHeaderRaw s = do+ hdrs <- gets ctxHeaders+ return $ Map.lookup (headerName s) hdrs++-- | (internal) declare that a header was accessed (and possibly that is+-- should take a certain value)+declareHeader+ :: forall m (n :: HeaderName)+ . Monad m => Sing n -> Maybe Text -> StateT Context m ()+declareHeader s val =+ modify $ \ctx ->+ ctx { ctxHeaderAccess =+ Map.insert+ (headerName s) val+ (ctxHeaderAccess ctx) }++-- | (internal) gets the raw query data+getQueryRaw+ :: forall m (n :: Symbol)+ . Monad m => Sing n -> StateT Context m (QueryKeyState Text)+getQueryRaw s = do+ qs <- gets ctxQuery+ let qKey = withKnownSymbol s (fromString (symbolVal s))+ return $ case Map.lookup qKey qs of+ Nothing -> QueryKeyAbsent+ Just Nothing -> QueryKeyPresent+ Just (Just val) -> QueryKeyValued val++-- | (internal) declare that a query key was accessed+declareQuery+ :: forall m (n :: Symbol)+ . Monad m => Sing n -> StateT Context m ()+declareQuery s = do+ let qKey = withKnownSymbol s (fromString (symbolVal s))+ modify $ \ctx ->+ ctx { ctxQueryAccess = qKey : ctxQueryAccess ctx }++instance Monad m => Contextual (StateT Context m) where+ fork m = StateT $ \ctx -> do+ (a, newCtx) <- runStateT m ctx+ return ((a, newCtx), ctx)++ restore = put++ getVerb = parseVerb <$> gets (requestMethod . ctxRequest)++ endOfPath = do+ path <- gets ctxPathZipper+ case path of+ (_, []) -> return True+ _ -> return False++ popSegment = do+ state $ \ctx ->+ case ctxPathZipper ctx of+ (_past, []) -> (Nothing, ctx)+ (past, seg:future) ->+ (Just seg, ctx { ctxPathZipper = (seg:past, future) })++ popAllSegments = do+ state $ \ctx ->+ case ctxPathZipper ctx of+ (past, fut) ->+ (fut, ctx { ctxPathZipper = (reverse fut ++ past, []) })++ getHeader s = do+ declareHeader s Nothing+ mayVal <- getHeaderRaw s+ return (headerDecodeBS s mayVal)++ expectHeader s expected = do+ declareHeader s (Just expected)+ mayVal <- fmap (fmap Text.decodeUtf8) (getHeaderRaw s)+ return (maybe False (== expected) mayVal)++ getQuery s = do+ declareQuery s+ qks <- getQueryRaw s+ return (queryDecode s qks)++-- Context+-- ----------------------------------------------------------------------------++data Context =+ Context+ { ctxRequest :: Request+ -- ^ The original 'Request' which this 'Context' was initiated from.+ -- The 'requestBody' here has been "frozen" so that even if it is+ -- accessed by the 'Server' it can be accessed again later without+ -- impact.+ , ctxPathZipper :: ([Text], [Text])+ -- ^ The current location in the URI path. The 'Text' segments in the+ -- first part of the tuple are those which have already been+ -- consumed/visited (in reverse order) and those in the second part are+ -- those which have yet to be visited.+ , ctxHeaders :: Map SomeHeaderName S.ByteString+ -- ^ An extraction of the headers in the 'Request'+ , ctxHeaderAccess :: Map SomeHeaderName (Maybe Text)+ -- ^ A 'Map' from headers which have been requested so far by the+ -- 'Server' to, possibly, the values that these headers are expected to+ -- take.+ , ctxQuery :: Map Text (Maybe Text)+ -- ^ An extraction of the query parameters in the 'Request'+ , ctxQueryAccess :: [Text]+ -- ^ A listing of query keys which have been accessed so far by the+ -- 'Server'+++ , ctxBody :: S.ByteString+ -- ^ The body of the 'Request', strictly read.+ --+ -- This is cached via 'strictRequestBody' so that we don't have to deal+ -- with multiple request body pulls affecting one another; this defeats+ -- partial and lazy body loading, BUT the style of API description+ -- we're talking about here isn't really amenable to that sort of thing+ -- anyway.+ }++-- | Construct a fresh context from a 'Request'. Fully captures the+-- (normally streamed) body so that repeated accesses in the server will+-- all see the same body (e.g., allows for pure, strict access to the body+-- later).+makeContext :: Request -> IO Context+makeContext theRequest = do+ theBody <- strictRequestBody theRequest+ -- We create a "frozen", strict version of the body and augment the request to+ -- always return it directly.+ ref <- newIORef (Sl.toStrict theBody)+ let headerSet =+ map (\(name, value) ->+ (parseHeaderName (ciBsToText name), value))+ (requestHeaders theRequest)+ let querySet = queryToQueryText (queryString theRequest)+ return Context { ctxRequest = theRequest { requestBody = readIORef ref }+ , ctxPathZipper = ([], pathInfo theRequest)+ , ctxHeaders = Map.fromList headerSet+ , ctxQuery = Map.fromList querySet+ , ctxHeaderAccess = Map.empty+ , ctxQueryAccess = []+ , ctxBody = Sl.toStrict theBody+ }++-- | (internal) Converts a case insensitive bytestring to a case+-- insensitive text value.+ciBsToText :: CI.CI S.ByteString -> CI.CI Text+ciBsToText = CI.mk . Text.decodeUtf8 . CI.original
+ test/Examples/Ex1.hs view
@@ -0,0 +1,136 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeOperators #-}++module Examples.Ex1 where++import Data.String+import Data.Text (Text)+import Serv.Api.Prelude+import Serv.Wai.Prelude++import qualified Network.Wai as Wai+import qualified Network.Wai.Test as T+import Test.Tasty+import qualified Test.Tasty.HUnit as Hu++type RawBody = HasBody '[TextPlain] Text+type JSONBody = HasBody '[JSON] [Int]++type TheApi+ = Endpoint ()+ '[+ Method GET+ '[ Ok :::+ Respond '[ CacheControl ::: Raw Text ] RawBody+ ]+ , Method PUT+ '[ Ok :::+ Respond '[ CacheControl ::: Raw Text ] JSONBody+ ]+ , Method DELETE+ '[ InternalServerError :::+ Respond '[] RawBody+ ]+ ]++apiSing :: Sing TheApi+apiSing = sing++impl :: Impl IO TheApi+impl =+ SGET =:+ (return . respond+ $ emptyResponse SOk+ & withHeader SCacheControl "foo"+ & withBody "Hello")+ <+>+ SPUT =:+ (return . respond+ $ emptyResponse SOk+ & withHeader SCacheControl "foo"+ & withBody [1, 2, 3])+ <+>+ SDELETE =:+ (return . respond+ $ emptyResponse SInternalServerError+ & withBody "Server error")+ <+>+ RNil++theServer :: Server IO+theServer = server apiSing impl++runTest :: T.Session a -> IO a+runTest = flip T.runSession (serverApplication theServer)++test1 :: TestTree+test1 = testGroup "Simple responses"+ [ Hu.testCase "Constant GET response (RawText)" $ runTest $ do+ let req = Wai.defaultRequest+ resp <- T.request req+ T.assertStatus 200 resp+ T.assertContentType "text/plain" resp+ T.assertBody "Hello" resp+ T.assertHeader "Cache-Control" "foo" resp++ , Hu.testCase "404 response (RawText) at ////" $ runTest $ do+ let req = Wai.defaultRequest+ & flip T.setPath "////"+ resp <- T.request req+ T.assertStatus 404 resp++ , Hu.testCase "Constant PUT response (JSON)" $ runTest $ do+ let req = Wai.defaultRequest { Wai.requestMethod = "PUT" }+ resp <- T.request req+ T.assertStatus 200 resp+ T.assertContentType "application/json" resp+ T.assertBody "[1,2,3]" resp+ T.assertHeader "Cache-Control" "foo" resp++ , Hu.testCase "Proper OPTIONS response" $ runTest $ do+ let req = Wai.defaultRequest+ { Wai.requestMethod = "OPTIONS" }+ resp <- T.request req+ T.assertStatus 200 resp+ T.assertBody "" resp+ T.assertHeader "Allow" "DELETE,GET,HEAD,OPTIONS,PUT" resp++ , Hu.testCase "Proper HEAD response" $ runTest $ do+ let req = Wai.defaultRequest+ { Wai.requestMethod = "HEAD" }+ resp <- T.request req+ T.assertStatus 200 resp+ T.assertBody "" resp+ T.assertHeader "Cache-Control" "foo" resp++ , Hu.testCase "Error on DELETE response" $ runTest $ do+ let req = Wai.defaultRequest+ { Wai.requestMethod = "DELETE" }+ resp <- T.request req+ T.assertStatus 500 resp+ T.assertBody "Server error" resp++ , Hu.testCase "Missing response at bad path" $ runTest $ do+ let req =+ Wai.defaultRequest+ & flip T.setPath "/hello"+ resp <- T.request req+ T.assertStatus 404 resp+ T.assertBody "" resp+ T.assertNoHeader "Cache-Control" resp++ , testGroup "Missing responses at wrong methods"+ $ flip map ["POST", "NOTAMETHOD"] $ \method ->+ Hu.testCase ("Missing response at method " ++ method) $ runTest $ do+ let req =+ Wai.defaultRequest+ { Wai.requestMethod = fromString method }+ resp <- T.request req+ T.assertStatus 405 resp+ T.assertBody "" resp+ T.assertNoHeader "Cache-Control" resp+ ]++tests :: TestTree+tests = testGroup "Example 1" [ test1 ]
+ test/Spec.hs view
@@ -0,0 +1,31 @@++import qualified Examples.Ex1 as Ex1+import Test.HUnit+import Test.Tasty+import qualified Test.Tasty.HUnit as Hu+import Test.Tasty.Ingredients.Basic (consoleTestReporter,+ listingTests)+import Test.Tasty.Runners.AntXML (antXMLRunner)++main :: IO ()+main =+ defaultMainWithIngredients+ [ antXMLRunner+ , listingTests+ , consoleTestReporter+ ] tests++tests :: TestTree+tests =+ testGroup "Server Tests"+ [ systemTests+ , Ex1.tests+ ]++systemTests :: TestTree+systemTests = testGroup "System Tests"+ [ Hu.testCase "Trivial tests" trivial+ ] where++trivial :: Assertion+trivial = assertBool "True is False" True