From 1013e20067e3ea91893648a4dde849a6c21241e9 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Sat, 22 Jan 2011 20:02:14 +0200 Subject: [PATCH] Fix some Yesod typeclass type signatures --- Yesod/Core.hs | 94 ++++++++++++++++------------------------------- Yesod/Dispatch.hs | 14 +++---- 2 files changed, 37 insertions(+), 71 deletions(-) diff --git a/Yesod/Core.hs b/Yesod/Core.hs index 2dc122e8..d16e10e2 100644 --- a/Yesod/Core.hs +++ b/Yesod/Core.hs @@ -95,7 +95,7 @@ class Eq (Route a) => Yesod a where -- -- * You do not use any features that require absolute URLs, such as Atom -- feeds and XML sitemaps. - approot :: a -> String + approot :: a -> S.ByteString -- | The encryption key to be used for encrypting client sessions. -- Returning 'Nothing' disables sessions. @@ -116,27 +116,29 @@ class Eq (Route a) => Yesod a where defaultLayout w = do p <- widgetToPageContent w mmsg <- getMessage - hamletToRepHtml [HAMLET|\ -\ + hamletToRepHtml [HAMLET| +!!! #{pageTitle p} - \^{pageHead p} + ^{pageHead p} <body> $maybe msg <- mmsg <p .message>#{msg} - \^{pageBody p} + ^{pageBody p} |] -- | Gets called at the beginning of each request. Useful for logging. + -- + -- FIXME make this a part of the Yesod middlewares onRequest :: GHandler sub a () onRequest = return () -- | Override the rendering function for a particular URL. One use case for -- this is to offload static hosting to a different domain name to avoid -- sending cookies. - urlRenderOverride :: a -> Route a -> Maybe String + urlRenderOverride :: a -> Route a -> Maybe S.ByteString urlRenderOverride _ _ = Nothing -- | Determine if a request is authorized or not. @@ -144,6 +146,8 @@ class Eq (Route a) => Yesod a where -- Return 'Nothing' is the request is authorized, 'Just' a message if -- unauthorized. If authentication is required, you should use a redirect; -- the Auth helper provides this functionality automatically. + -- + -- FIXME make this a part of the Yesod middlewares isAuthorized :: Route a -> Bool -- ^ is this a write request? -> GHandler s a AuthResult @@ -169,73 +173,37 @@ class Eq (Route a) => Yesod a where authRoute :: a -> Maybe (Route a) authRoute _ = Nothing - -- | A function used to split a raw PATH_INFO value into path pieces. It - -- returns a 'Left' value when you should redirect to the given path, and a - -- 'Right' value on successful parse. - -- - -- By default, it splits paths on slashes, and ensures the following are true: + -- | A function used to clean up path segments. It returns 'Nothing' when + -- the given path is already clean, and a 'Just' when Yesod should redirect + -- to the given path pieces. -- -- * No double slashes -- - -- * If the last path segment has a period, there is no trailing slash. + -- * There is no trailing slash. -- - -- * Otherwise, ensures there /is/ a trailing slash. - splitPath :: a -> S.ByteString -> Either S.ByteString [String] - splitPath _ s = + -- Note that versions of Yesod prior to 0.7 used a different set of rules + -- involing trailing slashes. + cleanPath :: a -> [String] -> Maybe [String] + cleanPath _ s = if corrected == s - then Right $ filter (not . null) - $ decodePathInfo - $ S8.unpack s - else Left corrected + then Nothing + else Just corrected where - corrected = S8.pack $ rts $ ats $ rds $ S8.unpack s - - -- | Remove double slashes - rds :: String -> String - rds [] = [] - rds [x] = [x] - rds (a:b:c) - | a == '/' && b == '/' = rds (b:c) - | otherwise = a : rds (b:c) - - -- | Add a trailing slash if it is missing. Empty string is left alone. - ats :: String -> String - ats [] = [] - ats t = - if last t == '/' || dbs (reverse t) - then t - else t ++ "/" - - -- | Remove a trailing slash if the last piece has a period. - rts :: String -> String - rts [] = [] - rts t = - if last t == '/' && dbs (tail $ reverse t) - then init t - else t - - -- | Is there a period before a slash here? - dbs :: String -> Bool - dbs ('/':_) = False - dbs (_:'.':_) = True - dbs (_:x) = dbs x - dbs [] = False - + corrected = filter (not . null) s -- | Join the pieces of a path together into an absolute URL. This should -- be the inverse of 'splitPath'. - joinPath :: a -> String -> [String] -> [(String, String)] -> String + joinPath :: a + -> S.ByteString -- ^ application root + -> [String] -- ^ path pieces + -> [(String, String)] -- ^ query string + -> S.ByteString joinPath _ ar pieces qs = - ar ++ '/' : encodePathInfo (fixSegs pieces) qs - where - fixSegs [] = [] - fixSegs [x] - | anyButLast (== '.') x = [x] - | otherwise = [x, ""] -- append trailing slash - fixSegs (x:xs) = x : fixSegs xs - anyButLast _ [] = False - anyButLast _ [_] = False - anyButLast p (x:xs) = p x || anyButLast p xs + S.concat + [ ar + , S8.singleton '/' + , S8.pack $ encodePathInfo pieces qs + ] -- | This function is used to store some static content to be served as an -- external file. The most common case of this is stashing CSS and diff --git a/Yesod/Dispatch.hs b/Yesod/Dispatch.hs index f1e47ff7..08851dfb 100644 --- a/Yesod/Dispatch.hs +++ b/Yesod/Dispatch.hs @@ -37,7 +37,6 @@ import Web.Routes.Quasi.TH import Language.Haskell.TH.Syntax import qualified Network.Wai as W -import Network.Wai.Middleware.CleanPath (cleanPath) import Network.Wai.Middleware.Jsonp import Network.Wai.Middleware.Gzip @@ -241,20 +240,19 @@ toWaiApp y = do a -- | Convert the given argument into a WAI application, executable with any WAI --- handler. This differs from 'toWaiApp' in that it only uses the cleanpath --- middleware. +-- handler. This differs from 'toWaiApp' in that it uses no middlewares. toWaiAppPlain :: (Yesod y, YesodSite y) => y -> IO W.Application toWaiAppPlain a = do key' <- encryptKey a - return $ cleanPath (splitPath a) (B.pack $ approot a) - $ toWaiApp' a key' + return $ toWaiApp' a key' toWaiApp' :: (Yesod y, YesodSite y) => y -> Maybe Key - -> [String] -> W.Application -toWaiApp' y key' segments env = do +toWaiApp' y key' env = do + let segments = decodePathInfo $ B.unpack $ W.pathInfo env + -- FIXME call cleanPath now <- liftIO getCurrentTime let getExpires m = fromIntegral (m * 60) `addUTCTime` now let exp' = getExpires $ clientSessionDuration y @@ -275,7 +273,7 @@ toWaiApp' y key' segments env = do eurl = parsePathSegments site pathSegments render u qs = let (ps, qs') = formatPathSegments site u - in fromMaybe + in B.unpack $ fromMaybe (joinPath y (approot y) ps $ qs ++ qs') (urlRenderOverride y u) let errorHandler' = localNoCurrent . errorHandler