snap-accept (empty) → 0.1.0

raw patch · 4 files changed

+129/−0 lines, 4 filesdep +basedep +http-mediadep +snap-coresetup-changed

Dependencies added: base, http-media, snap-core

Files

• LICENSE +20/−0
• Setup.hs +2/−0
• snap-accept.cabal +39/−0
• src/Snap/Accept.hs +68/−0

@@ -0,0 +1,20 @@+Copyright (c) 2012 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+the Software without restriction, including without limitation the rights to+use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies+of the Software, and to permit persons to whom the Software is furnished to do+so, subject to the following conditions:++The above copyright notice and this permission notice shall be included in all+copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR+IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,+FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE+AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER+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.+

@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain

@@ -0,0 +1,39 @@+name:          snap-accept+version:       0.1.0+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+category:      Web+copyright:     (c) 2013 Timothy Jones+build-type:    Simple+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.++library+  hs-source-dirs: src++  ghc-options: -Wall++  default-language: Haskell2010+  default-extensions:+    OverloadedStrings++  exposed-modules:+    Snap.Accept++  build-depends:+    base       >= 4.6.0 && < 5.0,+    http-media >= 0.1.0 && < 0.2,+    snap-core  >= 0.9.4 && < 0.14++source-repository head+  type:     git+  location: git://github.com/zimothy/snap-accept.get+

@@ -0,0 +1,68 @@+------------------------------------------------------------------------------+-- | 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.+module Snap.Accept+    (+    -- * Accept routing+      accept+    , accepts++    -- * MediaType+    , MediaType+    , (//)+    , (/:)+    ) where++------------------------------------------------------------------------------+import Control.Monad                (join, (>=>))+import Data.Maybe                   (fromMaybe)+import Network.HTTP.Media+import Network.HTTP.Media.MediaType (toByteString)+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+++------------------------------------------------------------------------------+-- | 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+-- filled in.+accepts :: MonadSnap m => [(MediaType, m a)] -> m a+accepts []   = pass+accepts dict = withAccept (mapAccept dict') >>= fromMaybe (snd $ head dict')+  where+    dict' = map (join $ fmap . runWithType . fst) dict+++------------------------------------------------------------------------------+-- | 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+++------------------------------------------------------------------------------+-- | 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+