diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,5 +1,21 @@ # Changelog +## 0.37 + +* Allow specifying custom multi-action. Previously there was always a + top-level POST that could perform multiple actions in the API at + once. Now you can customize this handler (e.g. to add logging or + optimisations) , or turn it off completely by returning `NotFound`. + + Because this is an experimental feature, it's exposed through + `Rest.Driver.Routing.Internal` and is subject to future breaking + changes without a major bump. + + There is one breaking change due to this: the signature of `route` + now requires a `Monad` and `Applicative` constraint on `m`. This + propagates to `Rest.Run.apiToHandler(')` and related functions in + the rest-happstack, rest-snap and rest-wai packages. + #### 0.36.0.6 * Security: don't allow newlines in filenames. diff --git a/rest-core.cabal b/rest-core.cabal --- a/rest-core.cabal +++ b/rest-core.cabal @@ -1,5 +1,5 @@ name: rest-core -version: 0.36.0.6 +version: 0.37 description: Rest API library. synopsis: Rest API library. maintainer: code@silk.co @@ -30,6 +30,7 @@ Rest.Driver.Perform Rest.Driver.RestM Rest.Driver.Routing + Rest.Driver.Routing.Internal Rest.Driver.Types Rest.Error Rest.Handler @@ -40,7 +41,7 @@ Rest.ShowUrl build-depends: base >= 4.5 && < 4.9 - , aeson >= 0.7 && < 0.10 + , aeson >= 0.7 && < 0.11 , aeson-utils >= 0.2 && < 0.4 , bytestring >= 0.9 && < 0.11 , case-insensitive >= 1.2 && < 1.3 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 @@ -1,15 +1,3 @@ -{-# LANGUAGE - DeriveDataTypeable - , ExistentialQuantification - , FlexibleContexts - , GADTs - , GeneralizedNewtypeDeriving - , NamedFieldPuns - , RankNTypes - , ScopedTypeVariables - , StandaloneDeriving - , TupleSections - #-} module Rest.Driver.Routing ( route , mkListHandler @@ -19,339 +7,4 @@ , splitUriString ) where -import Prelude hiding (id, (.)) - -import Control.Applicative -import Control.Arrow -import Control.Category -import Control.Error.Util -import Control.Monad.Error.Class -import Control.Monad.Identity -import Control.Monad.Reader -import Control.Monad.State (MonadState, StateT, evalStateT) -import Control.Monad.Trans.Except -import Control.Monad.Trans.Maybe -import Data.List.Split -import Network.Multipart (BodyPart (..), HeaderName (..)) -import Safe -import qualified Control.Monad.State as State -import qualified Data.ByteString.Lazy.UTF8 as LUTF8 -import qualified Data.HashMap.Strict as H -import qualified Data.Label.Total as L - -import Network.URI.Encode (decode) -import Rest.Api (Some1 (..)) -import Rest.Container -import Rest.Dictionary -import Rest.Error -import Rest.Handler (Env (..), GenHandler (..), Handler, ListHandler, Range (..), mkInputHandler, range) -import Rest.Types.Container.Resource (Resource, Resources (..)) -import qualified Rest.Api as Rest -import qualified Rest.Resource as Rest -import qualified Rest.Schema as Rest -import qualified Rest.StringMap.HashMap.Strict as StringHashMap -import qualified Rest.Types.Container.Resource as R - -import Rest.Driver.Perform (failureWriter, writeResponse) -import Rest.Driver.RestM (runRestM) -import Rest.Driver.Types - -import qualified Rest.Driver.RestM as Rest - -type UriParts = [String] - -apiError :: (MonadError (Reason e) m) => Reason e -> m a -apiError = throwError - -newtype Router a = - Router { unRouter :: ReaderT Method (StateT UriParts (ExceptT Reason_ Identity)) a } - deriving ( Functor - , Applicative - , Monad - , MonadReader Method - , MonadState UriParts - , MonadError Reason_ - ) - -runRouter :: Method -> UriParts -> Router (RunnableHandler m) -> Either Reason_ (RunnableHandler m) -runRouter method uri = runIdentity - . runExceptT - . flip evalStateT uri - . flip runReaderT method - . unRouter - -route :: Maybe Method -> UriParts -> Rest.Api m -> Either Reason_ (RunnableHandler m) -route Nothing _ _ = apiError UnsupportedMethod -route (Just method) uri api = runRouter method uri $ - do versionStr <- popSegment - case versionStr `Rest.lookupVersion` api of - Just (Some1 router) -> routeRoot router - _ -> apiError UnsupportedVersion - -routeRoot :: Rest.Router m s -> Router (RunnableHandler m) -routeRoot router@(Rest.Embed resource _) = do - routeName (Rest.name resource) - fromMaybeT (routeRouter router) (routeMultiGet router) - -routeMultiGet :: Rest.Router m s -> MaybeT Router (RunnableHandler m) -routeMultiGet root@(Rest.Embed Rest.Resource{} _) = - do guardNullPath - guardMethod POST - return (RunnableHandler id (mkMultiGetHandler root)) - -routeRouter :: Rest.Router m s -> Router (RunnableHandler m) -routeRouter (Rest.Embed resource@(Rest.Resource { Rest.schema }) subRouters) = - case schema of - (Rest.Schema mToplevel step) -> maybe (apiError UnsupportedRoute) return =<< runMaybeT - ( routeToplevel resource subRouters mToplevel - <|> routeCreate resource - <|> lift (routeStep resource subRouters step) - ) - -routeToplevel :: Rest.Resource m s sid mid aid - -> [Some1 (Rest.Router s)] - -> Maybe (Rest.Cardinality sid mid) - -> MaybeT Router (RunnableHandler m) -routeToplevel resource@(Rest.Resource { Rest.list }) subRouters mToplevel = - hoistMaybe mToplevel >>= \toplevel -> - case toplevel of - Rest.Single sid -> lift $ withSubresource sid resource subRouters - Rest.Many mid -> - do guardNullPath - guardMethod GET - lift $ routeListHandler (list mid) - -routeCreate :: Rest.Resource m s sid mid aid -> MaybeT Router (RunnableHandler m) -routeCreate (Rest.Resource { Rest.create }) = guardNullPath >> guardMethod POST >> - maybe (apiError UnsupportedRoute) (return . RunnableHandler id) create - -routeStep :: Rest.Resource m s sid mid aid - -> [Some1 (Rest.Router s)] - -> Rest.Step sid mid aid - -> Router (RunnableHandler m) -routeStep resource subRouters step = - case step of - Rest.Named ns -> popSegment >>= \seg -> - case lookup seg ns of - Nothing -> apiError UnsupportedRoute - Just h -> routeNamed resource subRouters h - Rest.Unnamed h -> routeUnnamed resource subRouters h - -routeNamed :: Rest.Resource m s sid mid aid - -> [Some1 (Rest.Router s)] - -> Rest.Endpoint sid mid aid - -> Router (RunnableHandler m) -routeNamed resource@(Rest.Resource { Rest.list, Rest.statics }) subRouters h = - case h of - Left aid -> noRestPath >> hasMethod POST >> return (RunnableHandler id (statics aid)) - Right (Rest.Single getter) -> routeGetter getter resource subRouters - Right (Rest.Many getter) -> routeListGetter getter list - -routeUnnamed :: Rest.Resource m s sid mid aid - -> [Some1 (Rest.Router s)] - -> Rest.Cardinality (Rest.Id sid) (Rest.Id mid) - -> Router (RunnableHandler m) -routeUnnamed resource@(Rest.Resource { Rest.list }) subRouters cardinality = - case cardinality of - Rest.Single sBy -> withSegment (multi resource sBy) $ \seg -> - parseIdent sBy seg >>= \sid -> withSubresource sid resource subRouters - Rest.Many mBy -> - do seg <- popSegment - mid <- parseIdent mBy seg - noRestPath - hasMethod GET - routeListHandler (list mid) - -routeGetter :: Rest.Getter sid - -> Rest.Resource m s sid mid aid - -> [Some1 (Rest.Router s)] - -> Router (RunnableHandler m) -routeGetter getter resource subRouters = - case getter of - Rest.Singleton sid -> getOrDeep sid - Rest.By sBy -> withSegment (multi resource sBy) $ \seg -> - parseIdent sBy seg >>= getOrDeep - where - getOrDeep sid = withSubresource sid resource subRouters - -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 - -> (mid -> ListHandler m) - -> Router (RunnableHandler m) -routeListGetter getter list = hasMethod GET >> - case getter of - Rest.Singleton mid -> noRestPath >> routeListHandler (list mid) - Rest.By mBy -> - do seg <- popSegment - mid <- parseIdent mBy seg - noRestPath - routeListHandler (list mid) - -withSubresource :: sid - -> Rest.Resource m s sid mid aid - -> [Some1 (Rest.Router s)] - -> Router (RunnableHandler m) -withSubresource sid resource@(Rest.Resource { Rest.enter, Rest.selects, Rest.actions }) subRouters = - withSegment (routeSingle sid resource) $ \seg -> - case lookup seg selects of - Just select -> noRestPath >> hasMethod GET >> return (RunnableHandler (enter sid) select) - Nothing -> case lookup seg actions of - Just action -> noRestPath >> hasMethod POST >> return (RunnableHandler (enter sid) action) - Nothing -> - case lookupRouter seg subRouters of - Just (Some1 subRouter) -> do - (RunnableHandler subRun subHandler) <- routeRouter subRouter - return (RunnableHandler (enter sid . subRun) subHandler) - Nothing -> apiError UnsupportedRoute - -routeSingle :: sid -> Rest.Resource m s sid mid aid -> Router (RunnableHandler m) -routeSingle sid (Rest.Resource { Rest.enter, Rest.get, Rest.update, Rest.remove }) = - ask >>= \method -> - case method of - GET -> handleOrNotFound get - PUT -> handleOrNotFound update - DELETE -> handleOrNotFound remove - _ -> apiError UnsupportedMethod - where - handleOrNotFound = maybe (apiError UnsupportedRoute) (return . RunnableHandler (enter sid)) - -routeName :: String -> Router () -routeName ident = when (not . null $ ident) $ - do identStr <- popSegment - when (identStr /= ident) $ - apiError UnsupportedRoute - -routeListHandler :: Monad m => ListHandler m -> Router (RunnableHandler m) -routeListHandler list = - maybe (apiError UnsupportedRoute) - (return . RunnableHandler id) - (mkListHandler list) - -lookupRouter :: String -> [Some1 (Rest.Router s)] -> Maybe (Some1 (Rest.Router s)) -lookupRouter _ [] = Nothing -lookupRouter name (Some1 router@(Rest.Embed resource _) : routers) - = (guard (Rest.name resource == name) >> return (Some1 router)) - <|> lookupRouter name routers - -parseIdent :: MonadError (Reason e) m => Rest.Id id -> String -> m id -parseIdent (Rest.Id StringId byF) seg = return (byF seg) -parseIdent (Rest.Id ReadId byF) seg = - case readMay seg of - Nothing -> throwError (IdentError (ParseError $ "Failed to parse " ++ seg)) - Just sid -> return (byF sid) - -splitUriString :: String -> UriParts -splitUriString = filter (/= "") . map decode . splitOn "/" - -popSegment :: Router String -popSegment = - do uriParts <- State.get - case uriParts of - [] -> apiError UnsupportedRoute - (hd:tl) -> do - State.put tl - return hd - -withSegment :: Router a -> (String -> Router a) -> Router a -withSegment noSeg withSeg = - do uriParts <- State.get - case uriParts of - [] -> noSeg - (hd:tl) -> do - State.put tl - withSeg hd - -noRestPath :: Router () -noRestPath = - do uriParts <- State.get - unless (null uriParts) $ - apiError UnsupportedRoute - -guardNullPath :: (MonadPlus m, MonadState UriParts m) => m () -guardNullPath = State.get >>= guard . null - -hasMethod :: Method -> Router () -hasMethod wantedMethod = ask >>= \method -> - if method == wantedMethod - then return () - else apiError UnsupportedMethod - -guardMethod :: (MonadPlus m, MonadReader Method m) => Method -> m () -guardMethod method = ask >>= guard . (== method) - -mkListHandler :: Monad m => ListHandler m -> Maybe (Handler m) -mkListHandler (GenHandler dict act sec) = - do newDict <- L.traverse outputs listO . addPar range $ dict - return $ GenHandler newDict (mkListAction act) sec - -mkListAction :: Monad m - => (Env h p i -> ExceptT (Reason e) m [a]) - -> Env h (Range, p) i - -> ExceptT (Reason e) m (List a) -mkListAction act (Env h (Range f c, p) i) = do - xs <- act (Env h p i) - return (List f (min c (length xs)) (take c xs)) - -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 - <=< L.traverse outputs (mappingO <=< statusO (L.get errors newErrDict)) - . L.set errors defaultE - $ dict - newAct (Env hs ps vs) = - do bs <- lift $ forM (StringHashMap.toList vs) $ \(k, v) -> runExceptT $ - do i <- parseIdent sBy k - mapExceptT (run i) (act (Env hs ps v)) - return . StringHashMap.fromList $ zipWith (\(k, _) b -> (k, eitherToStatus b)) (StringHashMap.toList vs) bs - -mkMultiGetHandler :: forall m s. (Applicative m, Monad m) => Rest.Router m s -> Handler m -mkMultiGetHandler root = mkInputHandler (xmlJsonI . multipartO) $ \(Resources rs) -> multiGetHandler rs - where - multiGetHandler rs = lift $ - do mapM (runResource root) rs - -runResource :: forall m s. (Applicative m, Monad m) => Rest.Router m s -> Resource -> m BodyPart -runResource root res - = fmap (uncurry mkBodyPart) - . runRestM (toRestInput res) - . either (failureWriter None) (writeResponse . mapHandler lift) - . routeResource - $ R.uri res - where - routeResource :: String -> Either Reason_ (RunnableHandler m) - routeResource uri = runRouter (R.method res) (splitUriString uri) (routeRoot root) - - toRestInput r = Rest.emptyInput - { Rest.headers = H.map (R.unValue) . StringHashMap.toHashMap . R.headers $ r - , Rest.parameters = H.map (R.unValue) . StringHashMap.toHashMap . R.parameters $ r - , Rest.body = LUTF8.fromString (R.input r) - , Rest.method = Just (R.method r) - , Rest.paths = splitUriString (R.uri r) - } - - mkHeaders = map (first HeaderName) . H.toList - - mkBodyPart bdy restOutput = - let hdrs = (HeaderName "X-Response-Code", maybe "200" show (Rest.responseCode restOutput)) - : mkHeaders (Rest.headersSet restOutput) - in BodyPart hdrs bdy - --- * Utilities - -fromMaybeT :: Monad m => m a -> MaybeT m a -> m a -fromMaybeT def act = runMaybeT act >>= maybe def return +import Rest.Driver.Routing.Internal diff --git a/src/Rest/Driver/Routing/Internal.hs b/src/Rest/Driver/Routing/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Rest/Driver/Routing/Internal.hs @@ -0,0 +1,361 @@ +{-# LANGUAGE + DeriveDataTypeable + , ExistentialQuantification + , FlexibleContexts + , GADTs + , GeneralizedNewtypeDeriving + , NamedFieldPuns + , RankNTypes + , ScopedTypeVariables + , StandaloneDeriving + , TupleSections + #-} +module Rest.Driver.Routing.Internal where + +import Prelude hiding (id, (.)) + +import Control.Applicative +import Control.Arrow +import Control.Category +import Control.Error.Util +import Control.Monad.Error.Class +import Control.Monad.Identity +import Control.Monad.Reader +import Control.Monad.State (MonadState, StateT, evalStateT) +import Control.Monad.Trans.Except +import Control.Monad.Trans.Maybe +import Data.List.Split +import Network.Multipart (BodyPart (..), HeaderName (..)) +import Safe +import qualified Control.Monad.State as State +import qualified Data.ByteString.Lazy.UTF8 as LUTF8 +import qualified Data.HashMap.Strict as H +import qualified Data.Label.Total as L + +import Network.URI.Encode (decode) +import Rest.Api (Some1 (..)) +import Rest.Container +import Rest.Dictionary +import Rest.Error +import Rest.Handler (Env (..), GenHandler (..), Handler, ListHandler, Range (..), mkInputHandler, range) +import Rest.Types.Container.Resource (Resource, Resources (..)) +import qualified Rest.Api as Rest +import qualified Rest.Resource as Rest +import qualified Rest.Schema as Rest +import qualified Rest.StringMap.HashMap.Strict as StringHashMap +import qualified Rest.Types.Container.Resource as R + +import Rest.Driver.Perform (failureWriter, writeResponse) +import Rest.Driver.RestM (runRestM) +import Rest.Driver.Types + +import qualified Rest.Driver.RestM as Rest + +type UriParts = [String] + +apiError :: (MonadError (Reason e) m) => Reason e -> m a +apiError = throwError + +data RouterData m = RouterData { method :: Method, config :: Config m } + +newtype Router m a = + Router { unRouter :: ReaderT (RouterData m) (StateT UriParts (ExceptT Reason_ Identity)) a } + deriving ( Functor + , Applicative + , Monad + , MonadReader (RouterData m) + , MonadState UriParts + , MonadError Reason_ + ) + +runRouter :: Config m -> Method -> UriParts -> Router m (RunnableHandler m) -> Either Reason_ (RunnableHandler m) +runRouter cfg mtd uri = runIdentity + . runExceptT + . flip evalStateT uri + . flip runReaderT (RouterData mtd cfg) + . unRouter + +route :: (Applicative m, Monad m) => Maybe Method -> UriParts -> Rest.Api m -> Either Reason_ (RunnableHandler m) +route mtd uri = routeWith defaultConfig mtd uri + +routeWith :: Config m -> Maybe Method -> UriParts -> Rest.Api m -> Either Reason_ (RunnableHandler m) +routeWith _ Nothing _ _ = apiError UnsupportedMethod +routeWith cfg (Just mtd) uri api = runRouter cfg mtd uri $ + do versionStr <- popSegment + case versionStr `Rest.lookupVersion` api of + Just (Some1 router) -> routeRoot router + _ -> apiError UnsupportedVersion + +routeRoot :: Rest.Router m s -> Router m (RunnableHandler m) +routeRoot router@(Rest.Embed resource _) = do + routeName (Rest.name resource) + fromMaybeT (routeRouter router) (routeMultiGet router) + +routeMultiGet :: Rest.Router m s -> MaybeT (Router m) (RunnableHandler m) +routeMultiGet root@(Rest.Embed Rest.Resource{} _) = + do guardNullPath + guardMethod POST + cfg <- asks config + return (RunnableHandler id (mkMultiGetHandler cfg root)) + +routeRouter :: Rest.Router m s -> Router n (RunnableHandler m) +routeRouter (Rest.Embed resource@(Rest.Resource { Rest.schema }) subRouters) = + case schema of + (Rest.Schema mToplevel step) -> maybe (apiError UnsupportedRoute) return =<< runMaybeT + ( routeToplevel resource subRouters mToplevel + <|> routeCreate resource + <|> lift (routeStep resource subRouters step) + ) + +routeToplevel :: Rest.Resource m s sid mid aid + -> [Some1 (Rest.Router s)] + -> Maybe (Rest.Cardinality sid mid) + -> MaybeT (Router n) (RunnableHandler m) +routeToplevel resource@(Rest.Resource { Rest.list }) subRouters mToplevel = + hoistMaybe mToplevel >>= \toplevel -> + case toplevel of + Rest.Single sid -> lift $ withSubresource sid resource subRouters + Rest.Many mid -> + do guardNullPath + guardMethod GET + lift $ routeListHandler (list mid) + +routeCreate :: Rest.Resource m s sid mid aid -> MaybeT (Router n) (RunnableHandler m) +routeCreate (Rest.Resource { Rest.create }) = guardNullPath >> guardMethod POST >> + maybe (apiError UnsupportedRoute) (return . RunnableHandler id) create + +routeStep :: Rest.Resource m s sid mid aid + -> [Some1 (Rest.Router s)] + -> Rest.Step sid mid aid + -> Router n (RunnableHandler m) +routeStep resource subRouters step = + case step of + Rest.Named ns -> popSegment >>= \seg -> + case lookup seg ns of + Nothing -> apiError UnsupportedRoute + Just h -> routeNamed resource subRouters h + Rest.Unnamed h -> routeUnnamed resource subRouters h + +routeNamed :: Rest.Resource m s sid mid aid + -> [Some1 (Rest.Router s)] + -> Rest.Endpoint sid mid aid + -> Router n (RunnableHandler m) +routeNamed resource@(Rest.Resource { Rest.list, Rest.statics }) subRouters h = + case h of + Left aid -> noRestPath >> hasMethod POST >> return (RunnableHandler id (statics aid)) + Right (Rest.Single getter) -> routeGetter getter resource subRouters + Right (Rest.Many getter) -> routeListGetter getter list + +routeUnnamed :: Rest.Resource m s sid mid aid + -> [Some1 (Rest.Router s)] + -> Rest.Cardinality (Rest.Id sid) (Rest.Id mid) + -> Router n (RunnableHandler m) +routeUnnamed resource@(Rest.Resource { Rest.list }) subRouters cardinality = + case cardinality of + Rest.Single sBy -> withSegment (multi resource sBy) $ \seg -> + parseIdent sBy seg >>= \sid -> withSubresource sid resource subRouters + Rest.Many mBy -> + do seg <- popSegment + mid <- parseIdent mBy seg + noRestPath + hasMethod GET + routeListHandler (list mid) + +routeGetter :: Rest.Getter sid + -> Rest.Resource m s sid mid aid + -> [Some1 (Rest.Router s)] + -> Router n (RunnableHandler m) +routeGetter getter resource subRouters = + case getter of + Rest.Singleton sid -> getOrDeep sid + Rest.By sBy -> withSegment (multi resource sBy) $ \seg -> + parseIdent sBy seg >>= getOrDeep + where + getOrDeep sid = withSubresource sid resource subRouters + +multi :: Rest.Resource m s sid mid aid -> Rest.Id sid -> Router n (RunnableHandler m) +multi (Rest.Resource { Rest.update, Rest.remove, Rest.enter }) sBy = + asks method >>= \mtd -> + case mtd 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 + -> (mid -> ListHandler m) + -> Router n (RunnableHandler m) +routeListGetter getter list = hasMethod GET >> + case getter of + Rest.Singleton mid -> noRestPath >> routeListHandler (list mid) + Rest.By mBy -> + do seg <- popSegment + mid <- parseIdent mBy seg + noRestPath + routeListHandler (list mid) + +withSubresource :: sid + -> Rest.Resource m s sid mid aid + -> [Some1 (Rest.Router s)] + -> Router n (RunnableHandler m) +withSubresource sid resource@(Rest.Resource { Rest.enter, Rest.selects, Rest.actions }) subRouters = + withSegment (routeSingle sid resource) $ \seg -> + case lookup seg selects of + Just select -> noRestPath >> hasMethod GET >> return (RunnableHandler (enter sid) select) + Nothing -> case lookup seg actions of + Just action -> noRestPath >> hasMethod POST >> return (RunnableHandler (enter sid) action) + Nothing -> + case lookupRouter seg subRouters of + Just (Some1 subRouter) -> do + (RunnableHandler subRun subHandler) <- routeRouter subRouter + return (RunnableHandler (enter sid . subRun) subHandler) + Nothing -> apiError UnsupportedRoute + +routeSingle :: sid -> Rest.Resource m s sid mid aid -> Router n (RunnableHandler m) +routeSingle sid (Rest.Resource { Rest.enter, Rest.get, Rest.update, Rest.remove }) = + asks method >>= \mtd -> + case mtd of + GET -> handleOrNotFound get + PUT -> handleOrNotFound update + DELETE -> handleOrNotFound remove + _ -> apiError UnsupportedMethod + where + handleOrNotFound = maybe (apiError UnsupportedRoute) (return . RunnableHandler (enter sid)) + +routeName :: String -> Router n () +routeName ident = when (not . null $ ident) $ + do identStr <- popSegment + when (identStr /= ident) $ + apiError UnsupportedRoute + +routeListHandler :: Monad m => ListHandler m -> Router n (RunnableHandler m) +routeListHandler list = + maybe (apiError UnsupportedRoute) + (return . RunnableHandler id) + (mkListHandler list) + +lookupRouter :: String -> [Some1 (Rest.Router s)] -> Maybe (Some1 (Rest.Router s)) +lookupRouter _ [] = Nothing +lookupRouter name (Some1 router@(Rest.Embed resource _) : routers) + = (guard (Rest.name resource == name) >> return (Some1 router)) + <|> lookupRouter name routers + +parseIdent :: MonadError (Reason e) m => Rest.Id id -> String -> m id +parseIdent (Rest.Id StringId byF) seg = return (byF seg) +parseIdent (Rest.Id ReadId byF) seg = + case readMay seg of + Nothing -> throwError (IdentError (ParseError $ "Failed to parse " ++ seg)) + Just sid -> return (byF sid) + +splitUriString :: String -> UriParts +splitUriString = filter (/= "") . map decode . splitOn "/" + +popSegment :: Router n String +popSegment = + do uriParts <- State.get + case uriParts of + [] -> apiError UnsupportedRoute + (hd:tl) -> do + State.put tl + return hd + +withSegment :: Router n a -> (String -> Router n a) -> Router n a +withSegment noSeg withSeg = + do uriParts <- State.get + case uriParts of + [] -> noSeg + (hd:tl) -> do + State.put tl + withSeg hd + +noRestPath :: Router n () +noRestPath = + do uriParts <- State.get + unless (null uriParts) $ + apiError UnsupportedRoute + +guardNullPath :: (MonadPlus m, MonadState UriParts m) => m () +guardNullPath = State.get >>= guard . null + +hasMethod :: Method -> Router n () +hasMethod wantedMethod = asks method >>= \mtd -> + if mtd == wantedMethod + then return () + else apiError UnsupportedMethod + +guardMethod :: (MonadPlus m, MonadReader (RouterData c) m) => Method -> m () +guardMethod mtd = asks method >>= guard . (== mtd) + +mkListHandler :: Monad m => ListHandler m -> Maybe (Handler m) +mkListHandler (GenHandler dict act sec) = + do newDict <- L.traverse outputs listO . addPar range $ dict + return $ GenHandler newDict (mkListAction act) sec + +mkListAction :: Monad m + => (Env h p i -> ExceptT (Reason e) m [a]) + -> Env h (Range, p) i + -> ExceptT (Reason e) m (List a) +mkListAction act (Env h (Range f c, p) i) = do + xs <- act (Env h p i) + return (List f (min c (length xs)) (take c xs)) + +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 + <=< L.traverse outputs (mappingO <=< statusO (L.get errors newErrDict)) + . L.set errors defaultE + $ dict + newAct (Env hs ps vs) = + do bs <- lift $ forM (StringHashMap.toList vs) $ \(k, v) -> runExceptT $ + do i <- parseIdent sBy k + mapExceptT (run i) (act (Env hs ps v)) + return . StringHashMap.fromList $ zipWith (\(k, _) b -> (k, eitherToStatus b)) (StringHashMap.toList vs) bs + +mkMultiGetHandler :: forall m s. (Applicative m, Monad m) => Config m -> Rest.Router m s -> Handler m +mkMultiGetHandler cfg root = mkInputHandler (xmlJsonI . multipartO) $ \(Resources rs) -> (runMultiResources cfg) cfg root rs + +defaultRunMultiResources :: (Applicative m, Monad m) => Config m -> Rest.Router m s -> [Resource] -> ExceptT Reason_ m [BodyPart] +defaultRunMultiResources cfg root rs = lift $ forM rs (runResource cfg root) + +defaultConfig :: (Applicative m, Monad m) => Config m +defaultConfig = Config { runMultiResources = defaultRunMultiResources } + +runResource :: (Applicative m, Monad m) => Config m -> Rest.Router m s -> Resource -> m BodyPart +runResource cfg root res + = fmap (uncurry mkBodyPart) + . runRestM (toRestInput res) + . either (failureWriter None) (writeResponse . mapHandler lift) + $ routeResource cfg root res + +routeResource :: Config m -> Rest.Router m s -> Resource -> Either Reason_ (RunnableHandler m) +routeResource cfg root res = runRouter cfg (R.method res) (splitUriString $ R.uri res) (routeRoot root) + +toRestInput :: Resource -> Rest.RestInput +toRestInput r = Rest.emptyInput + { Rest.headers = H.map (R.unValue) . StringHashMap.toHashMap . R.headers $ r + , Rest.parameters = H.map (R.unValue) . StringHashMap.toHashMap . R.parameters $ r + , Rest.body = LUTF8.fromString (R.input r) + , Rest.method = Just (R.method r) + , Rest.paths = splitUriString (R.uri r) + } + +mkHeaders :: H.HashMap String d -> [(HeaderName, d)] +mkHeaders = map (first HeaderName) . H.toList + +mkBodyPart :: LUTF8.ByteString -> Rest.RestOutput -> BodyPart +mkBodyPart bdy restOutput = + let hdrs = (HeaderName "X-Response-Code", maybe "200" show (Rest.responseCode restOutput)) + : mkHeaders (Rest.headersSet restOutput) + in BodyPart hdrs bdy + +-- * Utilities + +fromMaybeT :: Monad m => m a -> MaybeT m a -> m a +fromMaybeT def act = runMaybeT act >>= maybe def return diff --git a/src/Rest/Driver/Types.hs b/src/Rest/Driver/Types.hs --- a/src/Rest/Driver/Types.hs +++ b/src/Rest/Driver/Types.hs @@ -2,14 +2,22 @@ module Rest.Driver.Types ( Run , RunnableHandler (..) + , Config (..) , mapHandler , module Rest.Types.Method ) where +import Control.Monad.Trans.Except +import Network.Multipart (BodyPart) + +import Rest.Api (Router) +import Rest.Error (Reason_) import Rest.Handler (Handler) +import Rest.Types.Container.Resource (Resource) import Rest.Types.Method (Method (..)) + type Run m n = forall a. m a -> n a data RunnableHandler n = forall m. RunnableHandler @@ -18,3 +26,8 @@ mapHandler :: Run m n -> RunnableHandler m -> RunnableHandler n mapHandler run (RunnableHandler run' h) = RunnableHandler (run . run') h + +data Config m + = Config + { runMultiResources :: forall s. Config m -> Router m s -> [Resource] -> ExceptT Reason_ m [BodyPart] + } diff --git a/src/Rest/Run.hs b/src/Rest/Run.hs --- a/src/Rest/Run.hs +++ b/src/Rest/Run.hs @@ -2,23 +2,29 @@ module Rest.Run ( apiToHandler , apiToHandler' + , apiToHandlerWith + , Config (..) ) where +import Control.Applicative import qualified Data.ByteString.Lazy.UTF8 as UTF8 import Rest.Api (Api) import Rest.Dictionary ( Dicts (..) ) import Rest.Driver.Perform -import Rest.Driver.Routing import Rest.Driver.Types +import qualified Rest.Driver.Routing.Internal as I -apiToHandler :: Rest m => Api m -> m UTF8.ByteString +apiToHandler :: (Applicative m, Monad m) => Rest m => Api m -> m UTF8.ByteString apiToHandler = apiToHandler' id -apiToHandler' :: Rest n => Run m n -> Api m -> n UTF8.ByteString -apiToHandler' run api = do +apiToHandler' :: (Applicative m, Monad m) => Rest n => Run m n -> Api m -> n UTF8.ByteString +apiToHandler' run = apiToHandlerWith I.defaultConfig run + +apiToHandlerWith :: Config m -> Rest n => Run m n -> Api m -> n UTF8.ByteString +apiToHandlerWith cfg run api = do method <- getMethod paths <- getPaths - case route method paths api of + case I.routeWith cfg method paths api of Left e -> failureWriter None e Right h -> writeResponse (mapHandler run h) diff --git a/tests/Runner.hs b/tests/Runner.hs --- a/tests/Runner.hs +++ b/tests/Runner.hs @@ -176,26 +176,26 @@ checkRoute GET (uri <> "/select") (root -/ Rest.route resource { selects = [("select", handler_)] }) checkRoute POST (uri <> "/action") (root -/ Rest.route resource { actions = [("action", handler_)] }) -checkRoute :: Method -> Uri -> Rest.Router m s -> Assertion +checkRoute :: (Applicative m, Monad m) => Method -> Uri -> Rest.Router m s -> Assertion checkRoute method uri router = checkRouteWithIgnoredMethods [method] router method uri -checkRoutes :: [(Method, Uri)] -> Rest.Router m s -> Assertion +checkRoutes :: (Applicative m, Monad m) => [(Method, Uri)] -> Rest.Router m s -> Assertion checkRoutes reqs router = do forM_ reqs $ uncurry $ checkRouteWithIgnoredMethods (map fst reqs) router -checkRouteWithIgnoredMethods :: [Method] -> Rest.Router m s -> Method -> Uri -> Assertion +checkRouteWithIgnoredMethods :: (Applicative m, Monad m) => [Method] -> Rest.Router m s -> Method -> Uri -> Assertion checkRouteWithIgnoredMethods ignoredMethods router method uri = do checkRouteSuccess method uri router forM_ (filter (not . (`elem` ignoredMethods)) allMethods) $ \badMethod -> checkRouteFailure badMethod uri router checkRouteFailure method (uri <> "/trailing") router -checkRouteFailure :: Method -> Uri -> Rest.Router m s -> Assertion +checkRouteFailure :: (Applicative m, Monad m) => Method -> Uri -> Rest.Router m s -> Assertion checkRouteFailure method uri router = case route (Just method) (splitUriString $ "v1.0/" <> uri) [(Version 1 0 Nothing, Some1 router)] of Left _ -> return () Right _ -> assertFailure ("Should be no route to " ++ show method ++ " " ++ uri ++ ".") -checkRouteSuccess :: Method -> Uri -> Rest.Router m s -> Assertion +checkRouteSuccess :: (Applicative m, Monad m) => Method -> Uri -> Rest.Router m s -> Assertion checkRouteSuccess method uri router = case route (Just method) (splitUriString $ "v1.0/" <> uri) [(Version 1 0 Nothing, Some1 router)] of Left e -> assertFailure ("No route to " ++ show method ++ " " ++ uri ++ ": " ++ show e)