diff --git a/.gitignore b/.gitignore index e86acaf..765d86d 100644 --- a/.gitignore +++ b/.gitignore @@ -1,6 +1,8 @@ dist .DS* cabal-dev +.cabal-sandbox +cabal.sandbox.config dist *.swp TAGS \ No newline at end of file diff --git a/snap-extras.cabal b/snap-extras.cabal index 639c2d1..e3ac406 100644 --- a/snap-extras.cabal +++ b/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 diff --git a/src/Snap/Extras/CoreUtils.hs b/src/Snap/Extras/CoreUtils.hs index 44d29f9..82671f3 100644 --- a/src/Snap/Extras/CoreUtils.hs +++ b/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,12 +25,12 @@ 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 ------------------------------------------------------------------------------- @@ -37,7 +38,7 @@ 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 diff --git a/src/Snap/Extras/MsgPack.hs b/src/Snap/Extras/MsgPack.hs new file mode 100644 index 0000000..32045f8 --- /dev/null +++ b/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