Fixed some FIXMEs

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

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