From f6221dacc9460c1b480ff76ada875410c662c504 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Thu, 17 Dec 2009 11:20:35 +0200 Subject: [PATCH] Quasi-quoting generates a single function --- Yesod/Handler.hs | 10 +++++++++- Yesod/Resource.hs | 33 ++++++++++++++++++++++++++++++--- Yesod/Response.hs | 2 ++ test/quasi-resource.hs | 37 +++++++++++++++++++++++++++---------- 4 files changed, 68 insertions(+), 14 deletions(-) diff --git a/Yesod/Handler.hs b/Yesod/Handler.hs index 4b997079..e10c81ad 100644 --- a/Yesod/Handler.hs +++ b/Yesod/Handler.hs @@ -42,6 +42,9 @@ import Control.Applicative import Control.Monad.Writer import Control.Monad.Attempt +import System.IO +import Data.Object.Html + --import Data.Typeable ------ Handler monad @@ -98,11 +101,16 @@ runHandler (Handler handler) eh rr y cts = do HCContent a -> Right a case contents' of Left e -> do - Response _ hs ct c <- runHandler (eh e) eh rr y cts + Response _ hs ct c <- runHandler (eh e) specialEh rr y cts return $ Response (getStatus e) hs ct c Right a -> do (ct, c) <- a cts return $ Response 200 headers ct c + +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 diff --git a/Yesod/Resource.hs b/Yesod/Resource.hs index 28806d7e..2ba20f68 100644 --- a/Yesod/Resource.hs +++ b/Yesod/Resource.hs @@ -57,6 +57,7 @@ import Data.Attempt -- for failure stuff import Data.Object.Text import Control.Monad ((<=<)) import Data.Object.Yaml +import Yesod.Handler #if TEST import Control.Monad (replicateM) @@ -107,6 +108,11 @@ data CheckPatternReturn = | DynamicMatch (String, String) | NoMatch +checkPatternBool :: RP -> Resource -> Bool +checkPatternBool rp r = case checkPattern rp r of + Nothing -> False + _ -> True + checkPattern :: RP -> Resource -> Maybe SMap checkPattern = checkPatternPieces . unRP @@ -234,10 +240,30 @@ instance Exception RepeatedVerb rpnodesTHCheck :: [RPNode] -> Q Exp rpnodesTHCheck nodes = do nodes' <- runIO $ checkRPNodes nodes - rpnodesTH nodes' + res <- rpnodesTH nodes' + -- For debugging purposes runIO $ putStrLn $ pprint res + return res + +notFoundVerb :: Verb -> Handler yesod a +notFoundVerb _verb = notFound rpnodesTH :: [RPNode] -> Q Exp -rpnodesTH = fmap ListE . mapM lift +rpnodesTH ns = do + b <- helper ns + nfv <- [|notFoundVerb|] + let b' = b ++ [(NormalG $ VarE $ mkName "otherwise", nfv)] + return $ LamE [VarP $ mkName "resource"] + $ CaseE (TupE []) [Match WildP (GuardedB b') []] + where + helper :: [RPNode] -> Q [(Guard, Exp)] + helper nodes = mapM helper2 nodes + helper2 :: RPNode -> Q (Guard, Exp) + helper2 (RPNode rp vm) = do + rp' <- lift rp + cpb <- [|checkPatternBool|] + let g = cpb `AppE` rp' `AppE` VarE (mkName "resource") + vm' <- lift vm + return (NormalG g, vm') instance Lift RPNode where lift (RPNode rp vm) = do rp' <- lift rp @@ -258,7 +284,8 @@ instance Lift RPP where return $ ConE (mkName "Slurp") `AppE` (LitE $ StringL s) instance Lift VerbMap where lift (AllVerbs s) = - return $ LamE [VarP $ mkName "_FIXMEverb"] $ VarE $ mkName s + return $ LamE [VarP $ mkName "verb"] + $ (VarE $ mkName s) `AppE` (VarE $ mkName "verb") lift (Verbs vs) = return $ LamE [VarP $ mkName "verb"] $ CaseE (VarE $ mkName "verb") diff --git a/Yesod/Response.hs b/Yesod/Response.hs index bf548de0..d5904229 100644 --- a/Yesod/Response.hs +++ b/Yesod/Response.hs @@ -53,6 +53,7 @@ import Data.Generics import Control.Exception (Exception) data Response = Response Int [Header] ContentType Content + deriving Show -- | Abnormal return codes. data ErrorResult = @@ -81,6 +82,7 @@ data Header = AddCookie Int String String | DeleteCookie String | Header String String + deriving (Eq, Show) -- | Convert Header to a key/value pair. toPair :: Header -> IO (String, String) diff --git a/test/quasi-resource.hs b/test/quasi-resource.hs index 44cee4d7..d30f97f7 100644 --- a/test/quasi-resource.hs +++ b/test/quasi-resource.hs @@ -4,29 +4,32 @@ import Yesod import Yesod.Rep +import Data.Object.Html data MyYesod = MyYesod instance Show (Handler MyYesod RepChooser) where show _ = "Another handler" -getStatic :: Handler MyYesod RepChooser -getStatic = undefined +getStatic :: Verb -> Handler MyYesod RepChooser +getStatic v = return $ chooseRep $ toHtmlObject ["getStatic", show v] pageIndex :: Handler MyYesod RepChooser -pageIndex = undefined +pageIndex = return $ chooseRep $ toHtmlObject ["pageIndex"] pageAdd :: Handler MyYesod RepChooser -pageAdd = undefined +pageAdd = return $ chooseRep $ toHtmlObject ["pageAdd"] pageDetail :: Handler MyYesod RepChooser -pageDetail = undefined +pageDetail = return $ chooseRep $ toHtmlObject ["pageDetail"] pageDelete :: Handler MyYesod RepChooser -pageDelete = undefined +pageDelete = return $ chooseRep $ toHtmlObject ["pageDelete"] pageUpdate :: Handler MyYesod RepChooser -pageUpdate = undefined +pageUpdate = return $ chooseRep $ toHtmlObject ["pageUpdate"] userInfo :: Handler MyYesod RepChooser -userInfo = undefined +userInfo = return $ chooseRep $ toHtmlObject ["userInfo"] instance Show (Verb -> Handler MyYesod RepChooser) where show _ = "verb -> handler" -handler :: [(RP, Verb -> Handler MyYesod RepChooser)] +instance Show (Resource -> Verb -> Handler MyYesod RepChooser) where + show _ = "resource -> verb -> handler" +handler :: Resource -> Verb -> Handler MyYesod RepChooser handler = [$rpnodesQuasi| /static/*filepath/: getStatic /page/: @@ -40,6 +43,20 @@ handler = [$rpnodesQuasi| Get: userInfo |] +ph :: Handler MyYesod RepChooser -> IO () +ph h = do + let eh e = return $ chooseRep $ toHtmlObject $ show e + rr = error "No raw request" + y = MyYesod + cts = [TypeHtml] + res <- runHandler h eh rr y cts + print res + main :: IO () main = do - print handler + ph $ handler ["static", "foo", "bar", "baz"] Get + ph $ handler ["foo", "bar", "baz"] Get + ph $ handler ["page"] Get + ph $ handler ["user"] Get + ph $ handler ["user", "five"] Get + ph $ handler ["user", "5"] Get