snap-accept 0.1.0 → 0.2.1
raw patch · 3 files changed
Files
- LICENSE +1/−2
- snap-accept.cabal +15/−13
- src/Snap/Accept.hs +95/−44
LICENSE view
@@ -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.-
snap-accept.cabal view
@@ -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 <git@zimothy.com>-homepage: http://github.com/zimothy/snap-accept-bug-reports: http://github.com/zimothy/snap-accept/issues+maintainer: Timothy Jones <tim@zmthy.net>+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
src/Snap/Accept.hs view
@@ -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