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

Major modification of data types

Browse Source
This commit is contained in:
Michael Snoyman 2011-03-24 16:32:44 +02:00
parent a221c1c832
commit 33db6ced91
12 changed files with 88 additions and 82 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

5
Test/CleanPath.hs
View File

@ -16,10 +16,11 @@ import Network.Wai.Test
import Network.HTTP.Types (status200, decodePathSegments) import Network.HTTP.Types (status200, decodePathSegments)
import qualified Data.ByteString.Lazy.Char8 as L8 import qualified Data.ByteString.Lazy.Char8 as L8
import qualified Data.Text as TS
data Subsite = Subsite data Subsite = Subsite
getSubsite = const Subsite getSubsite = const Subsite
data SubsiteRoute = SubsiteRoute [String] data SubsiteRoute = SubsiteRoute [TS.Text]
deriving (Eq, Show, Read) deriving (Eq, Show, Read)
type instance Route Subsite = SubsiteRoute type instance Route Subsite = SubsiteRoute
instance RenderRoute SubsiteRoute where instance RenderRoute SubsiteRoute where
@ -48,7 +49,7 @@ instance Yesod Y where
then Right s then Right s
else Left corrected else Left corrected
where where
corrected = filter (not . null) s corrected = filter (not . TS.null) s
getFooR = return $ RepPlain "foo" getFooR = return $ RepPlain "foo"
getFooStringR = return . RepPlain . toContent getFooStringR = return . RepPlain . toContent

4
Test/Exceptions.hs
View File

@ -35,9 +35,9 @@ exceptionsTest = testGroup "Test.Exceptions"
runner f = toWaiApp Y >>= runSession f runner f = toWaiApp Y >>= runSession f
defaultRequest = Request defaultRequest = Request
{ pathInfo = "" { pathInfo = []
, requestHeaders = [] , requestHeaders = []
, queryString = "" , queryString = []
, requestMethod = "GET" , requestMethod = "GET"
} }

7
Yesod/Content.hs
View File

@ -61,7 +61,6 @@ import Data.Monoid (mempty)
import Text.Hamlet (Html) import Text.Hamlet (Html)
import Text.Blaze.Renderer.Utf8 (renderHtmlBuilder) import Text.Blaze.Renderer.Utf8 (renderHtmlBuilder)
import Data.String (IsString (fromString)) import Data.String (IsString (fromString))
import qualified Data.Ascii as A
data Content = ContentBuilder Builder (Maybe Int) -- ^ The content and optional content length. data Content = ContentBuilder Builder (Maybe Int) -- ^ The content and optional content length.
| ContentEnum (forall a. Enumerator Builder IO a) | ContentEnum (forall a. Enumerator Builder IO a)
@ -167,7 +166,7 @@ newtype RepXml = RepXml Content
instance HasReps RepXml where instance HasReps RepXml where
chooseRep (RepXml c) _ = return (typeXml, c) chooseRep (RepXml c) _ = return (typeXml, c)
type ContentType = A.Ascii type ContentType = B.ByteString
typeHtml :: ContentType typeHtml :: ContentType
typeHtml = "text/html; charset=utf-8" typeHtml = "text/html; charset=utf-8"
@ -216,8 +215,8 @@ typeOctet = "application/octet-stream"
-- --
-- For example, \"text/html; charset=utf-8\" is commonly used to specify the -- For example, \"text/html; charset=utf-8\" is commonly used to specify the
-- character encoding for HTML data. This function would return \"text/html\". -- character encoding for HTML data. This function would return \"text/html\".
simpleContentType :: A.Ascii -> A.Ascii simpleContentType :: ContentType -> ContentType
simpleContentType = A.unsafeFromByteString . fst . B.breakByte 59 . A.toByteString -- 59 == ; simpleContentType = fst . B.breakByte 59 -- 59 == ;
-- | Format a 'UTCTime' in W3 format. -- | Format a 'UTCTime' in W3 format.
formatW3 :: UTCTime -> String formatW3 :: UTCTime -> String

35
Yesod/Core.hs
View File

