diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/serv-wai.cabal b/serv-wai.cabal new file mode 100644 --- /dev/null +++ b/serv-wai.cabal @@ -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 +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 diff --git a/src/Serv/Wai.hs b/src/Serv/Wai.hs new file mode 100644 --- /dev/null +++ b/src/Serv/Wai.hs @@ -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 diff --git a/src/Serv/Wai/Corec.hs b/src/Serv/Wai/Corec.hs new file mode 100644 --- /dev/null +++ b/src/Serv/Wai/Corec.hs @@ -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 diff --git a/src/Serv/Wai/Error.hs b/src/Serv/Wai/Error.hs new file mode 100644 --- /dev/null +++ b/src/Serv/Wai/Error.hs @@ -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 diff --git a/src/Serv/Wai/Prelude.hs b/src/Serv/Wai/Prelude.hs new file mode 100644 --- /dev/null +++ b/src/Serv/Wai/Prelude.hs @@ -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 diff --git a/src/Serv/Wai/Rec.hs b/src/Serv/Wai/Rec.hs new file mode 100644 --- /dev/null +++ b/src/Serv/Wai/Rec.hs @@ -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 diff --git a/src/Serv/Wai/Response.hs b/src/Serv/Wai/Response.hs new file mode 100644 --- /dev/null +++ b/src/Serv/Wai/Response.hs @@ -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 diff --git a/src/Serv/Wai/Type.hs b/src/Serv/Wai/Type.hs new file mode 100644 --- /dev/null +++ b/src/Serv/Wai/Type.hs @@ -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 diff --git a/test/Examples/Ex1.hs b/test/Examples/Ex1.hs new file mode 100644 --- /dev/null +++ b/test/Examples/Ex1.hs @@ -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 ] diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -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