diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,13 @@ +# Changelog + +## 0.29 + +* Add multi-delete handler. It is used on a DELETE to + `///` and is derived from the single delete handler. +* Don't put `Cache-Control: private` header on served files. This way + they can be cached by public proxies, e.g. cloudfront. +* Add `Show` instances for `Header`, `Param` and `Dict`. +* Renamed `mkMultiPutHandler` to `mkMultiHandler` in + `Rest.Driver.Routing`. +* Explicit exports in `Rest.Driver.Routing`, removing a lot of + private functions from the public interface. diff --git a/rest-core.cabal b/rest-core.cabal --- a/rest-core.cabal +++ b/rest-core.cabal @@ -1,13 +1,14 @@ -Name: rest-core -Version: 0.28.0.1 -Description: Rest API library. -Synopsis: Rest API library. -Maintainer: code@silk.co -Category: Web -Build-Type: Simple -Cabal-Version: >= 1.8 -License: BSD3 -License-File: LICENSE +Name: rest-core +Version: 0.29 +Description: Rest API library. +Synopsis: Rest API library. +Maintainer: code@silk.co +Category: Web +Build-Type: Simple +Cabal-Version: >= 1.8 +License: BSD3 +License-File: LICENSE +Extra-Source-Files: CHANGELOG.md Library GHC-Options: -Wall diff --git a/src/Rest/Dictionary/Types.hs b/src/Rest/Dictionary/Types.hs --- a/src/Rest/Dictionary/Types.hs +++ b/src/Rest/Dictionary/Types.hs @@ -94,6 +94,10 @@ NoHeader :: Header () Header :: [String] -> ([Maybe String] -> Either DataError h) -> Header h +instance Show (Header h) where + showsPrec _ NoHeader = showString "NoHeader" + showsPrec n (Header hs _) = showParen (n > 9) (showString "Header " . showsPrec 10 hs) + -- | The explicit dictionary `Parameter` describes how to translate the request -- parameters to some Haskell value. The first field in the `Header` -- constructor is a white list of paramters we can recognize, used in generic @@ -110,6 +114,15 @@ Param :: [String] -> ([Maybe String] -> Either DataError p) -> Param p TwoParams :: Param p -> Param q -> Param (p, q) +instance Show (Param p) where + showsPrec _ NoParam = showString "NoParam" + showsPrec n (Param ns _) = showParen (n > 9) (showString "Param " . showsPrec 10 ns) + showsPrec n (TwoParams p q) = showParen (n > 9) ( showString "TwoParams " + . showsPrec 10 p + . showString " " + . showsPrec 10 q + ) + -- | The explicitly dictionary `Input` describes how to translate the request -- body into some Haskell value. We currently use a constructor for every -- combination of input type to output type. For example, we can use XML input @@ -187,7 +200,7 @@ , inputs :: Inputs i , outputs :: Outputs o , errors :: Errors e - } + } deriving Show |] -- | The empty dictionary, recognizing no types. diff --git a/src/Rest/Driver/Perform.hs b/src/Rest/Driver/Perform.hs --- a/src/Rest/Driver/Perform.hs +++ b/src/Rest/Driver/Perform.hs @@ -332,7 +332,7 @@ tryD (MultipartO : _ ) _ = outputMultipart v tryD (FileO : _ ) FileFormat = do mime <- fromMaybe "application/octet-stream" <$> lookupMimeType (map toLower (snd v)) setHeader "Content-Type" mime - setHeader "Cache-Control" "private, max-age=604800" + setHeader "Cache-Control" "max-age=604800" ok (fst v) tryD [] t = throwError (UnsupportedFormat (show t)) tryD (_ : xs) t = tryD xs t diff --git a/src/Rest/Driver/Routing.hs b/src/Rest/Driver/Routing.hs --- a/src/Rest/Driver/Routing.hs +++ b/src/Rest/Driver/Routing.hs @@ -9,8 +9,14 @@ , DeriveDataTypeable , TupleSections #-} -module Rest.Driver.Routing where +module Rest.Driver.Routing + ( route + , mkListHandler + , mkMultiHandler + , UriParts + ) where + import Prelude hiding (id, (.)) import Control.Applicative @@ -24,11 +30,9 @@ import Control.Monad.State (StateT, evalStateT, MonadState) import Control.Monad.Trans.Either import Control.Monad.Trans.Maybe -import Data.ByteString (ByteString) import Network.Multipart (BodyPart (..), HeaderName (..)) import Safe import qualified Control.Monad.State as State -import qualified Data.ByteString.UTF8 as UTF8 import qualified Data.ByteString.Lazy.UTF8 as LUTF8 import qualified Data.Label.Total as L import qualified Data.Map as Map @@ -51,7 +55,6 @@ import qualified Rest.Driver.RestM as Rest -type Uri = ByteString type UriParts = [String] apiError :: (MonadError (Reason e) m) => Reason e -> m a @@ -146,7 +149,7 @@ -> Router (RunnableHandler m) routeUnnamed resource@(Rest.Resource { Rest.list }) subRouters cardinality = case cardinality of - Rest.Single sBy -> withSegment (multiPut resource sBy) $ \seg -> + Rest.Single sBy -> withSegment (multi resource sBy) $ \seg -> parseIdent sBy seg >>= \sid -> withSubresource sid resource subRouters Rest.Many mBy -> do seg <- popSegment @@ -162,18 +165,23 @@ routeGetter getter resource subRouters = case getter of Rest.Singleton sid -> getOrDeep sid - Rest.By sBy -> withSegment (multiPut resource sBy) $ \seg -> + Rest.By sBy -> withSegment (multi resource sBy) $ \seg -> parseIdent sBy seg >>= getOrDeep where getOrDeep sid = withSubresource sid resource subRouters -multiPut :: Rest.Resource m s sid mid aid -> Rest.Id sid -> Router (RunnableHandler m) -multiPut (Rest.Resource { Rest.update, Rest.enter }) sBy = - do hasMethod PUT - maybe (apiError UnsupportedRoute) return $ - do updateH <- update - putHandler <- mkMultiPutHandler sBy enter updateH - return (RunnableHandler id putHandler) +multi :: Rest.Resource m s sid mid aid -> Rest.Id sid -> Router (RunnableHandler m) +multi (Rest.Resource { Rest.update, Rest.remove, Rest.enter }) sBy = + ask >>= \method -> + case method of + PUT -> handleOrNotFound update + DELETE -> handleOrNotFound remove + _ -> apiError UnsupportedMethod + where + handleOrNotFound handler = + maybe (apiError UnsupportedRoute) + (return . RunnableHandler id) + (handler >>= mkMultiHandler sBy enter) routeListGetter :: Monad m => Rest.Getter mid @@ -241,9 +249,6 @@ Nothing -> throwError (IdentError (ParseError $ "Failed to parse " ++ seg)) Just sid -> return (byF sid) -splitUri :: Uri -> UriParts -splitUri = splitUriString . UTF8.toString - splitUriString :: String -> UriParts splitUriString = filter (/= "") . map decode . splitOn "/" @@ -296,8 +301,8 @@ xs <- act (Env h p i) return (List f (min c (length xs)) (take c xs)) -mkMultiPutHandler :: Monad m => Rest.Id id -> (id -> Run s m) -> Handler s -> Maybe (Handler m) -mkMultiPutHandler sBy run (GenHandler dict act sec) = GenHandler <$> mNewDict <*> pure newAct <*> pure sec +mkMultiHandler :: Monad m => Rest.Id id -> (id -> Run s m) -> Handler s -> Maybe (Handler m) +mkMultiHandler sBy run (GenHandler dict act sec) = GenHandler <$> mNewDict <*> pure newAct <*> pure sec where newErrDict = L.modify errors reasonE dict mNewDict = L.traverse inputs mappingI