diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,4 +1,4 @@ -Copyright (c) 2012 Timothy Jones +Copyright (c) 2012-2017 Timothy Jones Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal in @@ -17,4 +17,3 @@ LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. - diff --git a/snap-accept.cabal b/snap-accept.cabal --- a/snap-accept.cabal +++ b/snap-accept.cabal @@ -1,20 +1,21 @@ name: snap-accept -version: 0.1.0 +version: 0.2.1 license: MIT license-file: LICENSE author: Timothy Jones -maintainer: Timothy Jones -homepage: http://github.com/zimothy/snap-accept -bug-reports: http://github.com/zimothy/snap-accept/issues +maintainer: Timothy Jones +homepage: https://github.com/zmthy/snap-accept +bug-reports: https://github.com/zmthy/snap-accept/issues category: Web -copyright: (c) 2013 Timothy Jones +copyright: (c) 2013-2017 Timothy Jones build-type: Simple -cabal-version: >=1.10 +cabal-version: >= 1.10 synopsis: Accept header branching for the Snap web framework description: HTTP media type functionality as a complement to Snap's 'method' and 'methods' - functions. Branches based on the value of the Accept header of the current - request, automatically setting the Content-Type header of the response. + functions. Branches based on the value of the Accept or Accept-Language + header of the current request, automatically setting the Content-Type or + Content-Language header of the response as appropriate. library hs-source-dirs: src @@ -29,11 +30,12 @@ Snap.Accept build-depends: - base >= 4.6.0 && < 5.0, - http-media >= 0.1.0 && < 0.2, - snap-core >= 0.9.4 && < 0.14 + base >= 4.6.0 && < 5.0, + bytestring >= 0.10.0 && < 0.11, + case-insensitive >= 1.2.0 && < 1.3, + http-media >= 0.6.0 && < 0.8, + snap-core >= 0.9.4 && < 1.1 source-repository head type: git - location: git://github.com/zimothy/snap-accept.get - + location: https://github.com/zmthy/snap-accept diff --git a/src/Snap/Accept.hs b/src/Snap/Accept.hs --- a/src/Snap/Accept.hs +++ b/src/Snap/Accept.hs @@ -1,68 +1,119 @@ ------------------------------------------------------------------------------ --- | Provides a simple interface for routing based on the value of the Accept --- header in the client's request. The functions 'accept' and 'accepts' --- mirror Snap's standard 'method' and 'methods' functions. --- --- The most convenient way of building 'MediaType' values is to use the --- 'IsString' instance with OverloadedStrings. --- --- > accept "application/json" serveJson --- --- Simple constructor operators are also supplied if you prefer. +-- | HTTP media type functionality as a complement to Snap's 'method' and +-- 'methods' functions. Branches based on the value of the Accept or +-- Accept-Language header of the current request, automatically setting the +-- Content-Type or Content-Language header of the response as appropriate. module Snap.Accept ( - -- * Accept routing + -- * Branching accept + , acceptMedia + , acceptLanguage , accepts + , acceptsMedia + , acceptsLanguage - -- * MediaType + -- * Accept types , MediaType - , (//) - , (/:) + , Language + + -- * Header names + , FromHeader (..) ) where ------------------------------------------------------------------------------- -import Control.Monad (join, (>=>)) -import Data.Maybe (fromMaybe) -import Network.HTTP.Media -import Network.HTTP.Media.MediaType (toByteString) -import Snap.Core +import Control.Monad (join) +import Data.ByteString (ByteString) +import Data.CaseInsensitive (CI) +import Data.Maybe (fromMaybe) +import Data.Proxy (Proxy (..)) +import Network.HTTP.Media +import Network.HTTP.Media.RenderHeader (renderHeader) +import Snap.Core ------------------------------------------------------------------------------ --- | Runs a Snap monad only if the request's Accept header allows for the --- given media type. If accepted, the response's Content-Type header is --- automatically filled in. -accept :: MonadSnap m => MediaType -> m a -> m a -accept mtype action = - withAccept (matchAccept [mtype]) >>= maybe (run mtype) run - where - run = flip runWithType action +-- | The class of values that represent some Accept* header in a request and +-- corresponding Content-* header in a response, such that the name of the +-- header can be retrieved from the type. +class (Accept a, RenderHeader a) => FromHeader a where + -- | The name of the corresponding Accept* header for this type. + requestName :: Proxy a -> CI ByteString + -- | The name of the corresponding Content-* header for this type. + responseName :: Proxy a -> CI ByteString + -- | The default header value to use if the header is absent. + defaultValue :: Proxy a -> ByteString +instance FromHeader MediaType where + requestName _ = "Accept" + responseName _ = "Content-Type" + defaultValue _ = "*/*" +instance FromHeader Language where + requestName _ = "Accept-Language" + responseName _ = "Content-Language" + defaultValue _ = "*" + + ------------------------------------------------------------------------------ --- | Runs a Snap monad only if the request's Accept header allows for one of --- the given media types. If accepted, the expected type is passed to the --- given function and the response's Content-Type header is automatically +-- | Runs a Snap monad only if the request's Accept* header allows for the +-- given value. If accepted, the response's Content-* header is automatically -- filled in. -accepts :: MonadSnap m => [(MediaType, m a)] -> m a -accepts [] = pass -accepts dict = withAccept (mapAccept dict') >>= fromMaybe (snd $ head dict') +accept :: (FromHeader a, MonadSnap m) => a -> m b -> m b +accept a s = + withAccept (proxyFor a) (matchAccept [a]) >>= maybe pass (`withHeader` s) where - dict' = map (join $ fmap . runWithType . fst) dict + proxyFor :: a -> Proxy a + proxyFor _ = Proxy +-- | The 'accept' function but specialised to 'MediaType'. +acceptMedia :: (MonadSnap m) => MediaType -> m a -> m a +acceptMedia = accept +-- | The 'accept' function but specialised to 'Language'. +acceptLanguage :: (MonadSnap m) => Language -> m a -> m a +acceptLanguage = accept + + ------------------------------------------------------------------------------ --- | Parses the Accept header from the request and, if successful, passes --- it to the given function. -withAccept :: MonadSnap m => ([Quality MediaType] -> Maybe a) -> m (Maybe a) -withAccept f = getsRequest $ getHeader "Accept" >=> parseAccept >=> f +-- | Matches the Accept* header of the request to each of the values in the +-- pairs of the given list, running the corresponding Snap monad in the pair +-- that is most desired by the client. If two or more results arise with the +-- same quality level and specificity, then the pair that appears earliest in +-- the list is matched. On any match, the response's Content-* header is +-- automatically filled in. +accepts :: (FromHeader a, MonadSnap m) => [(a, m b)] -> m b +accepts d = withAccept (proxyFor d) (mapAccept d') >>= fromMaybe pass + where + d' = map (join $ fmap . withHeader . fst) d + proxyFor :: [(a, m b)] -> Proxy a + proxyFor _ = Proxy +-- | The 'accepts' function but specialised to 'MediaType'. +acceptsMedia :: (MonadSnap m) => [(MediaType, m a)] -> m a +acceptsMedia = accepts +-- | The 'accepts' function but specialised to 'Language'. +acceptsLanguage :: (MonadSnap m) => [(Language, m a)] -> m a +acceptsLanguage = accepts + + ------------------------------------------------------------------------------ --- | Runs the given Snap monad with the given media type set in the --- response's ContentType header. -runWithType :: MonadSnap m => MediaType -> m a -> m a -runWithType mtype action = - modifyResponse (setContentType $ toByteString mtype) >> action +-- | Parses the Accept* header from the request and, if successful, passes it +-- to the given function. +withAccept :: (FromHeader a, MonadSnap m) + => Proxy a + -> (ByteString -> Maybe b) -> m (Maybe b) +withAccept p f = getsRequest $ f . fromMaybe (defaultValue p) . getHeader name + where + name = requestName p + +------------------------------------------------------------------------------ +-- | Runs a Snap monad with the rendered value of an Content-* form set in the +-- appropriate header of the response. +withHeader :: (FromHeader a, MonadSnap m) => a -> m b -> m b +withHeader a m = modifyResponse (setHeader name (renderHeader a)) >> m + where + name = responseName (proxyFor a) + proxyFor :: a -> Proxy a + proxyFor _ = Proxy