Removed Verb
This commit is contained in:
Michael Snoyman
parent
2babde3d78
commit
81a6e7a464
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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)]
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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}
|
||||
|
||||
|
||||
@ -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|
|
||||
/:
|
||||
|
||||
@ -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
|
||||
|
||||
Loading…
Reference in New Issue
Block a user