From 764b981f6c10cfd8868c6b665fecd249220d5df0 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Tue, 26 Jan 2010 00:16:02 +0200 Subject: [PATCH] Changed Content data type. Removed i18n and pushed it back into RawRequest. Now prepared for the WAI interface, though this is less efficient for Hack. --- Yesod/Request.hs | 16 +++++++++++++++- Yesod/Response.hs | 38 +++++++++++++++++++++++++++----------- Yesod/Yesod.hs | 10 +--------- examples/i18n.hs | 22 +++++++++------------- 4 files changed, 52 insertions(+), 34 deletions(-) diff --git a/Yesod/Request.hs b/Yesod/Request.hs index 5e3458b3..64927cc7 100644 --- a/Yesod/Request.hs +++ b/Yesod/Request.hs @@ -28,6 +28,7 @@ module Yesod.Request , cookies , getParams , postParams + , languages -- * Building actual request , Request (..) , Hack.RequestMethod (..) @@ -39,6 +40,7 @@ module Yesod.Request import qualified Hack import Data.Function.Predicate (equals) import Yesod.Parameter +import Yesod.Definitions import Control.Applicative (Applicative (..)) import Web.Encodings import qualified Data.ByteString.Lazy as BL @@ -99,6 +101,9 @@ getParam = genParam getParams GetParam postParam :: (Parameter a) => ParamName -> Request a postParam = genParam postParams PostParam +languages :: (Functor m, RequestReader m) => m [Language] +languages = rawLangs `fmap` getRawRequest + -- | Get the raw 'Hack.Env' value. parseEnv :: (Functor m, RequestReader m) => m Hack.Env parseEnv = rawEnv `fmap` getRawRequest @@ -112,6 +117,7 @@ data RawRequest = RawRequest , rawPostParams :: [(ParamName, ParamValue)] , rawFiles :: [(ParamName, FileInfo String BL.ByteString)] , rawEnv :: Hack.Env + , rawLangs :: [Language] } deriving Show @@ -145,7 +151,15 @@ instance ConvertSuccess Hack.Env RawRequest where $ Hack.hackInput env rawCookie = fromMaybe "" $ lookup "Cookie" $ Hack.http env cookies' = decodeCookies rawCookie :: [(String, String)] - in RawRequest gets' cookies' posts files env + acceptLang = lookup "Accept-Language" $ Hack.http env + langs = maybe [] parseHttpAccept acceptLang + langs' = case lookup langKey cookies' of + Nothing -> langs + Just x -> x : langs + langs'' = case lookup langKey gets' of + Nothing -> langs' + Just x -> x : langs' + in RawRequest gets' cookies' posts files env langs'' #if TEST testSuite :: Test diff --git a/Yesod/Response.hs b/Yesod/Response.hs index 3fb0ba17..645babf5 100644 --- a/Yesod/Response.hs +++ b/Yesod/Response.hs @@ -4,6 +4,7 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE CPP #-} +{-# LANGUAGE Rank2Types #-} --------------------------------------------------------- -- -- Module : Yesod.Response @@ -47,10 +48,12 @@ module Yesod.Response import Data.Time.Clock import Data.Maybe (mapMaybe) -import Data.ByteString.Lazy (ByteString) +import Data.ByteString.Lazy (ByteString, toChunks, fromChunks) +import qualified Data.ByteString as B import Data.Text.Lazy (Text) -import Yesod.Definitions +import qualified Data.Text as T import Data.Object.Json +import Control.Monad (foldM) import Web.Encodings (formatW3) import qualified Hack @@ -67,14 +70,18 @@ import Test.Framework (testGroup, Test) import Web.Mime -newtype Content = Content { unContent :: [Language] -> IO ByteString } +data Content = Content (forall a. ((a -> B.ByteString -> IO a) -> a -> IO a)) -instance ConvertSuccess Text Content where - convertSuccess = Content . const . return . cs +instance ConvertSuccess B.ByteString Content where + convertSuccess bs = Content $ \f a -> f a bs instance ConvertSuccess ByteString Content where - convertSuccess = Content . const . return + convertSuccess lbs = Content $ \f a -> foldM f a $ toChunks lbs +instance ConvertSuccess T.Text Content where + convertSuccess t = cs (cs t :: B.ByteString) +instance ConvertSuccess Text Content where + convertSuccess lt = cs (cs lt :: ByteString) instance ConvertSuccess String Content where - convertSuccess = Content . const . return . cs + convertSuccess s = cs (cs s :: Text) instance ConvertSuccess HtmlDoc Content where convertSuccess = cs . unHtmlDoc instance ConvertSuccess XmlDoc Content where @@ -185,14 +192,23 @@ headerToPair (DeleteCookie key) = return key ++ "=; path=/; expires=Thu, 01-Jan-1970 00:00:00 GMT") headerToPair (Header key value) = return (key, value) -responseToHackResponse :: [String] -- ^ language list - -> Response -> IO Hack.Response -responseToHackResponse ls (Response sc hs ct c) = do +responseToHackResponse :: Response -> IO Hack.Response +responseToHackResponse (Response sc hs ct c) = do hs' <- mapM headerToPair hs let hs'' = ("Content-Type", cs ct) : hs' - asLBS <- unContent c ls + asLBS <- runContent c return $ Hack.Response sc hs'' asLBS +runContent :: Content -> IO ByteString +runContent (Content c) = do + front <- c helper id + return $ fromChunks $ front [] + where + helper :: ([B.ByteString] -> [B.ByteString]) + -> B.ByteString + -> IO ([B.ByteString] -> [B.ByteString]) + helper front bs = return $ front . (:) bs + #if TEST ----- Testing testSuite :: Test diff --git a/Yesod/Yesod.hs b/Yesod/Yesod.hs index 72abfd8b..e77e7864 100644 --- a/Yesod/Yesod.hs +++ b/Yesod/Yesod.hs @@ -101,15 +101,7 @@ toHackApp'' y tg env = do handler = handlers resource verb rr = cs env res <- runHandler handler errorHandler rr y tg types - let acceptLang = lookup "Accept-Language" $ Hack.http env - let langs = maybe [] parseHttpAccept acceptLang - langs' = case lookup langKey $ rawCookies rr of - Nothing -> langs - Just x -> x : langs - langs'' = case lookup langKey $ rawGetParams rr of - Nothing -> langs' - Just x -> x : langs' - responseToHackResponse langs'' res + responseToHackResponse res httpAccept :: Hack.Env -> [ContentType] httpAccept = map TypeOther . parseHttpAccept . fromMaybe "" diff --git a/examples/i18n.hs b/examples/i18n.hs index 6e7cc36f..e393ba2a 100644 --- a/examples/i18n.hs +++ b/examples/i18n.hs @@ -12,23 +12,19 @@ instance Yesod I18N where Get: setLang |] -homepage = return Hello +homepage = do + ls <- languages + let hello = chooseHello ls + return [(TypePlain, cs hello :: Content)] + +chooseHello [] = "Hello" +chooseHello ("he":_) = "שלום" +chooseHello ("es":_) = "Hola" +chooseHello (_:rest) = chooseHello rest setLang lang = do addCookie 1 langKey lang redirect RedirectTemporary "/" return () -data Hello = Hello - -instance HasReps Hello where - chooseRep = defChooseRep - [(TypeHtml, const $ return $ Content $ return . cs . content)] - where - content [] = "Hello" - content ("he":_) = "שלום" - content ("es":_) = "Hola" - content (_:rest) = content rest - - main = putStrLn "Running..." >> toHackApp I18N >>= run 3000