diff --git a/Yesod/Definitions.hs b/Yesod/Definitions.hs index 1604c908..6c7238f1 100644 --- a/Yesod/Definitions.hs +++ b/Yesod/Definitions.hs @@ -15,8 +15,7 @@ -- --------------------------------------------------------- module Yesod.Definitions - ( Verb (..) - , Resource + ( Resource , Approot , Language , Location (..) @@ -30,34 +29,8 @@ module Yesod.Definitions , destCookieTimeout ) where -import qualified Network.Wai as W -import Data.Convertible.Text -import Control.Exception (Exception) -import Data.Typeable (Typeable) -import Language.Haskell.TH.Syntax import Data.ByteString.Char8 (pack, ByteString) --- FIXME replace with Method? -data Verb = Get | Put | Delete | Post - deriving (Eq, Show, Enum, Bounded) -instance Lift Verb where - lift = return . ConE . mkName . show -instance ConvertAttempt String Verb where - convertAttempt "Get" = return Get - convertAttempt "Put" = return Put - convertAttempt "Delete" = return Delete - convertAttempt "Post" = return Post - convertAttempt s = failure $ InvalidVerb s -newtype InvalidVerb = InvalidVerb String - deriving (Show, Typeable) -instance Exception InvalidVerb - -instance ConvertSuccess W.Method Verb where - convertSuccess W.PUT = Put - convertSuccess W.DELETE = Delete - convertSuccess W.POST = Post - convertSuccess _ = Get - type Resource = [String] -- | An absolute URL to the base of this application. This can almost be done diff --git a/Yesod/Helpers/Auth.hs b/Yesod/Helpers/Auth.hs index 130ec0f3..9304216e 100644 --- a/Yesod/Helpers/Auth.hs +++ b/Yesod/Helpers/Auth.hs @@ -32,7 +32,7 @@ import Control.Monad.Attempt import qualified Data.ByteString.Char8 as B8 import Data.Maybe (fromMaybe) -import qualified Network.Wai +import qualified Network.Wai as W import Data.Typeable (Typeable) import Control.Exception (Exception) @@ -73,13 +73,12 @@ data AuthResource = rc :: HasReps x => Handler y x -> Handler y ChooseRep rc = fmap chooseRep -authHandler :: YesodAuth y => - Verb -> [String] -> Handler y ChooseRep -authHandler Get ["check"] = rc authCheck -authHandler Get ["logout"] = rc authLogout -authHandler Get ["openid"] = rc authOpenidForm -authHandler Get ["openid", "forward"] = rc authOpenidForward -authHandler Get ["openid", "complete"] = rc authOpenidComplete +authHandler :: YesodAuth y => W.Method -> [String] -> Handler y ChooseRep +authHandler W.GET ["check"] = rc authCheck +authHandler W.GET ["logout"] = rc authLogout +authHandler W.GET ["openid"] = rc authOpenidForm +authHandler W.GET ["openid", "forward"] = rc authOpenidForward +authHandler W.GET ["openid", "complete"] = rc authOpenidComplete -- two different versions of RPX protocol apparently, so just accepting all -- verbs authHandler _ ["login", "rpxnow"] = rc rpxnowLogin @@ -225,11 +224,11 @@ redirectLogin = requestPath :: (Functor m, Monad m, RequestReader m) => m String requestPath = do env <- waiRequest - let q = case B8.unpack $ Network.Wai.queryString env of + let q = case B8.unpack $ W.queryString env of "" -> "" q'@('?':_) -> q' q' -> '?' : q' - return $! dropSlash (B8.unpack $ Network.Wai.pathInfo env) ++ q + return $! dropSlash (B8.unpack $ W.pathInfo env) ++ q where dropSlash ('/':x) = x dropSlash x = x diff --git a/Yesod/Helpers/Static.hs b/Yesod/Helpers/Static.hs index 02ccb14d..c48d9514 100644 --- a/Yesod/Helpers/Static.hs +++ b/Yesod/Helpers/Static.hs @@ -27,6 +27,7 @@ import Control.Monad import Yesod import Data.List (intercalate) +import Network.Wai (Method (GET)) type FileLookup = FilePath -> IO (Maybe (Either FilePath Content)) @@ -44,9 +45,9 @@ fileLookupDir dir fp = do then return $ Just $ Left fp' else return Nothing -serveStatic :: FileLookup -> Verb -> [String] +serveStatic :: FileLookup -> Method -> [String] -> Handler y [(ContentType, Content)] -serveStatic fl Get fp = getStatic fl fp +serveStatic fl GET fp = getStatic fl fp serveStatic _ _ _ = notFound getStatic :: FileLookup -> [String] -> Handler y [(ContentType, Content)] diff --git a/Yesod/Resource.hs b/Yesod/Resource.hs index 4e8ae0e6..fc30cb27 100644 --- a/Yesod/Resource.hs +++ b/Yesod/Resource.hs @@ -38,6 +38,7 @@ import Data.Char (isDigit) import Language.Haskell.TH.Syntax import Language.Haskell.TH.Quote +import Network.Wai (Method (..), methodFromBS, methodToBS) {- Debugging import Language.Haskell.TH.Ppr import System.IO @@ -53,6 +54,7 @@ import Yesod.Handler import Data.Maybe (fromJust) import Yesod.Response (chooseRep) import Control.Arrow +import Data.ByteString (ByteString) #if TEST import Control.Monad (replicateM) @@ -212,9 +214,9 @@ checkPatterns rpss = do | overlaps x y = [(a, b)] | otherwise = [] -data RPNode = RPNode RP VerbMap +data RPNode = RPNode RP MethodMap deriving (Show, Eq) -data VerbMap = AllVerbs String | Verbs [(Verb, String)] +data MethodMap = AllMethods String | Methods [(Method, String)] deriving (Show, Eq) instance ConvertAttempt TextObject [RPNode] where convertAttempt = mapM helper <=< fromMapping where @@ -223,40 +225,38 @@ instance ConvertAttempt TextObject [RPNode] where verbMap <- fromTextObject rest rp' <- readRP $ cs rp return $ RPNode rp' verbMap -instance ConvertAttempt TextObject VerbMap where - convertAttempt (Scalar s) = return $ AllVerbs $ cs s - convertAttempt (Mapping m) = Verbs `fmap` mapM helper m where - helper :: (Text, TextObject) -> Attempt (Verb, String) - helper (v, Scalar f) = do - v' <- ca (cs v :: String) - return (v', cs f) - helper (_, x) = failure $ VerbMapNonScalar x - convertAttempt o = failure $ VerbMapSequence o -data RPNodeException = VerbMapNonScalar TextObject - | VerbMapSequence TextObject +instance ConvertAttempt TextObject MethodMap where + convertAttempt (Scalar s) = return $ AllMethods $ cs s + convertAttempt (Mapping m) = Methods `fmap` mapM helper m where + helper :: (Text, TextObject) -> Attempt (Method, String) + helper (v, Scalar f) = return (methodFromBS $ cs v, cs f) + helper (_, x) = failure $ MethodMapNonScalar x + convertAttempt o = failure $ MethodMapSequence o +data RPNodeException = MethodMapNonScalar TextObject + | MethodMapSequence TextObject deriving (Show, Typeable) instance Exception RPNodeException checkRPNodes :: (MonadFailure OverlappingPatterns m, - MonadFailure RepeatedVerb m, + MonadFailure RepeatedMethod m, MonadFailure InvalidResourcePattern m ) => [RPNode] -> m [RPNode] checkRPNodes nodes = do _ <- checkPatterns $ map (\(RPNode r _) -> cs r) nodes - mapM_ (\(RPNode _ v) -> checkVerbMap v) nodes + mapM_ (\(RPNode _ v) -> checkMethodMap v) nodes return nodes where - checkVerbMap (AllVerbs _) = return () - checkVerbMap (Verbs vs) = + checkMethodMap (AllMethods _) = return () + checkMethodMap (Methods vs) = let vs' = map fst vs res = nub vs' == vs' - in unless res $ failure $ RepeatedVerb vs + in unless res $ failure $ RepeatedMethod vs -newtype RepeatedVerb = RepeatedVerb [(Verb, String)] +newtype RepeatedMethod = RepeatedMethod [(Method, String)] deriving (Show, Typeable) -instance Exception RepeatedVerb +instance Exception RepeatedMethod rpnodesTHCheck :: [RPNode] -> Q Exp rpnodesTHCheck nodes = do @@ -267,13 +267,13 @@ rpnodesTHCheck nodes = do -} rpnodesTH nodes' -notFoundVerb :: Verb -> Handler yesod a -notFoundVerb _verb = notFound +notFoundMethod :: Method -> Handler yesod a +notFoundMethod _verb = notFound rpnodesTH :: [RPNode] -> Q Exp rpnodesTH ns = do b <- mapM helper ns - nfv <- [|notFoundVerb|] + nfv <- [|notFoundMethod|] ow <- [|otherwise|] let b' = b ++ [(NormalG ow, nfv)] return $ LamE [VarP $ mkName "resource"] @@ -285,7 +285,7 @@ rpnodesTH ns = do cpb <- [|doesPatternMatch|] let r' = VarE $ mkName "resource" let g = cpb `AppE` rp' `AppE` r' - vm' <- liftVerbMap vm r' rp + vm' <- liftMethodMap vm r' rp let vm'' = LamE [VarP $ mkName "verb"] vm' return (NormalG g, vm'') @@ -350,8 +350,8 @@ instance Lift RPP where lift (Slurp s) = do sl <- [|Slurp|] return $ sl `AppE` (LitE $ StringL s) -liftVerbMap :: VerbMap -> Exp -> RP -> Q Exp -liftVerbMap (AllVerbs s) r rp = do +liftMethodMap :: MethodMap -> Exp -> RP -> Q Exp +liftMethodMap (AllMethods s) r rp = do -- handler function let f = VarE $ mkName s -- applied to the verb @@ -362,23 +362,36 @@ liftVerbMap (AllVerbs s) r rp = do cr <- [|fmap chooseRep|] let f''' = cr `AppE` f'' return f''' -liftVerbMap (Verbs vs) r rp = do +liftMethodMap (Methods vs) r rp = do cr <- [|fmap chooseRep|] vs' <- mapM (helper cr) vs - return $ CaseE (VarE $ mkName "verb") $ vs' ++ [whenNotFound] + return $ CaseE (TupE []) [Match WildP (GuardedB $ vs' ++ [whenNotFound]) []] + --return $ CaseE (VarE $ mkName "verb") $ vs' ++ [whenNotFound] where - helper :: Exp -> (Verb, String) -> Q Match + helper :: Exp -> (Method, String) -> Q (Guard, Exp) helper cr (v, fName) = do + method' <- liftMethod v + equals <- [|(==)|] + let eq = equals + `AppE` method' + `AppE` VarE ((mkName "verb")) + let g = NormalG $ eq let f = VarE $ mkName fName f' <- applyUrlParams rp r f let f'' = cr `AppE` f' - let con = ConP (mkName $ show v) [] - return $ Match con (NormalB f'') [] - whenNotFound :: Match + return (g, f'') + whenNotFound :: (Guard, Exp) whenNotFound = - Match WildP - (NormalB $ VarE $ mkName "notFound") - [] + (NormalG $ ConE $ mkName "True", + VarE $ mkName "notFound") + +liftMethod :: Method -> Q Exp +liftMethod m = do + cs' <- [|cs :: String -> ByteString|] + methodFromBS' <- [|methodFromBS|] + let s = cs $ methodToBS m :: String + s' <- liftString s + return $ methodFromBS' `AppE` AppE cs' s' strToExp :: Bool -> String -> Q Exp strToExp toCheck s = do @@ -482,13 +495,13 @@ caseFromYaml = do rp3 <- readRP "page/$page" rp4 <- readRP "user/#id" let expected = - [ RPNode rp1 $ AllVerbs "getStatic" - , RPNode rp2 $ Verbs [(Get, "pageIndex"), (Put, "pageAdd")] - , RPNode rp3 $ Verbs [ (Get, "pageDetail") + [ RPNode rp1 $ AllMethods "getStatic" + , RPNode rp2 $ Methods [(Get, "pageIndex"), (Put, "pageAdd")] + , RPNode rp3 $ Methods [ (Get, "pageDetail") , (Delete, "pageDelete") , (Post, "pageUpdate") ] - , RPNode rp4 $ Verbs [(Get, "userInfo")] + , RPNode rp4 $ Methods [(Get, "userInfo")] ] contents' <- decodeFile "Test/resource-patterns.yaml" contents <- convertAttemptWrap (contents' :: TextObject) @@ -501,12 +514,12 @@ caseCheckRPNodes = do Just good @=? checkRPNodes good rp1 <- readRP "foo/bar" rp2 <- readRP "$foo/bar" - let bad1 = [ RPNode rp1 $ AllVerbs "foo" - , RPNode rp2 $ AllVerbs "bar" + let bad1 = [ RPNode rp1 $ AllMethods "foo" + , RPNode rp2 $ AllMethods "bar" ] Nothing @=? checkRPNodes bad1 rp' <- readRP "" - let bad2 = [RPNode rp' $ Verbs [(Get, "foo"), (Get, "bar")]] + let bad2 = [RPNode rp' $ Methods [(Get, "foo"), (Get, "bar")]] Nothing @=? checkRPNodes bad2 caseReadRP :: Assertion diff --git a/Yesod/Yesod.hs b/Yesod/Yesod.hs index b5a92e1c..b34572d2 100644 --- a/Yesod/Yesod.hs +++ b/Yesod/Yesod.hs @@ -30,7 +30,7 @@ import Network.Wai.Middleware.MethodOverride class Yesod a where -- | Please use the Quasi-Quoter, you\'ll be happier. For more information, -- see the examples/fact.lhs sample. - resources :: Resource -> Verb -> Handler a ChooseRep + resources :: Resource -> W.Method -> Handler a ChooseRep -- | The encryption key to be used for encrypting client sessions. encryptKey :: a -> IO Word256 @@ -125,8 +125,7 @@ toWaiApp' :: Yesod y -> IO W.Response toWaiApp' y resource session env = do let types = httpAccept env - verb = cs $ W.requestMethod env :: Verb - handler = resources (map cs resource) verb + handler = resources (map cs resource) $ W.requestMethod env rr <- parseWaiRequest env session res <- runHandler handler errorHandler rr y types responseToWaiResponse res diff --git a/examples/fact.lhs b/examples/fact.lhs index 05a7b089..301143eb 100644 --- a/examples/fact.lhs +++ b/examples/fact.lhs @@ -56,11 +56,11 @@ request method.) \begin{code} resources = [$mkResources| /: - Get: index + GET: index /#num: - Get: fact + GET: fact /fact: - Get: factRedirect + GET: factRedirect |] \end{code} diff --git a/examples/hellotemplate.lhs b/examples/hellotemplate.lhs index af1479fe..3e8d9c7c 100644 --- a/examples/hellotemplate.lhs +++ b/examples/hellotemplate.lhs @@ -7,7 +7,8 @@ import Network.Wai.Handler.SimpleServer data HelloWorld = HelloWorld TemplateGroup instance YesodTemplate HelloWorld where getTemplateGroup (HelloWorld tg) = tg - defaultTemplateAttribs _ = return . setHtmlAttrib "default" "" + defaultTemplateAttribs _ _ = return + . setHtmlAttrib "default" "" instance Yesod HelloWorld where resources = [$mkResources| /: diff --git a/examples/i18n.hs b/examples/i18n.hs index b98cd724..27568b90 100644 --- a/examples/i18n.hs +++ b/examples/i18n.hs @@ -1,6 +1,6 @@ {-# LANGUAGE QuasiQuotes #-} import Yesod -import Hack.Handler.SimpleServer +import Network.Wai.Handler.SimpleServer data I18N = I18N @@ -12,19 +12,22 @@ instance Yesod I18N where Get: setLang |] +homepage :: Handler y [(ContentType, Content)] homepage = do ls <- languages let hello = chooseHello ls return [(TypePlain, cs hello :: Content)] +chooseHello :: [Language] -> String chooseHello [] = "Hello" chooseHello ("he":_) = "שלום" chooseHello ("es":_) = "Hola" chooseHello (_:rest) = chooseHello rest +setLang :: String -> Handler y () setLang lang = do addCookie 1 langKey lang redirect RedirectTemporary "/" - return () -main = putStrLn "Running..." >> toHackApp I18N >>= run 3000 +main :: IO () +main = putStrLn "Running..." >> toWaiApp I18N >>= run 3000