@ -54,9 +54,11 @@ import Web.Cookie (parseCookies)
import qualified Data.Map as Map import qualified Data.Map as Map
import Data.Time import Data.Time
import Network.HTTP.Types (encodePath) import Network.HTTP.Types (encodePath)
import qualified Network.HTTP.Types as H
import qualified Data.Text as TS import qualified Data.Text as TS
import Data.Text (Text)
import qualified Data.Text.Encoding as TE import qualified Data.Text.Encoding as TE
import qualified Data.Ascii as A import Blaze.ByteString.Builder (Builder, fromByteString, toByteString)
#if GHC7 #if GHC7
#define HAMLET hamlet #define HAMLET hamlet
@ -65,7 +67,7 @@ import qualified Data.Ascii as A
#endif #endif
class Eq u => RenderRoute u where class Eq u => RenderRoute u where
renderRoute :: u -> ([String], [(String, String)]) -- FIXME switch to Text? renderRoute :: u -> ([Text], [(Text, Text)])
-- | 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.
@ -74,7 +76,7 @@ class YesodDispatch a master where
:: Yesod master :: Yesod master
=> a => a
-> Maybe CS.Key -> Maybe CS.Key
-> [String] -> [Text]
-> master -> master
-> (Route a -> Route master) -> (Route a -> Route master)
-> Maybe W.Application -> Maybe W.Application
@ -99,7 +101,7 @@ class RenderRoute (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 -> A.Ascii approot :: a -> H.Ascii
-- | 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.
@ -136,7 +138,7 @@ class RenderRoute (Route a) => Yesod a where
-- | 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 A.AsciiBuilder urlRenderOverride :: a -> Route a -> Maybe Builder
urlRenderOverride _ _ = Nothing urlRenderOverride _ _ = Nothing
-- | Determine if a request is authorized or not. -- | Determine if a request is authorized or not.
@ -179,21 +181,21 @@ class RenderRoute (Route a) => Yesod a where
-- --
-- Note that versions of Yesod prior to 0.7 used a different set of rules -- Note that versions of Yesod prior to 0.7 used a different set of rules
-- involing trailing slashes. -- involing trailing slashes.
cleanPath :: a -> [String] -> Either [String] [String] cleanPath :: a -> [Text] -> Either [Text] [Text]
cleanPath _ s = cleanPath _ s =
if corrected == s if corrected == s
then Right s then Right s
else Left corrected else Left corrected
where where
corrected = filter (not . null) s corrected = filter (not . TS.null) s
-- | 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 joinPath :: a
-> A.AsciiBuilder -- ^ application root -> Builder -- ^ application root
-> [TS.Text] -- ^ path pieces FIXME Text -> [TS.Text] -- ^ path pieces FIXME Text
-> [(TS.Text, TS.Text)] -- ^ query string -> [(TS.Text, TS.Text)] -- ^ query string
-> A.AsciiBuilder -> Builder
joinPath _ ar pieces qs' = ar `mappend` encodePath pieces qs joinPath _ ar pieces qs' = ar `mappend` encodePath pieces qs
where where
qs = map (TE.encodeUtf8 *** go) qs' qs = map (TE.encodeUtf8 *** go) qs'
@ -379,7 +381,7 @@ defaultErrorHandler (BadMethod m) =
[$hamlet| [$hamlet|
#endif #endif
<h1>Method Not Supported <h1>Method Not Supported
<p>Method "#{A.toText m}" not supported <p>Method "#{S8.unpack m}" not supported
|] |]
-- | Return the same URL if the user is authorized to see it. -- | Return the same URL if the user is authorized to see it.
@ -411,7 +413,8 @@ widgetToPageContent (GWidget w) = do
jelper :: Julius url -> Hamlet url jelper :: Julius url -> Hamlet url
jelper = fmap jsToHtml jelper = fmap jsToHtml
render <- getUrlRenderParams renderFIXME <- getUrlRenderParams
let render a b = renderFIXME a $ map (TS.pack *** TS.pack) b
let renderLoc x = let renderLoc x =
case x of case x of
Nothing -> Nothing Nothing -> Nothing
@ -462,13 +465,13 @@ yesodVersion = showVersion Paths_yesod_core.version
yesodRender :: Yesod y yesodRender :: Yesod y
=> y => y
-> Route y -> Route y
-> [(String, String)] -> [(Text, Text)]
-> String -> String -- FIXME
yesodRender y u qs = yesodRender y u qs =
A.toString $ A.fromAsciiBuilder $ S8.unpack $ toByteString $
fromMaybe fromMaybe
( joinPath y (A.toAsciiBuilder $ approot y) (map TS.pack ps) (joinPath y (fromByteString $ approot y) ps
$ map (TS.pack *** TS.pack) $ qs ++ qs') $ qs ++ qs')
(urlRenderOverride y u) (urlRenderOverride y u)
where where
(ps, qs') = renderRoute u (ps, qs') = renderRoute u

6
Yesod/Dispatch.hs
View File

@ -39,7 +39,6 @@ import Data.ByteString.Lazy.Char8 ()
import Web.ClientSession import Web.ClientSession
import Data.Char (isUpper) import Data.Char (isUpper)
import qualified Data.Text as TS
-- | Generates URL datatype and site function for the given 'Resource's. This -- | Generates URL datatype and site function for the given 'Resource's. This
-- is used for creating sites, /not/ subsites. See 'mkYesodSub' for the latter. -- is used for creating sites, /not/ subsites. See 'mkYesodSub' for the latter.
@ -175,8 +174,7 @@ toWaiApp' :: (Yesod y, YesodDispatch y y)
=> y => y
-> Maybe Key -> Maybe Key
-> W.Application -> W.Application
toWaiApp' y key' env = do toWaiApp' y key' env =
let segments = map TS.unpack $ W.pathInfo env case yesodDispatch y key' (W.pathInfo env) y id of
case yesodDispatch y key' segments y id of
Just app -> app env Just app -> app env
Nothing -> yesodRunner y y id key' Nothing notFound env Nothing -> yesodRunner y y id key' Nothing notFound env

60
Yesod/Handler.hs
View File

@ -125,7 +125,7 @@ import Control.Failure (Failure (failure))
import Text.Hamlet import Text.Hamlet
import Control.Monad.IO.Peel (MonadPeelIO) import Control.Monad.IO.Peel (MonadPeelIO) -- FIXME monad-control
import Control.Monad.Trans.Peel (MonadTransPeel (peel), liftPeel) import Control.Monad.Trans.Peel (MonadTransPeel (peel), liftPeel)
import qualified Data.Map as Map import qualified Data.Map as Map
import qualified Data.ByteString as S import qualified Data.ByteString as S
@ -139,8 +139,12 @@ import Web.Cookie (SetCookie (..), renderSetCookie)
import Data.Enumerator (run_, ($$)) import Data.Enumerator (run_, ($$))
import Control.Arrow (second, (***)) import Control.Arrow (second, (***))
import qualified Network.Wai.Parse as NWP import qualified Network.Wai.Parse as NWP
import qualified Data.Ascii as A
import Data.Monoid (mappend, mempty) import Data.Monoid (mappend, mempty)
import qualified Data.ByteString.Char8 as S8
import Data.CaseInsensitive (CI)
import Blaze.ByteString.Builder (toByteString)
import Data.Text (Text)
import qualified Data.Text as TS
-- | The type-safe URLs associated with a site argument. -- | The type-safe URLs associated with a site argument.
type family Route a type family Route a
@ -153,7 +157,7 @@ data HandlerData sub master = HandlerData
, handlerSub :: sub , handlerSub :: sub
, handlerMaster :: master , handlerMaster :: master
, handlerRoute :: Maybe (Route sub) , handlerRoute :: Maybe (Route sub)
, handlerRender :: (Route master -> [(String, String)] -> String) -- FIXME replace output String with Ascii , handlerRender :: (Route master -> [(Text, Text)] -> String) -- FIXME replace output String with Ascii
, handlerToMaster :: Route sub -> Route master , handlerToMaster :: Route sub -> Route master
} }
@ -271,8 +275,8 @@ data HandlerContents =
HCContent H.Status ChooseRep HCContent H.Status ChooseRep
| HCError ErrorResponse | HCError ErrorResponse
| HCSendFile ContentType FilePath | HCSendFile ContentType FilePath
| HCRedirect RedirectType A.Ascii | HCRedirect RedirectType H.Ascii
| HCCreated A.Ascii | HCCreated H.Ascii
| HCWai W.Response | HCWai W.Response
instance Error HandlerContents where instance Error HandlerContents where
@ -318,7 +322,7 @@ getUrlRender = do
-- | The URL rendering function with query-string parameters. -- | The URL rendering function with query-string parameters.
getUrlRenderParams getUrlRenderParams
:: Monad m :: Monad m
=> GGHandler sub master m (Route master -> [(String, String)] -> String) => GGHandler sub master m (Route master -> [(Text, Text)] -> String)
getUrlRenderParams = handlerRender `liftM` GHandler ask getUrlRenderParams = handlerRender `liftM` GHandler ask
-- | Get the route requested by the user. If this is a 404 response- where the -- | Get the route requested by the user. If this is a 404 response- where the
@ -335,7 +339,7 @@ getRouteToMaster = handlerToMaster `liftM` GHandler ask
-- 'GHandler' into an 'W.Application'. Should not be needed by users. -- 'GHandler' into an 'W.Application'. Should not be needed by users.
runHandler :: HasReps c runHandler :: HasReps c
=> GHandler sub master c => GHandler sub master c
-> (Route master -> [(String, String)] -> String) -> (Route master -> [(Text, Text)] -> String)
-> Maybe (Route sub) -> Maybe (Route sub)
-> (Route sub -> Route master) -> (Route sub -> Route master)
-> master -> master
@ -419,14 +423,14 @@ redirect rt url = redirectParams rt url []
-- | Redirects to the given route with the associated query-string parameters. -- | Redirects to the given route with the associated query-string parameters.
redirectParams :: Monad mo redirectParams :: Monad mo
=> RedirectType -> Route master -> [(String, String)] => RedirectType -> Route master -> [(Text, Text)]
-> GGHandler sub master mo a -> GGHandler sub master mo a
redirectParams rt url params = do redirectParams rt url params = do
r <- getUrlRenderParams r <- getUrlRenderParams
redirectString rt $ A.unsafeFromString $ r url params redirectString rt $ S8.pack $ r url params
-- | Redirect to the given URL. -- | Redirect to the given URL.
redirectString :: Monad mo => RedirectType -> A.Ascii -> GGHandler sub master mo a redirectString :: Monad mo => RedirectType -> H.Ascii -> GGHandler sub master mo a
redirectString rt = GHandler . lift . throwError . HCRedirect rt redirectString rt = GHandler . lift . throwError . HCRedirect rt
ultDestKey :: String ultDestKey :: String
@ -458,7 +462,8 @@ setUltDest' = do
tm <- getRouteToMaster tm <- getRouteToMaster
gets' <- reqGetParams `liftM` handlerRequest `liftM` GHandler ask gets' <- reqGetParams `liftM` handlerRequest `liftM` GHandler ask
render <- getUrlRenderParams render <- getUrlRenderParams
setUltDestString $ render (tm r) gets' let renderFIXME a b = render a $ map (TS.pack *** TS.pack) b
setUltDestString $ renderFIXME (tm r) gets'
-- | Redirect to the ultimate destination in the user's session. Clear the -- | Redirect to the ultimate destination in the user's session. Clear the
-- value from the session. -- value from the session.
@ -471,7 +476,7 @@ redirectUltDest :: Monad mo
redirectUltDest rt def = do redirectUltDest rt def = do
mdest <- lookupSession ultDestKey mdest <- lookupSession ultDestKey
deleteSession ultDestKey deleteSession ultDestKey
maybe (redirect rt def) (redirectString rt . A.unsafeFromString) mdest maybe (redirect rt def) (redirectString rt . S8.pack) mdest
msgKey :: String msgKey :: String
msgKey = "_MSG" msgKey = "_MSG"
@ -516,7 +521,7 @@ sendResponseStatus s = GHandler . lift . throwError . HCContent s
sendResponseCreated :: Monad mo => Route m -> GGHandler s m mo a sendResponseCreated :: Monad mo => Route m -> GGHandler s m mo a
sendResponseCreated url = do sendResponseCreated url = do
r <- getUrlRender r <- getUrlRender
GHandler $ lift $ throwError $ HCCreated $ A.unsafeFromString $ r url GHandler $ lift $ throwError $ HCCreated $ S8.pack $ r url
-- | Send a 'W.Response'. Please note: this function is rarely -- | Send a 'W.Response'. Please note: this function is rarely
-- necessary, and will /disregard/ any changes to response headers and session -- necessary, and will /disregard/ any changes to response headers and session
@ -548,29 +553,29 @@ invalidArgs = failure . InvalidArgs
-- | Set the cookie on the client. -- | Set the cookie on the client.
setCookie :: Monad mo setCookie :: Monad mo
=> Int -- ^ minutes to timeout => Int -- ^ minutes to timeout
-> A.Ascii -- ^ key -> H.Ascii -- ^ key
-> A.Ascii -- ^ value -> H.Ascii -- ^ value
-> GGHandler sub master mo () -> GGHandler sub master mo ()
setCookie a b = addHeader . AddCookie a b setCookie a b = addHeader . AddCookie a b
-- | Unset the cookie on the client. -- | Unset the cookie on the client.
deleteCookie :: Monad mo => A.Ascii -> GGHandler sub master mo () deleteCookie :: Monad mo => H.Ascii -> GGHandler sub master mo ()
deleteCookie = addHeader . DeleteCookie deleteCookie = addHeader . DeleteCookie
-- | Set the language in the user session. Will show up in 'languages' on the -- | Set the language in the user session. Will show up in 'languages' on the
-- next request. -- next request.
setLanguage :: Monad mo => String -> GGHandler sub master mo () setLanguage :: Monad mo => String -> GGHandler sub master mo ()
setLanguage = setSession (A.toString langKey) setLanguage = setSession $ S8.unpack langKey
-- | Set an arbitrary response header. -- | Set an arbitrary response header.
setHeader :: Monad mo setHeader :: Monad mo
=> A.CIAscii -> A.Ascii -> GGHandler sub master mo () => CI H.Ascii -> H.Ascii -> GGHandler sub master mo ()
setHeader a = addHeader . Header a setHeader a = addHeader . Header a
-- | Set the Cache-Control header to indicate this response should be cached -- | Set the Cache-Control header to indicate this response should be cached
-- for the given number of seconds. -- for the given number of seconds.
cacheSeconds :: Monad mo => Int -> GGHandler s m mo () cacheSeconds :: Monad mo => Int -> GGHandler s m mo ()
cacheSeconds i = setHeader "Cache-Control" $ A.unsafeFromString $ concat cacheSeconds i = setHeader "Cache-Control" $ S8.pack $ concat
[ "max-age=" [ "max-age="
, show i , show i
, ", public" , ", public"
@ -588,7 +593,7 @@ alreadyExpired = setHeader "Expires" "Thu, 01 Jan 1970 05:05:05 GMT"
-- | Set an Expires header to the given date. -- | Set an Expires header to the given date.
expiresAt :: Monad mo => UTCTime -> GGHandler s m mo () expiresAt :: Monad mo => UTCTime -> GGHandler s m mo ()
expiresAt = setHeader "Expires" . A.unsafeFromString . formatRFC1123 expiresAt = setHeader "Expires" . S8.pack . formatRFC1123
-- | Set a variable in the user's session. -- | Set a variable in the user's session.
-- --
@ -648,7 +653,7 @@ handlerToYAR :: (HasReps a, HasReps b)
=> m -- ^ master site foundation => m -- ^ master site foundation
-> s -- ^ sub site foundation -> s -- ^ sub site foundation
-> (Route s -> Route m) -> (Route s -> Route m)
-> (Route m -> [(String, String)] -> String) -- ^ url render -> (Route m -> [(Text, Text)] -> String) -- ^ url render FIXME
-> (ErrorResponse -> GHandler s m a) -> (ErrorResponse -> GHandler s m a)
-> Request -> Request
-> Maybe (Route s) -> Maybe (Route s)
@ -666,7 +671,7 @@ handlerToYAR y s toMasterRoute render errorHandler rr murl sessionMap h =
type HeaderRenderer = [Header] type HeaderRenderer = [Header]
-> ContentType -> ContentType
-> SessionMap -> SessionMap
-> [(A.CIAscii, A.Ascii)] -> [(CI H.Ascii, H.Ascii)]
yarToResponse :: HeaderRenderer -> YesodAppResult -> W.Response yarToResponse :: HeaderRenderer -> YesodAppResult -> W.Response
yarToResponse _ (YARWai a) = a yarToResponse _ (YARWai a) = a
@ -675,12 +680,12 @@ yarToResponse renderHeaders (YARPlain s hs ct c sessionFinal) =
ContentBuilder b mlen -> ContentBuilder b mlen ->
let hs' = maybe finalHeaders finalHeaders' mlen let hs' = maybe finalHeaders finalHeaders' mlen
in W.ResponseBuilder s hs' b in W.ResponseBuilder s hs' b
ContentFile fp -> W.ResponseFile s finalHeaders fp ContentFile fp -> W.ResponseFile s finalHeaders fp Nothing -- FIXME handle partial files
ContentEnum e -> ContentEnum e ->
W.ResponseEnumerator $ \iter -> run_ $ e $$ iter s finalHeaders W.ResponseEnumerator $ \iter -> run_ $ e $$ iter s finalHeaders
where where
finalHeaders = renderHeaders hs ct sessionFinal finalHeaders = renderHeaders hs ct sessionFinal
finalHeaders' len = ("Content-Length", A.unsafeFromString $ show len) finalHeaders' len = ("Content-Length", S8.pack $ show len)
: finalHeaders : finalHeaders
{- {-
getExpires m = fromIntegral (m * 60) `addUTCTime` now getExpires m = fromIntegral (m * 60) `addUTCTime` now
@ -711,9 +716,9 @@ httpAccept = parseHttpAccept
-- | Convert Header to a key/value pair. -- | Convert Header to a key/value pair.
headerToPair :: (Int -> UTCTime) -- ^ minutes -> expiration time headerToPair :: (Int -> UTCTime) -- ^ minutes -> expiration time
-> Header -> Header
-> (A.CIAscii, A.Ascii) -> (CI H.Ascii, H.Ascii)
headerToPair getExpires (AddCookie minutes key value) = headerToPair getExpires (AddCookie minutes key value) =
("Set-Cookie", A.fromAsciiBuilder $ renderSetCookie $ SetCookie ("Set-Cookie", toByteString $ renderSetCookie $ SetCookie
{ setCookieName = key { setCookieName = key
, setCookieValue = value , setCookieValue = value
, setCookiePath = Just "/" -- FIXME make a config option, or use approot? , setCookiePath = Just "/" -- FIXME make a config option, or use approot?
@ -777,7 +782,8 @@ hamletToContent :: Monad mo
=> Hamlet (Route master) -> GGHandler sub master mo Content => Hamlet (Route master) -> GGHandler sub master mo Content
hamletToContent h = do hamletToContent h = do
render <- getUrlRenderParams render <- getUrlRenderParams
return $ toContent $ h render let renderFIXME a b = render a $ map (TS.pack *** TS.pack) b
return $ toContent $ h renderFIXME
-- | Wraps the 'Content' generated by 'hamletToContent' in a 'RepHtml'. -- | Wraps the 'Content' generated by 'hamletToContent' in a 'RepHtml'.
hamletToRepHtml :: Monad mo hamletToRepHtml :: Monad mo

5
Yesod/Internal.hs
View File

@ -51,8 +51,9 @@ import qualified Data.Text.Lazy.Encoding as LT
import Data.Typeable (Typeable) import Data.Typeable (Typeable)
import Control.Exception (Exception) import Control.Exception (Exception)
import qualified Data.Ascii as A
import qualified Network.HTTP.Types as H import qualified Network.HTTP.Types as H
import qualified Network.HTTP.Types as A
import Data.CaseInsensitive (CI)
#if GHC7 #if GHC7
#define HAMLET hamlet #define HAMLET hamlet
@ -76,7 +77,7 @@ instance Exception ErrorResponse
data Header = data Header =
AddCookie Int A.Ascii A.Ascii AddCookie Int A.Ascii A.Ascii
| DeleteCookie A.Ascii | DeleteCookie A.Ascii
| Header A.CIAscii A.Ascii | Header (CI A.Ascii) A.Ascii
deriving (Eq, Show) deriving (Eq, Show)
langKey :: A.Ascii langKey :: A.Ascii

15
Yesod/Internal/Dispatch.hs
View File

@ -20,11 +20,11 @@ import Data.Char (toLower)
import qualified Data.ByteString as S import qualified Data.ByteString as S
import Yesod.Core (Yesod (joinPath, approot, cleanPath)) import Yesod.Core (Yesod (joinPath, approot, cleanPath))
import Network.HTTP.Types (status301) import Network.HTTP.Types (status301)
import qualified Data.Ascii as A
import Data.Text (Text) import Data.Text (Text)
import Data.Monoid (mappend) import Data.Monoid (mappend)
import qualified Blaze.ByteString.Builder import qualified Blaze.ByteString.Builder
import qualified Blaze.ByteString.Builder.Char8 import qualified Blaze.ByteString.Builder.Char8
import qualified Data.ByteString.Char8 as S8
{-| {-|
@ -83,15 +83,14 @@ sendRedirect :: Yesod master => master -> [Text] -> W.Application
sendRedirect y segments' env = sendRedirect y segments' env =
return $ W.responseLBS status301 return $ W.responseLBS status301
[ ("Content-Type", "text/plain") [ ("Content-Type", "text/plain")
, ("Location", A.fromAsciiBuilder dest') , ("Location", Blaze.ByteString.Builder.toByteString dest')
] "Redirecting" ] "Redirecting"
where where
dest = joinPath y (A.toAsciiBuilder $ approot y) segments' [] dest = joinPath y (Blaze.ByteString.Builder.fromByteString $ approot y) segments' []
dest' = dest' =
if S.null (W.rawQueryString env) if S.null (W.rawQueryString env)
then dest then dest
else A.unsafeFromBuilder else (dest `mappend`
(A.toBuilder dest `mappend`
Blaze.ByteString.Builder.Char8.fromChar '?' `mappend` Blaze.ByteString.Builder.Char8.fromChar '?' `mappend`
Blaze.ByteString.Builder.fromByteString (W.rawQueryString env)) Blaze.ByteString.Builder.fromByteString (W.rawQueryString env))
@ -154,7 +153,7 @@ mkSimpleExp segments [] frontVars (master, sub, toMasterRoute, mkey, constr, met
onSuccess <- newName "onSuccess" onSuccess <- newName "onSuccess"
req <- newName "req" req <- newName "req"
badMethod' <- [|badMethod|] badMethod' <- [|badMethod|]
rm <- [|A.toString . W.requestMethod|] rm <- [|S8.unpack . W.requestMethod|]
let caseExp = rm `AppE` VarE req let caseExp = rm `AppE` VarE req
yr <- [|yesodRunner|] yr <- [|yesodRunner|]
cr <- [|fmap chooseRep|] cr <- [|fmap chooseRep|]
@ -205,11 +204,11 @@ mkSimpleExp segments (SinglePiece _:pieces) frontVars x = do
fsp <- [|fromSinglePiece|] fsp <- [|fromSinglePiece|]
let exp' = CaseE (fsp `AppE` VarE next) let exp' = CaseE (fsp `AppE` VarE next)
[ Match [ Match
(ConP (mkName "Left") [WildP]) (ConP (mkName "Nothing") [])
(NormalB nothing) (NormalB nothing)
[] []
, Match , Match
(ConP (mkName "Right") [VarP next']) (ConP (mkName "Just") [VarP next'])
(NormalB innerExp) (NormalB innerExp)
[] []
] ]

10
Yesod/Internal/Request.hs
View File

@ -10,8 +10,8 @@ import Yesod.Internal
import qualified Network.Wai as W import qualified Network.Wai as W
import System.Random (randomR, newStdGen) import System.Random (randomR, newStdGen)
import Web.Cookie (parseCookies) import Web.Cookie (parseCookies)
import qualified Data.Ascii as A
import Data.Monoid (mempty) import Data.Monoid (mempty)
import qualified Data.ByteString.Char8 as S8
parseWaiRequest :: W.Request parseWaiRequest :: W.Request
-> [(String, String)] -- ^ session -> [(String, String)] -- ^ session
@ -24,14 +24,14 @@ parseWaiRequest env session' key' = do
$ W.requestHeaders env $ W.requestHeaders env
cookies' = parseCookies reqCookie cookies' = parseCookies reqCookie
acceptLang = lookup "Accept-Language" $ W.requestHeaders env acceptLang = lookup "Accept-Language" $ W.requestHeaders env
langs = map A.toString $ maybe [] NWP.parseHttpAccept acceptLang langs = map S8.unpack $ maybe [] NWP.parseHttpAccept acceptLang
langs' = case lookup (A.toString langKey) session' of langs' = case lookup (S8.unpack langKey) session' of
Nothing -> langs Nothing -> langs
Just x -> x : langs Just x -> x : langs
langs'' = case lookup langKey cookies' of langs'' = case lookup langKey cookies' of
Nothing -> langs' Nothing -> langs'
Just x -> A.toString x : langs' Just x -> S8.unpack x : langs'
langs''' = case lookup (A.toString langKey) gets' of langs''' = case lookup (S8.unpack langKey) gets' of
Nothing -> langs'' Nothing -> langs''
Just x -> x : langs'' Just x -> x : langs''
nonce <- case (key', lookup nonceKey session') of nonce <- case (key', lookup nonceKey session') of

5
Yesod/Internal/Session.hs
View File

@ -8,20 +8,19 @@ import Data.Serialize
import Data.Time import Data.Time
import Data.ByteString (ByteString) import Data.ByteString (ByteString)
import Control.Monad (guard) import Control.Monad (guard)
import qualified Data.Ascii as A
encodeSession :: CS.Key encodeSession :: CS.Key
-> UTCTime -- ^ expire time -> UTCTime -- ^ expire time
-> ByteString -- ^ remote host -> ByteString -- ^ remote host
-> [(String, String)] -- ^ session -> [(String, String)] -- ^ session
-> A.Ascii -- ^ cookie value -> ByteString -- ^ cookie value
encodeSession key expire rhost session' = encodeSession key expire rhost session' =
CS.encrypt key $ encode $ SessionCookie expire rhost session' CS.encrypt key $ encode $ SessionCookie expire rhost session'
decodeSession :: CS.Key decodeSession :: CS.Key
-> UTCTime -- ^ current time -> UTCTime -- ^ current time
-> ByteString -- ^ remote host field -> ByteString -- ^ remote host field
-> A.Ascii -- ^ cookie value -> ByteString -- ^ cookie value
-> Maybe [(String, String)] -> Maybe [(String, String)]
decodeSession key now rhost encrypted = do decodeSession key now rhost encrypted = do
decrypted <- CS.decrypt key encrypted decrypted <- CS.decrypt key encrypted

2
Yesod/Request.hs
View File

@ -43,7 +43,7 @@ import Control.Monad.IO.Class
import Control.Monad (liftM) import Control.Monad (liftM)
import Control.Monad.Instances () -- I'm missing the instance Monad ((->) r import Control.Monad.Instances () -- I'm missing the instance Monad ((->) r
import Data.Maybe (listToMaybe) import Data.Maybe (listToMaybe)
import qualified Data.Ascii as A import qualified Network.HTTP.Types as A
type ParamName = String type ParamName = String
type ParamValue = String type ParamValue = String

16
yesod-core.cabal
View File

@ -33,22 +33,22 @@ library
, bytestring >= 0.9.1.4 && < 0.10 , bytestring >= 0.9.1.4 && < 0.10
, text >= 0.5 && < 0.12 , text >= 0.5 && < 0.12
, template-haskell , template-haskell
, web-routes-quasi >= 0.6.3.1 && < 0.7 , web-routes-quasi >= 0.7 && < 0.8
, hamlet >= 0.7 && < 0.8 , hamlet >= 0.7.3 && < 0.8
, blaze-builder >= 0.2.1 && < 0.3 , blaze-builder >= 0.2.1 && < 0.4
, transformers >= 0.2 && < 0.3 , transformers >= 0.2 && < 0.3
, clientsession >= 0.5 && < 0.6 , clientsession >= 0.6 && < 0.7
, random >= 1.0.0.2 && < 1.1 , random >= 1.0.0.2 && < 1.1
, cereal >= 0.2 && < 0.4 , cereal >= 0.2 && < 0.4
, old-locale >= 1.0.0.2 && < 1.1 , old-locale >= 1.0.0.2 && < 1.1
, failure >= 0.1 && < 0.2 , failure >= 0.1 && < 0.2
, containers >= 0.2 && < 0.5 , containers >= 0.2 && < 0.5
, monad-peel >= 0.1 && < 0.2 , monad-peel >= 0.1 && < 0.2
, enumerator >= 0.4 && < 0.5 , enumerator >= 0.4.7 && < 0.5
, cookie >= 0.1 && < 0.2 , cookie >= 0.2 && < 0.3
, blaze-html >= 0.4 && < 0.5 , blaze-html >= 0.4 && < 0.5
, ascii >= 0.0.2 && < 0.1 , http-types >= 0.6 && < 0.7
, http-types >= 0.5 && < 0.6 , case-insensitive >= 0.2 && < 0.3
exposed-modules: Yesod.Content exposed-modules: Yesod.Content
Yesod.Core Yesod.Core
Yesod.Dispatch Yesod.Dispatch