linnet 0.2.0.0 → 0.3.0.0

raw patch · 19 files changed

+318/−136 lines, 19 filesdep +http-mediadep ~exceptionsPVP ok

version bump matches the API change (PVP)

Dependencies added: http-media

Dependency ranges changed: exceptions

API changes (from Hackage documentation)

Files

• linnet.cabal +5/−3
• src/Linnet.hs +5/−0
• src/Linnet/Bootstrap.hs +22/−21
• src/Linnet/Compile.hs +61/−15
• src/Linnet/ContentTypes.hs +5/−3
• src/Linnet/Decode.hs +1/−1
• src/Linnet/Encode.hs +1/−1
• src/Linnet/Endpoint.hs +23/−12
• src/Linnet/Endpoints/Bodies.hs +2/−2
• src/Linnet/Endpoints/Cookies.hs +3/−4
• src/Linnet/Endpoints/Methods.hs +6/−3
• src/Linnet/Endpoints/Paths.hs +5/−5
• src/Linnet/Internal/Coproduct.hs +7/−0
• src/Linnet/Output.hs +11/−10
• src/Linnet/ToResponse.hs +76/−17
• test/BootstrapSpec.hs +78/−32
• test/EncodeLaws.hs +2/−2
• test/Instances.hs +1/−1
• test/Util.hs +4/−4

@@ -1,6 +1,6 @@ cabal-version: 1.12 name: linnet-version: 0.2.0.0+version: 0.3.0.0 license: Apache license-file: LICENSE copyright: 2019 Sergey Kolbasov@@ -55,7 +55,8 @@         bytestring-conversion >=0.3.1,         case-insensitive >=1.2.0.11,         either >=5.0.1.1,-        exceptions >=0.10.2,+        exceptions >=0.10.3,+        http-media >=0.8.0.0,         http-types >=0.12.3,         mtl >=2.2.2,         text >=1.2.3.1,@@ -93,8 +94,9 @@         bytestring-conversion >=0.3.1,         case-insensitive >=1.2.0.11,         either >=5.0.1.1,-        exceptions >=0.10.2,+        exceptions >=0.10.3,         hspec >=2.7.1,+        http-media >=0.8.0.0,         http-types >=0.12.3,         linnet -any,         mtl >=2.2.2,

@@ -94,6 +94,9 @@   , ApplicationJson   , TextHtml   , TextPlain+  -- * Content-Type negotiation+  , NotAcceptable406+  , (:+:)   ) where  import           Linnet.Bootstrap@@ -102,7 +105,9 @@ import           Linnet.Encode import           Linnet.Endpoint import           Linnet.Endpoints+import           Linnet.Internal.Coproduct ((:+:)) import           Linnet.Output+import           Linnet.ToResponse         (NotAcceptable406) import           Network.Wai.Handler.Warp -- $helloWorld -- Hello @name@ example using warp server:

@@ -17,11 +17,9 @@   ) where  import           Control.Monad.Reader         (ReaderT (..))-import           Data.Data                    (Proxy)-import           GHC.Base                     (Symbol) import qualified Linnet.Compile               as Compile import           Linnet.Endpoint-import           Linnet.Internal.Coproduct    (CNil, Coproduct)+import           Linnet.Internal.Coproduct    ((:+:), CNil) import           Linnet.Internal.HList        (HList (..)) import           Linnet.NaturalTransformation import           Network.Wai                  (Application, Request, Response)@@ -32,19 +30,24 @@ -- | Create 'Bootstrap' out of single 'Endpoint' and some given Content-Type: -- -- > bootstrap @TextPlain (pure "foo")-bootstrap ::-     forall (ct :: Symbol) m a. Endpoint m a -> Bootstrap m (Coproduct (Proxy ct) CNil) (HList '[ (Endpoint m a)])-bootstrap ea = Bootstrap @m @(Coproduct (Proxy ct) CNil) (ea ::: HNil)+--+-- To enable Content-Type negotiation based on @Accept@ header, use 'Coproduct' ':+:' type operator to set the type:+--+-- > bootstrap @(TextPlain :+: TextHtml) (pure "foo") -- in case of failed negotiation, text/html is picked as the last resort+-- > bootstrap @(TextPlain :+: TextHtml :+: NotAcceptable406) (pure "foo") -- in case of failed negotiation, 406 is returned+--+bootstrap :: forall ct m a. Endpoint m a -> Bootstrap m (ct :+: CNil) (HList '[ (Endpoint m a)])+bootstrap ea = Bootstrap @m @(ct :+: CNil) (ea ::: HNil)  -- | Add another endpoint to 'Bootstrap' for purpose of serving multiple Content-Types with *different* endpoints ----- > bootstrap @TextPlain (pure "foo") & server @ApplicationJson (pure "bar")+-- > bootstrap @TextPlain (pure "foo") & serve @ApplicationJson (pure "bar") serve ::-     forall (ct :: Symbol) cts es m a.+     forall ct cts es m a.      Endpoint m a   -> Bootstrap m cts (HList es)-  -> Bootstrap m (Coproduct (Proxy ct) cts) (HList (Endpoint m a ': es))-serve ea (Bootstrap e) = Bootstrap @m @(Coproduct (Proxy ct) cts) (ea ::: e)+  -> Bootstrap m (ct :+: cts) (HList (Endpoint m a ': es))+serve ea (Bootstrap e) = Bootstrap @m @(ct :+: cts) (ea ::: e)  -- | Compile 'Bootstrap' into @ReaderT Request m Response@ for further combinations. -- Might be useful to implement middleware in context of the same monad @m@:@@ -58,16 +61,14 @@  -- | Convert @ReaderT Request m Response@ into WAI @Application@ ----- > bootstrap @TextPlain (pure "foo") & compile & toApp id------ The first parameter here is a natural transformation of 'Endpoint's monad @m@ into @IO@.--- In case if selected monad is @IO@ already then @id@ is just enough. Otherwise, it's a good place to define how to "start"--- custom monad for each request to come and convert it to @IO@.------ As an example:------  * @ReaderT RequestContext IO@ could be used to pass some data as local context for the request.+-- > bootstrap @TextPlain (pure "foo") & compile & toApp @IO -----  * Some monad for logging (i.e. co-log)-toApp :: forall m . (NaturalTransformation m IO) => ReaderT Request m Response -> Application+-- The constraint here is a natural transformation of 'Endpoint's monad @m@ into @IO@.+-- In case if selected monad is @IO@ already then provided instance is just enough.+-- Otherwise, it's necessary define how to "start" custom monad for each request to come and convert it to @IO@ as the+-- instance of 'NaturalTransformation' @m IO@.+toApp ::+     forall m. (NaturalTransformation m IO)+  => ReaderT Request m Response+  -> Application toApp !readerT request callback = mapK (runReaderT readerT request) >>= callback

