Removed Verb

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

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 =>
+authHandler :: YesodAuth y => W.Method -> [String] -> Handler y ChooseRep
-            Verb -> [String] -> Handler y ChooseRep
+authHandler W.GET ["check"] = rc authCheck
-authHandler Get ["check"] = rc authCheck
+authHandler W.GET ["logout"] = rc authLogout
-authHandler Get ["logout"] = rc authLogout
+authHandler W.GET ["openid"] = rc authOpenidForm
-authHandler Get ["openid"] = rc authOpenidForm
+authHandler W.GET ["openid", "forward"] = rc authOpenidForward
-authHandler Get ["openid", "forward"] = rc authOpenidForward
+authHandler W.GET ["openid", "complete"] = rc authOpenidComplete
-authHandler 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

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)]

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
+instance ConvertAttempt TextObject MethodMap where
-    convertAttempt (Scalar s) = return $ AllVerbs $ cs s
+    convertAttempt (Scalar s) = return $ AllMethods $ cs s
-    convertAttempt (Mapping m) = Verbs `fmap` mapM helper m where
+    convertAttempt (Mapping m) = Methods `fmap` mapM helper m where
-        helper :: (Text, TextObject) -> Attempt (Verb, String)
+        helper :: (Text, TextObject) -> Attempt (Method, String)
-        helper (v, Scalar f) = do
+        helper (v, Scalar f) = return (methodFromBS $ cs v, cs f)
-            v' <- ca (cs v :: String)
+        helper (_, x) = failure $ MethodMapNonScalar x
-            return (v', cs f)
+    convertAttempt o = failure $ MethodMapSequence o
-        helper (_, x) = failure $ VerbMapNonScalar x
+data RPNodeException = MethodMapNonScalar TextObject
-    convertAttempt o = failure $ VerbMapSequence o
+                     | MethodMapSequence TextObject
-data RPNodeException = VerbMapNonScalar TextObject
-                     | VerbMapSequence 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 ()
+            checkMethodMap (AllMethods _) = return ()
-            checkVerbMap (Verbs vs) =
+            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
+notFoundMethod :: Method -> Handler yesod a
-notFoundVerb _verb = notFound
+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
+liftMethodMap :: MethodMap -> Exp -> RP -> Q Exp
-liftVerbMap (AllVerbs s) r rp = do
+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 (g, f'')
-                return $ Match con (NormalB f'') []
+            whenNotFound :: (Guard, Exp)
-            whenNotFound :: Match
             whenNotFound =
-                Match WildP
+                (NormalG $ ConE $ mkName "True",
-                      (NormalB $ VarE $ mkName "notFound")
+                 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 rp1 $ AllMethods "getStatic"
-         , RPNode rp2 $ Verbs [(Get, "pageIndex"), (Put, "pageAdd")]
+         , RPNode rp2 $ Methods [(Get, "pageIndex"), (Put, "pageAdd")]
-         , RPNode rp3 $ Verbs [ (Get, "pageDetail")
+         , 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"
+    let bad1 = [ RPNode rp1 $ AllMethods "foo"
-               , RPNode rp2 $ AllVerbs "bar"
+               , 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

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) $ W.requestMethod env
-        handler = resources (map cs resource) verb
     rr <- parseWaiRequest env session
     res <- runHandler handler errorHandler rr y types
     responseToWaiResponse res

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}
 

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" "<DEFAULT>"
+    defaultTemplateAttribs _ _ = return
+        . setHtmlAttrib "default" "<DEFAULT>"
 instance Yesod HelloWorld where
     resources = [$mkResources|
 /:

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