This commit is contained in:
Michael Snoyman 2009-10-05 06:23:10 +02:00
parent 45bd3dca66
commit 1a997621e8
7 changed files with 41 additions and 44 deletions

View File

@ -73,12 +73,12 @@ class ResourceName a b => RestfulApp a b | a -> b where
errorHandler _ _ (InternalError e) =
reps $ toObject $ "Internal server error: " ++ e
errorHandler _ _ (InvalidArgs ia) =
reps $ toObject $
reps $ toObject
[ ("errorMsg", toObject "Invalid arguments")
, ("messages", toObject ia)
]
errorHandler _ _ PermissionDenied =
reps $ toObject $ "Permission denied"
reps $ toObject "Permission denied"
-- | Given a sample resource name (purely for typing reasons), generating
-- a Hack application.

View File

@ -1,6 +1,5 @@
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE TypeSynonymInstances #-}
---------------------------------------------------------
@ -77,7 +76,7 @@ chooseRep :: Monad m
-> [ContentType]
-> m (ContentType, B.ByteString)
chooseRep rs cs
| length rs == 0 = fail "All reps must have at least one value"
| null rs = fail "All reps must have at least one representation"
| otherwise = do
let availCs = map fst rs
case filter (`elem` availCs) cs of
@ -137,7 +136,7 @@ addCookie :: Monad m
-> String -- ^ key
-> String -- ^ value
-> HandlerT m ()
addCookie a b c = addHeader $ AddCookie a b c
addCookie a b = addHeader . AddCookie a b
-- | Unset the cookie on the client.
deleteCookie :: Monad m => String -> HandlerT m ()
@ -145,7 +144,7 @@ deleteCookie = addHeader . DeleteCookie
-- | Set an arbitrary header on the client.
header :: Monad m => String -> String -> HandlerT m ()
header a b = addHeader $ Header a b
header a = addHeader . Header a
addHeader :: Monad m => Header -> HandlerT m ()
addHeader h = HandlerT (const $ return (Right (), [h]))

View File

@ -42,13 +42,13 @@ data AuthResource =
instance Enumerable AuthResource where
enumerate =
Check
: Logout
: Openid
: OpenidForward
: OpenidComplete
: LoginRpxnow
: []
[ Check
, Logout
, Openid
, OpenidForward
, OpenidComplete
, LoginRpxnow
]
type RpxnowApiKey = String -- FIXME newtype
instance ResourceName AuthResource (Maybe RpxnowApiKey) where

View File