@@ -1,22 +1,29 @@ {-# LANGUAGE AllowAmbiguousTypes   #-}+{-# LANGUAGE ConstraintKinds       #-} {-# LANGUAGE DataKinds             #-} {-# LANGUAGE FlexibleContexts      #-} {-# LANGUAGE FlexibleInstances     #-} {-# LANGUAGE GADTs                 #-} {-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings     #-}+{-# LANGUAGE RecordWildCards       #-} {-# LANGUAGE ScopedTypeVariables   #-} {-# LANGUAGE TypeApplications      #-}+{-# LANGUAGE TypeFamilies          #-} {-# LANGUAGE TypeOperators         #-}+{-# LANGUAGE UndecidableInstances  #-}  module Linnet.Compile   ( Compile(..)   ) where  import           Control.Exception         (SomeException)+import           Control.Monad             (join, (>=>)) import           Control.Monad.Catch       (MonadCatch)-import           Control.Monad.Reader      (ReaderT(..))-import           Data.Data                 (Proxy)-import           GHC.TypeLits              (KnownSymbol)+import           Control.Monad.Reader      (ReaderT (..))+import           Data.ByteString           (intercalate)+import           Data.ByteString.Char8     (split)+import           Data.Maybe                (maybeToList) import           Linnet.Endpoint import           Linnet.Errors             (LinnetError) import           Linnet.Input@@ -24,27 +31,66 @@ import           Linnet.Internal.HList import           Linnet.Output             (Output (..), outputToResponse,                                             payloadError)-import           Linnet.ToResponse         (ToResponse)-import           Network.HTTP.Types        (badRequest400, status404)-import           Network.Wai               (Request, Response, responseLBS)+import           Linnet.ToResponse         (Negotiable (..))+import           Network.HTTP.Media        (MediaType, parseQuality)+import           Network.HTTP.Types        (Method, badRequest400, hAccept,+                                            methodNotAllowed405, notFound404)+import           Network.HTTP.Types.Header (hAllow)+import           Network.Wai               (Request, Response, requestHeaders,+                                            responseLBS) +newtype CompileContext =+  CompileContext+    { allowedMethods :: [Method]+    }+ class Compile cts m es where   compile :: es -> ReaderT Request m Response -instance (Monad m) => Compile CNil m (HList '[]) where-  compile _ = ReaderT $ const notFoundResponse+instance (Compile' cts m es) => Compile cts m es where+  compile es = compile' @cts es (CompileContext []) -instance (KnownSymbol ct, ToResponse ct a, ToResponse ct SomeException, Compile cts m (HList es), MonadCatch m) =>-         Compile (Coproduct (Proxy ct) cts) m (HList (Endpoint m a ': es)) where-  compile (ea ::: es) =+class Compile' cts m es where+  compile' :: es -> CompileContext -> ReaderT Request m Response++instance (Monad m) => Compile' CNil m (HList '[]) where+  compile' _ CompileContext {..} =+    ReaderT $+    const+      (if null allowedMethods+         then notFoundResponse+         else methodNotAllowedResponse allowedMethods)++instance (Negotiable ct a, Negotiable ct SomeException, Negotiable ct (), Compile' cts m (HList es), MonadCatch m) =>+         Compile' (ct :+: cts) m (HList (Endpoint m a ': es)) where+  compile' (ea ::: es) ctx@CompileContext {..} =     ReaderT       (\req ->-         case runEndpoint (handle respond400 ea) (inputFromRequest req) of-           Matched _ mo -> outputToResponse @a @ct <$> mo-           NotMatched   -> runReaderT (compile @cts es) req)+         let accept =+               (maybeToList . lookup hAccept >=> split ',' >=> (join . maybeToList . parseQuality @MediaType)) .+               requestHeaders $+               req+          in case runEndpoint (handle respond400 ea) (inputFromRequest req) of+               Matched _ mo ->+                 outputToResponse+                   (negotiate @ct accept Nothing)+                   (negotiate @ct accept Nothing)+                   (negotiate @ct accept Nothing) <$>+                 mo+               NotMatched r ->+                 let newContext =+                       case r of+                         MethodNotAllowed allowed -> ctx {allowedMethods = allowed : allowedMethods}+                         Other -> ctx+                  in runReaderT (compile' @cts es newContext) req)  notFoundResponse :: (Applicative m) => m Response-notFoundResponse = pure $ responseLBS status404 [] mempty+notFoundResponse = pure $ responseLBS notFound404 [] mempty++methodNotAllowedResponse :: (Applicative m) => [Method] -> m Response+methodNotAllowedResponse wouldAllow = pure $ responseLBS methodNotAllowed405 [(hAllow, headerValue)] mempty+  where+    headerValue = intercalate ", " wouldAllow  respond400 :: (Applicative m) => LinnetError -> m (Output a) respond400 err = pure $ payloadError badRequest400 err

@@ -6,11 +6,13 @@   , ApplicationJson   ) where +import Data.Data (Proxy)+ -- | Content-Type literal for @text/html@ encoding-type TextHtml = "text/html"+type TextHtml = Proxy "text/html"  -- | Content-Type literal for @text/plain@ encoding-type TextPlain = "text/plain"+type TextPlain = Proxy "text/plain"  -- | Content-Type literal for @application/json@ encoding-type ApplicationJson = "application/json"+type ApplicationJson = Proxy "application/json"

