packages feed

snaplet-rest (empty) → 0.1.0

raw patch · 16 files changed

+1473/−0 lines, 16 filesdep +aesondep +basedep +blaze-buildersetup-changed

Dependencies added: aeson, base, blaze-builder, bytestring, case-insensitive, http-media, lens, mtl, snap, snap-accept, snap-core, text, utf8-string, xmlhtml

Files

+ LICENSE view
@@ -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.+
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ snaplet-rest.cabal view
@@ -0,0 +1,110 @@+name:          snaplet-rest+version:       0.1.0+homepage:      http://github.com/zimothy/snaplet-rest+license:       MIT+license-file:  LICENSE+author:        Timothy Jones+maintainer:    Timothy Jones <git@zimothy.com>+copyright:     (c) 2013 Timothy Jones+category:      Web+build-type:    Simple+cabal-version: >=1.10+synopsis:      REST resources for the Snap web framework+description:+  REST resources for the Snap framework.+  .+  As an example, let's translate the following datatype into a resource.+  .+  > data User = User Username String Int+  >+  > type Username = CI String+  .+  We need a type to represent changes to the resource.  This 'partial' type+  indicates what properties to change: either the name, the age, or both.+  .+  > data UserPart = UserPart (Maybe String) (Maybe Int)+  .+  This type also acts as a search mechanism: we can search by names, ages, or+  both.  We can use either a username or a @UserPart@ search to find users, and+  define a function to convert URL query string parameters to this search.+  .+  > type UserId = Either Username UserPart+  >+  > userIdFromParams :: Params -> Maybe UserId+  .+  Now we have the pieces required to define our CRUD behaviour.+  .+  > createUser :: User -> AppHandler ()+  >+  > readUser :: UserId -> AppHandler [User]+  >+  > updateUser :: UserId -> UserPart -> AppHandler Bool+  >+  > deleteUser :: UserId -> AppHandler Bool+  .+  If we've implemented Aeson instances, we can add JSON as a media format+  without having to define these manually.  Once the behaviour is attached to+  the resource, it can be served in the handler.+  .+  > serveUser :: AppHandler ()+  > serveUser = serveResource $ resource+  >     & addMedia jsonInstances+  >     & setCreate createUser+  >     & setRead readUser+  >     & setUpdate updateUser+  >     & setDelete deleteUser+  >     & setFromParams userIdFromParams+++library+  hs-source-dirs: src++  ghc-options: -Wall++  default-language: Haskell2010+  default-extensions:+    MultiParamTypeClasses+    OverloadedStrings+  other-extensions:+    FlexibleInstances+    IncoherentInstances+    OverlappingInstances+    Rank2Types+    TupleSections++  exposed-modules:+    Snap.Snaplet.Rest+    Snap.Snaplet.Rest.Config+    Snap.Snaplet.Rest.FromRequest+    Snap.Snaplet.Rest.Resource+  other-modules:+    Snap.Snaplet.Rest.Failure+    Snap.Snaplet.Rest.FromRequest.Internal+    Snap.Snaplet.Rest.Media+    Snap.Snaplet.Rest.Options+    Snap.Snaplet.Rest.Proxy+    Snap.Snaplet.Rest.Resource.Builder+    Snap.Snaplet.Rest.Resource.Internal+    Snap.Snaplet.Rest.Resource.Media+    Snap.Snaplet.Rest.Serve++  build-depends:+    aeson            >= 0.6.2  && < 0.7,+    base             >= 4.6.0  && < 4.7,+    blaze-builder    >= 0.3.1  && < 0.4,+    bytestring       >= 0.10.0 && < 0.11,+    case-insensitive >= 1.0.0  && < 1.1,+    http-media       >= 0.1.0  && < 0.2,+    lens             >= 3.9.0  && < 3.10,+    mtl              >= 2.1.2  && < 2.2,+    snap             >= 0.13.0 && < 0.14,+    snap-accept      >= 0.1.0  && < 0.2,+    snap-core        >= 0.9.4  && < 0.10,+    text             >= 0.11.3 && < 0.12,+    utf8-string      >= 0.3.7  && < 0.4,+    xmlhtml          >= 0.2.3  && < 0.3++source-repository head+  type:     git+  location: git://github.com/zimothy/snaplet-rest.git+
+ src/Snap/Snaplet/Rest.hs view
@@ -0,0 +1,66 @@+------------------------------------------------------------------------------+module Snap.Snaplet.Rest+    (+    -- * Serving resources+      serveResource+    , serveResourceWith++    -- * Resource+    , Resource+    , resource+    , addMedia+    , setCreate+    , setRead+    , setUpdate+    , setDelete+    , setToDiff+    , setFromParams+    , setPutAction+    , PutAction (..)++    -- * Request parsing+    , FromRequest (..)+    , parseRead+    , Params++    -- * Media+    , Media+    , newMedia+    , newIntermediateMedia+    , newRequestMedia+    , newResponseMedia+    , MediaSetter+    , fromResource+    , toResource+    , toDiff+    , toEither+    , fromResourceList+    , toResourceList++    -- * Common media instances+    , json+    , jsonFromInstances+    , xml+    , xhtml+    , html+    , form+    , multipart++    -- * Config+    , ResourceConfig (..)+    , defaultConfig+    , HasResourceConfig (..)+    , Resources+    , resourceInit+    , resourceInitDefault+    ) where++------------------------------------------------------------------------------+import Snap.Core (Params)++------------------------------------------------------------------------------+import Snap.Snaplet.Rest.Config+import Snap.Snaplet.Rest.FromRequest+import Snap.Snaplet.Rest.Resource+import Snap.Snaplet.Rest.Serve+
+ src/Snap/Snaplet/Rest/Config.hs view
@@ -0,0 +1,140 @@+------------------------------------------------------------------------------+module Snap.Snaplet.Rest.Config+    (+    -- * Configuration+      ResourceConfig (..)+    , defaultConfig++    -- * Snaplet type class+    , HasResourceConfig (..)+    , Resources+    , resourceInit+    , resourceInitDefault++    -- * Local utility+    , getResourceConfig+    ) where++------------------------------------------------------------------------------+import qualified Data.ByteString as BS++------------------------------------------------------------------------------+import Control.Monad.State (get)+import Data.Int            (Int64)+import Data.Text           (Text)+import Snap.Core+import Snap.Snaplet+++------------------------------------------------------------------------------+-- | Configuration data.+data ResourceConfig m = ResourceConfig+    {+    -- | The maximum number of members to retrieve from a collection in+    -- a single request.+      readLimit :: Maybe Int++    -- | Maximum size of request bodies allowed when receiving resources.+    , maxRequestBodySize :: Int64++    -- | Action to run if the request header parsing fails.+    , onHeaderFailure :: m ()++    -- | Action to run if the resource path parsing fails.+    , onPathFailure :: m ()++    -- | Action to run if the URL query string parsing fails.+    , onQueryFailure :: m ()++    -- | Action to run if the requested resource cannot be found.+    , onLookupFailure :: m ()++    -- | Action to run an invalid method is requested on a resource.+    , onMethodFailure :: m ()++    -- | Action to run if the response media type is not supported.+    , onAcceptFailure :: m ()++    -- | Action to run if the request media type is not supported.+    , onContentTypeFailure :: m ()++    -- | Action to run if the request body parse fails.+    , onContentParseFailure :: m ()++    }+++------------------------------------------------------------------------------+-- | The default configuration settings.  Requires a value for the maximum+-- size of a request body.+--+-- > defaultConfig mrbs = ResourceConfig+-- >     { readLimit = Nothing+-- >     , maxRequestBodySize = mrbs+-- >     , on*Failure = write "reason"+-- >     }+defaultConfig :: MonadSnap m => Int64 -> ResourceConfig m+defaultConfig mrbs = ResourceConfig+    { readLimit             = Nothing+    , maxRequestBodySize    = mrbs+    , onHeaderFailure       = write "Failed to parse request headers\n"+    , onPathFailure         = write "Failed to parse resource path\n"+    , onQueryFailure        = write "Failed to parse query string\n"+    , onLookupFailure       = write "Failed to find resource\n"+    , onMethodFailure       = write "Method not allowed\n"+    , onAcceptFailure       = write "No required media types are supported\n"+    , onContentTypeFailure  = write "No parser for request content available\n"+    , onContentParseFailure = write "Failed to parse request content\n"+    }+  where+    write msg = do+        modifyResponse $ setContentType "text/plain" .+            setContentLength (fromIntegral $ BS.length msg)+        writeBS msg+++------------------------------------------------------------------------------+-- | The type class for an implementing Snaplet.+class HasResourceConfig b where++    -- | Retrieve the configuration from the Snaplet monad.+    resourceLens :: SnapletLens (Snaplet b) (ResourceConfig (Handler b b))+++------------------------------------------------------------------------------+-- | Convenience alias of 'ResourceConfig'.+type Resources b = ResourceConfig (Handler b b)+++------------------------------------------------------------------------------+-- | Initialize the resource snaplet with the given configuration.+resourceInit+    :: ResourceConfig (Handler b b)+    -> SnapletInit b (Resources b)+resourceInit = makeSnaplet snapletName snapletDescription Nothing . return+++------------------------------------------------------------------------------+-- | Initialize the resource snaplet with the default configuration.+resourceInitDefault :: Int64 -> SnapletInit b (Resources b)+resourceInitDefault mrbs =+    makeSnaplet snapletName snapletDescription Nothing $+        return $ defaultConfig mrbs+++------------------------------------------------------------------------------+snapletName :: Text+snapletName = "rest-resources"+++------------------------------------------------------------------------------+snapletDescription :: Text+snapletDescription = "REST resources"+++------------------------------------------------------------------------------+-- | Returns the resource configuration.+getResourceConfig+    :: HasResourceConfig b => Handler b v (ResourceConfig (Handler b b))+getResourceConfig = withTop' resourceLens get+
+ src/Snap/Snaplet/Rest/Failure.hs view
@@ -0,0 +1,81 @@+------------------------------------------------------------------------------+module Snap.Snaplet.Rest.Failure+    ( headerFailure+    , pathFailure+    , queryFailure+    , lookupFailure+    , methodFailure+    , acceptFailure+    , contentTypeFailure+    , contentParseFailure+    ) where++------------------------------------------------------------------------------+import Snap.Core++------------------------------------------------------------------------------+import Snap.Snaplet.Rest.Config+import Snap.Snaplet.Rest.Options+import Snap.Snaplet.Rest.Resource+++------------------------------------------------------------------------------+-- | Serves a 400 error and runs the handler specified in the configuration.+headerFailure :: MonadSnap m => ResourceConfig m -> m a+headerFailure = failure 400 . onHeaderFailure+++------------------------------------------------------------------------------+-- | Serves a 400 error and runs the handler specified in the configuration.+pathFailure :: MonadSnap m => ResourceConfig m -> m a+pathFailure = failure 400 . onPathFailure+++------------------------------------------------------------------------------+-- | Serves a 400 error and runs the handler specified in the configuration.+queryFailure :: MonadSnap m => ResourceConfig m -> m a+queryFailure = failure 400 . onQueryFailure+++------------------------------------------------------------------------------+-- | Serves a 404 error and runs the handler specified in the configuration.+lookupFailure :: MonadSnap m => ResourceConfig m -> m a+lookupFailure = failure 404 . onLookupFailure+++------------------------------------------------------------------------------+-- | Serves a 405 error and runs the handler specified in the configuration,+-- specifying which methods are allowed in the Allow header.+methodFailure+    :: MonadSnap m => Resource res m id diff -> ResourceConfig m -> m a+methodFailure res cfg = do+    setAllow (optionsFor res)+    failure 405 $ onMethodFailure cfg+++------------------------------------------------------------------------------+-- | Serves a 406 error and runs the handler specified in the configuration.+acceptFailure :: MonadSnap m => ResourceConfig m -> m a+acceptFailure = failure 406 . onAcceptFailure+++------------------------------------------------------------------------------+-- | Serves a 415 error and runs the handler specified in the configuration.+contentTypeFailure :: MonadSnap m => ResourceConfig m -> m a+contentTypeFailure = failure 415 . onContentTypeFailure+++------------------------------------------------------------------------------+-- | Serves a 400 error and runs the handler specified in the configuration.+contentParseFailure :: MonadSnap m => ResourceConfig m -> m a+contentParseFailure = failure 400 . onContentParseFailure+++------------------------------------------------------------------------------+-- | Serve the given error code, running the given handler.+failure :: MonadSnap m => Int -> m () -> m a+failure code handler = do+    modifyResponse (setResponseCode code)+    handler+    withResponse finishWith+
+ src/Snap/Snaplet/Rest/FromRequest.hs view
@@ -0,0 +1,9 @@+------------------------------------------------------------------------------+module Snap.Snaplet.Rest.FromRequest+    ( FromRequest (fromPath)+    , parseRead+    ) where++------------------------------------------------------------------------------+import Snap.Snaplet.Rest.FromRequest.Internal+
+ src/Snap/Snaplet/Rest/FromRequest/Internal.hs view
@@ -0,0 +1,117 @@+{-# LANGUAGE FlexibleInstances #-}++------------------------------------------------------------------------------+module Snap.Snaplet.Rest.FromRequest.Internal+    ( FromRequest (..)+    , parseRead+    ) where++------------------------------------------------------------------------------+import qualified Data.ByteString      as BS+import qualified Data.ByteString.Lazy as LBS+import qualified Data.ByteString.UTF8 as BS+import qualified Data.Text            as Text++------------------------------------------------------------------------------+import Control.Applicative+import Control.Monad+import Data.ByteString      (ByteString)+import Data.CaseInsensitive (CI, mk)+import Snap.Core            (Params)++------------------------------------------------------------------------------+import Snap.Snaplet.Rest.Proxy (Proxy)+++------------------------------------------------------------------------------+-- | Instances of this class can be parsed from the remaining path information+-- at the current route, and potentially also the URL parameters.+class FromRequest id where++    -- | Parse a value from the remaining path information.  A value of+    -- 'Nothing' indicates that the parse failed.+    fromPath :: ByteString -> Maybe id++    -- | Internal method that indicates if individual resources are disabled.+    pathEnabled :: Proxy id -> Bool+    pathEnabled _ = True++    -- | Internal method that allows standard types to provide a default+    -- implementation of 'fromParams'.+    defaultFromParams :: Maybe (Params -> Maybe id)+    defaultFromParams = Nothing++-- This instance is useful for a singleton resource.  Indicates that the+-- resource can only be accessed at its root, and cannot be searched.+instance FromRequest () where+    fromPath _ = Nothing+    pathEnabled _ = False++-- This instance can be used to indicate that while query string searching is+-- disabled, operations can still be performed on collections.+instance FromRequest a => FromRequest (Maybe a) where+    fromPath = Just . fromPath+    defaultFromParams = Just $ const Nothing++-- Useful for disparate path and query types.+instance FromRequest a => FromRequest (Either a b) where+    fromPath = fmap Left . fromPath++instance FromRequest Int where+    fromPath = parseRead++instance FromRequest (CI String) where+    fromPath p = mk . BS.toString <$> checkSplit p++instance FromRequest (CI Text.Text) where+    fromPath p = mk . Text.pack . BS.toString <$> checkSplit p++instance FromRequest (CI ByteString) where+    fromPath p = mk <$> checkSplit p++instance FromRequest (CI LBS.ByteString) where+    fromPath p = mk . LBS.fromStrict <$> checkSplit p++instance FromRequest a => FromRequest [a] where+    fromPath = mapM (checkSplit >=> fromPath) . BS.split 47++instance (FromRequest a, FromRequest b) => FromRequest (a, b) where+    fromPath p = do+        let (a, b) = BS.breakByte 47 p+        a' <- fromPath a+        b' <- fromPath b+        return (a', b')++instance (FromRequest a, FromRequest b, FromRequest c)+        => FromRequest (a, b, c) where+    fromPath p = do+        let (a, r) = BS.breakByte 47 p+        a' <- fromPath a+        (b, c) <- fromPath r+        return (a', b, c)++instance (FromRequest a, FromRequest b, FromRequest c, FromRequest d)+        => FromRequest (a, b, c, d) where+    fromPath p = do+        let (a, r) = BS.breakByte 47 p+        a' <- fromPath a+        (b, c, d) <- fromPath r+        return (a', b, c, d)+++------------------------------------------------------------------------------+-- | Ensures that the given 'ByteString' is neither empty nor containing a+-- path split, evaluating to 'Nothing' in either case.+checkSplit :: ByteString -> Maybe ByteString+checkSplit bs = if length (BS.split 47 bs) /= 1 then Nothing else Just bs+++------------------------------------------------------------------------------+-- | A convenient helper function that wraps a read failure into 'Nothing'+-- instead of throwing an error.+parseRead :: Read a => ByteString -> Maybe a+parseRead = safeRead . reads . BS.toString+  where+    safeRead [(a, "")] = Just a+    safeRead _         = Nothing+
+ src/Snap/Snaplet/Rest/Media.hs view
@@ -0,0 +1,58 @@+{-# LANGUAGE TupleSections #-}++------------------------------------------------------------------------------+-- | Defines a data structure for converting back and forth from media+-- representations in HTTP.+--+-- Note that the conversion does not necessarily need to be a two-way process:+-- for instance, a type may have an HTML representation for output, but a+-- form-encoding parser for input.+module Snap.Snaplet.Rest.Media+    ( serve+    , receive+    ) where++------------------------------------------------------------------------------+import qualified Data.ByteString              as BS+import qualified Data.ByteString.Lazy         as LBS+import qualified Network.HTTP.Media.MediaType as MT++------------------------------------------------------------------------------+import Control.Applicative+import Control.Monad+import Data.ByteString     (ByteString)+import Network.HTTP.Media  (MediaType, mapContent)+import Snap.Accept         (accepts)+import Snap.Core++------------------------------------------------------------------------------+import Snap.Snaplet.Rest.Config+import Snap.Snaplet.Rest.Failure+++------------------------------------------------------------------------------+-- | Serve the given resource using the given configuration.+serve+    :: MonadSnap m+    => [(MediaType, a -> m ByteString)] -> ResourceConfig m -> a -> m ()+serve composers cfg rep =+        accepts (map (fmap $ writeDone <=< ($ rep)) composers)+    <|> acceptFailure cfg+  where+    writeDone bs = do+        modifyResponse $ setContentLength $ fromIntegral $ BS.length bs+        writeBS bs+++------------------------------------------------------------------------------+receive+    :: MonadSnap m+    => [(MediaType, ByteString -> m (Maybe a))] -> ResourceConfig m -> m a+receive parsers cfg = do+    header <- getHeader "Content-Type" <$> getRequest+    ctype  <- mayFail headerFailure $ header >>= MT.parse+    parser <- mayFail contentTypeFailure $ mapContent ctype parsers+    body   <- LBS.toStrict <$> readRequestBody (maxRequestBodySize cfg)+    parser body >>= mayFail contentParseFailure+  where mayFail handler = maybe (handler cfg) return+
+ src/Snap/Snaplet/Rest/Options.hs view
@@ -0,0 +1,96 @@+{-# LANGUAGE FlexibleInstances #-}++------------------------------------------------------------------------------+-- | Specifies client options for given path point on the server.+module Snap.Snaplet.Rest.Options+    ( ResourceOptions+    , optionsFor+    , setAllow+    ) where++------------------------------------------------------------------------------+import qualified Data.ByteString as BS++------------------------------------------------------------------------------+import Control.Applicative+import Control.Lens.Combinators ((&))+import Data.ByteString          (ByteString)+import Data.Maybe+import Snap.Core++------------------------------------------------------------------------------+import Snap.Snaplet.Rest.Resource.Internal+++------------------------------------------------------------------------------+-- | Options for a REST resource.+data ResourceOptions = ResourceOptions+    { hasRetrieve      :: Bool+    , hasCreate        :: Bool+    , hasUpdate        :: Bool+    , hasDiff          :: Bool+    , hasDelete        :: Bool+    , hasListRenderers :: Bool+    , hasListParsers   :: Bool+    , hasFromParams    :: Bool+    , hasPut           :: Bool+    }+++------------------------------------------------------------------------------+-- | Build options for a single resource.+optionsFor :: Resource res m id diff -> ResourceOptions+optionsFor res = ResourceOptions+    { hasRetrieve      = isJust $ retrieve res+    , hasCreate        = isJust $ create res+    , hasUpdate        = isJust $ update res+    , hasDiff          = isJust $ toDiff res+    , hasDelete        = isJust $ delete res+    , hasListRenderers = not . null $ listRenderers res+    , hasListParsers   = not . null $ listParsers res+    , hasFromParams    = isJust $ fromParams res+    , hasPut           = case putAction res of+        Nothing     -> isJust (create res) && isJust (update res)+        Just Create -> isJust $ create res+        Just Update -> isJust $ update res+    }+++------------------------------------------------------------------------------+setAllow :: MonadSnap m => ResourceOptions -> m ()+setAllow opt =+    ifTop (return (collectionAllow opt))+        <|> return (resourceAllow opt) >>=+    modifyResponse . setHeader "Allow" . BS.intercalate ","+++------------------------------------------------------------------------------+collectionAllow :: ResourceOptions -> [ByteString]+collectionAllow opt = []+    & addMethod (hasRetrieve opt && readEnabled) "HEAD"+    & addMethod True "OPTIONS"+    & addMethod (hasUpdate opt && writeEnabled) "UPDATE"+    & addMethod (hasDelete opt && writeEnabled) "DELETE"+    & addMethod (hasCreate opt && hasDelete opt && writeEnabled) "PUT"+    & addMethod (hasCreate opt) "POST"+    & addMethod (hasRetrieve opt && readEnabled) "GET"+  where+    readEnabled = hasFromParams opt && hasListRenderers opt+    writeEnabled = hasFromParams opt && hasListParsers opt+++------------------------------------------------------------------------------+resourceAllow :: ResourceOptions -> [ByteString]+resourceAllow opt = []+    & addMethod (hasRetrieve opt) "HEAD"+    & addMethod True "OPTIONS"+    & addMethod (hasUpdate opt && hasDiff opt) "PATCH"+    & addMethod (hasDelete opt) "DELETE"+    & addMethod (hasPut opt) "PUT"+    & addMethod (hasRetrieve opt) "GET"+++------------------------------------------------------------------------------+addMethod :: Bool -> ByteString -> [ByteString] -> [ByteString]+addMethod cond verb = if cond then (verb :) else id+
+ src/Snap/Snaplet/Rest/Proxy.hs view
@@ -0,0 +1,11 @@+------------------------------------------------------------------------------+-- | Defines a simple proxy type for complicated type classes.+module Snap.Snaplet.Rest.Proxy+    ( Proxy (..)+    ) where++------------------------------------------------------------------------------+-- | Uses a phantom type to indicate to the type system which class instance+-- to use when it may be ambiguous.+data Proxy t = Proxy+
+ src/Snap/Snaplet/Rest/Resource.hs view
@@ -0,0 +1,45 @@+------------------------------------------------------------------------------+module Snap.Snaplet.Rest.Resource+    (+    -- * Resource+      Resource+    , resource+    , addMedia+    , setCreate+    , setRead+    , setUpdate+    , setDelete+    , setToDiff+    , setFromParams+    , setPutAction+    , PutAction (..)++    -- * Media+    , Media+    , newMedia+    , newIntermediateMedia+    , newRequestMedia+    , newResponseMedia+    , MediaSetter+    , fromResource+    , toResource+    , toDiff+    , toEither+    , fromResourceList+    , toResourceList++    -- * Common media instances+    , json+    , jsonFromInstances+    , xml+    , xhtml+    , html+    , form+    , multipart+    ) where++------------------------------------------------------------------------------+import Snap.Snaplet.Rest.Resource.Builder+import Snap.Snaplet.Rest.Resource.Internal hiding (toDiff)+import Snap.Snaplet.Rest.Resource.Media+
+ src/Snap/Snaplet/Rest/Resource/Builder.hs view
@@ -0,0 +1,108 @@+{-# LANGUAGE TupleSections #-}++------------------------------------------------------------------------------+module Snap.Snaplet.Rest.Resource.Builder+    ( addMedia+    , setCreate+    , setRead+    , setUpdate+    , setDelete+    , setToDiff+    , setFromParams+    , setPutAction+    ) where++------------------------------------------------------------------------------+import Control.Monad+import Data.Maybe++------------------------------------------------------------------------------+import Snap.Core (Params)++------------------------------------------------------------------------------+import Snap.Snaplet.Rest.Resource.Internal+import Snap.Snaplet.Rest.Resource.Media    (Media (..))+++------------------------------------------------------------------------------+type ResourceBuilder res m id diff+    = Resource res m id diff -> Resource res m id diff+++------------------------------------------------------------------------------+-- | Add a media representation for rendering and parsing.+addMedia :: Monad m => Media res m diff int -> ResourceBuilder res m id diff+addMedia media res = res+    { renderers     = renderers res ++ renderers'+    , parsers       = parsers res ++ parsers'+    , diffParsers   = diffParsers res ++ diffParsers'+    , listRenderers = listRenderers res ++ listRenderers'+    , listParsers   = listParsers res ++ listParsers'+    }+  where+    renderers' = fromMaybe [] $ do+        fromResource' <- _fromResource media+        (mts, render) <- responseMedia media+        return $ map (, fromResource' >=> render) mts+    parsers' = fromMaybe [] $ do+        toResource' <- _toResource media+        (mts, parse) <- requestMedia media+        return $ map (, parse >=> maybe (return Nothing) toResource') mts+    diffParsers' = fromMaybe [] $ do+        toDiff' <- _toDiff media+        (mts, parse) <- requestMedia media+        return $ map (, parse >=> maybe (return Nothing) toDiff') mts+    listRenderers' = fromMaybe [] $ do+        fromResourceList' <- _fromResourceList media+        (mts, render) <- responseMedia media+        return $ map (, fromResourceList' >=> render) mts+    listParsers' = fromMaybe [] $ do+        toResourceList' <- _toResourceList media+        (mts, parse) <- requestMedia media+        return $ map (, parse >=> maybe (return Nothing) toResourceList') mts+++------------------------------------------------------------------------------+-- | Set the create method for the resource.+setCreate :: (res -> m ()) -> ResourceBuilder res m id diff+setCreate f res = res { create = Just f }+++------------------------------------------------------------------------------+-- | Set the read method for the resource.+setRead :: (id -> m [res]) -> ResourceBuilder res m id diff+setRead f res = res { retrieve = Just f }+++------------------------------------------------------------------------------+-- | Set the update method for the resource.  The method must return+-- a boolean, indicating whether anything was updated.+setUpdate :: (id -> diff -> m Bool) -> ResourceBuilder res m id diff+setUpdate f res = res { update = Just f }+++------------------------------------------------------------------------------+-- | Set the delete method for the resource.  The method must return a+-- boolean, indicating whether anything was deleted.+setDelete :: (id -> m Bool) -> ResourceBuilder res m id diff+setDelete f res = res { delete = Just f }+++------------------------------------------------------------------------------+-- | Sets the conversion function from resource to diff value.+setToDiff :: (res -> diff) -> ResourceBuilder res m id diff+setToDiff f res = res { toDiff = Just f }+++------------------------------------------------------------------------------+-- | Sets the URL query string parser.+setFromParams :: (Params -> Maybe id) -> ResourceBuilder res m id diff+setFromParams f res = res { fromParams = Just f }+++------------------------------------------------------------------------------+-- | Sets a specific action to take when a PUT method is received.  If not+-- set, this defaults to trying to update and then creating if that fails.+setPutAction :: PutAction -> ResourceBuilder res m id diff+setPutAction a res = res { putAction = Just a }+
+ src/Snap/Snaplet/Rest/Resource/Internal.hs view
@@ -0,0 +1,94 @@+{-# LANGUAGE FlexibleInstances, IncoherentInstances #-}++------------------------------------------------------------------------------+module Snap.Snaplet.Rest.Resource.Internal+    ( Resource (..)+    , resource+    , complete+    , PutAction (..)+    ) where++------------------------------------------------------------------------------+import Control.Applicative+import Data.ByteString     (ByteString)+import Data.Maybe+import Network.HTTP.Media  (MediaType)+import Snap.Core           (Params)++------------------------------------------------------------------------------+import Snap.Snaplet.Rest.FromRequest.Internal (FromRequest (..))+import Snap.Snaplet.Rest.Proxy                (Proxy (..))+++------------------------------------------------------------------------------+-- | A resource descriptor for the type 'res'.  The resource runs in the monad+-- 'm', identifies resources with values of the type 'id', and describes+-- changes with value of the type 'diff'.+data Resource res m id diff = Resource+    { renderers     :: [(MediaType, res -> m ByteString)]+    , parsers       :: [(MediaType, ByteString -> m (Maybe res))]+    , diffParsers   :: [(MediaType, ByteString -> m (Maybe diff))]+    , listRenderers :: [(MediaType, [res] -> m ByteString)]+    , listParsers   :: [(MediaType, ByteString -> m (Maybe [res]))]+    , create        :: Maybe (res -> m ())+    , retrieve      :: Maybe (id -> m [res])+    , update        :: Maybe (id -> diff -> m Bool)+    , toDiff        :: Maybe (res -> diff)+    , delete        :: Maybe (id -> m Bool)+    , fromParams    :: Maybe (Params -> Maybe id)+    , putAction     :: Maybe PutAction+    , patchEnabled  :: Bool+    }+++------------------------------------------------------------------------------+class Diff a b where+    defaultToDiff :: Maybe (a -> b)+    isDifferentType :: Proxy (a, b) -> Bool++instance Diff a a where+    defaultToDiff = Just id+    isDifferentType _ = False++instance Diff a b where+    defaultToDiff = Nothing+    isDifferentType _ = True+++------------------------------------------------------------------------------+-- | The empty resource descriptor, useful as a starting point for building+-- resources.+resource :: Resource res m id diff+resource = Resource [] [] [] [] []+    Nothing Nothing Nothing Nothing Nothing Nothing Nothing False+++------------------------------------------------------------------------------+complete :: FromRequest id => Resource res m id diff -> Resource res m id diff+complete = complete' Proxy++complete'+    :: FromRequest id+    => Proxy (res, diff) -> Resource res m id diff -> Resource res m id diff+complete' p r = r+    { toDiff       = toDiff r <|> defaultToDiff+    , fromParams   = fromParams r <|> defaultFromParams+    , putAction    = putAction r <|> defaultPutAction+    , patchEnabled = isDifferentType p+    }+  where+    hasCreate  = isJust $ create r+    hasUpdate = isJust $ update r+    defaultPutAction+        | hasCreate && not hasUpdate = Just Create+        | hasUpdate && not hasCreate = Just Update+        | otherwise                 = Nothing+++------------------------------------------------------------------------------+-- | Indicates which action that a PUT request should take for a resource.+data PutAction+    = Create  -- ^ Always create+    | Update  -- ^ Always update+    deriving (Eq, Show)+
+ src/Snap/Snaplet/Rest/Resource/Media.hs view
@@ -0,0 +1,233 @@+{-# LANGUAGE ExistentialQuantification, FlexibleInstances, Rank2Types #-}++------------------------------------------------------------------------------+module Snap.Snaplet.Rest.Resource.Media+    (+    -- * Type+      Media (..)+    , newMedia+    , newResponseMedia+    , newRequestMedia+    , newIntermediateMedia++    -- * Setters+    , MediaSetter+    , fromResource+    , toResource+    , toDiff+    , toEither+    , fromResourceList+    , toResourceList++    -- * Common instances+    , json+    , jsonFromInstances+    , xml+    , xhtml+    , html+    , form+    , multipart+    ) where++------------------------------------------------------------------------------+import qualified Blaze.ByteString.Builder as BB+import qualified Data.ByteString.Lazy     as LBS+import qualified Data.ByteString.UTF8     as BS+import qualified Text.XmlHtml             as Xml++------------------------------------------------------------------------------+import Control.Lens+import Control.Monad+import Data.Aeson         hiding (json)+import Data.ByteString    (ByteString)+import Network.HTTP.Media (MediaType)+import Snap.Core+import Text.XmlHtml       (Document)+++------------------------------------------------------------------------------+-- | A grouping of mediatypes and their associated renderers and parsers.  You+-- can use the standard instances defined below, or define your own.+data Media res m diff int = Media+    { _fromResource     :: Maybe (res -> m int)+    , _toResource       :: Maybe (int -> m (Maybe res))+    , _toDiff           :: Maybe (int -> m (Maybe diff))+    , _fromResourceList :: Maybe ([res] -> m int)+    , _toResourceList   :: Maybe (int -> m (Maybe [res]))+    , responseMedia     :: Maybe ([MediaType], int -> m ByteString)+    , requestMedia      :: Maybe ([MediaType], ByteString -> m (Maybe int))+    }+++------------------------------------------------------------------------------+-- | Convenience class that allows 'serialize' and 'parse' to be implemented+-- with a default for some types.+class Intermediate int where+    defaultFrom :: MonadSnap m => int -> m ByteString+    defaultTo   :: MonadSnap m => ByteString -> m (Maybe int)++instance Intermediate ByteString where+    defaultFrom = return+    defaultTo   = return . Just++instance Intermediate String where+    defaultFrom = return . BS.fromString+    defaultTo   = return . Just . BS.toString+++------------------------------------------------------------------------------+-- | Construct a new media grouping with the given response and request+-- mediatypes.+newMedia+    :: (Intermediate int, MonadSnap m) => [MediaType] -> [MediaType]+    -> Media res m diff int+newMedia = newIntermediateMedia defaultFrom defaultTo+++------------------------------------------------------------------------------+-- | Construct a new media grouping with response mediatypes only.+newResponseMedia+    :: (int -> m ByteString) -> [MediaType] -> Media res m diff int+newResponseMedia a b =+    Media Nothing Nothing Nothing Nothing Nothing (notEmpty b a) Nothing+++------------------------------------------------------------------------------+-- | Construct a new media grouping with request mediatypes only.+newRequestMedia+    :: (ByteString -> m (Maybe int)) -> [MediaType]+    -> Media res m diff int+newRequestMedia a b =+    Media Nothing Nothing Nothing Nothing Nothing Nothing (notEmpty b a)+++------------------------------------------------------------------------------+-- | Construct a new media grouping with an intermediate type between the+-- resource and the rendered form.+newIntermediateMedia+    :: (int -> m ByteString) -> (ByteString -> m (Maybe int))+    -> [MediaType] -> [MediaType] -> Media res m diff int+newIntermediateMedia a b x y = Media+    Nothing Nothing Nothing Nothing Nothing (notEmpty x a) (notEmpty y b)+++------------------------------------------------------------------------------+notEmpty :: [a] -> f -> Maybe ([a], f)+notEmpty l f = guard (not $ null l) >> Just (l, f)+++------------------------------------------------------------------------------+-- | A 'Setter' for defining properties of a media grouping.+type MediaSetter res m diff int f a = Setter+    (Media res m diff int) (Media res m diff int) (f a) a+++------------------------------------------------------------------------------+-- | Set the resource renderer.+fromResource :: MediaSetter res m diff int Maybe (res -> m int)+fromResource f m = f (_fromResource m) <&> \g -> m { _fromResource = Just g }+++------------------------------------------------------------------------------+-- | Set the resource parser.+toResource :: MediaSetter res m diff int Maybe (int -> m (Maybe res))+toResource f m = f (_toResource m) <&> \g -> m { _toResource = Just g }+++------------------------------------------------------------------------------+-- | Set the diff parser.+toDiff :: MediaSetter res m diff int Maybe (int -> m (Maybe diff))+toDiff f m = f (_toDiff m) <&> \g -> m { _toDiff = Just g }+++------------------------------------------------------------------------------+-- | Set the resource and diff parser at the same time.+toEither :: MediaSetter res m res int Both (int -> m (Maybe res))+toEither f m = f (_toResource m, _toDiff m) <&> \g -> m+    { _toResource = Just g+    , _toDiff     = Just g+    }++type Both a = (Maybe a, Maybe a)+++------------------------------------------------------------------------------+-- | Set the resource list renderer.+fromResourceList :: MediaSetter res m diff int Maybe ([res] -> m int)+fromResourceList f m =+    f (_fromResourceList m) <&> \g -> m { _fromResourceList = Just g }+++------------------------------------------------------------------------------+-- | Set the resource list parser.+toResourceList :: MediaSetter res m diff int Maybe (int -> m (Maybe [res]))+toResourceList f m =+    f (_toResourceList m) <&> \g -> m { _toResourceList = Just g }+++------------------------------------------------------------------------------+-- | Outputs JSON in UTF-8 and parses JSON agnostic of character set.+json :: Monad m => Media res m diff Value+json = newIntermediateMedia+    (return . LBS.toStrict . encode) (return . decodeStrict)+    ["application/json; charset=utf-8"] ["application/json"]+++------------------------------------------------------------------------------+-- | Outputs JSON in UTF-8 and parses JSON agnostic of character set.  Uses+-- the type class instances to automatically set the media methods.+jsonFromInstances+    :: (Monad m, ToJSON res, FromJSON res, FromJSON diff)+    => Media res m diff Value+jsonFromInstances = Media+    (Just (return . toJSON))+    (Just (return . resultToMaybe . fromJSON))+    (Just (return . resultToMaybe . fromJSON))+    (Just (return . toJSON))+    (Just (return . resultToMaybe . fromJSON))+    (Just (["application/json; charset=utf-8"],+        return . LBS.toStrict . encode))+    (Just (["application/json"], return . decode . LBS.fromStrict))+++------------------------------------------------------------------------------+resultToMaybe :: Result a -> Maybe a+resultToMaybe (Error _)   = Nothing+resultToMaybe (Success a) = Just a++------------------------------------------------------------------------------+-- | Outputs XML in UTF-8 and parses XML agnostic of character set.+xml :: Monad m => Media res m diff Document+xml = newIntermediateMedia+    (return . BB.toByteString . Xml.render)+    (return . either (const Nothing) Just . Xml.parseXML "")+    ["application/xml; charset=utf-8"] ["application/xml"]+++------------------------------------------------------------------------------+-- | Supports both XHTML and HTML in UTF-8 as the output format only.+-- Recommended over 'html' if the output will be valid XHTML.+xhtml :: MonadSnap m => Media res m diff ByteString+xhtml = newMedia+    ["application/xhtml+xml; charset=utf-8", "text/html; charset=utf-8"] []+++------------------------------------------------------------------------------+-- | Supports HTML in UTF-8 as the output format only.  Use 'xhtml' if the+-- output is guaranteed to be well formed.+html :: MonadSnap m => Media res m diff ByteString+html = newMedia ["text/html; charset=utf-8"] []+++------------------------------------------------------------------------------+-- | Supports URL-encoded web forms as the input format only.+form :: MonadSnap m => Media res m diff Params+form = newRequestMedia (const $ fmap Just getParams)+    ["application/x-www-form-urlencoded"]+++------------------------------------------------------------------------------+-- | Supports multipart web forms as the input format only.+multipart :: MonadSnap m => Media res m diff ByteString+multipart = newMedia [] ["multipart/form-data"]+
+ src/Snap/Snaplet/Rest/Serve.hs view
@@ -0,0 +1,283 @@+{-# LANGUAGE FlexibleContexts #-}++------------------------------------------------------------------------------+module Snap.Snaplet.Rest.Serve+    ( serveResource+    , serveResourceWith+    ) where++------------------------------------------------------------------------------+import qualified Data.ByteString as BS++------------------------------------------------------------------------------+import Control.Applicative+import Control.Monad+import Data.Maybe+import Snap.Core+import Snap.Snaplet        (Handler)++------------------------------------------------------------------------------+import Snap.Snaplet.Rest.Config+import Snap.Snaplet.Rest.Failure+import Snap.Snaplet.Rest.FromRequest.Internal+import Snap.Snaplet.Rest.Media+import Snap.Snaplet.Rest.Options+import Snap.Snaplet.Rest.Proxy                (Proxy (..))+import Snap.Snaplet.Rest.Resource.Internal+++------------------------------------------------------------------------------+-- | Serve the specified resource using the configuration in the monad.+serveResource+    :: (HasResourceConfig b, FromRequest id)+    => Resource res (Handler b b) id diff -> Handler b b ()+serveResource res = getResourceConfig >>= serveResourceWith res+++------------------------------------------------------------------------------+-- | Serve the specified resource using the given configuration.+serveResourceWith+    :: (MonadSnap m, FromRequest id)+    => Resource res m id diff -> ResourceConfig m -> m ()+serveResourceWith res' cfg = checkPath $+        serveRoute' GET (handleGet res) (retrieve res)+    <|> serveRoute' POST (handlePost res) (create res)+    <|> serveRoute' DELETE (handleDelete res) (delete res)+    <|> servePut res cfg+    <|> serveRoute' PATCH (handlePatch res) (update res)+    <|> serveRoute' OPTIONS (retrieveOptions parsePath) (Just res)+    <|> serveRoute' HEAD (handleGet res) (retrieve res)+  where+    res = complete res'+    serveRoute' = serveRoute res cfg+    checkPath = if pathEnabled' res Proxy+        then id else (ifNotTop (pathFailure cfg) <|>)+++------------------------------------------------------------------------------+-- | Serves a route for the given method if the Maybe value is Just, otherwise+-- serves a method failure error.+serveRoute+    :: MonadSnap m+    => Resource res m id diff -> ResourceConfig m -> Method+    -> (ResourceConfig m -> a -> m b) -> Maybe a -> m b+serveRoute res cfg mt rt mf = method mt $+    maybe (methodFailure res cfg) (rt cfg) mf+++------------------------------------------------------------------------------+-- | Produces a PUT response depending on the PutAction in the resource.+servePut+    :: (MonadSnap m, FromRequest id)+    => Resource res m id diff -> ResourceConfig m -> m ()+servePut res cfg =+    (ifTop (serveRoute' (replaceResources res) (both create delete)) <|>) $+    ifNotTop $ case putAction res of+        Just Create -> serveRoute' (createResource res) (create res)+        Just Update -> serveRoute' updatePut (both update toDiff)+        Nothing     -> serveRoute' (tryUpdateResource res)+            ((,,) <$> create res <*> update res <*> toDiff res)+  where+    serveRoute' = serveRoute res cfg PUT+    both f g = (,) <$> f res <*> g res+    updatePut _ (update', toDiff') = updateResource+        (fmap toDiff' . receive (parsers res)) cfg update'+++------------------------------------------------------------------------------+-- | Routes to 'retrieveResources' and 'retrieveResource'.+handleGet+    :: (MonadSnap m, FromRequest id)+    => Resource res m id diff -> ResourceConfig m -> (id -> m [res])+    -> m ()+handleGet res cfg retrieve' =+    ifTop (retrieveResources res cfg retrieve') <|> retrieveResource res cfg retrieve'+++------------------------------------------------------------------------------+-- | Retrieves and serves resources using the URL query string.+retrieveResources+    :: MonadSnap m+    => Resource res m id diff -> ResourceConfig m -> (id -> m [res])+    -> m ()+retrieveResources res cfg retrieve' = parseParams res cfg >>= maybe+    (queryFailure cfg) (retrieve' >=> serve (listRenderers res) cfg . limit)+  where limit = maybe id take $ readLimit cfg+++------------------------------------------------------------------------------+-- | Retrieve and serve a resource using the remaining path information.+retrieveResource+    :: (MonadSnap m, FromRequest id)+    => Resource res m id diff -> ResourceConfig m -> (id -> m [res])+    -> m ()+retrieveResource res cfg retrieve' = parsePath >>= maybe (pathFailure cfg)+    (retrieve' >=> maybe (lookupFailure cfg)+        (serve (renderers res) cfg) . listToMaybe)+++------------------------------------------------------------------------------+-- | Routes to 'createResource' if there is no remaining path information,+-- otherwise indicates that POST is not allowed directly on a resource.+handlePost+    :: MonadSnap m+    => Resource res m id diff -> ResourceConfig m -> (res -> m ()) -> m ()+handlePost res cfg create' =+    ifTop (createResource res cfg create') <|> methodFailure res cfg+++------------------------------------------------------------------------------+-- | Create a new resource from the request body.+createResource+    :: MonadSnap m+    => Resource res m id diff -> ResourceConfig m -> (res -> m ()) -> m ()+createResource res cfg create' = receive (parsers res) cfg >>= create'+++------------------------------------------------------------------------------+-- | Replaces all matched resources with the ones from the request body.+-- Retrieves and parses the request body before proceeding to delete.  Note+-- that this operation is non-atomic.+replaceResources+    :: MonadSnap m+    => Resource res m id diff -> ResourceConfig m+    -> (res -> m (), id -> m Bool) -> m ()+replaceResources res cfg (create', delete') = do+    m <- receive (listParsers res) cfg+    deleteResources res cfg delete'+    mapM_ create' m+++------------------------------------------------------------------------------+-- | Updates resources from the request body.+updateResources+    :: MonadSnap m+    => Resource res m id diff -> ResourceConfig m+    -> (id -> diff -> m Bool) -> m ()+updateResources res cfg update' = do+    search <- parseParams res cfg >>= maybe (queryFailure cfg) return+    receive (diffParsers res) cfg >>= void . update' search+++------------------------------------------------------------------------------+-- | Update a resource from the request body.  Sends a lookup failure if the+-- update failed.+updateResource+    :: (MonadSnap m, FromRequest id)+    => (ResourceConfig m -> m diff) -> ResourceConfig m+    -> (id -> diff -> m Bool) -> m ()+updateResource receive' cfg update' = receive' cfg >>=+    updateResource' cfg update' >>= flip unless (lookupFailure cfg)+++------------------------------------------------------------------------------+-- | Update a resource with the given value.  Returns 'True' if the update was+-- successful.+updateResource'+    :: (MonadSnap m, FromRequest id)+    => ResourceConfig m -> (id -> diff -> m Bool) -> diff -> m Bool+updateResource' cfg update' diff = parsePath >>=+    maybe (pathFailure cfg) (`update'` diff)+++------------------------------------------------------------------------------+-- | Attempts to update with the request body, and creates it instead if that+-- fails.+tryUpdateResource+    :: (MonadSnap m, FromRequest id)+    => Resource res m id diff -> ResourceConfig m+    -> (res -> m (), id -> diff -> m Bool, res -> diff) -> m ()+tryUpdateResource res cfg (create', update', toDiff') = do+    par <- receive (parsers res) cfg+    updateResource' cfg update' (toDiff' par) >>= flip unless (create' par)+++------------------------------------------------------------------------------+-- | Routes to 'updateResources' and 'updateResource', ensuring that PATCH is+-- not disabled in the latter case.+handlePatch+    :: (MonadSnap m, FromRequest id)+    => Resource res m id diff -> ResourceConfig m+    -> (id -> diff -> m Bool) -> m ()+handlePatch res cfg update' =+    ifTop (updateResources res cfg update') <|> do+        unless (patchEnabled res) $ methodFailure res cfg+        updateResource (receive $ diffParsers res) cfg update'+++------------------------------------------------------------------------------+-- | Routes to 'deleteResources' and 'deleteResource'.+handleDelete+    :: (MonadSnap m, FromRequest id)+    => Resource res m id diff -> ResourceConfig m -> (id -> m Bool) -> m ()+handleDelete res cfg delete' =+    ifTop (deleteResources res cfg delete') <|> deleteResource cfg delete'+++------------------------------------------------------------------------------+-- | Deletes the resources matching the URL query string.+deleteResources+    :: MonadSnap m+    => Resource res m id diff -> ResourceConfig m -> (id -> m Bool)+    -> m ()+deleteResources res cfg delete' = parseParams res cfg >>=+    maybe (queryFailure cfg) (void . delete')+++------------------------------------------------------------------------------+-- | Deletes the resource at the current path.+deleteResource+    :: (MonadSnap m, FromRequest id)+    => ResourceConfig m -> (id -> m Bool) -> m ()+deleteResource cfg delete' = parsePath >>= maybe (pathFailure cfg)+    (delete' >=> flip unless (lookupFailure cfg))+++------------------------------------------------------------------------------+-- | Serves either collection or resource options, depending on the path.+retrieveOptions+    :: MonadSnap m+    => m (Maybe id) -> ResourceConfig m+    -> Resource res m id diff -> m ()+retrieveOptions parsePath' cfg res = do+    isTop >>=+        flip unless (isNothing <$> parsePath' >>= flip when (pathFailure cfg))+    setAllow $ optionsFor res+    modifyResponse $ setContentLength 0+++------------------------------------------------------------------------------+-- | Retrieve the remaining path info and parse it into the identifier type.+parsePath :: (MonadSnap m, FromRequest id) => m (Maybe id)+parsePath = fromPath . rqPathInfo <$> getRequest+++------------------------------------------------------------------------------+-- | Retrieve the URL query string and parse it into the identifier type.+parseParams+    :: MonadSnap m+    => Resource res m id diff -> ResourceConfig m -> m (Maybe id)+parseParams res cfg = maybe (methodFailure res cfg) tryParse (fromParams res)+  where tryParse fromParams' = fromParams' . rqParams <$> getRequest+++------------------------------------------------------------------------------+-- | Grabs the appropriate instance of 'pathEnabled' for the given resource.+pathEnabled'+    :: FromRequest id => Resource res m id diff -> Proxy id -> Bool+pathEnabled' _ = pathEnabled+++------------------------------------------------------------------------------+-- | Determines if 'rqPathInfo' is null.+isTop :: MonadSnap m => m Bool+isTop = BS.null . rqPathInfo <$> getRequest+++------------------------------------------------------------------------------+-- | Opposite of 'ifTop', runs the given action to 'rqPathInfo' is not null.+ifNotTop :: MonadSnap m => m a -> m a+ifNotTop m = do+    top <- isTop+    if top then pass else m+