diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. + diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/snaplet-rest.cabal b/snaplet-rest.cabal new file mode 100644 --- /dev/null +++ b/snaplet-rest.cabal @@ -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 +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 + diff --git a/src/Snap/Snaplet/Rest.hs b/src/Snap/Snaplet/Rest.hs new file mode 100644 --- /dev/null +++ b/src/Snap/Snaplet/Rest.hs @@ -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 + diff --git a/src/Snap/Snaplet/Rest/Config.hs b/src/Snap/Snaplet/Rest/Config.hs new file mode 100644 --- /dev/null +++ b/src/Snap/Snaplet/Rest/Config.hs @@ -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 + diff --git a/src/Snap/Snaplet/Rest/Failure.hs b/src/Snap/Snaplet/Rest/Failure.hs new file mode 100644 --- /dev/null +++ b/src/Snap/Snaplet/Rest/Failure.hs @@ -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 + diff --git a/src/Snap/Snaplet/Rest/FromRequest.hs b/src/Snap/Snaplet/Rest/FromRequest.hs new file mode 100644 --- /dev/null +++ b/src/Snap/Snaplet/Rest/FromRequest.hs @@ -0,0 +1,9 @@ +------------------------------------------------------------------------------ +module Snap.Snaplet.Rest.FromRequest + ( FromRequest (fromPath) + , parseRead + ) where + +------------------------------------------------------------------------------ +import Snap.Snaplet.Rest.FromRequest.Internal + diff --git a/src/Snap/Snaplet/Rest/FromRequest/Internal.hs b/src/Snap/Snaplet/Rest/FromRequest/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Snap/Snaplet/Rest/FromRequest/Internal.hs @@ -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 + diff --git a/src/Snap/Snaplet/Rest/Media.hs b/src/Snap/Snaplet/Rest/Media.hs new file mode 100644 --- /dev/null +++ b/src/Snap/Snaplet/Rest/Media.hs @@ -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 + diff --git a/src/Snap/Snaplet/Rest/Options.hs b/src/Snap/Snaplet/Rest/Options.hs new file mode 100644 --- /dev/null +++ b/src/Snap/Snaplet/Rest/Options.hs @@ -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 + diff --git a/src/Snap/Snaplet/Rest/Proxy.hs b/src/Snap/Snaplet/Rest/Proxy.hs new file mode 100644 --- /dev/null +++ b/src/Snap/Snaplet/Rest/Proxy.hs @@ -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 + diff --git a/src/Snap/Snaplet/Rest/Resource.hs b/src/Snap/Snaplet/Rest/Resource.hs new file mode 100644 --- /dev/null +++ b/src/Snap/Snaplet/Rest/Resource.hs @@ -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 + diff --git a/src/Snap/Snaplet/Rest/Resource/Builder.hs b/src/Snap/Snaplet/Rest/Resource/Builder.hs new file mode 100644 --- /dev/null +++ b/src/Snap/Snaplet/Rest/Resource/Builder.hs @@ -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 } + diff --git a/src/Snap/Snaplet/Rest/Resource/Internal.hs b/src/Snap/Snaplet/Rest/Resource/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Snap/Snaplet/Rest/Resource/Internal.hs @@ -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) + diff --git a/src/Snap/Snaplet/Rest/Resource/Media.hs b/src/Snap/Snaplet/Rest/Resource/Media.hs new file mode 100644 --- /dev/null +++ b/src/Snap/Snaplet/Rest/Resource/Media.hs @@ -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"] + diff --git a/src/Snap/Snaplet/Rest/Serve.hs b/src/Snap/Snaplet/Rest/Serve.hs new file mode 100644 --- /dev/null +++ b/src/Snap/Snaplet/Rest/Serve.hs @@ -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 +