This commit is contained in:
Michael Snoyman 2010-08-04 23:07:27 +03:00
parent 9fada88b6e
commit 191b406fd5
2 changed files with 14 additions and 24 deletions

View File

@ -18,8 +18,6 @@ module Yesod.Dispatch
, toWaiApp , toWaiApp
, basicHandler , basicHandler
, basicHandler' , basicHandler'
-- * Utilities
, fullRender
#if TEST #if TEST
, testSuite , testSuite
#endif #endif
@ -46,7 +44,6 @@ import qualified Network.Wai.Handler.CGI as CGI
import System.Environment (getEnvironment) import System.Environment (getEnvironment)
import qualified Data.ByteString.Char8 as B import qualified Data.ByteString.Char8 as B
import Web.Routes (encodePathInfo)
import qualified Data.ByteString.UTF8 as S import qualified Data.ByteString.UTF8 as S
@ -232,7 +229,7 @@ toWaiApp' y segments env = do
pathSegments = filter (not . null) segments pathSegments = filter (not . null) segments
eurl = parsePathSegments site pathSegments eurl = parsePathSegments site pathSegments
render u = fromMaybe render u = fromMaybe
(fullRender (approot y) (formatPathSegments site) u) (joinPath y (approot y) $ formatPathSegments site u)
(urlRenderOverride y u) (urlRenderOverride y u)
let errorHandler' = localNoCurrent . errorHandler let errorHandler' = localNoCurrent . errorHandler
rr <- parseWaiRequest env session' rr <- parseWaiRequest env session'
@ -268,19 +265,6 @@ toWaiApp' y segments env = do
hs''' = ("Content-Type", S.fromString ct) : hs'' hs''' = ("Content-Type", S.fromString ct) : hs''
return $ W.Response s hs''' c return $ W.Response s hs''' c
-- | Fully render a route to an absolute URL. Since Yesod does this for you
-- internally, you will rarely need access to this. However, if you need to
-- generate links /outside/ of the Handler monad, this may be useful.
--
-- For example, if you want to generate an e-mail which links to your site,
-- this is the function you would want to use.
fullRender :: String -- ^ approot, no trailing slash
-> (url -> [String])
-> url
-> String
fullRender ar render route =
ar ++ '/' : encodePathInfo (fixSegs $ render route)
httpAccept :: W.Request -> [ContentType] httpAccept :: W.Request -> [ContentType]
httpAccept = map B.unpack httpAccept = map B.unpack
. parseHttpAccept . parseHttpAccept
@ -316,13 +300,6 @@ basicHandler' port mhost y = do
SS.run port app SS.run port app
Just _ -> CGI.run app Just _ -> CGI.run app
fixSegs :: [String] -> [String]
fixSegs [] = []
fixSegs [x]
| any (== '.') x = [x]
| otherwise = [x, ""] -- append trailing slash
fixSegs (x:xs) = x : fixSegs xs
parseWaiRequest :: W.Request parseWaiRequest :: W.Request
-> [(String, String)] -- ^ session -> [(String, String)] -- ^ session
-> IO Request -> IO Request

View File

@ -44,6 +44,7 @@ import Control.Monad.Trans.Class (MonadTrans (..))
import Control.Monad.Attempt (Failure) import Control.Monad.Attempt (Failure)
import qualified Data.ByteString as S import qualified Data.ByteString as S
import qualified Network.Wai.Middleware.CleanPath import qualified Network.Wai.Middleware.CleanPath
import Web.Routes (encodePathInfo)
-- | This class is automatically instantiated when you use the template haskell -- | This class is automatically instantiated when you use the template haskell
-- mkYesod function. You should never need to deal with it directly. -- mkYesod function. You should never need to deal with it directly.
@ -150,6 +151,18 @@ class Eq (Route a) => Yesod a where
splitPath :: a -> S.ByteString -> Either S.ByteString [String] splitPath :: a -> S.ByteString -> Either S.ByteString [String]
splitPath _ = Network.Wai.Middleware.CleanPath.splitPath splitPath _ = Network.Wai.Middleware.CleanPath.splitPath
-- | 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)
where
fixSegs [] = []
fixSegs [x]
| any (== '.') x = [x]
| otherwise = [x, ""] -- append trailing slash
fixSegs (x:xs) = x : fixSegs xs
data AuthResult = Authorized | AuthenticationRequired | Unauthorized String data AuthResult = Authorized | AuthenticationRequired | Unauthorized String
deriving (Eq, Show, Read) deriving (Eq, Show, Read)