@@ -28,7 +28,7 @@ -- | Decoding of HTTP request payload into some type @a@. -- Phantom type @ct@ guarantees that compiler checks support of decoding some @a@ from content of given @Content-Type@ -- by looking for specific @Decode@ instance.-class Decode (ct :: Symbol) a where+class Decode ct a where   decode :: BL.ByteString -> Either LinnetError a  class DecodePath a where

@@ -22,7 +22,7 @@ -- | Encoding of some type @a@ into payload of HTTP response -- Phantom type @ct@ guarantees that compiler checks support of encoding of some @a@ into content of given @Content-Type@ -- by looking for specific @Encode@ instance.-class Encode (ct :: Symbol) a where+class Encode ct a where   encode :: a -> BL.ByteString  instance Encode TextPlain BL.ByteString where

@@ -10,6 +10,7 @@ module Linnet.Endpoint   ( EndpointResult(..)   , Endpoint(..)+  , NotMatchedReason(..)   , isMatched   , maybeReminder   , lift@@ -40,6 +41,7 @@ import           Linnet.Internal.Coproduct import           Linnet.Internal.HList import           Linnet.Output+import           Network.HTTP.Types        (Method) import           Network.Wai               (Request)  infixl 0 ~>@@ -61,7 +63,16 @@       , matchedOutput   :: m (Output a)       }   | NotMatched+      { reason :: NotMatchedReason+      } +data NotMatchedReason+  = MethodNotAllowed+      { allowedMethod :: Method+      }+  | Other+  deriving (Show, Eq)+ isMatched :: EndpointResult m a -> Bool isMatched (Matched _ _) = True isMatched _             = False@@ -72,11 +83,11 @@  instance (Show (m (Output a))) => Show (EndpointResult m a) where   show (Matched _ out) = "EndpointResult.Matched(" ++ show out ++ ")"-  show NotMatched      = "EndpointResult.NotMatched"+  show (NotMatched r)  = "EndpointResult.NotMatched(" ++ show r ++ ")"  instance (Functor m) => Functor (EndpointResult m) where-  fmap f (Matched r m) = Matched r $ (fmap . fmap) f m-  fmap _ NotMatched    = NotMatched+  fmap f (Matched r m)  = Matched r $ (fmap . fmap) f m+  fmap _ (NotMatched r) = NotMatched r  -- | Basic Linnet data type that abstracts away operations over HTTP communication. -- While WAI Application has type of @Request -> (Response -> IO ResponseReceived) -> IO ResponseReceived@,@@ -126,7 +137,7 @@   liftA2 fn fa fb = productWith fa fb fn  instance (MC.MonadCatch m) => Alternative (Endpoint m) where-  empty = Endpoint {runEndpoint = const NotMatched, toString = "empty"}+  empty = Endpoint {runEndpoint = const $ NotMatched Other, toString = "empty"}   (<|>) ea eb =     Endpoint       { runEndpoint =@@ -138,8 +149,8 @@                     if length (reminder remA) <= length (reminder remB)                       then a                       else b-                  NotMatched -> a-              NotMatched -> runEndpoint eb input+                  NotMatched _ -> a+              NotMatched _ -> runEndpoint eb input       , toString = toString ea ++ "<|>" ++ toString eb       } @@ -159,7 +170,7 @@         \input ->           case runEndpoint ea input of             Matched remA ma -> Matched remA $ ma >>= transformM fn-            NotMatched      -> NotMatched+            NotMatched r    -> NotMatched r     }  transformOutput :: (m (Output a) -> m (Output b)) -> Endpoint m a -> Endpoint m b@@ -169,7 +180,7 @@         \input ->           case runEndpoint ea input of             Matched remA ma -> Matched remA $ fn ma-            NotMatched      -> NotMatched+            NotMatched r    -> NotMatched r     }  transform :: (Monad m) => (m a -> m b) -> Endpoint m a -> Endpoint m b@@ -179,7 +190,7 @@         \input ->           case runEndpoint ea input of             Matched remA ma -> Matched {matchedReminder = remA, matchedOutput = ma >>= traverse (fn . pure)}-            NotMatched -> NotMatched+            NotMatched r -> NotMatched r     }  -- | Handle exception in monad @m@ of Endpoint result using provided function that returns new 'Output'@@ -201,7 +212,7 @@               traverseEither (Right out) = Right <$> out            in case runEndpoint ea input of                 Matched remA out -> Matched {matchedReminder = remA, matchedOutput = traverseEither <$> MC.try out}-                NotMatched -> NotMatched+                NotMatched r -> NotMatched r     }  -- | Inversed alias for 'mapOutputM'@@ -243,8 +254,8 @@                         ob <- MC.try bOutM                         product_ oa ob                    in Matched bRem out-                NotMatched -> NotMatched-            NotMatched -> NotMatched+                NotMatched r -> NotMatched r+            NotMatched r -> NotMatched r     }   where     product_ :: Either LinnetError (Output a) -> Either LinnetError (Output b) -> m (Output c)

