packages feed

rest-core 0.36.0.6 → 0.37

raw patch · 7 files changed

+410/−360 lines, 7 filesdep ~errorsdep ~transformersdep ~transformers-compat

Dependency ranges changed: errors, transformers, transformers-compat

Files

CHANGELOG.md view
@@ -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.
rest-core.cabal view
@@ -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
src/Rest/Driver/Routing.hs view
@@ -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
+ src/Rest/Driver/Routing/Internal.hs view
@@ -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
src/Rest/Driver/Types.hs view
@@ -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]+  }
src/Rest/Run.hs view
@@ -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)
tests/Runner.hs view
@@ -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)