diff --git a/CodeGen.hs b/CodeGen.hs index 75f1e609..632c2a7c 100644 --- a/CodeGen.hs +++ b/CodeGen.hs @@ -5,14 +5,16 @@ module CodeGen (codegen) where import Language.Haskell.TH.Syntax import Text.ParserCombinators.Parsec -import qualified System.IO.UTF8 as U +import qualified Data.ByteString.Lazy as L +import qualified Data.Text.Lazy as LT +import qualified Data.Text.Lazy.Encoding as LT data Token = VarToken String | LitToken String | EmptyToken codegen :: FilePath -> Q Exp codegen fp = do - s' <- qRunIO $ U.readFile $ "scaffold/" ++ fp ++ ".cg" - let s = init s' + s' <- qRunIO $ L.readFile $ "scaffold/" ++ fp ++ ".cg" + let s = init $ LT.unpack $ LT.decodeUtf8 s' case parse (many parseToken) s s of Left e -> error $ show e Right tokens' -> do diff --git a/Yesod/Content.hs b/Yesod/Content.hs index 75e22d0f..f8af3092 100644 --- a/Yesod/Content.hs +++ b/Yesod/Content.hs @@ -63,7 +63,6 @@ import System.Locale import qualified Data.Text.Encoding import qualified Data.Text.Lazy.Encoding -import qualified Data.ByteString.Lazy.UTF8 #if TEST import Test.Framework (testGroup, Test) @@ -94,7 +93,7 @@ instance ToContent T.Text where instance ToContent Text where toContent = W.ResponseLBS . Data.Text.Lazy.Encoding.encodeUtf8 instance ToContent String where - toContent = W.ResponseLBS . Data.ByteString.Lazy.UTF8.fromString + toContent = toContent . T.pack -- | A function which gives targetted representations of content based on the -- content-types the user accepts. diff --git a/Yesod/Dispatch.hs b/Yesod/Dispatch.hs index 70e514f5..a9105261 100644 --- a/Yesod/Dispatch.hs +++ b/Yesod/Dispatch.hs @@ -52,8 +52,6 @@ import System.Environment (getEnvironment) import qualified Data.ByteString.Char8 as B -import qualified Data.ByteString.UTF8 as S - import Control.Concurrent.MVar import Control.Arrow ((***)) @@ -268,10 +266,10 @@ toWaiApp' y segments env = do (s, hs, ct, c, sessionFinal) <- unYesodApp ya eh rr types let sessionVal = encodeSession key' exp' host sessionFinal let hs' = AddCookie (clientSessionDuration y) sessionName - (S.toString sessionVal) + (bsToChars sessionVal) : hs hs'' = map (headerToPair getExpires) hs' - hs''' = ("Content-Type", S.fromString ct) : hs'' + hs''' = ("Content-Type", charsToBs ct) : hs'' return $ W.Response s hs''' c httpAccept :: W.Request -> [ContentType] @@ -313,13 +311,13 @@ parseWaiRequest :: W.Request -> [(String, String)] -- ^ session -> IO Request parseWaiRequest env session' = do - let gets' = map (S.toString *** S.toString) + let gets' = map (bsToChars *** bsToChars) $ parseQueryString $ W.queryString env let reqCookie = fromMaybe B.empty $ lookup "Cookie" $ W.requestHeaders env - cookies' = map (S.toString *** S.toString) $ parseCookies reqCookie + cookies' = map (bsToChars *** bsToChars) $ parseCookies reqCookie acceptLang = lookup "Accept-Language" $ W.requestHeaders env - langs = map S.toString $ maybe [] parseHttpAccept acceptLang + langs = map bsToChars $ maybe [] parseHttpAccept acceptLang langs' = case lookup langKey session' of Nothing -> langs Just x -> x : langs @@ -334,9 +332,9 @@ parseWaiRequest env session' = do rbHelper :: W.Request -> IO RequestBodyContents rbHelper = fmap (fix1 *** map fix2) . parseRequestBody lbsSink where - fix1 = map (S.toString *** S.toString) + fix1 = map (bsToChars *** bsToChars) fix2 (x, NWP.FileInfo a b c) = - (S.toString x, FileInfo (S.toString a) (S.toString b) c) + (bsToChars x, FileInfo (bsToChars a) (bsToChars b) c) -- | Produces a \"compute on demand\" value. The computation will be run once -- it is requested, and then the result will be stored. This will happen only @@ -357,14 +355,14 @@ headerToPair :: (Int -> UTCTime) -- ^ minutes -> expiration time -> (W.ResponseHeader, B.ByteString) headerToPair getExpires (AddCookie minutes key value) = let expires = getExpires minutes - in ("Set-Cookie", S.fromString + in ("Set-Cookie", charsToBs $ key ++ "=" ++ value ++"; path=/; expires=" ++ formatW3 expires) headerToPair _ (DeleteCookie key) = - ("Set-Cookie", S.fromString $ + ("Set-Cookie", charsToBs $ key ++ "=; path=/; expires=Thu, 01-Jan-1970 00:00:00 GMT") headerToPair _ (Header key value) = - (fromString key, S.fromString value) + (fromString key, charsToBs value) encodeSession :: CS.Key -> UTCTime -- ^ expire time diff --git a/Yesod/Form/Nic.hs b/Yesod/Form/Nic.hs index fa83ffdd..e8a5bc91 100644 --- a/Yesod/Form/Nic.hs +++ b/Yesod/Form/Nic.hs @@ -9,9 +9,10 @@ import Yesod.Handler import Yesod.Form.Core import Yesod.Hamlet import Yesod.Widget -import qualified Data.ByteString.Lazy.UTF8 as U import Text.HTML.SanitizeXSS (sanitizeXSS) +import Yesod.Internal (lbsToChars) + class YesodNic a where -- | NIC Editor. urlNicEdit :: a -> Either (Route a) String @@ -26,7 +27,7 @@ maybeNicHtmlField = optionalFieldHelper nicHtmlFieldProfile nicHtmlFieldProfile :: YesodNic y => FieldProfile sub y Html nicHtmlFieldProfile = FieldProfile { fpParse = Right . preEscapedString . sanitizeXSS - , fpRender = U.toString . renderHtml + , fpRender = lbsToChars . renderHtml , fpWidget = \theId name val _isReq -> do addBody [$hamlet|%textarea.html#$theId$!name=$name$ $val$|] addScript' urlNicEdit diff --git a/Yesod/Form/Profiles.hs b/Yesod/Form/Profiles.hs index 7762ed35..029260bb 100644 --- a/Yesod/Form/Profiles.hs +++ b/Yesod/Form/Profiles.hs @@ -21,7 +21,6 @@ import Yesod.Form.Core import Yesod.Widget import Text.Hamlet import Data.Time (Day, TimeOfDay(..)) -import qualified Data.ByteString.Lazy.UTF8 as U import qualified Text.Email.Validate as Email import Network.URI (parseURI) import Database.Persist (PersistField) @@ -30,6 +29,8 @@ import Text.HTML.SanitizeXSS (sanitizeXSS) import Text.Blaze.Builder.Utf8 (writeChar) import Text.Blaze.Builder.Core (writeList, writeByteString) +import Yesod.Internal (lbsToChars) + intFieldProfile :: Integral i => FieldProfile sub y i intFieldProfile = FieldProfile { fpParse = maybe (Left "Invalid integer") Right . readMayI @@ -74,7 +75,7 @@ timeFieldProfile = FieldProfile htmlFieldProfile :: FieldProfile sub y Html htmlFieldProfile = FieldProfile { fpParse = Right . preEscapedString . sanitizeXSS - , fpRender = U.toString . renderHtml + , fpRender = lbsToChars . renderHtml , fpWidget = \theId name val _isReq -> addBody [$hamlet| %textarea.html#$theId$!name=$name$ $val$ |] diff --git a/Yesod/Handler.hs b/Yesod/Handler.hs index cf15f133..08fa6341 100644 --- a/Yesod/Handler.hs +++ b/Yesod/Handler.hs @@ -98,8 +98,6 @@ import Control.Monad.Trans.Reader import System.IO import qualified Network.Wai as W import Control.Failure (Failure (failure)) -import Data.ByteString.UTF8 (toString) -import qualified Data.ByteString.Lazy.UTF8 as L import Text.Hamlet @@ -362,7 +360,7 @@ msgKey = "_MSG" -- -- See 'getMessage'. setMessage :: Html -> GHandler sub master () -setMessage = setSession msgKey . L.toString . renderHtml +setMessage = setSession msgKey . lbsToChars . renderHtml -- | Gets the message in the user's session, if available, and then clears the -- variable. @@ -392,7 +390,7 @@ notFound = failure NotFound badMethod :: (RequestReader m, Failure ErrorResponse m) => m a badMethod = do w <- waiRequest - failure $ BadMethod $ toString $ W.requestMethod w + failure $ BadMethod $ bsToChars $ W.requestMethod w -- | Return a 403 permission denied page. permissionDenied :: Failure ErrorResponse m => String -> m a diff --git a/Yesod/Internal.hs b/Yesod/Internal.hs index ef66e3f5..97ddbfe3 100644 --- a/Yesod/Internal.hs +++ b/Yesod/Internal.hs @@ -19,12 +19,26 @@ module Yesod.Internal , locationToHamlet , runUniqueList , toUnique + -- * UTF8 helpers + , bsToChars + , lbsToChars + , charsToBs ) where import Text.Hamlet (Hamlet, hamlet, Html) import Data.Monoid (Monoid (..)) import Data.List (nub) +import qualified Data.ByteString as S +import qualified Data.ByteString.Lazy as L + +import qualified Data.Text as T +import qualified Data.Text.Encoding as T +import qualified Data.Text.Encoding.Error as T + +import qualified Data.Text.Lazy as LT +import qualified Data.Text.Lazy.Encoding as LT + -- | Responses to indicate some form of an error occurred. These are different -- from 'SpecialResponse' in that they allow for custom error pages. data ErrorResponse = @@ -71,3 +85,12 @@ newtype Head url = Head (Hamlet url) deriving Monoid newtype Body url = Body (Hamlet url) deriving Monoid + +lbsToChars :: L.ByteString -> String +lbsToChars = LT.unpack . LT.decodeUtf8With T.lenientDecode + +bsToChars :: S.ByteString -> String +bsToChars = T.unpack . T.decodeUtf8With T.lenientDecode + +charsToBs :: String -> S.ByteString +charsToBs = T.encodeUtf8 . T.pack diff --git a/Yesod/Yesod.hs b/Yesod/Yesod.hs index 5762e6d1..0170ea95 100644 --- a/Yesod/Yesod.hs +++ b/Yesod/Yesod.hs @@ -49,7 +49,6 @@ import qualified Network.Wai as W import Yesod.Internal import Web.ClientSession (getKey, defaultKeyFile) import qualified Web.ClientSession as CS -import qualified Data.ByteString.UTF8 as BSU import Database.Persist import Control.Monad.Trans.Class (MonadTrans (..)) import Control.Failure (Failure) @@ -262,7 +261,7 @@ applyLayout' title body = fmap chooseRep $ defaultLayout $ do defaultErrorHandler :: Yesod y => ErrorResponse -> GHandler sub y ChooseRep defaultErrorHandler NotFound = do r <- waiRequest - let path' = BSU.toString $ pathInfo r + let path' = bsToChars $ pathInfo r applyLayout' "Not Found" $ [$hamlet| %h1 Not Found %p $path'$ diff --git a/scaffold.hs b/scaffold.hs index a1d68b6a..36f6deed 100644 --- a/scaffold.hs +++ b/scaffold.hs @@ -6,6 +6,9 @@ import qualified Data.ByteString.Char8 as S import Language.Haskell.TH.Syntax import Data.Time (getCurrentTime, utctDay, toGregorian) import Control.Applicative ((<$>)) +import qualified Data.ByteString.Lazy as L +import qualified Data.Text.Lazy as LT +import qualified Data.Text.Lazy.Encoding as LT main :: IO () main = do @@ -44,7 +47,7 @@ main = do let writeFile' fp s = do putStrLn $ "Generating " ++ fp - writeFile (dir ++ '/' : fp) s + L.writeFile (dir ++ '/' : fp) $ LT.encodeUtf8 $ LT.pack s mkDir fp = createDirectoryIfMissing True $ dir ++ '/' : fp mkDir "Handler" diff --git a/yesod.cabal b/yesod.cabal index 0f6f3228..7dec6e7a 100644 --- a/yesod.cabal +++ b/yesod.cabal @@ -28,7 +28,6 @@ library , bytestring >= 0.9.1.4 && < 0.10 , directory >= 1 && < 1.2 , text >= 0.5 && < 0.10 - , utf8-string >= 0.3.4 && < 0.4 , template-haskell >= 2.4 && < 2.6 , web-routes-quasi >= 0.6 && < 0.7 , hamlet >= 0.5.1 && < 0.6