@ -1,7 +1,6 @@
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE TypeSynonymInstances #-}
{-# LANGUAGE OverlappingInstances #-}
{-# LANGUAGE StandaloneDeriving #-}
---------------------------------------------------------
--
-- Module : Web.Restful.Request
@ -254,7 +253,7 @@ cookies rr name = map snd . filter (fst `equals` name) . rawCookies $ rr
instance Parameter a => Parameter (Maybe a) where
readParams [] = Right Nothing
readParams [x] = readParam x >>= return . Just
readParams [x] = Just `fmap` readParam x
readParams xs = Left $ "Given " ++ show (length xs) ++
" values, expecting 0 or 1"

View File

@ -31,6 +31,7 @@ import Web.Restful.Definitions
import Web.Restful.Handler
import Data.List (intercalate)
import Data.Enumerable
import Control.Monad (replicateM)
import Test.Framework (testGroup, Test)
import Test.Framework.Providers.HUnit
@ -82,14 +83,14 @@ type SMap = [(String, String)]
data CheckPatternReturn = StaticMatch | DynamicMatch (String, String) | NoMatch
checkPattern :: ResourcePattern -> Resource -> Maybe SMap
checkPattern rp r = checkPattern'' (unRP rp) r
checkPattern = checkPatternPieces . unRP
checkPattern'' :: [ResourcePatternPiece] -> Resource -> Maybe SMap
checkPattern'' rp r
| length rp /= 0 && isSlurp (last rp) = do
checkPatternPieces :: [ResourcePatternPiece] -> Resource -> Maybe SMap
checkPatternPieces rp r
| not (null rp) && isSlurp (last rp) = do
let rp' = init rp
(r1, r2) = splitAt (length rp') r
smap <- checkPattern'' rp' r1
smap <- checkPatternPieces rp' r1
let slurpValue = intercalate "/" r2
Slurp slurpKey = last rp
return $ (slurpKey, slurpValue) : smap
@ -133,35 +134,33 @@ validatePatterns (x:xs) =
validatePatterns' :: ResourcePattern
-> ResourcePattern
-> [(ResourcePattern, ResourcePattern)]
validatePatterns' a b =
if overlaps (unRP a) (unRP b)
then [(a, b)]
else []
validatePatterns' a b = [(a, b) | overlaps (unRP a) (unRP b)]
---- Testing
testSuite :: Test
testSuite = testGroup "Web.Restful.Resource"
[ testCase "non-overlap" case_overlap1
, testCase "overlap" case_overlap2
, testCase "overlap-slurp" case_overlap3
, testCase "validatePatterns" case_validatePatterns
[ testCase "non-overlap" caseOverlap1
, testCase "overlap" caseOverlap2
, testCase "overlap-slurp" caseOverlap3
, testCase "validatePatterns" caseValidatePatterns
, testProperty "show pattern" prop_showPattern
]
case_overlap1 :: Assertion
case_overlap1 = assert $ not $ overlaps
caseOverlap1 :: Assertion
caseOverlap1 = assert $ not $ overlaps
(unRP $ fromString "/foo/$bar/")
(unRP $ fromString "/foo/baz/$bin")
case_overlap2 :: Assertion
case_overlap2 = assert $ overlaps
caseOverlap2 :: Assertion
caseOverlap2 = assert $ overlaps
(unRP $ fromString "/foo/bar")
(unRP $ fromString "/foo/$baz")
case_overlap3 :: Assertion
case_overlap3 = assert $ overlaps
caseOverlap3 :: Assertion
caseOverlap3 = assert $ overlaps
(unRP $ fromString "/foo/bar/baz/$bin")
(unRP $ fromString "*slurp")
case_validatePatterns :: Assertion
case_validatePatterns =
caseValidatePatterns :: Assertion
caseValidatePatterns =
let p1 = fromString "/foo/bar/baz"
p2 = fromString "/foo/$bar/baz"
p3 = fromString "/bin"
@ -179,6 +178,6 @@ instance Arbitrary ResourcePatternPiece where
arbitrary = do
constr <- elements [Static, Dynamic, Slurp]
size <- elements [1..10]
s <- sequence (replicate size $ elements ['a'..'z'])
s <- replicateM size $ elements ['a'..'z']
return $ constr s
coarbitrary = undefined

View File

@ -62,7 +62,7 @@ instance Show SitemapResponse where
prefix = "http://" ++ host ++
case port of
80 -> ""
_ -> ":" ++ show port
_ -> ':' : show port
helper (SitemapUrl loc modTime freq pri) = concat
[ "<url><loc>"
, encodeHtml $ showLoc loc

View File

@ -41,12 +41,12 @@ tryLookup def key = fromMaybe def . lookup key
----- Testing
testSuite :: Test
testSuite = testGroup "Web.Restful.Response"
[ testCase "tryLookup1" test_tryLookup1
, testCase "tryLookup2" test_tryLookup2
[ testCase "tryLookup1" caseTryLookup1
, testCase "tryLookup2" caseTryLookup2
]
test_tryLookup1 :: Assertion
test_tryLookup1 = tryLookup "default" "foo" [] @?= "default"
caseTryLookup1 :: Assertion
caseTryLookup1 = tryLookup "default" "foo" [] @?= "default"
test_tryLookup2 :: Assertion
test_tryLookup2 = tryLookup "default" "foo" [("foo", "baz")] @?= "baz"
caseTryLookup2 :: Assertion
caseTryLookup2 = tryLookup "default" "foo" [("foo", "baz")] @?= "baz"