diff --git a/Yesod/Handler.hs b/Yesod/Handler.hs index b28c374c..2ba325a6 100644 --- a/Yesod/Handler.hs +++ b/Yesod/Handler.hs @@ -1,7 +1,7 @@ {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE TypeSynonymInstances #-} -- FIXME remove +{-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE PackageImports #-} --------------------------------------------------------- @@ -105,7 +105,6 @@ runHandler (Handler handler) eh rr y cts = do HCContent a -> Right a case contents' of Left e -> do - -- FIXME doesn't look right Response _ hs ct c <- runHandler (eh e) specialEh rr y cts let hs' = headers ++ hs ++ getHeaders e return $ Response (getStatus e) hs' ct c @@ -117,84 +116,6 @@ specialEh :: ErrorResult -> Handler yesod RepChooser specialEh er = do liftIO $ hPutStrLn stderr $ "Error handler errored out: " ++ show er return $ chooseRep $ toHtmlObject "Internal server error" -{- FIXME -class ToHandler a where - toHandler :: a -> Handler - -instance (Request r, ToHandler h) => ToHandler (r -> h) where - toHandler f = parseRequest >>= toHandler . f - -instance ToHandler Handler where - toHandler = id - -instance HasReps r HandlerIO => ToHandler (HandlerIO r) where - toHandler = fmap reps - -runHandler :: Handler - -> RawRequest - -> [ContentType] - -> IO (Either (ErrorResult, [Header]) Response) -runHandler h rr cts = do - --let (ares, _FIXMEheaders) = - let x :: IO (Attempt (ContentType, Content), [Header]) - x = - runWriterT $ runAttemptT $ runReaderT (joinHandler cts h) rr - y :: IO (Attempt (Attempt (ContentType, Content), [Header])) - y = takeAllExceptions x - z <- y - let z' :: Attempt (Attempt (ContentType, Content), [Header]) - z' = z - a :: (Attempt (ContentType, Content), [Header]) - a = attempt (\e -> (failure e, [])) id z' - (b, headers) = a - return $ attempt (\e -> (Left (toErrorResult e, headers))) (Right . toResponse headers) b - where - takeAllExceptions :: MonadFailure SomeException m => IO x -> IO (m x) - takeAllExceptions ioa = - Control.Exception.catch (return `fmap` ioa) (\e -> return $ failure (e :: SomeException)) - toErrorResult :: Exception e => e -> ErrorResult - toErrorResult e = - case cast e of - Just x -> x - Nothing -> InternalError $ show e - toResponse :: [Header] -> (ContentType, Content) -> Response - toResponse hs (ct, c) = Response 200 hs ct c - -joinHandler :: Monad m - => [ContentType] - -> m [RepT m] - -> m (ContentType, Content) -joinHandler cts rs = do - rs' <- rs - let (ct, c) = chooseRep cts rs' - c' <- c - return (ct, c') --} - -{- -runHandler :: (ErrorResult -> Reps) - -> (ContentType -> B.ByteString -> IO B.ByteString) - -> [ContentType] - -> Handler - -> RawRequest - -> IO Hack.Response -runHandler eh wrapper ctypesAll (HandlerT inside) rr = do - let extraHeaders = - case x of - Left r -> getHeaders r - Right _ -> [] - headers <- mapM toPair (headers' ++ extraHeaders) - let outReps = either (reps . eh) reps x - let statusCode = - case x of - Left r -> getStatus r - Right _ -> 200 - (ctype, selectedRep) <- chooseRep outReps ctypesAll - let languages = [] -- FIXME - finalRep <- wrapper ctype $ selectedRep languages - let headers'' = ("Content-Type", ctype) : headers - return $! Hack.Response statusCode headers'' finalRep --} ------ Special handlers errorResult :: ErrorResult -> Handler yesod a diff --git a/Yesod/Resource.hs b/Yesod/Resource.hs index f0ab2561..8e6e5f7c 100644 --- a/Yesod/Resource.hs +++ b/Yesod/Resource.hs @@ -62,6 +62,7 @@ import Test.Framework.Providers.QuickCheck (testProperty) import Test.HUnit hiding (Test) import Test.QuickCheck import Control.Monad (when) +import Data.Typeable #endif resources :: QuasiQuoter @@ -187,7 +188,7 @@ overlaps (Static a:x) (Static b:y) = a == b && overlaps x y data OverlappingPatterns = OverlappingPatterns [(ResourcePattern, ResourcePattern)] - deriving (Show, Typeable) + deriving (Show, Typeable, Eq) instance Exception OverlappingPatterns getAllPairs :: [x] -> [(x, x)] @@ -394,7 +395,7 @@ testSuite = testGroup "Yesod.Resource" [ testCase "non-overlap" caseOverlap1 , testCase "overlap" caseOverlap2 , testCase "overlap-slurp" caseOverlap3 - -- FIXME, testCase "validatePatterns" caseValidatePatterns + , testCase "checkPatterns" caseCheckPatterns , testProperty "show pattern" prop_showPattern , testCase "integers" caseIntegers , testCase "read patterns from YAML" caseFromYaml @@ -424,19 +425,24 @@ caseOverlap2 = caseOverlap' "/foo/bar" "/foo/$baz" True caseOverlap3 :: Assertion caseOverlap3 = caseOverlap' "/foo/bar/baz/$bin" "*slurp" True -{- FIXME rewrite this test -caseValidatePatterns :: Assertion -caseValidatePatterns = - let p1 = cs "/foo/bar/baz" - p2 = cs "/foo/$bar/baz" - p3 = cs "/bin" - p4 = cs "/bin/boo" - p5 = cs "/bin/*slurp" - in validatePatterns [p1, p2, p3, p4, p5] @?= Just - [ (p1, p2) - , (p4, p5) - ] --} +caseCheckPatterns :: Assertion +caseCheckPatterns = do + let res = checkPatterns [p1, p2, p3, p4, p5] + attempt helper (fail "Did not fail") res + where + p1 = cs "/foo/bar/baz" + p2 = cs "/foo/$bar/baz" + p3 = cs "/bin" + p4 = cs "/bin/boo" + p5 = cs "/bin/*slurp" + expected = OverlappingPatterns + [ (p1, p2) + , (p4, p5) + ] + helper e = case cast e of + Nothing -> fail "Wrong exception" + Just op -> do + expected @=? op prop_showPattern :: RP -> Bool prop_showPattern p = readRP (cs p) == Just p