haskell/yesod
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Fix some Yesod typeclass type signatures

Browse Source
This commit is contained in:
Michael Snoyman 2011-01-22 20:02:14 +02:00
parent 04df11e41c
commit 1013e20067
2 changed files with 37 additions and 71 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

94
Yesod/Core.hs
View File

@ -95,7 +95,7 @@ class Eq (Route a) => Yesod a where
-- --
-- * You do not use any features that require absolute URLs, such as Atom -- * You do not use any features that require absolute URLs, such as Atom
-- feeds and XML sitemaps. -- feeds and XML sitemaps.
approot :: a -> String approot :: a -> S.ByteString
-- | The encryption key to be used for encrypting client sessions. -- | The encryption key to be used for encrypting client sessions.
-- Returning 'Nothing' disables sessions. -- Returning 'Nothing' disables sessions.
@ -116,27 +116,29 @@ class Eq (Route a) => Yesod a where
defaultLayout w = do defaultLayout w = do
p <- widgetToPageContent w p <- widgetToPageContent w
mmsg <- getMessage mmsg <- getMessage
hamletToRepHtml [HAMLET|\ hamletToRepHtml [HAMLET|
\<!DOCTYPE html> !!!
<html> <html>
<head> <head>
<title>#{pageTitle p} <title>#{pageTitle p}
\^{pageHead p} ^{pageHead p}
<body> <body>
$maybe msg <- mmsg $maybe msg <- mmsg
<p .message>#{msg} <p .message>#{msg}
\^{pageBody p} ^{pageBody p}
|] |]
-- | Gets called at the beginning of each request. Useful for logging. -- | 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 :: GHandler sub a ()
onRequest = return () onRequest = return ()
-- | Override the rendering function for a particular URL. One use case for -- | 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 -- this is to offload static hosting to a different domain name to avoid
-- sending cookies. -- sending cookies.
urlRenderOverride :: a -> Route a -> Maybe String urlRenderOverride :: a -> Route a -> Maybe S.ByteString
urlRenderOverride _ _ = Nothing urlRenderOverride _ _ = Nothing
-- | Determine if a request is authorized or not. -- | 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 -- Return 'Nothing' is the request is authorized, 'Just' a message if
-- unauthorized. If authentication is required, you should use a redirect; -- unauthorized. If authentication is required, you should use a redirect;
-- the Auth helper provides this functionality automatically. -- the Auth helper provides this functionality automatically.
--
-- FIXME make this a part of the Yesod middlewares
isAuthorized :: Route a isAuthorized :: Route a
-> Bool -- ^ is this a write request? -> Bool -- ^ is this a write request?
-> GHandler s a AuthResult -> GHandler s a AuthResult
@ -169,73 +173,37 @@ class Eq (Route a) => Yesod a where
authRoute :: a -> Maybe (Route a) authRoute :: a -> Maybe (Route a)
authRoute _ = Nothing authRoute _ = Nothing
-- | A function used to split a raw PATH_INFO value into path pieces. It -- | A function used to clean up path segments. It returns 'Nothing' when
-- returns a 'Left' value when you should redirect to the given path, and a -- the given path is already clean, and a 'Just' when Yesod should redirect
-- 'Right' value on successful parse. -- to the given path pieces.
--
-- By default, it splits paths on slashes, and ensures the following are true:
-- --
-- * No double slashes -- * 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. -- Note that versions of Yesod prior to 0.7 used a different set of rules
splitPath :: a -> S.ByteString -> Either S.ByteString [String] -- involing trailing slashes.
splitPath _ s = cleanPath :: a -> [String] -> Maybe [String]
cleanPath _ s =
if corrected == s if corrected == s
then Right $ filter (not . null) then Nothing
$ decodePathInfo else Just corrected
$ S8.unpack s
else Left corrected
where where
corrected = S8.pack $ rts $ ats $ rds $ S8.unpack s corrected = filter (not . null) 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
-- | Join the pieces of a path together into an absolute URL. This should -- | Join the pieces of a path together into an absolute URL. This should
-- be the inverse of 'splitPath'. -- 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 = joinPath _ ar pieces qs =
ar ++ '/' : encodePathInfo (fixSegs pieces) qs S.concat
where [ ar
fixSegs [] = [] , S8.singleton '/'
fixSegs [x] , S8.pack $ encodePathInfo pieces qs
| 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
-- | This function is used to store some static content to be served as an -- | 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 -- external file. The most common case of this is stashing CSS and

14
Yesod/Dispatch.hs
View File

@ -37,7 +37,6 @@ import Web.Routes.Quasi.TH
import Language.Haskell.TH.Syntax import Language.Haskell.TH.Syntax
import qualified Network.Wai as W import qualified Network.Wai as W
import Network.Wai.Middleware.CleanPath (cleanPath)
import Network.Wai.Middleware.Jsonp import Network.Wai.Middleware.Jsonp
import Network.Wai.Middleware.Gzip import Network.Wai.Middleware.Gzip
@ -241,20 +240,19 @@ toWaiApp y = do
a a
-- | Convert the given argument into a WAI application, executable with any WAI -- | Convert the given argument into a WAI application, executable with any WAI
-- handler. This differs from 'toWaiApp' in that it only uses the cleanpath -- handler. This differs from 'toWaiApp' in that it uses no middlewares.
-- middleware.
toWaiAppPlain :: (Yesod y, YesodSite y) => y -> IO W.Application toWaiAppPlain :: (Yesod y, YesodSite y) => y -> IO W.Application
toWaiAppPlain a = do toWaiAppPlain a = do
key' <- encryptKey a key' <- encryptKey a
return $ cleanPath (splitPath a) (B.pack $ approot a) return $ toWaiApp' a key'
$ toWaiApp' a key'
toWaiApp' :: (Yesod y, YesodSite y) toWaiApp' :: (Yesod y, YesodSite y)
=> y => y
-> Maybe Key -> Maybe Key
-> [String]
-> W.Application -> 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 now <- liftIO getCurrentTime
let getExpires m = fromIntegral (m * 60) `addUTCTime` now let getExpires m = fromIntegral (m * 60) `addUTCTime` now
let exp' = getExpires $ clientSessionDuration y let exp' = getExpires $ clientSessionDuration y
@ -275,7 +273,7 @@ toWaiApp' y key' segments env = do
eurl = parsePathSegments site pathSegments eurl = parsePathSegments site pathSegments
render u qs = render u qs =
let (ps, qs') = formatPathSegments site u let (ps, qs') = formatPathSegments site u
in fromMaybe in B.unpack $ fromMaybe
(joinPath y (approot y) ps $ qs ++ qs') (joinPath y (approot y) ps $ qs ++ qs')
(urlRenderOverride y u) (urlRenderOverride y u)
let errorHandler' = localNoCurrent . errorHandler let errorHandler' = localNoCurrent . errorHandler