From 0ce3740c649320091e2ee3c051638d8978975b41 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Sun, 8 Aug 2010 15:15:37 +0300 Subject: [PATCH] query string --- Yesod/Dispatch.hs | 6 +++-- Yesod/Hamlet.hs | 2 +- Yesod/Handler.hs | 50 +++++++++++++---------------------------- Yesod/Helpers/Static.hs | 25 +++++++++++++++++---- Yesod/Widget.hs | 6 ++--- Yesod/Yesod.hs | 8 +++---- hellowidget.hs | 2 +- yesod.cabal | 4 ++-- 8 files changed, 51 insertions(+), 52 deletions(-) diff --git a/Yesod/Dispatch.hs b/Yesod/Dispatch.hs index 5154ca70..4dc89406 100644 --- a/Yesod/Dispatch.hs +++ b/Yesod/Dispatch.hs @@ -228,8 +228,10 @@ toWaiApp' y segments env = do types = httpAccept env pathSegments = filter (not . null) segments eurl = parsePathSegments site pathSegments - render u = fromMaybe - (joinPath y (approot y) $ formatPathSegments site u) + render u qs = + let (ps, qs') = formatPathSegments site u + in fromMaybe + (joinPath y (approot y) ps $ qs ++ qs') (urlRenderOverride y u) let errorHandler' = localNoCurrent . errorHandler rr <- parseWaiRequest env session' diff --git a/Yesod/Hamlet.hs b/Yesod/Hamlet.hs index 18af6ba4..4757474a 100644 --- a/Yesod/Hamlet.hs +++ b/Yesod/Hamlet.hs @@ -36,7 +36,7 @@ data PageContent url = PageContent -- Yesod 'Response'. hamletToContent :: Hamlet (Route master) -> GHandler sub master Content hamletToContent h = do - render <- getUrlRender + render <- getUrlRenderParams return $ toContent $ renderHamlet render h -- | Wraps the 'Content' generated by 'hamletToContent' in a 'RepHtml'. diff --git a/Yesod/Handler.hs b/Yesod/Handler.hs index 03bf02ea..2010659e 100644 --- a/Yesod/Handler.hs +++ b/Yesod/Handler.hs @@ -30,6 +30,7 @@ module Yesod.Handler , getYesod , getYesodSub , getUrlRender + , getUrlRenderParams , getCurrentRoute , getRouteToMaster -- * Special responses @@ -73,7 +74,7 @@ import Prelude hiding (catch) import Yesod.Request import Yesod.Content import Yesod.Internal -import Data.List (foldl', intercalate) +import Data.List (foldl') import Data.Neither import Control.Exception hiding (Handler, catch) @@ -93,8 +94,6 @@ import Data.ByteString.UTF8 (toString) import qualified Data.ByteString.Lazy.UTF8 as L import Text.Hamlet -import Numeric (showIntAtBase) -import Data.Char (ord, chr) -- | The type-safe URLs associated with a site argument. type family Route a @@ -104,7 +103,7 @@ data HandlerData sub master = HandlerData , handlerSub :: sub , handlerMaster :: master , handlerRoute :: Maybe (Route sub) - , handlerRender :: (Route master -> String) + , handlerRender :: (Route master -> [(String, String)] -> String) , handlerToMaster :: Route sub -> Route master } @@ -183,7 +182,13 @@ getYesod = handlerMaster <$> GHandler ask -- | Get the URL rendering function. getUrlRender :: GHandler sub master (Route master -> String) -getUrlRender = handlerRender <$> GHandler ask +getUrlRender = do + x <- handlerRender <$> GHandler ask + return $ flip x [] + +-- | The URL rendering function with query-string parameters. +getUrlRenderParams :: GHandler sub master (Route master -> [(String, String)] -> String) +getUrlRenderParams = handlerRender <$> GHandler ask -- | Get the route requested by the user. If this is a 404 response- where the -- user requested an invalid route- this function will return 'Nothing'. @@ -209,7 +214,7 @@ dropKeys k = filter $ \(x, _) -> x /= k -- 'GHandler' into an 'W.Application'. Should not be needed by users. runHandler :: HasReps c => GHandler sub master c - -> (Route master -> String) + -> (Route master -> [(String, String)] -> String) -> Maybe (Route sub) -> (Route sub -> Route master) -> master @@ -268,33 +273,8 @@ redirect rt url = redirectParams rt url [] redirectParams :: RedirectType -> Route master -> [(String, String)] -> GHandler sub master a redirectParams rt url params = do - r <- getUrlRender - redirectString rt $ r url ++ encodeUrlPairs params - -encodeUrlPairs :: [(String, String)] -> String -encodeUrlPairs [] = "" -encodeUrlPairs pairs = - (:) '?' $ encodeUrlPairs' pairs - where - encodeUrlPairs' = intercalate "&" . map encodeUrlPair - encodeUrlPair (x, []) = escape x - encodeUrlPair (x, y) = escape x ++ '=' : escape y - escape = concatMap escape' - escape' c - | 'A' < c && c < 'Z' = [c] - | 'a' < c && c < 'a' = [c] - | '0' < c && c < '9' = [c] - | c `elem` ".-~_" = [c] - | c == ' ' = "+" - | otherwise = '%' : myShowHex (ord c) "" - myShowHex :: Int -> ShowS - myShowHex n r = case showIntAtBase 16 toChrHex n r of - [] -> "00" - [c] -> ['0',c] - s -> s - toChrHex d - | d < 10 = chr (ord '0' + fromIntegral d) - | otherwise = chr (ord 'A' + fromIntegral (d - 10)) + r <- getUrlRenderParams + redirectString rt $ r url params -- | Redirect to the given URL. redirectString :: RedirectType -> String -> GHandler sub master a @@ -328,8 +308,8 @@ setUltDest' = do Just r -> do tm <- getRouteToMaster gets <- reqGetParams <$> getRequest - render <- getUrlRender - setUltDestString $ render (tm r) ++ encodeUrlPairs gets + render <- getUrlRenderParams + setUltDestString $ render (tm r) gets -- | Redirect to the ultimate destination in the user's session. Clear the -- value from the session. diff --git a/Yesod/Helpers/Static.hs b/Yesod/Helpers/Static.hs index 734dac8b..11fff089 100644 --- a/Yesod/Helpers/Static.hs +++ b/Yesod/Helpers/Static.hs @@ -43,6 +43,10 @@ import Data.Maybe (fromMaybe) import Yesod import Data.List (intercalate) import Language.Haskell.TH.Syntax +import Web.Routes.Site + +import qualified Data.ByteString.Lazy as L +import Data.Digest.Pure.MD5 #if TEST import Test.Framework (testGroup, Test) @@ -58,9 +62,20 @@ data Static = Static , staticTypes :: [(String, ContentType)] } -mkYesodSub "Static" [] [$parseRoutes| -*Strings StaticRoute GET -|] +data StaticRoute = StaticRoute [String] [(String, String)] + deriving (Eq, Show, Read) + +type instance Route Static = StaticRoute + +instance YesodSubSite Static master where + getSubSite = Site + { handleSite = \_ (StaticRoute ps _) m -> + case m of + "GET" -> Just $ fmap chooseRep $ getStaticRoute ps + _ -> Nothing + , formatPathSegments = \(StaticRoute x y) -> (x, y) + , parsePathSegments = \x -> Right $ StaticRoute x [] + } -- | Lookup files in a specific directory. -- @@ -132,10 +147,12 @@ staticFiles fp = do let name = mkName $ intercalate "_" $ map (map replace') f f' <- lift f let sr = ConE $ mkName "StaticRoute" + hash <- qRunIO $ fmap (show . md5) $ L.readFile $ fp ++ '/' : intercalate "/" f + let qs = ListE [TupE [LitE $ StringL "hash", LitE $ StringL hash]] return [ SigD name $ ConT ''Route `AppT` ConT ''Static , FunD name - [ Clause [] (NormalB $ sr `AppE` f') [] + [ Clause [] (NormalB $ sr `AppE` f' `AppE` qs) [] ] ] diff --git a/Yesod/Widget.hs b/Yesod/Widget.hs index cc908b20..2c9563c1 100644 --- a/Yesod/Widget.hs +++ b/Yesod/Widget.hs @@ -38,7 +38,7 @@ import Control.Monad.Trans.State import Yesod.Hamlet (Hamlet, hamlet, PageContent (..), Html) import Text.Camlet import Text.Jamlet -import Yesod.Handler (Route, GHandler, getUrlRender) +import Yesod.Handler (Route, GHandler, getUrlRenderParams) import Yesod.Yesod (Yesod, defaultLayout, addStaticContent) import Yesod.Content (RepHtml (..)) import Control.Applicative (Applicative) @@ -186,12 +186,12 @@ widgetToPageContent (GWidget w) = do let jelper :: Jamlet url -> Hamlet url jelper j render = lbsToHtml $ renderJamlet render j - render <- getUrlRender + render <- getUrlRenderParams let renderLoc x = case x of Nothing -> Nothing Just (Left s) -> Just s - Just (Right u) -> Just $ render u + Just (Right (u, p)) -> Just $ render u p cssLoc <- case style of Nothing -> return Nothing diff --git a/Yesod/Yesod.hs b/Yesod/Yesod.hs index 2830d6ee..2ed95adf 100644 --- a/Yesod/Yesod.hs +++ b/Yesod/Yesod.hs @@ -154,9 +154,9 @@ class Eq (Route a) => Yesod a where -- | Join the pieces of a path together into an absolute URL. This should -- be the inverse of 'splitPath'. - joinPath :: a -> String -> [String] -> String - joinPath _ ar pieces = - ar ++ '/' : encodePathInfo (fixSegs pieces) + joinPath :: a -> String -> [String] -> [(String, String)] -> String + joinPath _ ar pieces qs = + ar ++ '/' : encodePathInfo (fixSegs pieces) qs where fixSegs [] = [] fixSegs [x] @@ -177,7 +177,7 @@ class Eq (Route a) => Yesod a where addStaticContent :: String -- ^ filename extension -> String -- ^ mime-type -> L.ByteString -- ^ content - -> GHandler sub a (Maybe (Either String (Route a))) + -> GHandler sub a (Maybe (Either String (Route a, [(String, String)]))) addStaticContent _ _ _ = return Nothing data AuthResult = Authorized | AuthenticationRequired | Unauthorized String diff --git a/hellowidget.hs b/hellowidget.hs index e6a4a30c..a8dfe524 100644 --- a/hellowidget.hs +++ b/hellowidget.hs @@ -22,7 +22,7 @@ instance Yesod HW where let fn = show (md5 content) ++ '.' : ext liftIO $ createDirectoryIfMissing True "static/tmp" liftIO $ L.writeFile ("static/tmp/" ++ fn) content - return $ Just $ Right $ StaticR $ StaticRoute ["tmp", fn] + return $ Just $ Right (StaticR $ StaticRoute ["tmp", fn], []) instance YesodNic HW instance YesodJquery HW diff --git a/yesod.cabal b/yesod.cabal index 6d9678fe..aafc37c9 100644 --- a/yesod.cabal +++ b/yesod.cabal @@ -30,8 +30,8 @@ library text >= 0.5 && < 0.8, utf8-string >= 0.3.4 && < 0.4, template-haskell >= 2.4 && < 2.5, - web-routes >= 0.22 && < 0.23, - web-routes-quasi >= 0.5 && < 0.6, + web-routes >= 0.23 && < 0.24, + web-routes-quasi >= 0.6 && < 0.7, hamlet >= 0.5.0 && < 0.6, blaze-html >= 0.1.1 && < 0.2, transformers >= 0.2 && < 0.3,