hlinted
This commit is contained in:
parent
45bd3dca66
commit
1a997621e8
@ -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.
|
||||
|
||||
@ -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]))
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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"
|
||||
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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"
|
||||
|
||||
Loading…
Reference in New Issue
Block a user