@@ -49,7 +49,7 @@     { runEndpoint =         \input ->           case (requestBodyLength . request) input of-            ChunkedBody -> NotMatched+            ChunkedBody -> NotMatched Other             KnownLength 0 -> Matched {matchedReminder = input, matchedOutput = throwM $ MissingEntity Body}             KnownLength _ ->               Matched@@ -71,7 +71,7 @@     { runEndpoint =         \input ->           case (requestBodyLength . request) input of-            ChunkedBody -> NotMatched+            ChunkedBody -> NotMatched Other             KnownLength 0 -> Matched {matchedReminder = input, matchedOutput = pure $ ok Nothing}             KnownLength _ ->               Matched

@@ -1,5 +1,4 @@ {-# LANGUAGE DataKinds           #-}-{-# LANGUAGE OverloadedStrings   #-} {-# LANGUAGE ScopedTypeVariables #-}  module Linnet.Endpoints.Cookies@@ -10,13 +9,13 @@ import           Control.Monad.Catch     (MonadThrow, throwM) import qualified Data.ByteString         as B import qualified Data.ByteString.Char8   as C8-import qualified Data.CaseInsensitive    as CI import           Linnet.Decode import           Linnet.Endpoint import           Linnet.Endpoints.Entity import           Linnet.Errors import           Linnet.Input import           Linnet.Output+import           Network.HTTP.Types      (hCookie) import           Network.URI.Encode      (decodeByteString) import           Network.Wai             (requestHeaders) @@ -43,7 +42,7 @@   Endpoint     { runEndpoint =         \input ->-          let maybeCookie = (lookup (CI.mk "Cookie") . requestHeaders . request) input >>= findCookie name+          let maybeCookie = (lookup hCookie . requestHeaders . request) input >>= findCookie name               output =                 case maybeCookie of                   Just val ->@@ -69,7 +68,7 @@   Endpoint     { runEndpoint =         \input ->-          let maybeCookie = (lookup (CI.mk "Cookie") . requestHeaders . request) input >>= findCookie name+          let maybeCookie = (lookup hCookie . requestHeaders . request) input >>= findCookie name               output =                 case maybeCookie of                   Just val ->

@@ -20,9 +20,12 @@   Endpoint     { runEndpoint =         \input ->-          if (requestMethod . request) input == method-            then runEndpoint underlying input-            else NotMatched+          let result = runEndpoint underlying input+           in if (requestMethod . request) input == method+                then result+                else case result of+                       Matched _ _ -> NotMatched (MethodNotAllowed method)+                       skipped     -> skipped     , toString = show method ++ " " ++ toString underlying     } 

@@ -33,11 +33,11 @@     { runEndpoint =         \input ->           case reminder input of-            [] -> NotMatched+            [] -> NotMatched Other             (h:t) ->               case decodePath h of                 Just v -> Matched {matchedReminder = input {reminder = t}, matchedOutput = pure $ ok v}-                Nothing -> NotMatched+                Nothing -> NotMatched Other     , toString = show (typeRep (Proxy :: Proxy a))     } @@ -53,11 +53,11 @@     { runEndpoint =         \input ->           case reminder input of-            [] -> NotMatched+            [] -> NotMatched Other             (h:t) ->               if h == value                 then Matched {matchedReminder = input {reminder = t}, matchedOutput = pure $ ok HNil}-                else NotMatched+                else NotMatched Other     , toString = T.unpack value     } @@ -73,7 +73,7 @@         \input ->           case reminder input of             [] -> Matched input (pure . ok $ HNil)-            _  -> NotMatched+            _  -> NotMatched Other     , toString = "/"     } 

@@ -8,10 +8,12 @@ {-# LANGUAGE ScopedTypeVariables    #-} {-# LANGUAGE TypeApplications       #-} {-# LANGUAGE TypeFamilies           #-}+{-# LANGUAGE TypeOperators          #-} {-# LANGUAGE UndecidableInstances   #-}  module Linnet.Internal.Coproduct   ( Coproduct(..)+  , (:+:)   , CNil   , AdjoinCoproduct(..)   ) where@@ -20,6 +22,11 @@  instance Eq CNil where   (==) _ _ = True++-- | Type operator for 'Coproduct' type +type a :+: b = Coproduct a b++infixr 9 :+:  data Coproduct a b where   Inl :: a -> Coproduct a b

@@ -3,9 +3,9 @@ {-# LANGUAGE FlexibleContexts          #-} {-# LANGUAGE MonoLocalBinds            #-} {-# LANGUAGE OverloadedStrings         #-}+{-# LANGUAGE RecordWildCards           #-} {-# LANGUAGE ScopedTypeVariables       #-} {-# LANGUAGE StandaloneDeriving        #-}-{-# LANGUAGE TypeApplications          #-} {-# LANGUAGE UndecidableInstances      #-}  module Linnet.Output@@ -47,6 +47,7 @@ import           Control.Monad.Catch       (MonadThrow (..)) import qualified Data.ByteString           as B import qualified Data.CaseInsensitive      as CI+import           Data.Data                 (Proxy) import           GHC.TypeLits              (KnownSymbol) import           Linnet.ToResponse         (ToResponse (..)) import           Network.HTTP.Types        (Header)@@ -236,13 +237,13 @@ payloadEmpty status = Output {outputStatus = status, outputPayload = NoPayload, outputHeaders = []}  outputToResponse ::-     forall a ct. (KnownSymbol ct, ToResponse ct a, ToResponse ct SomeException)-  => Output a+     (Status -> [Header] -> a -> Response)+  -> (Status -> [Header] -> SomeException -> Response)+  -> (Status -> [Header] -> () -> Response)+  -> Output a   -> Response-outputToResponse output =-  let response =-        case outputPayload output of-          Payload a      -> toResponse @ct a-          NoPayload      -> toResponse @ct ()-          ErrorPayload e -> toResponse @ct $ toException e-   in (mapResponseStatus (const (outputStatus output)) . mapResponseHeaders (++ outputHeaders output)) response+outputToResponse tr tre tru Output {..} =+  case outputPayload of+    Payload a      -> tr outputStatus outputHeaders a+    NoPayload      -> tru outputStatus outputHeaders ()+    ErrorPayload e -> tre outputStatus outputHeaders $ toException e

@@ -2,57 +2,64 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeOperators #-}  module Linnet.ToResponse   ( ToResponse(..)+  , Negotiable(..)+  , NotAcceptable406   ) where +import Control.Applicative ((<|>)) import qualified Data.ByteString.Char8 as C8 import qualified Data.ByteString.Lazy as BL+import Data.Maybe (fromMaybe) import Data.Proxy (Proxy(..)) import GHC.Base (Symbol) import GHC.TypeLits (KnownSymbol, symbolVal) import Linnet.Encode (Encode(..))-import Linnet.Internal.Coproduct (CNil, Coproduct(..))-import Network.HTTP.Types (status200, status404)+import Linnet.Internal.Coproduct ((:+:), CNil, Coproduct(..))+import Network.HTTP.Media (MediaType, Quality, (//), matchQuality, matches)+import Network.HTTP.Types (Header, Status, hContentType, notAcceptable406, status200, status404) import Network.Wai (Response, responseLBS)  -- | Type-class to convert a value of type @a@ into Response with Content-Type of @ct@-class ToResponse (ct :: Symbol) a where-  toResponse :: a -> Response+class ToResponse ct a where+  toResponse :: Status -> [Header] -> a -> Response  instance {-# OVERLAPPABLE #-} (ToResponse' (ValueT a) ct a) => ToResponse ct a where   toResponse = toResponse' @(ValueT a) @ct -class ToResponse' (value :: Value) (ct :: Symbol) a where-  toResponse' :: a -> Response+class ToResponse' (value :: Value) ct a where+  toResponse' :: Status -> [Header] -> a -> Response -instance (Encode ct a, KnownSymbol ct) => ToResponse' 'Value ct a where-  toResponse' a = mkResponse @ct $ encode @ct a+instance (Encode (Proxy ct) a, KnownSymbol ct) => ToResponse' 'Value (Proxy ct) a where+  toResponse' status headers a = mkResponse @ct status headers $ encode @(Proxy ct) a  instance ToResponse' 'ResponseValue ct Response where-  toResponse' = id+  toResponse' _ _ = id -instance (KnownSymbol ct) => ToResponse' 'UnitValue ct () where-  toResponse' _ = mkResponse @ct mempty+instance (KnownSymbol ct) => ToResponse' 'UnitValue (Proxy ct) () where+  toResponse' status headers _ = mkResponse @ct status headers mempty  instance ToResponse' 'CNilValue ct CNil where-  toResponse' _ = responseLBS status404 [] mempty+  toResponse' _ _ _ = responseLBS status404 [] mempty  instance (ToResponse ct a, ToResponse ct b) => ToResponse' 'CoproductValue ct (Coproduct a b) where-  toResponse' (Inl a) = toResponse @ct a-  toResponse' (Inr b) = toResponse @ct b+  toResponse' status headers (Inl a) = toResponse @ct status headers a+  toResponse' status headers (Inr b) = toResponse @ct status headers b  mkResponse ::      forall ct. (KnownSymbol ct)-  => BL.ByteString+  => Status+  -> [Header]+  -> BL.ByteString   -> Response-mkResponse = responseLBS status200 [("Content-Type", C8.pack $ symbolVal (Proxy :: Proxy ct))]+mkResponse status headers = responseLBS status ((hContentType, C8.pack $ symbolVal (Proxy :: Proxy ct)) : headers)  data Value   = Value@@ -67,3 +74,55 @@   ValueT Response = 'ResponseValue   ValueT () = 'UnitValue   ValueT _ = 'Value++type ToResponseF a = Status -> [Header] -> a -> Response++-- | Type-class that enables Content-Type negotiation between client and server baked by instances of 'ToResponse'.+class Negotiable cts a where+  negotiate :: [Quality MediaType] -> Maybe (MediaType, ToResponseF a) -> ToResponseF a++instance (Negotiable' (ContentTypeValueT cts) cts a) => Negotiable cts a where+  negotiate = negotiate' @(ContentTypeValueT cts) @cts++class Negotiable' (t :: ContentTypeValue) cts a where+  negotiate' :: [Quality MediaType] -> Maybe (MediaType, ToResponseF a) -> ToResponseF a++instance (KnownSymbol c, ToResponse (Proxy c) a, Negotiable t a) =>+         Negotiable' 'ContentTypeCoproduct (Proxy c :+: t) a where+  negotiate' accept bestMatch = acceptMatcher accept+    where+      acceptMatcher mediaType =+        let value = C8.pack $ symbolVal (Proxy :: Proxy c)+            [p, s] = C8.split '/' value+            mt = p // s+            bestMatchExists = do+              (bestMatchMediaType, fn) <- bestMatch+              match <- matchQuality [bestMatchMediaType, mt] mediaType+              if match == bestMatchMediaType+                then pure $ negotiate @t mediaType bestMatch+                else pure $ negotiate @t mediaType (Just (match, toResponse @(Proxy c)))+            bestMatchUnknown = do+              match <- matchQuality [mt] mediaType+              pure $ negotiate @t mediaType (Just (match, toResponse @(Proxy c)))+            noMatchExists = negotiate @t mediaType Nothing+         in fromMaybe noMatchExists (bestMatchExists <|> bestMatchUnknown)++instance Negotiable' 'ContentTypeNegotiationFailed NotAcceptable406 a where+  negotiate' _ (Just (_, fn)) = fn+  negotiate' _ Nothing = \_ _ _ -> responseLBS notAcceptable406 [] mempty++instance ToResponse cts a => Negotiable' 'ContentTypeValue cts a where+  negotiate' _ _ = toResponse @cts++data ContentTypeValue+  = ContentTypeValue+  | ContentTypeNegotiationFailed+  | ContentTypeCoproduct++type family ContentTypeValueT ct :: ContentTypeValue where+  ContentTypeValueT (Coproduct _ _) = 'ContentTypeCoproduct+  ContentTypeValueT NotAcceptable406 = 'ContentTypeNegotiationFailed+  ContentTypeValueT _ = 'ContentTypeValue++-- | Uninhabited type to signal the need of 406 error during Content-Type negotiation+data NotAcceptable406

@@ -1,31 +1,38 @@ {-# LANGUAGE OverloadedStrings   #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications    #-}+{-# LANGUAGE TypeOperators       #-}  module BootstrapSpec where  import           Test.Hspec -import           Control.Concurrent      (newEmptyMVar, putMVar, takeMVar)-import           Control.Monad.Catch     (throwM)-import           Control.Monad.IO.Class  (liftIO)-import           Control.Monad.Reader    (ReaderT (..))-import qualified Data.CaseInsensitive    as CI-import           Data.Function           ((&))-import           Data.Functor.Identity   (runIdentity)-import qualified Data.Text               as T+import           Control.Concurrent        (newEmptyMVar, putMVar, takeMVar)+import           Control.Monad.Catch       (throwM)+import           Control.Monad.IO.Class    (liftIO)+import           Control.Monad.Reader      (ReaderT (..))+import qualified Data.CaseInsensitive      as CI+import           Data.Function             ((&))+import           Data.Functor.Identity     (runIdentity)+import qualified Data.Text                 as T import           Instances import           Linnet import           Linnet.Bootstrap import           Linnet.Endpoint import           Linnet.Errors+import           Linnet.Internal.Coproduct ((:+:), CNil) import           Linnet.Output-import           Network.HTTP.Types      (status400, status404)-import           Network.Wai             (defaultRequest, pathInfo,-                                          responseHeaders, responseStatus)-import           Network.Wai.Internal    (ResponseReceived (..))-import           Test.QuickCheck         (property)-import           Test.QuickCheck.Monadic (assert, monadicIO)+import           Linnet.ToResponse         (NotAcceptable406, toResponse)+import           Network.HTTP.Types        (hAccept, hContentType, methodPost,+                                            status400, status404, status405,+                                            status406)+import           Network.HTTP.Types.Header (hAllow)+import           Network.Wai               (defaultRequest, pathInfo,+                                            requestHeaders, responseHeaders,+                                            responseStatus)+import           Network.Wai.Internal      (ResponseReceived (..))+import           Test.QuickCheck           (property)+import           Test.QuickCheck.Monadic   (assert, monadicIO)  spec :: Spec spec = do@@ -34,7 +41,7 @@       monadicIO $ do         let readerT = bootstrap @TextPlain (liftOutputM (return out)) & compile         result <- liftIO $ runReaderT readerT defaultRequest-        assert (result == outputToResponse @T.Text @TextPlain out)+        assert (result == outputToResponse (toResponse @TextPlain) (toResponse @TextPlain) (toResponse @TextPlain) out)   it "responds with corresponding content-type" $     property $ \(out :: (Output T.Text)) ->       monadicIO $ do@@ -42,19 +49,20 @@         result <- liftIO $ runReaderT readerT defaultRequest         let maybeContentType = lookup (CI.mk "Content-Type") (responseHeaders result)         assert (maybeContentType == Just "text/plain")-  it "responds with 404" $-    property $ \(out :: (Output T.Text)) ->-      monadicIO $ do-        let readerT = bootstrap @TextPlain (p' "foo" ~>> (return . ok $ ("text" :: T.Text))) & compile-        result <- liftIO $ runReaderT readerT defaultRequest-        assert (responseStatus result == status404)-  it "responds with 400 on LinnetError" $-    property $ \(out :: (Output T.Text)) ->-      monadicIO $ do-        let endpoint = liftOutputM (throwM $ DecodeError "oops") :: Endpoint IO T.Text-        let readerT = bootstrap @TextPlain endpoint & compile-        result <- liftIO $ runReaderT readerT defaultRequest-        assert (responseStatus result == status400)+  it "responds with 404" $ do+    let readerT = bootstrap @TextPlain (get (p' "foo") ~>> (return . ok $ ("text" :: T.Text))) & compile+    result <- liftIO $ runReaderT readerT defaultRequest+    responseStatus result `shouldBe` status404+  it "responds with 400 on LinnetError" $ do+    let endpoint = liftOutputM (throwM $ DecodeError "oops") :: Endpoint IO T.Text+    let readerT = bootstrap @TextPlain endpoint & compile+    result <- runReaderT readerT defaultRequest+    responseStatus result `shouldBe` status400+  it "responds with 405 on method mismatch" $ do+    let readerT = bootstrap @TextPlain (post (p' "foo") ~>> (return . ok $ ("text" :: T.Text))) & compile+    result <- runReaderT readerT defaultRequest {pathInfo = ["foo"]}+    responseStatus result `shouldBe` status405+    responseHeaders result `shouldBe` [(hAllow, methodPost)]   it "serves different content-types" $     property $ \(out :: (Output T.Text)) ->       monadicIO $ do@@ -63,11 +71,48 @@         let readerT = bootstrap @TextPlain text & serve @TextHtml html & compile         textResult <- liftIO $ runReaderT readerT (defaultRequest {pathInfo = ["foo"]})         htmlResult <- liftIO $ runReaderT readerT (defaultRequest {pathInfo = ["bar"]})-        let contentType = lookup (CI.mk "Content-Type")-        let maybeTextContentType = contentType (responseHeaders textResult)-        let maybeHtmlContentType = contentType (responseHeaders htmlResult)+        let maybeTextContentType = lookup hContentType (responseHeaders textResult)+        let maybeHtmlContentType = lookup hContentType (responseHeaders htmlResult)         assert (maybeTextContentType == Just "text/plain")         assert (maybeHtmlContentType == Just "text/html")+  it "negotiates content-type" $+    property $ \(out :: (Output T.Text)) ->+      monadicIO $ do+        let text = get (p' "foo") ~>> return out+        let readerT = bootstrap @(TextPlain :+: TextHtml :+: NotAcceptable406) text & compile+        textResult <-+          liftIO $+          runReaderT+            readerT+            (defaultRequest {pathInfo = ["foo"], requestHeaders = [(hAccept, "text/plain; q=1.0, text/html; q=0.9")]})+        htmlResult <-+          liftIO $+          runReaderT+            readerT+            (defaultRequest {pathInfo = ["foo"], requestHeaders = [(hAccept, "text/plain; q=0.9, text/html; q=1.0")]})+        let maybeTextContentType = lookup hContentType (responseHeaders textResult)+        let maybeHtmlContentType = lookup hContentType (responseHeaders htmlResult)+        assert (maybeTextContentType == Just "text/plain")+        assert (maybeHtmlContentType == Just "text/html")+  it "returns 406 on failed negotiation" $+    property $ \(out :: (Output T.Text)) ->+      monadicIO $ do+        let text = get (p' "foo") ~>> return out+        let readerT = bootstrap @(TextPlain :+: TextHtml :+: NotAcceptable406) text & compile+        textResult <-+          liftIO $+          runReaderT readerT (defaultRequest {pathInfo = ["foo"], requestHeaders = [(hAccept, "application/json")]})+        assert (responseStatus textResult == status406)+  it "falls back to the latest option when 406 is disabled" $+    property $ \(out :: (Output T.Text)) ->+      monadicIO $ do+        let text = get (p' "foo") ~>> return out+        let readerT = bootstrap @(TextPlain :+: TextHtml) text & compile+        htmlResult <-+          liftIO $+          runReaderT readerT (defaultRequest {pathInfo = ["foo"], requestHeaders = [(hAccept, "application/json")]})+        let maybeHtmlContentType = lookup hContentType (responseHeaders htmlResult)+        assert (maybeHtmlContentType == Just "text/html")   it "compiles into WAI application" $     property $ \(out :: (Output T.Text)) ->       monadicIO $ do@@ -76,4 +121,5 @@         let callback req = ResponseReceived <$ putMVar mvar req         _ <- liftIO $ app defaultRequest callback         response <- liftIO $ takeMVar mvar-        assert (response == outputToResponse @T.Text @TextPlain out)+        assert+          (response == outputToResponse (toResponse @TextPlain) (toResponse @TextPlain) (toResponse @TextPlain) out)

@@ -1,7 +1,6 @@ {-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE DataKinds           #-} {-# LANGUAGE FlexibleContexts    #-}-{-# LANGUAGE KindSignatures      #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications    #-} @@ -11,6 +10,7 @@   ) where  import           Data.ByteString.Conversion (ToByteString, toByteString)+import           Data.Data                  (Proxy) import           GHC.Base                   (Symbol) import           Linnet                     (TextPlain) import           Linnet.Encode@@ -18,7 +18,7 @@ import           Test.QuickCheck.Classes    (Laws (..))  encodeLaws ::-     forall a (ct :: Symbol). (ToByteString a, Encode ct a, Arbitrary a, Show a)+     forall a ct . (ToByteString a, Encode ct a, Arbitrary a, Show a)   => Laws encodeLaws = Laws "Encode" properties   where

@@ -282,7 +282,7 @@  instance Eq (m (Output a)) => Eq (EndpointResult m a) where   (==) (Matched i m) (Matched i' m') = i == i' && m == m'-  (==) NotMatched NotMatched         = True+  (==) (NotMatched r) (NotMatched r')         = r == r'   (==) _ _                           = False  instance Eq (m (Output a)) => Eq (Endpoint m a) where

@@ -22,8 +22,8 @@ headOption (h:t) = Just h  resultOutputUnsafe :: (Applicative m) => EndpointResult m a -> m (Maybe (Output a))-resultOutputUnsafe (Matched _ m) = fmap Just m-resultOutputUnsafe NotMatched    = pure Nothing+resultOutputUnsafe (Matched _ m)  = fmap Just m+resultOutputUnsafe (NotMatched _) = pure Nothing  resultValueUnsafe :: (Applicative m) => EndpointResult m a -> m (Maybe a) resultValueUnsafe (Matched _ m) =@@ -32,12 +32,12 @@        Output _ (Payload a) _ -> Just a        _ -> Nothing)     m-resultValueUnsafe NotMatched = pure Nothing+resultValueUnsafe (NotMatched _) = pure Nothing  resultOutputEither :: (MonadCatch m) => EndpointResult m a -> m (Either SomeException (Maybe (Output a))) resultOutputEither endpointResult =   case endpointResult of-    NotMatched -> pure $ Right Nothing+    NotMatched _ -> pure $ Right Nothing     Matched {matchedOutput = m} -> catchAll (fmap (Right . Just) m) (pure . Left)  checkLaws :: String -> Laws -> SpecWith ()