Removed bad undefineds

Yesod.hs

@@ -1,3 +1,4 @@
+{-# LANGUAGE TemplateHaskell #-}
 ---------------------------------------------------------
 --
 -- Module        : Yesod

Yesod/Handler.hs

@@ -81,21 +81,28 @@ instance MonadRequestReader (Handler yesod) where
 getYesod :: Handler yesod yesod
 getYesod = Handler $ \(_, yesod) -> return ([], HCContent yesod)
 
--- FIXME this is a stupid signature
-runHandler :: HasReps a
-           => Handler yesod a
+runHandler :: Handler yesod RepChooser
+           -> (ErrorResult -> Handler yesod RepChooser)
            -> RawRequest
            -> yesod
            -> [ContentType]
-           -> IO (Either (ErrorResult, [Header]) Response)
-runHandler (Handler handler) rr yesod cts = do
-    (headers, contents) <- handler (rr, yesod)
-    case contents of
-        HCError e -> return $ Left (InternalError $ show e, headers)
-        HCSpecial e -> return $ Left (e, headers)
-        HCContent a ->
-            let (ct, c) = chooseRep a cts
-             in return $ Right $ Response 200 headers ct c
+           -> IO Response
+runHandler (Handler handler) eh rr y cts = do
+    (headers, contents) <- Control.Exception.catch
+        (handler (rr, y))
+        (\e -> return ([], HCError (e :: Control.Exception.SomeException)))
+    let contents' =
+            case contents of
+                HCError e -> Left $ InternalError $ show e
+                HCSpecial e -> Left e
+                HCContent a -> Right a
+    case contents' of
+        Left e -> do
+            Response _ hs ct c <- runHandler (eh e) eh rr y cts
+            return $ Response (getStatus e) hs ct c
+        Right a ->
+            let (ct, c) = a cts
+             in return $ Response 200 headers ct c
 {- FIXME
 class ToHandler a where
     toHandler :: a -> Handler

Yesod/Resource.hs

@@ -6,6 +6,7 @@
 {-# LANGUAGE StandaloneDeriving #-}
 {-# LANGUAGE DeriveDataTypeable #-}
 {-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE TemplateHaskell #-}
 ---------------------------------------------------------
 --
 -- Module        : Yesod.Resource
@@ -22,8 +23,9 @@
 module Yesod.Resource
     ( ResourcePattern
     , checkPattern
+    , checkPatternsTH
     , validatePatterns
-    , checkResourceName
+    , checkPatterns
 #if TEST
       -- * Testing
     , testSuite
@@ -35,13 +37,16 @@ import Yesod.Definitions
 import Data.List (intercalate)
 import Data.Char (isDigit)
 
+import Control.Monad (when)
+import Language.Haskell.TH
+
 import Data.Typeable (Typeable)
 import Control.Exception (Exception)
 import Data.Attempt -- for failure stuff
 import Data.Convertible.Text
 
 #if TEST
-import Control.Monad (replicateM, when)
+import Control.Monad (replicateM)
 import Test.Framework (testGroup, Test)
 import Test.Framework.Providers.HUnit
 import Test.Framework.Providers.QuickCheck (testProperty)
@@ -93,6 +98,11 @@ data CheckPatternReturn =
 checkPattern :: RP -> Resource -> Maybe SMap
 checkPattern = checkPatternPieces . unRP
 
+checkPatternsTH :: Bool -> [ResourcePattern] -> Q Exp
+checkPatternsTH toCheck patterns = do
+    runIO $ when toCheck $ checkPatterns patterns
+    [|return ()|]
+
 checkPatternPieces :: [RPP] -> Resource -> Maybe SMap
 checkPatternPieces rp r
     | not (null rp) && isSlurp (last rp) = do
@@ -141,10 +151,10 @@ data OverlappingPatterns =
     deriving (Show, Typeable)
 instance Exception OverlappingPatterns
 
-checkResourceName :: MonadFailure OverlappingPatterns f
-                  => [ResourcePattern]
-                  -> f ()
-checkResourceName patterns =
+checkPatterns :: MonadFailure OverlappingPatterns f
+              => [ResourcePattern]
+              -> f ()
+checkPatterns patterns =
     case validatePatterns patterns of
         [] -> return ()
         x -> failure $ OverlappingPatterns x

Yesod/Response.hs

@@ -26,6 +26,8 @@ module Yesod.Response
       -- * Header
     , Header (..)
     , toPair
+      -- * Converting to Hack values
+    , responseToHackResponse
 #if TEST
       -- * Tests
     , testSuite
@@ -41,6 +43,7 @@ import Yesod.Rep
 import Data.Time.Clock
 
 import Web.Encodings (formatW3)
+import qualified Hack
 
 #if TEST
 import Test.Framework (testGroup, Test)
@@ -91,6 +94,15 @@ toPair (DeleteCookie key) = return
      key ++ "=; path=/; expires=Thu, 01-Jan-1970 00:00:00 GMT")
 toPair (Header key value) = return (key, value)
 
+-- FIXME add test
+responseToHackResponse :: [String] -- ^ language list
+                       -> Response -> IO Hack.Response
+responseToHackResponse _FIXMEls (Response sc hs ct c) = do
+    hs' <- mapM toPair hs
+    let hs'' = ("Content-Type", show ct) : hs'
+    let asLBS = unContent c
+    return $ Hack.Response sc hs'' asLBS
+
 #if TEST
 ----- Testing
 testSuite :: Test

Yesod/Yesod.hs

@@ -12,12 +12,13 @@ import Yesod.Constants
 import Yesod.Definitions
 import Yesod.Resource
 import Yesod.Handler
+import Yesod.Utils
 
-import Control.Monad (when)
 import Data.Maybe (fromMaybe)
 import Data.Convertible.Text
 import Web.Encodings
 import Control.Arrow ((***))
+import Control.Monad (when)
 
 import qualified Hack
 import Hack.Middleware.CleanPath
@@ -34,7 +35,7 @@ class Yesod a where
     encryptKey _ = getKey defaultKeyFile
 
     -- | Output error response pages.
-    errorHandler :: ErrorResult -> [ContentType] -> Handler a ContentPair
+    errorHandler :: ErrorResult -> Handler a RepChooser
     errorHandler = defaultErrorHandler
 
     -- | Whether or not we should check for overlapping resource names.
@@ -46,24 +47,23 @@ class Yesod a where
 
 defaultErrorHandler :: Yesod y
                     => ErrorResult
-                    -> [ContentType]
-                    -> Handler y ContentPair
-defaultErrorHandler NotFound cts = do
+                    -> Handler y RepChooser
+defaultErrorHandler NotFound = do
     rr <- askRawRequest
-    return $ chooseRep (toHtmlObject $ "Not found: " ++ show rr) cts
-defaultErrorHandler (Redirect url) cts =
-    return $ chooseRep (toHtmlObject $ "Redirect to: " ++ url) cts
-defaultErrorHandler PermissionDenied cts =
-    return $ chooseRep (toHtmlObject "Permission denied") cts
-defaultErrorHandler (InvalidArgs ia) cts =
-    return $ chooseRep (toHtmlObject
+    return $ chooseRep $ toHtmlObject $ "Not found: " ++ show rr
+defaultErrorHandler (Redirect url) =
+    return $ chooseRep $ toHtmlObject $ "Redirect to: " ++ url
+defaultErrorHandler PermissionDenied =
+    return $ chooseRep $ toHtmlObject "Permission denied"
+defaultErrorHandler (InvalidArgs ia) =
+    return $ chooseRep $ toHtmlObject
             [ ("errorMsg", toHtmlObject "Invalid arguments")
             , ("messages", toHtmlObject ia)
-            ]) cts
-defaultErrorHandler (InternalError e) cts =
-    return $ chooseRep (toHtmlObject
+            ]
+defaultErrorHandler (InternalError e) =
+    return $ chooseRep $ toHtmlObject
                 [ ("Internal server error", e)
-                ]) cts
+                ]
 
 -- | For type signature reasons.
 handlers' :: Yesod y => y ->
@@ -72,8 +72,12 @@ handlers' _ = handlers
 
 toHackApp :: Yesod y => y -> Hack.Application
 toHackApp a env = do
-    let patterns = map fst $ handlers' a
-    when (checkOverlaps a) $ checkResourceName patterns -- FIXME maybe this should be done compile-time?
+    -- FIXME figure out a way to do this check compile-time
+    when (checkOverlaps a) $ checkPatterns $ map fst $ handlers' a
+    toHackAppUnchecked a env
+
+toHackAppUnchecked :: Yesod y => y -> Hack.Application
+toHackAppUnchecked a env = do
     key <- encryptKey a
     let app' = toHackApp' a
         middleware =
@@ -94,27 +98,28 @@ toHackApp' y env = do
             (verbPairs, urlParams'') <- lookupHandlers resource
             let verb = cs $ Hack.requestMethod env
             handler'' <- lookup verb verbPairs
-            return (handler'' types, urlParams'')
+            return (handler'', urlParams'')
         rr = envToRawRequest urlParams' env
-    runHandler' handler rr y
+    res <- runHandler handler errorHandler rr y types
+    let langs = ["en"] -- FIXME
+    responseToHackResponse langs res
 
 httpAccept :: Hack.Env -> [ContentType]
-httpAccept = undefined
+httpAccept = map TypeOther . parseHttpAccept . fromMaybe ""
+           . lookup "Accept" . Hack.http
 
 lookupHandlers :: Yesod y
                => Resource
                -> Maybe
-                  ( [(Verb, [ContentType] -> Handler y ContentPair)]
+                  ( [(Verb, Handler y RepChooser)]
                   , [(ParamName, ParamValue)]
                   )
-lookupHandlers = undefined
-
-runHandler' :: Yesod y
-            => Handler y ContentPair
-            -> RawRequest
-            -> y
-            -> IO Hack.Response
-runHandler' = undefined
+lookupHandlers r = helper handlers where
+    helper [] = Nothing
+    helper ((rps, v):rest) =
+        case checkPattern (cs rps) r of
+            Just up -> Just (v, up)
+            Nothing -> helper rest
 
 envToRawRequest :: [(ParamName, ParamValue)] -> Hack.Env -> RawRequest
 envToRawRequest urlParams' env =

yesod.cabal

@@ -42,7 +42,8 @@ library
                      containers >= 0.2.0.1 && < 0.3,
                      HStringTemplate >= 0.6.2 && < 0.7,
                      data-object-json >= 0.0.0 && < 0.1,
-                     attempt >= 0.2.1 && < 0.3
+                     attempt >= 0.2.1 && < 0.3,
+                     template-haskell
     exposed-modules: Yesod
                      Yesod.Constants
                      Yesod.Rep