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.39 +version: 0.39.0.1 description: Rest API library. synopsis: Rest API library. maintainer: code@silk.co @@ -40,13 +40,13 @@ Rest.Schema Rest.ShowUrl build-depends: - base >= 4.5 && < 4.10 - , aeson >= 0.7 && < 0.12 + base >= 4.5 && < 4.12 + , aeson >= 0.7 && < 1.4 , aeson-utils >= 0.2 && < 0.4 , base-compat >= 0.8 && < 0.10 , bytestring >= 0.9 && < 0.11 , case-insensitive >= 1.2 && < 1.3 - , errors >= 1.4 && < 2.2 + , errors >= 1.4 && < 2.3 , fclabels == 2.0.* , hxt >= 9.2 && < 9.4 , hxt-pickle-utils == 0.1.* @@ -61,7 +61,7 @@ , split >= 0.1 && < 0.3 , text >= 0.11 && < 1.3 , transformers >= 0.2 && < 0.6 - , transformers-compat >= 0.3 && < 0.6 + , transformers-compat >= 0.3 && < 0.7 , unordered-containers == 0.2.* , uri-encode == 1.5.* , utf8-string >= 0.3 && < 1.1 @@ -73,13 +73,14 @@ main-is: Runner.hs type: exitcode-stdio-1.0 build-depends: - base >= 4.5 && < 4.10 - , HUnit >= 1.2 && < 1.4 + base >= 4.5 && < 4.12 + , aeson >= 0.7 && < 1.4 + , HUnit >= 1.2 && < 1.7 , bytestring >= 0.9 && < 0.11 , mtl >= 2.0 && < 2.3 , rest-core , test-framework == 0.8.* , test-framework-hunit == 0.3.* , transformers >= 0.3 && < 0.6 - , transformers-compat >= 0.3 && < 0.6 + , transformers-compat >= 0.3 && < 0.7 , unordered-containers == 0.2.* diff --git a/src/Rest.hs b/src/Rest.hs --- a/src/Rest.hs +++ b/src/Rest.hs @@ -26,3 +26,5 @@ ) import Rest.Resource (Resource, mkResource, mkResourceId, mkResourceReader, mkResourceReaderWith, Void) import Rest.Schema + +{-# ANN module "HLint: ignore Use import/export shortcut" #-} diff --git a/src/Rest/Api.hs b/src/Rest/Api.hs --- a/src/Rest/Api.hs +++ b/src/Rest/Api.hs @@ -1,8 +1,12 @@ {-# LANGUAGE - GADTs + CPP + , GADTs , KindSignatures , NoImplicitPrelude #-} +#if MIN_VERSION_base(4,9,0) +{-# OPTIONS_GHC -Wno-redundant-constraints #-} +#endif -- | This module allows you to combine 'Resource's into an 'Api'. This -- can then be served using 'rest-happstack' or 'rest-snap', or used -- to generate clients or documentation using 'rest-gen'. @@ -129,7 +133,7 @@ -- | Get the latest version of an API. latest :: VersionSet m -> Maybe (Version, Some1 (Router m)) -latest = headMay . reverse . sortBy (compare `on` fst) +latest = headMay . sortBy (flip compare `on` fst) -- | Parse a 'String' as a 'Version'. The string should contain two or -- three numbers separated by dots, e.g. @1.12.3@. diff --git a/src/Rest/Container.hs b/src/Rest/Container.hs --- a/src/Rest/Container.hs +++ b/src/Rest/Container.hs @@ -1,11 +1,7 @@ {-# LANGUAGE DataKinds - , DeriveDataTypeable - , EmptyDataDecls - , FlexibleInstances , GADTs , ScopedTypeVariables - , TemplateHaskell , TypeFamilies #-} module Rest.Container @@ -84,7 +80,7 @@ mkStatusDict :: forall e o. [Error e] -> [Output o] -> Maybe (Outputs ('Just (Status e o))) mkStatusDict es os = - case mapMaybe mappingDictO (intersect es os) of + case mapMaybe mappingDictO (es `intersect` os) of [] -> Nothing sos -> Just (Dicts sos) where 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 @@ -1,10 +1,14 @@ {-# LANGUAGE - FlexibleContexts + CPP + , FlexibleContexts , GADTs , OverloadedStrings , RankNTypes , ScopedTypeVariables #-} +#if MIN_VERSION_base(4,9,0) +{-# OPTIONS_GHC -Wno-redundant-constraints #-} +#endif module Rest.Driver.Perform ( Rest (..) , failureWriter @@ -29,11 +33,10 @@ import Data.List.Split import Data.Maybe import Data.Text.Lazy.Encoding (decodeUtf8) -import Data.UUID (UUID) +import Data.UUID.V4 (nextRandom) import Network.Multipart (BodyPart (..), MultiPart (..), showMultipartBody) import Safe import System.IO.Unsafe -import System.Random (randomIO) import Text.Xml.Pickle import qualified Data.ByteString.Lazy as B @@ -355,14 +358,14 @@ tryOutputs :: Rest m => (t -> Format -> ExceptT (Last DataError) m a) -> t -> ExceptT (Reason e) m a tryOutputs try outputs = do formats <- lift acceptM - rethrowLast $ (msum $ try outputs <$> formats) <|> unsupportedFormat formats + rethrowLast $ msum (try outputs <$> formats) <|> unsupportedFormat formats where rethrowLast :: Monad m => ExceptT (Last DataError) m a -> ExceptT (Reason e) m a rethrowLast = either (maybe (error "Rest.Driver.Perform: ExceptT threw Last Nothing, this is a bug") (throwError . OutputError) . getLast) return <=< lift . runExceptT outputMultipart :: Rest m => [BodyPart] -> m UTF8.ByteString outputMultipart vs = - do let boundary = show $ unsafePerformIO (randomIO :: IO UUID) + do let boundary = show $ unsafePerformIO nextRandom setHeader "Content-Type" ("multipart/mixed; boundary=" ++ boundary) return $ showMultipartBody boundary (MultiPart vs) @@ -388,7 +391,7 @@ in (fromQuery ++ fromAccept) where allFormats :: Maybe Format -> [Format] - allFormats ct = (maybe id (:) ct) [minBound .. maxBound] + allFormats ct = maybe id (:) ct [minBound .. maxBound] splitter :: Maybe Format -> String -> [Format] splitter ct hdr = nub (match ct =<< takeWhile (/= ';') . trim <$> splitOn "," hdr) diff --git a/src/Rest/Driver/RestM.hs b/src/Rest/Driver/RestM.hs --- a/src/Rest/Driver/RestM.hs +++ b/src/Rest/Driver/RestM.hs @@ -1,4 +1,10 @@ -{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE + CPP + , GeneralizedNewtypeDeriving + #-} +#if MIN_VERSION_base(4,9,0) +{-# OPTIONS_GHC -Wno-redundant-constraints #-} +#endif module Rest.Driver.RestM ( RestM , runRestM @@ -44,12 +50,15 @@ , responseCode :: Maybe Int } deriving Show -instance Monoid RestOutput where - mempty = RestOutput { headersSet = H.empty, responseCode = Nothing } - o1 `mappend` o2 = RestOutput +instance Semigroup RestOutput where + o1 <> o2 = RestOutput { headersSet = headersSet o2 `H.union` headersSet o1 , responseCode = responseCode o2 <|> responseCode o1 } + +instance Monoid RestOutput where + mempty = RestOutput { headersSet = H.empty, responseCode = Nothing } + mappend = (<>) outputHeader :: String -> String -> RestOutput outputHeader h v = mempty { headersSet = H.singleton h v } diff --git a/src/Rest/Driver/Routing/Internal.hs b/src/Rest/Driver/Routing/Internal.hs --- a/src/Rest/Driver/Routing/Internal.hs +++ b/src/Rest/Driver/Routing/Internal.hs @@ -1,5 +1,5 @@ {-# LANGUAGE - DeriveDataTypeable + CPP , ExistentialQuantification , FlexibleContexts , GADTs @@ -7,9 +7,12 @@ , NamedFieldPuns , RankNTypes , ScopedTypeVariables - , StandaloneDeriving , TupleSections #-} +#if MIN_VERSION_base(4,9,0) +{-# OPTIONS_GHC -Wno-redundant-constraints #-} +#endif + module Rest.Driver.Routing.Internal where import Prelude hiding (id, (.)) @@ -51,6 +54,8 @@ import qualified Rest.Driver.RestM as Rest +{-# ANN module "HLint: ignore Reduce duplication" #-} + type UriParts = [String] apiError :: (MonadError (Reason e) m) => Reason e -> m a @@ -76,11 +81,11 @@ . unRouter route :: (Applicative m, Monad m) => Maybe Method -> UriParts -> Rest.Api m -> Either Reason_ (RunnableHandler m) -route mtd uri = routeWith defaultConfig mtd uri +route = routeWith defaultConfig 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 +routeWith cfg (Just mtd) uri api = runRouter cfg mtd uri $ case api of Rest.Unversioned (Some1 router) -> routeRoot router Rest.Versioned vrs -> do @@ -102,7 +107,7 @@ return (RunnableHandler id (mkMultiGetHandler cfg root)) routeRouter :: Rest.Router m s -> Router n (RunnableHandler m) -routeRouter (Rest.Embed resource@(Rest.Resource { Rest.schema }) subRouters) = +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 @@ -114,7 +119,7 @@ -> [Some1 (Rest.Router s)] -> Maybe (Rest.Cardinality sid mid) -> MaybeT (Router n) (RunnableHandler m) -routeToplevel resource@(Rest.Resource { Rest.list }) subRouters mToplevel = +routeToplevel resource@Rest.Resource { Rest.list } subRouters mToplevel = hoistMaybe mToplevel >>= \toplevel -> case toplevel of Rest.Single sid -> lift $ withSubresource sid resource subRouters @@ -124,7 +129,7 @@ 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 >> +routeCreate Rest.Resource { Rest.create } = guardNullPath >> guardMethod POST >> maybe (apiError UnsupportedRoute) (return . RunnableHandler id) create routeStep :: Rest.Resource m s sid mid aid @@ -143,7 +148,7 @@ -> [Some1 (Rest.Router s)] -> Rest.Endpoint sid mid aid -> Router n (RunnableHandler m) -routeNamed resource@(Rest.Resource { Rest.list, Rest.statics }) subRouters h = +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 @@ -153,10 +158,10 @@ -> [Some1 (Rest.Router s)] -> Rest.Cardinality (Rest.Id sid) (Rest.Id mid) -> Router n (RunnableHandler m) -routeUnnamed resource@(Rest.Resource { Rest.list }) subRouters cardinality = +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.Single sBy -> withSegment (multi resource sBy) $ + parseIdent sBy >=> \sid -> withSubresource sid resource subRouters Rest.Many mBy -> do seg <- popSegment mid <- parseIdent mBy seg @@ -171,13 +176,13 @@ routeGetter getter resource subRouters = case getter of Rest.Singleton sid -> getOrDeep sid - Rest.By sBy -> withSegment (multi resource sBy) $ \seg -> - parseIdent sBy seg >>= getOrDeep + Rest.By sBy -> withSegment (multi resource sBy) $ + parseIdent sBy >=> 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 = +multi Rest.Resource { Rest.update, Rest.remove, Rest.enter } sBy = asks method >>= \mtd -> case mtd of PUT -> handleOrNotFound update @@ -206,7 +211,7 @@ -> 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 = +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) @@ -220,7 +225,7 @@ 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 }) = +routeSingle sid Rest.Resource { Rest.enter, Rest.get, Rest.update, Rest.remove } = asks method >>= \mtd -> case mtd of GET -> handleOrNotFound get @@ -231,7 +236,7 @@ handleOrNotFound = maybe (apiError UnsupportedRoute) (return . RunnableHandler (enter sid)) routeName :: String -> Router n () -routeName ident = when (not . null $ ident) $ +routeName ident = unless (null ident) $ do identStr <- popSegment when (identStr /= ident) $ apiError UnsupportedRoute @@ -287,9 +292,8 @@ hasMethod :: Method -> Router n () hasMethod wantedMethod = asks method >>= \mtd -> - if mtd == wantedMethod - then return () - else apiError UnsupportedMethod + unless (mtd == wantedMethod) $ + apiError UnsupportedMethod guardMethod :: (MonadPlus m, MonadReader (RouterData c) m) => Method -> m () guardMethod mtd = asks method >>= guard . (== mtd) @@ -322,7 +326,7 @@ 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 +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) @@ -342,8 +346,8 @@ 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.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) 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 @@ -27,7 +27,7 @@ mapHandler :: Run m n -> RunnableHandler m -> RunnableHandler n mapHandler run (RunnableHandler run' h) = RunnableHandler (run . run') h -data Config m +newtype Config m = Config { runMultiResources :: forall s. Config m -> Router m s -> [Resource] -> ExceptT Reason_ m [BodyPart] } diff --git a/src/Rest/Error.hs b/src/Rest/Error.hs --- a/src/Rest/Error.hs +++ b/src/Rest/Error.hs @@ -1,8 +1,12 @@ {-# LANGUAGE - FlexibleContexts + CPP + , FlexibleContexts , GADTs , NoImplicitPrelude #-} +#if MIN_VERSION_base(4,9,0) +{-# OPTIONS_GHC -Wno-redundant-constraints #-} +#endif -- | Error types that can be returned by handlers, as well as some -- utilities for manipulating these errors. module Rest.Error diff --git a/src/Rest/Handler.hs b/src/Rest/Handler.hs --- a/src/Rest/Handler.hs +++ b/src/Rest/Handler.hs @@ -1,5 +1,6 @@ {-# LANGUAGE - DataKinds + CPP + , DataKinds , DeriveDataTypeable , GADTs , KindSignatures @@ -7,6 +8,9 @@ , TupleSections , TypeFamilies #-} +#if MIN_VERSION_base(4,9,0) +{-# OPTIONS_GHC -Wno-redundant-constraints #-} +#endif -- | Handlers for endpoints in a 'Resource'. module Rest.Handler ( -- * Single handlers. diff --git a/src/Rest/Resource.hs b/src/Rest/Resource.hs --- a/src/Rest/Resource.hs +++ b/src/Rest/Resource.hs @@ -1,5 +1,6 @@ {-# LANGUAGE - FlexibleContexts + CPP + , FlexibleContexts , FlexibleInstances , GADTs , KindSignatures @@ -7,9 +8,11 @@ , NamedFieldPuns , NoImplicitPrelude , RankNTypes - , TemplateHaskell , TypeSynonymInstances #-} +#if MIN_VERSION_base(4,9,0) +{-# OPTIONS_GHC -Wno-redundant-constraints #-} +#endif -- | A 'Resource' type for representing a REST resource, as well as -- smart constructors for empty resources which can then be filled in -- using record updates. diff --git a/src/Rest/Run.hs b/src/Rest/Run.hs --- a/src/Rest/Run.hs +++ b/src/Rest/Run.hs @@ -1,7 +1,11 @@ {-# LANGUAGE - NoImplicitPrelude + CPP + , NoImplicitPrelude , RankNTypes #-} +#if MIN_VERSION_base(4,9,0) +{-# OPTIONS_GHC -Wno-redundant-constraints #-} +#endif module Rest.Run ( apiToHandler , apiToHandler' @@ -23,7 +27,7 @@ apiToHandler = apiToHandler' id apiToHandler' :: (Applicative m, Monad m) => Rest n => Run m n -> Api m -> n UTF8.ByteString -apiToHandler' run = apiToHandlerWith I.defaultConfig run +apiToHandler' = apiToHandlerWith I.defaultConfig apiToHandlerWith :: Config m -> Rest n => Run m n -> Api m -> n UTF8.ByteString apiToHandlerWith cfg run api = do diff --git a/src/Rest/Schema.hs b/src/Rest/Schema.hs --- a/src/Rest/Schema.hs +++ b/src/Rest/Schema.hs @@ -82,7 +82,7 @@ -- | A single resource endpoint with an identifier that can be read. -singleRead :: (Show a, Read a, Info a) => (a -> sid) -> Endpoint sid mid aid +singleRead :: (Read a, Info a) => (a -> sid) -> Endpoint sid mid aid singleRead = singleIdent ReadId -- | A single resource identified as specified by the 'Ident'. @@ -102,7 +102,7 @@ -- | A listing with an identifier that can be read. -listingRead :: (Show a, Read a, Info a) => (a -> mid) -> Endpoint sid mid aid +listingRead :: (Read a, Info a) => (a -> mid) -> Endpoint sid mid aid listingRead = listingIdent ReadId -- | A listing identified as specified by the 'Ident'. @@ -118,7 +118,7 @@ -- | An unnamed single resource with an identifier that can be read. -unnamedSingleRead :: (Show a, Read a, Info a) => (a -> sid) -> Step sid mid aid +unnamedSingleRead :: (Read a, Info a) => (a -> sid) -> Step sid mid aid unnamedSingleRead = unnamedSingleIdent ReadId -- | An unnamed single resource identified as specified by the @@ -133,7 +133,7 @@ unnamedListing = unnamedListingIdent StringId -- | An unnamed listing with an identifier that can be read. -unnamedListingRead :: (Show a, Read a, Info a) => (a -> mid) -> Step sid mid aid +unnamedListingRead :: (Read a, Info a) => (a -> mid) -> Step sid mid aid unnamedListingRead = unnamedListingIdent ReadId -- | An unnamed listing identified as specified by the 'Ident'. diff --git a/tests/Runner.hs b/tests/Runner.hs --- a/tests/Runner.hs +++ b/tests/Runner.hs @@ -1,32 +1,38 @@ {-# LANGUAGE - OverloadedStrings + CPP + , OverloadedStrings + , RankNTypes , ScopedTypeVariables #-} - -import Control.Applicative +#if MIN_VERSION_base(4,9,0) +{-# OPTIONS_GHC -Wno-redundant-constraints #-} +#endif import Control.Monad +import Control.Monad.Except +import Control.Monad.Identity import Control.Monad.Reader +import Data.Aeson import Data.Monoid import Test.Framework (defaultMain) import Test.Framework.Providers.HUnit (testCase) import Test.HUnit (Assertion, assertEqual, assertFailure) - -import qualified Data.HashMap.Strict as H +import qualified Data.HashMap.Strict as H +import Rest hiding (input) import Rest.Api hiding (route) -import Rest.Dictionary +import Rest.Dictionary (Format (..), Ident (..)) import Rest.Driver.Perform (accept) -import Rest.Driver.RestM (runRestM_) import Rest.Driver.Routing import Rest.Driver.Types -import Rest.Handler import Rest.Resource -import Rest.Schema import qualified Rest.Api as Rest -import qualified Rest.Driver.RestM as RestM +import qualified Rest.Container as C +import qualified Rest.Driver.RestM as RM +import qualified Rest.Resource as Res +import qualified Rest.Run as Run main :: IO () -main = do +main = defaultMain [ testCase "Top level listing." testListing , testCase "Top level listing (trailing slash)." testListingTrailingSlash , testCase "Top level singleton." testToplevelSingleton @@ -44,21 +50,19 @@ , testCase "Multi-PUT." testMultiPut , testCase "Multi-POST" testMultiPost , testCase "Accept headers." testAcceptHeaders + , testCase "Test listing count" testListingCount ] -testListing :: Assertion -testListing = checkRoute GET "resource" (Rest.root -/ Rest.route resource) +listResource :: Resource IO IO Void () Void +listResource = mkResourceId { name = "resource", schema = Schema (Just (Many ())) (Named []), list = listHandler } where - resource :: Resource IO IO Void () Void - resource = mkResourceId { name = "resource", schema = Schema (Just (Many ())) (Named []), list = listHandler } listHandler () = mkListing id $ \_ -> return [] +testListing :: Assertion +testListing = checkRoute GET "resource" (Rest.root -/ Rest.route listResource) + testListingTrailingSlash :: Assertion -testListingTrailingSlash = checkRoute GET "resource/" (Rest.root -/ Rest.route resource) - where - resource :: Resource IO IO Void () Void - resource = mkResourceId { name = "resource", schema = Schema (Just (Many ())) (Named []), list = listHandler } - listHandler () = mkListing id $ \_ -> return [] +testListingTrailingSlash = checkRoute GET "resource/" (Rest.root -/ Rest.route listResource) testToplevelSingleton :: Assertion testToplevelSingleton = checkSingleRoute "resource" resource handler_ @@ -159,7 +163,7 @@ resource = mkResourceReader { name = "resource" , schema = Schema Nothing (Named [("foo", Right (Single (By (Id StringId id))))]) - , update = Just (mkConstHandler xmlJsonO (liftM void ask)) + , update = Just (mkConstHandler xmlJsonO (fmap void ask)) } testMultiPost :: Assertion @@ -181,7 +185,7 @@ checkRoutes :: (Applicative m, Monad m) => [(Method, Uri)] -> Rest.Router m s -> Assertion checkRoutes reqs router = - do forM_ reqs $ uncurry $ checkRouteWithIgnoredMethods (map fst reqs) router + forM_ reqs $ uncurry $ checkRouteWithIgnoredMethods (map fst reqs) router checkRouteWithIgnoredMethods :: (Applicative m, Monad m) => [Method] -> Rest.Router m s -> Method -> Uri -> Assertion checkRouteWithIgnoredMethods ignoredMethods router method uri = @@ -208,3 +212,31 @@ testAcceptHeaders = do let fmt = accept (Just "text/json") Nothing Nothing assertEqual "Accept json format." [JsonFormat] fmt + +testListingCount :: Assertion +testListingCount = assertEqual "listing count" (Right $ C.List 0 5 [1..5::Int]) (eitherDecode bs) + where + (bs, _meta) = runIdentity . RM.runRestM input $ Run.apiToHandler api + input :: RM.RestInput + input = RM.emptyInput + { RM.parameters = H.fromList [("count", "5")] + , RM.paths = splitUriString "resource" + , RM.headers = H.fromList + [ ("Accept" , "application/json") + , ("Content-Type", "application/json") + ] + } + api :: Api (RM.RestM Identity) + api = Unversioned (Some1 $ Rest.root -/ Rest.route resource) + resource :: Resource (RM.RestM Identity) (RM.RestM Identity) String () Void + resource = mkResourceId + { Res.name = "resource" + , Res.schema = withListing () $ named [] + , Res.list = const listHandler + } + where + listHandler :: ListHandler (RM.RestM Identity) + listHandler = mkListing jsonO h + where + h :: Range -> ExceptT Reason_ (RM.RestM Identity) [Int] + h _rng = return [1..10]