From b78a16e9383f13fab80f1e2890da81cad63616ae Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Mon, 14 Dec 2009 19:50:16 +0200 Subject: [PATCH] Removed bad undefineds --- Yesod.hs | 1 + Yesod/Handler.hs | 31 +++++++++++++--------- Yesod/Resource.hs | 22 +++++++++++----- Yesod/Response.hs | 12 +++++++++ Yesod/Yesod.hs | 65 +++++++++++++++++++++++++---------------------- yesod.cabal | 3 ++- 6 files changed, 85 insertions(+), 49 deletions(-) diff --git a/Yesod.hs b/Yesod.hs index 124c83d4..6d492102 100644 --- a/Yesod.hs +++ b/Yesod.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE TemplateHaskell #-} --------------------------------------------------------- -- -- Module : Yesod diff --git a/Yesod/Handler.hs b/Yesod/Handler.hs index 0d5ffc93..0d801a5b 100644 --- a/Yesod/Handler.hs +++ b/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 diff --git a/Yesod/Resource.hs b/Yesod/Resource.hs index 455c6c09..f339357b 100644 --- a/Yesod/Resource.hs +++ b/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 diff --git a/Yesod/Response.hs b/Yesod/Response.hs index f4232ead..bf548de0 100644 --- a/Yesod/Response.hs +++ b/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 diff --git a/Yesod/Yesod.hs b/Yesod/Yesod.hs index 7321fcae..b794b74f 100644 --- a/Yesod/Yesod.hs +++ b/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 = diff --git a/yesod.cabal b/yesod.cabal index 3bff64b1..705a419e 100644 --- a/yesod.cabal +++ b/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