Adding MsgPack convenience module

.gitignore

@@ -1,6 +1,8 @@
 dist
 .DS*
 cabal-dev
+.cabal-sandbox
+cabal.sandbox.config
 dist
 *.swp
 TAGS

snap-extras.cabal

@@ -39,6 +39,7 @@ Library
   hs-source-dirs: src
   Build-depends:
       aeson                    >= 0.6   && < 0.8
+    , msgpack                  >= 0.7.2 && < 0.7.3
     , base                     >= 4     && < 5
     , blaze-builder            >= 0.3   && < 0.4
     , blaze-html               >= 0.6   && < 0.8

src/Snap/Extras/CoreUtils.hs

@@ -1,5 +1,5 @@
-{-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE NoMonomorphismRestriction #-}
+{-# LANGUAGE OverloadedStrings         #-}
 
 module Snap.Extras.CoreUtils
     ( finishEarly
@@ -8,6 +8,7 @@ module Snap.Extras.CoreUtils
     , serverError
     , plainResponse
     , jsonResponse
+    , mpResponse
     , jsResponse
     , easyLog
     , getParam'
@@ -24,20 +25,20 @@ module Snap.Extras.CoreUtils
     ) where
 
 -------------------------------------------------------------------------------
-import Control.Monad
-import Data.ByteString.Char8 (ByteString)
+import           Control.Monad
+import           Data.ByteString.Char8 (ByteString)
 import qualified Data.ByteString.Char8 as B
-import Data.Maybe
-import Safe
-import Snap.Core
+import           Data.Maybe
+import           Safe
+import           Snap.Core
 -------------------------------------------------------------------------------
 
 
 
 -------------------------------------------------------------------------------
 -- | Discard anything after this and return given status code to HTTP
 -- client immediately.
-finishEarly :: MonadSnap m => Int -> ByteString -> m b 
+finishEarly :: MonadSnap m => Int -> ByteString -> m b
 finishEarly code str = do
   modifyResponse $ setResponseStatus code str
   modifyResponse $ addHeader "Content-Type" "text/plain"
@@ -47,19 +48,19 @@ finishEarly code str = do
 
 -------------------------------------------------------------------------------
 -- | Finish early with error code 400
-badReq :: MonadSnap m => ByteString -> m b 
-badReq = finishEarly 400 
+badReq :: MonadSnap m => ByteString -> m b
+badReq = finishEarly 400
 
 
 -------------------------------------------------------------------------------
 -- | Finish early with error code 404
-notFound :: MonadSnap m => ByteString -> m b 
+notFound :: MonadSnap m => ByteString -> m b
 notFound = finishEarly 404
 
 
 -------------------------------------------------------------------------------
 -- | Finish early with error code 500
-serverError :: MonadSnap m => ByteString -> m b 
+serverError :: MonadSnap m => ByteString -> m b
 serverError = finishEarly 500
 
 
@@ -74,6 +75,11 @@ plainResponse = modifyResponse $ setHeader "Content-Type" "text/plain"
 jsonResponse :: MonadSnap m => m ()
 jsonResponse = modifyResponse $ setHeader "Content-Type" "application/json"
 
+-------------------------------------------------------------------------------
+-- | Mark response as 'application/x-msgpack'
+mpResponse :: MonadSnap m => m ()
+mpResponse = modifyResponse $ setHeader "Content-Type" "application/x-msgpack"
+
 
 -------------------------------------------------------------------------------
 -- | Mark response as 'application/javascript'
@@ -103,7 +109,7 @@ reqParam :: (MonadSnap m) => ByteString -> m ByteString
 reqParam s = do
   p <- getParam s
   maybe (badReq $ B.concat ["Required parameter ", s, " is missing."]) return p
- 
+
 
 -------------------------------------------------------------------------------
 -- | Read a parameter from request. Be sure it is readable if it's
@@ -116,7 +122,7 @@ readParam k = fmap (readNote "readParam failed" . B.unpack) `fmap` getParam k
 -- | Try to read a parameter from request. Computation may fail
 -- because the param is not there, or because it can't be read.
 readMayParam :: (MonadSnap m, Read a) => ByteString -> m (Maybe a)
-readMayParam k = do 
+readMayParam k = do
   p <- getParam k
   return $ readMay . B.unpack =<< p
 
@@ -134,7 +140,7 @@ redirectReferer = redirectRefererFunc (fromMaybe "/")
 redirectRefererFunc :: MonadSnap m => (Maybe ByteString -> ByteString) -> m b
 redirectRefererFunc f = do
     req <- getRequest
-    let referer = getHeader "Referer" req 
+    let referer = getHeader "Referer" req
     redirect $ f referer
 
 
@@ -166,7 +172,7 @@ maybeBadReq e f = fromMaybeM (badReq e) f
 
 
 -------------------------------------------------------------------------------
--- | Evaluates an action that returns a Maybe and 
+-- | Evaluates an action that returns a Maybe and
 fromMaybeM :: Monad m => m a -> m (Maybe a) -> m a
 fromMaybeM e f = maybe e return =<< f
 

src/Snap/Extras/MsgPack.hs

@@ -0,0 +1,93 @@
+{-# LANGUAGE NoMonomorphismRestriction #-}
+{-# LANGUAGE OverloadedStrings         #-}
+
+module Snap.Extras.MsgPack
+    (
+    -- * Parsing MP from Request Body
+      getBoundedMP
+    , getMP
+    , reqBoundedMP
+    , reqMP
+    , getMPField
+    , reqMPField
+    -- * Sending MP Data
+    , writeMP
+    ) where
+
+
+-------------------------------------------------------------------------------
+import qualified Data.ByteString.Char8 as B
+import           Data.Int
+import           Data.MessagePack      as MP
+import           Snap.Core
+-------------------------------------------------------------------------------
+import           Snap.Extras.CoreUtils
+-------------------------------------------------------------------------------
+
+-------------------------------------------------------------------------------
+-- | Demand the presence of MP in the body assuming it is not larger
+-- than 50000 bytes.
+reqMP :: (MonadSnap m, Unpackable b) => m b
+reqMP = reqBoundedMP 50000
+
+-------------------------------------------------------------------------------
+-- | Demand the presence of MP in the body with a size up to N
+-- bytes. If parsing fails for any reson, request is terminated early
+-- and a server error is returned.
+reqBoundedMP
+    :: (MonadSnap m, Unpackable a)
+    => Int64
+    -- ^ Maximum size in bytes
+    -> m a
+reqBoundedMP n = do
+  res <- getBoundedMP n
+  case res of
+    Left e -> badReq $ B.pack e
+    Right a -> return a
+
+-------------------------------------------------------------------------------
+-- | Try to parse request body as MP with a default max size of
+-- 50000.
+getMP :: (MonadSnap m, Unpackable a) => m (Either String a)
+getMP = getBoundedMP 50000
+
+-------------------------------------------------------------------------------
+-- | Parse request body into MP or return an error string.
+getBoundedMP
+    :: (MonadSnap m, Unpackable a)
+    => Int64
+    -- ^ Maximum size in bytes
+    -> m (Either String a)
+getBoundedMP n = tryUnpack `fmap` readRequestBody n
+
+-------------------------------------------------------------------------------
+-- | Get MP data from the given Param field
+getMPField
+    :: (MonadSnap m, Unpackable a)
+    => B.ByteString
+    -> m (Either String a)
+getMPField fld = do
+  val <- getParam fld
+  return $ case val of
+    Nothing -> Left $ "Cant find field " ++ B.unpack fld
+    Just val' -> tryUnpack val'
+
+-------------------------------------------------------------------------------
+-- | Force the MP value from field. Similar to 'getMPField'
+reqMPField
+    :: (MonadSnap m, Unpackable a)
+    => B.ByteString
+    -> m a
+reqMPField fld = do
+  res <- getMPField fld
+  case res of
+    Left e -> badReq $ B.pack e
+    Right a -> return a
+
+-------------------------------------------------------------------------------
+-- | Set MIME to 'application/x-msgpack' and write given object into
+-- 'Response' body.
+writeMP :: (MonadSnap m, Packable a) => a -> m ()
+writeMP a = do
+  mpResponse
+  writeLBS . MP.pack $ a