From 9b816aec75fb143a8e8483dd01ac0bcc1156fe90 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Fri, 18 Apr 2014 16:08:57 +0300 Subject: [PATCH 01/35] Scaffolding update --- yesod-bin/hsfiles/mongo.hsfiles | 2 +- yesod-bin/hsfiles/mysql.hsfiles | 2 +- yesod-bin/hsfiles/postgres-fay.hsfiles | 2 +- yesod-bin/hsfiles/postgres.hsfiles | 2 +- yesod-bin/hsfiles/simple.hsfiles | 2 +- yesod-bin/hsfiles/sqlite.hsfiles | 2 +- yesod-bin/yesod-bin.cabal | 2 +- 7 files changed, 7 insertions(+), 7 deletions(-) diff --git a/yesod-bin/hsfiles/mongo.hsfiles b/yesod-bin/hsfiles/mongo.hsfiles index 8f424d7b..c593f816 100644 --- a/yesod-bin/hsfiles/mongo.hsfiles +++ b/yesod-bin/hsfiles/mongo.hsfiles @@ -175,7 +175,7 @@ instance Yesod App where -- Store session data on the client in encrypted cookies, -- default session idle timeout is 120 minutes makeSessionBackend _ = fmap Just $ defaultClientSessionBackend - (120 * 60) -- 120 minutes + 120 -- timeout in minutes "config/client_session_key.aes" defaultLayout widget = do diff --git a/yesod-bin/hsfiles/mysql.hsfiles b/yesod-bin/hsfiles/mysql.hsfiles index 7a0b177a..2fcd2dfe 100644 --- a/yesod-bin/hsfiles/mysql.hsfiles +++ b/yesod-bin/hsfiles/mysql.hsfiles @@ -182,7 +182,7 @@ instance Yesod App where -- Store session data on the client in encrypted cookies, -- default session idle timeout is 120 minutes makeSessionBackend _ = fmap Just $ defaultClientSessionBackend - (120 * 60) -- 120 minutes + 120 -- timeout in minutes "config/client_session_key.aes" defaultLayout widget = do diff --git a/yesod-bin/hsfiles/postgres-fay.hsfiles b/yesod-bin/hsfiles/postgres-fay.hsfiles index 742e852a..934cd676 100644 --- a/yesod-bin/hsfiles/postgres-fay.hsfiles +++ b/yesod-bin/hsfiles/postgres-fay.hsfiles @@ -186,7 +186,7 @@ instance Yesod App where -- Store session data on the client in encrypted cookies, -- default session idle timeout is 120 minutes makeSessionBackend _ = fmap Just $ defaultClientSessionBackend - (120 * 60) -- 120 minutes + 120 -- timeout in minutes "config/client_session_key.aes" defaultLayout widget = do diff --git a/yesod-bin/hsfiles/postgres.hsfiles b/yesod-bin/hsfiles/postgres.hsfiles index b7e09d67..eb743911 100644 --- a/yesod-bin/hsfiles/postgres.hsfiles +++ b/yesod-bin/hsfiles/postgres.hsfiles @@ -182,7 +182,7 @@ instance Yesod App where -- Store session data on the client in encrypted cookies, -- default session idle timeout is 120 minutes makeSessionBackend _ = fmap Just $ defaultClientSessionBackend - (120 * 60) -- 120 minutes + 120 -- timeout in minutes "config/client_session_key.aes" defaultLayout widget = do diff --git a/yesod-bin/hsfiles/simple.hsfiles b/yesod-bin/hsfiles/simple.hsfiles index e6dbc834..f534c98f 100644 --- a/yesod-bin/hsfiles/simple.hsfiles +++ b/yesod-bin/hsfiles/simple.hsfiles @@ -160,7 +160,7 @@ instance Yesod App where -- Store session data on the client in encrypted cookies, -- default session idle timeout is 120 minutes makeSessionBackend _ = fmap Just $ defaultClientSessionBackend - (120 * 60) -- 120 minutes + 120 -- timeout in minutes "config/client_session_key.aes" defaultLayout widget = do diff --git a/yesod-bin/hsfiles/sqlite.hsfiles b/yesod-bin/hsfiles/sqlite.hsfiles index 82913b12..d8caba18 100644 --- a/yesod-bin/hsfiles/sqlite.hsfiles +++ b/yesod-bin/hsfiles/sqlite.hsfiles @@ -182,7 +182,7 @@ instance Yesod App where -- Store session data on the client in encrypted cookies, -- default session idle timeout is 120 minutes makeSessionBackend _ = fmap Just $ defaultClientSessionBackend - (120 * 60) -- 120 minutes + 120 -- timeout in minutes "config/client_session_key.aes" defaultLayout widget = do diff --git a/yesod-bin/yesod-bin.cabal b/yesod-bin/yesod-bin.cabal index 4655034e..cdc360af 100644 --- a/yesod-bin/yesod-bin.cabal +++ b/yesod-bin/yesod-bin.cabal @@ -1,5 +1,5 @@ name: yesod-bin -version: 1.2.8.1 +version: 1.2.8.2 license: MIT license-file: LICENSE author: Michael Snoyman From c3976efea9b74d10eda502b78a54757380f1c870 Mon Sep 17 00:00:00 2001 From: Greg Weber Date: Thu, 2 Jan 2014 11:46:18 -0800 Subject: [PATCH 02/35] make relative css urls absolute --- .../Yesod/EmbeddedStatic/Css/AbsoluteUrl.hs | 70 +++++++ yesod-static/Yesod/EmbeddedStatic/Css/Util.hs | 191 ++++++++++++++++++ yesod-static/yesod-static.cabal | 9 +- 3 files changed, 269 insertions(+), 1 deletion(-) create mode 100644 yesod-static/Yesod/EmbeddedStatic/Css/AbsoluteUrl.hs create mode 100644 yesod-static/Yesod/EmbeddedStatic/Css/Util.hs diff --git a/yesod-static/Yesod/EmbeddedStatic/Css/AbsoluteUrl.hs b/yesod-static/Yesod/EmbeddedStatic/Css/AbsoluteUrl.hs new file mode 100644 index 00000000..f9403482 --- /dev/null +++ b/yesod-static/Yesod/EmbeddedStatic/Css/AbsoluteUrl.hs @@ -0,0 +1,70 @@ +{-# LANGUAGE OverloadedStrings #-} +-- | Manipulate CSS urls. +-- +-- * Make relative urls absolute (useful when combining assets) +module Yesod.EmbeddedStatic.Css.AbsoluteUrl ( + -- * Absolute urls + absoluteUrls + , absoluteUrlsAt + , absoluteUrlsWith +) where + +import Prelude hiding (FilePath) +import Yesod.EmbeddedStatic.Generators +import Yesod.EmbeddedStatic.Types + +import qualified Data.ByteString.Lazy as BL +import qualified Data.Text as T +import qualified Data.Text.Lazy.Encoding as TL +import Control.Monad ((>=>)) +import Data.Maybe (fromMaybe) +import Filesystem.Path.CurrentOS ((), collapse, FilePath, fromText, toText, encodeString, decodeString) + +import Yesod.EmbeddedStatic.Css.Util + +------------------------------------------------------------------------------- +-- Generator +------------------------------------------------------------------------------- + +-- | Anchors relative CSS image urls +createAbsCssUrlsProd :: FilePath -- ^ Anchor relative urls to here + -> FilePath + -> IO BL.ByteString +createAbsCssUrlsProd dir file = do + css <- parseCssUrls file + let r = renderCssWith toAbsoluteUrl css + return $ TL.encodeUtf8 r + where + toAbsoluteUrl (UrlReference rel) = T.concat + [ "url('/" + , (either id id $ toText $ collapse $ dir fromText rel) + , "')" + ] + + +-- | Equivalent to passing the same string twice to 'absoluteUrlsAt'. +absoluteUrls :: FilePath -> Generator +absoluteUrls f = absoluteUrlsAt (encodeString f) f + +-- | Equivalent to passing @return@ to 'absoluteUrlsWith'. +absoluteUrlsAt :: Location -> FilePath -> Generator +absoluteUrlsAt loc f = absoluteUrlsWith loc f Nothing + +-- | Automatically make relative urls absolute +-- +-- During development, leave CSS as is. +-- +-- When CSS is organized into a directory structure, it will work properly for individual requests for each file. +-- During production, we want to combine and minify CSS as much as possible. +-- The combination process combines files from different directories, messing up relative urls. +-- This pre-processor makes relative urls absolute +absoluteUrlsWith :: + Location -- ^ The location the CSS file should appear in the static subsite + -> FilePath -- ^ Path to the CSS file. + -> Maybe (CssGeneration -> IO BL.ByteString) -- ^ Another filter function run after this one (for example @return . yuiCSS . cssContent@) or other CSS filter that runs after this filter. + -> Generator +absoluteUrlsWith loc file mpostFilter = + return [ cssProductionFilter (createAbsCssUrlsProd (decodeString loc) >=> postFilter . mkCssGeneration loc file) loc file + ] + where + postFilter = fromMaybe (return . cssContent) mpostFilter diff --git a/yesod-static/Yesod/EmbeddedStatic/Css/Util.hs b/yesod-static/Yesod/EmbeddedStatic/Css/Util.hs new file mode 100644 index 00000000..70819a54 --- /dev/null +++ b/yesod-static/Yesod/EmbeddedStatic/Css/Util.hs @@ -0,0 +1,191 @@ +{-# LANGUAGE OverloadedStrings, QuasiQuotes, TemplateHaskell, TupleSections, GeneralizedNewtypeDeriving #-} +module Yesod.EmbeddedStatic.Css.Util where + +import Prelude hiding (FilePath) +import Control.Applicative +import Control.Monad (void, foldM) +import Data.Hashable (Hashable) +import Data.Monoid +import Network.Mime (MimeType, defaultMimeLookup) +import Filesystem.Path.CurrentOS (FilePath, directory, (), dropExtension, filename, toText, decodeString, encodeString, fromText) +import Text.CSS.Parse (parseBlocks) +import Language.Haskell.TH (litE, stringL) +import Text.CSS.Render (renderBlocks) +import Yesod.EmbeddedStatic.Types +import Yesod.EmbeddedStatic (pathToName) +import Data.Default (def) + +import qualified Blaze.ByteString.Builder as B +import qualified Blaze.ByteString.Builder.Char.Utf8 as B +import qualified Data.Attoparsec.Text as P +import qualified Data.Attoparsec.ByteString.Lazy as PBL +import qualified Data.ByteString.Lazy as BL +import qualified Data.ByteString.Base64 as B64 +import qualified Data.HashMap.Lazy as M +import qualified Data.Text as T +import qualified Data.Text.Encoding as T +import qualified Data.Text.IO as T +import qualified Data.Text.Lazy as TL +import qualified Data.Text.Lazy.Builder as TL + +------------------------------------------------------------------------------- +-- Loading CSS +------------------------------------------------------------------------------- + +-- | In the parsed CSS, this will be an image reference that we want to replace. +-- the contents will be the filepath. +newtype UrlReference = UrlReference T.Text + deriving (Show, Eq, Hashable, Ord) + +type EithUrl = (T.Text, Either T.Text UrlReference) + +-- | The parsed CSS +type Css = [(T.Text, [EithUrl])] + +-- | Parse the filename out of url('filename') +parseUrl :: P.Parser T.Text +parseUrl = do + P.skipSpace + void $ P.string "url('" + P.takeTill (== '\'') + +checkForUrl :: T.Text -> T.Text -> EithUrl +checkForUrl n@("background-image") v = parseBackgroundImage n v +checkForUrl n@("src") v = parseBackgroundImage n v +checkForUrl n v = (n, Left v) + +-- | Check if a given CSS attribute is a background image referencing a local file +checkForImage :: T.Text -> T.Text -> EithUrl +checkForImage n@("background-image") v = parseBackgroundImage n v +checkForImage n v = (n, Left v) + +parseBackgroundImage :: T.Text -> T.Text -> EithUrl +parseBackgroundImage n v = case P.parseOnly parseUrl v of + Left _ -> (n, Left v) -- Can't parse url + Right url + | "http" `T.isPrefixOf` url -> (n, Left v) + | "/" `T.isPrefixOf` url -> (n, Left v) + | otherwise -> (n, Right $ UrlReference url) + +parseCssWith :: (T.Text -> T.Text -> EithUrl) -> FilePath -> IO Css +parseCssWith urlParser fp = do + mparsed <- parseBlocks <$> T.readFile (encodeString fp) + case mparsed of + Left err -> fail $ "Unable to parse " ++ encodeString fp ++ ": " ++ err + Right blocks -> + return [ (t, map (uncurry urlParser) b) | (t,b) <- blocks ] + +parseCssUrls :: FilePath -> IO Css +parseCssUrls = parseCssWith checkForUrl + +-- | Parse the CSS from the file. If a parse error occurs, a failure is raised (exception) +parseCss :: FilePath -> IO Css +parseCss = parseCssWith checkForImage + +renderCssWith :: (UrlReference -> T.Text) -> Css -> TL.Text +renderCssWith urlRenderer css = + TL.toLazyText $ renderBlocks [(n, map render block) | (n,block) <- css] + where + render (n, Left b) = (n, b) + render (n, Right f) = (n, urlRenderer f) + +-- | Load an image map from the images in the CSS +loadImages :: FilePath -> Css -> (FilePath -> IO (Maybe a)) -> IO (M.HashMap UrlReference a) +loadImages dir css loadImage = foldM load M.empty $ concat [map snd block | (_,block) <- css] + where + load imap (Left _) = return imap + load imap (Right f) | f `M.member` imap = return imap + load imap (Right f@(UrlReference path)) = do + img <- loadImage (dir fromText path) + return $ maybe imap (\i -> M.insert f i imap) img + + +-- | If you tack on additional CSS post-processing filters, they use this as an argument. +data CssGeneration = CssGeneration { + cssContent :: BL.ByteString + , cssStaticLocation :: Location + , cssFileLocation :: FilePath + } + +mkCssGeneration :: Location -> FilePath -> BL.ByteString -> CssGeneration +mkCssGeneration loc file content = + CssGeneration { cssContent = content + , cssStaticLocation = loc + , cssFileLocation = file + } + +cssProductionFilter :: + (FilePath -> IO BL.ByteString) -- ^ a filter to be run on production + -> Location -- ^ The location the CSS file should appear in the static subsite + -> FilePath -- ^ Path to the CSS file. + -> Entry +cssProductionFilter prodFilter loc file = + def { ebHaskellName = Just $ pathToName loc + , ebLocation = loc + , ebMimeType = "text/css" + , ebProductionContent = prodFilter file + , ebDevelReload = [| develPassThrough $(litE (stringL loc)) $(litE (stringL $ encodeString file)) |] + , ebDevelExtraFiles = Nothing + } + +cssProductionImageFilter :: (FilePath -> IO BL.ByteString) -> Location -> FilePath -> Entry +cssProductionImageFilter prodFilter loc file = + (cssProductionFilter prodFilter loc file) + { ebDevelReload = [| develBgImgB64 $(litE (stringL loc)) $(litE (stringL $ encodeString file)) |] + , ebDevelExtraFiles = Just [| develExtraFiles $(litE (stringL loc)) |] + } + +------------------------------------------------------------------------------- +-- Helpers for the generators +------------------------------------------------------------------------------- + +-- For development, all we need to do is update the background-image url to base64 encode it. +-- We want to preserve the formatting (whitespace+newlines) during development so we do not parse +-- using css-parse. Instead we write a simple custom parser. + +parseBackground :: Location -> FilePath -> PBL.Parser B.Builder +parseBackground loc file = do + void $ PBL.string "background-image" + s1 <- PBL.takeWhile (\x -> x == 32 || x == 9) -- space or tab + void $ PBL.word8 58 -- colon + s2 <- PBL.takeWhile (\x -> x == 32 || x == 9) -- space or tab + void $ PBL.string "url('" + url <- PBL.takeWhile (/= 39) -- single quote + void $ PBL.string "')" + + let b64 = B64.encode $ T.encodeUtf8 (either id id $ toText (directory file)) <> url + newUrl = B.fromString (encodeString $ filename $ decodeString loc) <> B.fromString "/" <> B.fromByteString b64 + + return $ B.fromByteString "background-image" + <> B.fromByteString s1 + <> B.fromByteString ":" + <> B.fromByteString s2 + <> B.fromByteString "url('" + <> newUrl + <> B.fromByteString "')" + +parseDev :: Location -> FilePath -> B.Builder -> PBL.Parser B.Builder +parseDev loc file b = do + b' <- parseBackground loc file <|> (B.fromWord8 <$> PBL.anyWord8) + (PBL.endOfInput *> (pure $! b <> b')) <|> (parseDev loc file $! b <> b') + +develPassThrough :: Location -> FilePath -> IO BL.ByteString +develPassThrough _ = BL.readFile . encodeString + +-- | Create the CSS during development +develBgImgB64 :: Location -> FilePath -> IO BL.ByteString +develBgImgB64 loc file = do + ct <- BL.readFile $ encodeString file + case PBL.eitherResult $ PBL.parse (parseDev loc file mempty) ct of + Left err -> error err + Right b -> return $ B.toLazyByteString b + +-- | Serve the extra image files during development +develExtraFiles :: Location -> [T.Text] -> IO (Maybe (MimeType, BL.ByteString)) +develExtraFiles loc parts = + case reverse parts of + (file:dir) | T.pack loc == T.intercalate "/" (reverse dir) -> do + let file' = T.decodeUtf8 $ B64.decodeLenient $ T.encodeUtf8 $ either id id $ toText $ dropExtension $ fromText file + ct <- BL.readFile $ T.unpack file' + return $ Just (defaultMimeLookup file', ct) + _ -> return Nothing diff --git a/yesod-static/yesod-static.cabal b/yesod-static/yesod-static.cabal index 9e1ad67b..85996318 100644 --- a/yesod-static/yesod-static.cabal +++ b/yesod-static/yesod-static.cabal @@ -1,5 +1,5 @@ name: yesod-static -version: 1.2.2.5 +version: 1.2.3 license: MIT license-file: LICENSE author: Michael Snoyman @@ -56,12 +56,19 @@ library , process , async + , attoparsec >= 0.10 + , blaze-builder >= 0.3 + , css-text >= 0.1 + , hashable >= 1.1 + exposed-modules: Yesod.Static Yesod.EmbeddedStatic Yesod.EmbeddedStatic.Generators Yesod.EmbeddedStatic.Types + Yesod.EmbeddedStatic.Css.AbsoluteUrl other-modules: Yesod.EmbeddedStatic.Internal + Yesod.EmbeddedStatic.Css.Util ghc-options: -Wall extensions: TemplateHaskell From a2e979ccda75e817002a5314e0317f0eb5136ace Mon Sep 17 00:00:00 2001 From: Greg Weber Date: Thu, 2 Jan 2014 14:33:53 -0800 Subject: [PATCH 03/35] expose url re-writing function --- .../Yesod/EmbeddedStatic/Css/AbsoluteUrl.hs | 22 +++++++++++----- yesod-static/Yesod/EmbeddedStatic/Css/Util.hs | 25 +++++++++++-------- 2 files changed, 31 insertions(+), 16 deletions(-) diff --git a/yesod-static/Yesod/EmbeddedStatic/Css/AbsoluteUrl.hs b/yesod-static/Yesod/EmbeddedStatic/Css/AbsoluteUrl.hs index f9403482..14b9e9d6 100644 --- a/yesod-static/Yesod/EmbeddedStatic/Css/AbsoluteUrl.hs +++ b/yesod-static/Yesod/EmbeddedStatic/Css/AbsoluteUrl.hs @@ -7,6 +7,8 @@ module Yesod.EmbeddedStatic.Css.AbsoluteUrl ( absoluteUrls , absoluteUrlsAt , absoluteUrlsWith + , absCssUrlsFileProd + , absCssUrlsProd ) where import Prelude hiding (FilePath) @@ -15,6 +17,7 @@ import Yesod.EmbeddedStatic.Types import qualified Data.ByteString.Lazy as BL import qualified Data.Text as T +import qualified Data.Text.IO as T import qualified Data.Text.Lazy.Encoding as TL import Control.Monad ((>=>)) import Data.Maybe (fromMaybe) @@ -27,13 +30,20 @@ import Yesod.EmbeddedStatic.Css.Util ------------------------------------------------------------------------------- -- | Anchors relative CSS image urls -createAbsCssUrlsProd :: FilePath -- ^ Anchor relative urls to here +absCssUrlsFileProd :: FilePath -- ^ Anchor relative urls to here -> FilePath -> IO BL.ByteString -createAbsCssUrlsProd dir file = do - css <- parseCssUrls file - let r = renderCssWith toAbsoluteUrl css - return $ TL.encodeUtf8 r +absCssUrlsFileProd dir file = do + contents <- T.readFile (encodeString file) + return $ absCssUrlsProd dir contents + +absCssUrlsProd :: FilePath -- ^ Anchor relative urls to here + -> T.Text + -> BL.ByteString +absCssUrlsProd dir contents = + let css = either error id $ parseCssUrls contents + r = renderCssWith toAbsoluteUrl css + in TL.encodeUtf8 r where toAbsoluteUrl (UrlReference rel) = T.concat [ "url('/" @@ -64,7 +74,7 @@ absoluteUrlsWith :: -> Maybe (CssGeneration -> IO BL.ByteString) -- ^ Another filter function run after this one (for example @return . yuiCSS . cssContent@) or other CSS filter that runs after this filter. -> Generator absoluteUrlsWith loc file mpostFilter = - return [ cssProductionFilter (createAbsCssUrlsProd (decodeString loc) >=> postFilter . mkCssGeneration loc file) loc file + return [ cssProductionFilter (absCssUrlsFileProd (decodeString loc) >=> postFilter . mkCssGeneration loc file) loc file ] where postFilter = fromMaybe (return . cssContent) mpostFilter diff --git a/yesod-static/Yesod/EmbeddedStatic/Css/Util.hs b/yesod-static/Yesod/EmbeddedStatic/Css/Util.hs index 70819a54..9219cba6 100644 --- a/yesod-static/Yesod/EmbeddedStatic/Css/Util.hs +++ b/yesod-static/Yesod/EmbeddedStatic/Css/Util.hs @@ -67,20 +67,25 @@ parseBackgroundImage n v = case P.parseOnly parseUrl v of | "/" `T.isPrefixOf` url -> (n, Left v) | otherwise -> (n, Right $ UrlReference url) -parseCssWith :: (T.Text -> T.Text -> EithUrl) -> FilePath -> IO Css -parseCssWith urlParser fp = do - mparsed <- parseBlocks <$> T.readFile (encodeString fp) +parseCssWith :: (T.Text -> T.Text -> EithUrl) -> T.Text -> Either String Css +parseCssWith urlParser contents = + let mparsed = parseBlocks contents in case mparsed of - Left err -> fail $ "Unable to parse " ++ encodeString fp ++ ": " ++ err - Right blocks -> - return [ (t, map (uncurry urlParser) b) | (t,b) <- blocks ] + Left err -> Left err + Right blocks -> Right [ (t, map (uncurry urlParser) b) | (t,b) <- blocks ] -parseCssUrls :: FilePath -> IO Css +parseCssUrls :: T.Text -> Either String Css parseCssUrls = parseCssWith checkForUrl --- | Parse the CSS from the file. If a parse error occurs, a failure is raised (exception) -parseCss :: FilePath -> IO Css -parseCss = parseCssWith checkForImage +parseCssFileWith :: (T.Text -> T.Text -> EithUrl) -> FilePath -> IO Css +parseCssFileWith urlParser fp = do + mparsed <- parseCssWith urlParser <$> T.readFile (encodeString fp) + case mparsed of + Left err -> fail $ "Unable to parse " ++ encodeString fp ++ ": " ++ err + Right css -> return css + +parseCssFileUrls :: FilePath -> IO Css +parseCssFileUrls = parseCssFileWith checkForUrl renderCssWith :: (UrlReference -> T.Text) -> Css -> TL.Text renderCssWith urlRenderer css = From 22caf035ef839e9cae2fbeff63df84c08f56167d Mon Sep 17 00:00:00 2001 From: Greg Weber Date: Thu, 2 Jan 2014 14:42:17 -0800 Subject: [PATCH 04/35] absolute url function returns lazy text --- yesod-static/Yesod/EmbeddedStatic/Css/AbsoluteUrl.hs | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/yesod-static/Yesod/EmbeddedStatic/Css/AbsoluteUrl.hs b/yesod-static/Yesod/EmbeddedStatic/Css/AbsoluteUrl.hs index 14b9e9d6..19a9a1fb 100644 --- a/yesod-static/Yesod/EmbeddedStatic/Css/AbsoluteUrl.hs +++ b/yesod-static/Yesod/EmbeddedStatic/Css/AbsoluteUrl.hs @@ -17,6 +17,7 @@ import Yesod.EmbeddedStatic.Types import qualified Data.ByteString.Lazy as BL import qualified Data.Text as T +import qualified Data.Text.Lazy as TL import qualified Data.Text.IO as T import qualified Data.Text.Lazy.Encoding as TL import Control.Monad ((>=>)) @@ -35,15 +36,14 @@ absCssUrlsFileProd :: FilePath -- ^ Anchor relative urls to here -> IO BL.ByteString absCssUrlsFileProd dir file = do contents <- T.readFile (encodeString file) - return $ absCssUrlsProd dir contents + return $ TL.encodeUtf8 $ absCssUrlsProd dir contents absCssUrlsProd :: FilePath -- ^ Anchor relative urls to here -> T.Text - -> BL.ByteString + -> TL.Text absCssUrlsProd dir contents = let css = either error id $ parseCssUrls contents - r = renderCssWith toAbsoluteUrl css - in TL.encodeUtf8 r + in renderCssWith toAbsoluteUrl css where toAbsoluteUrl (UrlReference rel) = T.concat [ "url('/" From 2ea07ed398bd8c8fab81d3e81911a4213451e477 Mon Sep 17 00:00:00 2001 From: Greg Weber Date: Tue, 7 Jan 2014 15:50:37 -0800 Subject: [PATCH 05/35] use latest css-text version --- yesod-static/yesod-static.cabal | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/yesod-static/yesod-static.cabal b/yesod-static/yesod-static.cabal index 85996318..2582a958 100644 --- a/yesod-static/yesod-static.cabal +++ b/yesod-static/yesod-static.cabal @@ -58,7 +58,7 @@ library , attoparsec >= 0.10 , blaze-builder >= 0.3 - , css-text >= 0.1 + , css-text >= 0.1.2 , hashable >= 1.1 exposed-modules: Yesod.Static From bf3e8afefbe9f6b05a6e9848b4b9f720a3517975 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Wed, 23 Apr 2014 16:05:00 +0300 Subject: [PATCH 07/35] Fix some character encoding bugs --- yesod-test/Yesod/Test.hs | 10 +++++----- yesod-test/test/main.hs | 15 +++++++++++++++ yesod-test/yesod-test.cabal | 3 ++- 3 files changed, 22 insertions(+), 6 deletions(-) diff --git a/yesod-test/Yesod/Test.hs b/yesod-test/Yesod/Test.hs index 5e4884a2..ebe37a52 100644 --- a/yesod-test/Yesod/Test.hs +++ b/yesod-test/Yesod/Test.hs @@ -319,7 +319,7 @@ assertNoHeader header = withResponse $ \ SResponse { simpleHeaders = h } -> bodyEquals :: String -> YesodExample site () bodyEquals text = withResponse $ \ res -> liftIO $ HUnit.assertBool ("Expected body to equal " ++ text) $ - (simpleBody res) == BSL8.pack text + (simpleBody res) == encodeUtf8 (TL.pack text) -- | Assert the last response has the given text. The check is performed using the response -- body in full text form. @@ -329,7 +329,7 @@ bodyContains text = withResponse $ \ res -> (simpleBody res) `contains` text contains :: BSL8.ByteString -> String -> Bool -contains a b = DL.isInfixOf b (BSL8.unpack a) +contains a b = DL.isInfixOf b (TL.unpack $ decodeUtf8 a) -- | Queries the html using a css selector, and all matched elements must contain -- the given string. @@ -364,7 +364,7 @@ htmlCount query count = do -- | Outputs the last response body to stderr (So it doesn't get captured by HSpec) printBody :: YesodExample site () printBody = withResponse $ \ SResponse { simpleBody = b } -> - liftIO $ hPutStrLn stderr $ BSL8.unpack b + liftIO $ BSL8.hPutStrLn stderr b -- | Performs a CSS query and print the matches to stderr. printMatches :: Query -> YesodExample site () @@ -539,7 +539,7 @@ request reqBuilder = do , rbdGets = [] , rbdHeaders = [] } - let path = T.cons '/' $ T.intercalate "/" rbdPath + let path = TE.decodeUtf8 $ Builder.toByteString $ H.encodePathSegments rbdPath -- expire cookies and filter them for the current path. TODO: support max age currentUtc <- liftIO getCurrentTime @@ -644,7 +644,7 @@ request reqBuilder = do , remoteHost = Sock.SockAddrInet 1 2 , requestHeaders = headers ++ extraHeaders , rawPathInfo = TE.encodeUtf8 urlPath - , pathInfo = DL.filter (/="") $ T.split (== '/') urlPath + , pathInfo = H.decodePathSegments $ TE.encodeUtf8 urlPath , rawQueryString = H.renderQuery False urlQuery , queryString = urlQuery } diff --git a/yesod-test/test/main.hs b/yesod-test/test/main.hs index 3fd73d3c..d7ec787c 100644 --- a/yesod-test/test/main.hs +++ b/yesod-test/test/main.hs @@ -1,4 +1,5 @@ {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE CPP #-} {-# LANGUAGE MultiParamTypeClasses #-} import Test.HUnit hiding (Test) @@ -13,6 +14,7 @@ import Text.XML import Data.Text (Text) import Data.Monoid ((<>)) import Control.Applicative +import Network.Wai (pathInfo) import Data.ByteString.Lazy.Char8 () import qualified Data.Map as Map @@ -106,6 +108,15 @@ main = hspec $ do addNonce statusIs 200 bodyEquals "12345" + ydescribe "utf8 paths" $ do + yit "from path" $ do + get ("/dynamic1/שלום" :: Text) + statusIs 200 + bodyEquals "שלום" + yit "from WAI" $ do + get ("/dynamic2/שלום" :: Text) + statusIs 200 + bodyEquals "שלום" instance RenderMessage LiteApp FormMessage where renderMessage _ _ = defaultFormMessage @@ -117,6 +128,10 @@ app = liteApp $ do case mfoo of Nothing -> return "Hello world!" Just foo -> return $ "foo=" <> foo + onStatic "dynamic1" $ withDynamic $ \d -> dispatchTo $ return (d :: Text) + onStatic "dynamic2" $ onStatic "שלום" $ dispatchTo $ do + req <- waiRequest + return $ pathInfo req !! 1 onStatic "post" $ dispatchTo $ do mfoo <- lookupPostParam "foo" case mfoo of diff --git a/yesod-test/yesod-test.cabal b/yesod-test/yesod-test.cabal index 26f0b578..c83d1f51 100644 --- a/yesod-test/yesod-test.cabal +++ b/yesod-test/yesod-test.cabal @@ -1,5 +1,5 @@ name: yesod-test -version: 1.2.1.2 +version: 1.2.1.3 license: MIT license-file: LICENSE author: Nubis @@ -59,6 +59,7 @@ test-suite test , yesod-core , yesod-form , text + , wai source-repository head type: git From e9311d0e1f26ee272de512ab7b6c992593a67a34 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Wed, 23 Apr 2014 16:31:13 +0300 Subject: [PATCH 08/35] ToWidget instances for Css, JS --- yesod-core/Yesod/Core/Widget.hs | 18 ++++++++++++++++++ yesod-core/yesod-core.cabal | 2 +- 2 files changed, 19 insertions(+), 1 deletion(-) diff --git a/yesod-core/Yesod/Core/Widget.hs b/yesod-core/Yesod/Core/Widget.hs index a972efad..481199ee 100644 --- a/yesod-core/Yesod/Core/Widget.hs +++ b/yesod-core/Yesod/Core/Widget.hs @@ -83,10 +83,16 @@ instance render ~ RY site => ToWidget site (render -> Html) where toWidget x = tell $ GWData (Body x) mempty mempty mempty mempty mempty mempty instance render ~ RY site => ToWidget site (render -> Css) where toWidget x = toWidget $ CssBuilder . fromLazyText . renderCss . x +instance ToWidget site Css where + toWidget x = toWidget $ CssBuilder . fromLazyText . renderCss . const x instance render ~ RY site => ToWidget site (render -> CssBuilder) where toWidget x = tell $ GWData mempty mempty mempty mempty (Map.singleton Nothing $ unCssBuilder . x) mempty mempty +instance ToWidget site CssBuilder where + toWidget x = tell $ GWData mempty mempty mempty mempty (Map.singleton Nothing $ unCssBuilder . const x) mempty mempty instance render ~ RY site => ToWidget site (render -> Javascript) where toWidget x = tell $ GWData mempty mempty mempty mempty mempty (Just x) mempty +instance ToWidget site Javascript where + toWidget x = tell $ GWData mempty mempty mempty mempty mempty (Just $ const x) mempty instance (site' ~ site, IO ~ m, a ~ ()) => ToWidget site' (WidgetT site m a) where toWidget = liftWidgetT instance ToWidget site Html where @@ -105,8 +111,12 @@ class ToWidgetMedia site a where -> m () instance render ~ RY site => ToWidgetMedia site (render -> Css) where toWidgetMedia media x = toWidgetMedia media $ CssBuilder . fromLazyText . renderCss . x +instance ToWidgetMedia site Css where + toWidgetMedia media x = toWidgetMedia media $ CssBuilder . fromLazyText . renderCss . const x instance render ~ RY site => ToWidgetMedia site (render -> CssBuilder) where toWidgetMedia media x = tell $ GWData mempty mempty mempty mempty (Map.singleton (Just media) $ unCssBuilder . x) mempty mempty +instance ToWidgetMedia site CssBuilder where + toWidgetMedia media x = tell $ GWData mempty mempty mempty mempty (Map.singleton (Just media) $ unCssBuilder . const x) mempty mempty class ToWidgetBody site a where toWidgetBody :: (MonadWidget m, HandlerSite m ~ site) => a -> m () @@ -115,6 +125,8 @@ instance render ~ RY site => ToWidgetBody site (render -> Html) where toWidgetBody = toWidget instance render ~ RY site => ToWidgetBody site (render -> Javascript) where toWidgetBody j = toWidget $ \r -> H.script $ preEscapedLazyText $ renderJavascriptUrl r j +instance ToWidgetBody site Javascript where + toWidgetBody j = toWidget $ \_ -> H.script $ preEscapedLazyText $ renderJavascript j instance ToWidgetBody site Html where toWidgetBody = toWidget @@ -125,10 +137,16 @@ instance render ~ RY site => ToWidgetHead site (render -> Html) where toWidgetHead = tell . GWData mempty mempty mempty mempty mempty mempty . Head instance render ~ RY site => ToWidgetHead site (render -> Css) where toWidgetHead = toWidget +instance ToWidgetHead site Css where + toWidgetHead = toWidget instance render ~ RY site => ToWidgetHead site (render -> CssBuilder) where toWidgetHead = toWidget +instance ToWidgetHead site CssBuilder where + toWidgetHead = toWidget instance render ~ RY site => ToWidgetHead site (render -> Javascript) where toWidgetHead j = toWidgetHead $ \r -> H.script $ preEscapedLazyText $ renderJavascriptUrl r j +instance ToWidgetHead site Javascript where + toWidgetHead j = toWidgetHead $ \_ -> H.script $ preEscapedLazyText $ renderJavascript j instance ToWidgetHead site Html where toWidgetHead = toWidgetHead . const diff --git a/yesod-core/yesod-core.cabal b/yesod-core/yesod-core.cabal index 865ea6a4..0b83db47 100644 --- a/yesod-core/yesod-core.cabal +++ b/yesod-core/yesod-core.cabal @@ -1,5 +1,5 @@ name: yesod-core -version: 1.2.14 +version: 1.2.15 license: MIT license-file: LICENSE author: Michael Snoyman From f43c7fd3e42119c55c2c05af16991c5b8c3817b3 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Thu, 24 Apr 2014 06:38:53 +0300 Subject: [PATCH 09/35] copy-to-port #724 --- yesod-bin/Keter.hs | 5 ++++- yesod-bin/yesod-bin.cabal | 2 +- 2 files changed, 5 insertions(+), 2 deletions(-) diff --git a/yesod-bin/Keter.hs b/yesod-bin/Keter.hs index 8a246509..8093d6f0 100644 --- a/yesod-bin/Keter.hs +++ b/yesod-bin/Keter.hs @@ -62,7 +62,10 @@ keter cabal noBuild = do L.writeFile fp $ compress $ Tar.write archive case Map.lookup "copy-to" value of - Just (String s) -> run "scp" [fp, T.unpack s] + Just (String s) -> + case parseMaybe (.: "copy-to-port") value of + Just i -> run "scp" ["-P" ++ show (i :: Int), fp, T.unpack s] + Nothing -> run "scp" [fp, T.unpack s] _ -> return () try' :: IO a -> IO (Either SomeException a) diff --git a/yesod-bin/yesod-bin.cabal b/yesod-bin/yesod-bin.cabal index cdc360af..17c46606 100644 --- a/yesod-bin/yesod-bin.cabal +++ b/yesod-bin/yesod-bin.cabal @@ -1,5 +1,5 @@ name: yesod-bin -version: 1.2.8.2 +version: 1.2.9 license: MIT license-file: LICENSE author: Michael Snoyman From 99831b52a21b46a3d267804cc58f0a325dd3f8fe Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Thu, 24 Apr 2014 07:14:01 +0300 Subject: [PATCH 10/35] Respect accept header for JSON in devel server #719 --- yesod-bin/Devel.hs | 22 +++++++++++++++------- yesod-bin/yesod-bin.cabal | 1 + 2 files changed, 16 insertions(+), 7 deletions(-) diff --git a/yesod-bin/Devel.hs b/yesod-bin/Devel.hs index aebded89..ecf78cb6 100644 --- a/yesod-bin/Devel.hs +++ b/yesod-bin/Devel.hs @@ -77,9 +77,10 @@ import Network.HTTP.ReverseProxy (ProxyDest (ProxyDest), #if MIN_VERSION_http_reverse_proxy(0, 2, 0) import qualified Network.HTTP.ReverseProxy as ReverseProxy #endif -import Network.HTTP.Types (status200) +import Network.HTTP.Types (status200, status503) import Network.Socket (sClose) -import Network.Wai (responseLBS) +import Network.Wai (responseLBS, requestHeaders) +import Network.Wai.Parse (parseHttpAccept) import Network.Wai.Handler.Warp (run) import SrcLoc (Located) import Data.FileEmbed (embedFile) @@ -135,11 +136,18 @@ reverseProxy opts iappPort = do manager <- newManager def #endif let refreshHtml = LB.fromChunks $ return $(embedFile "refreshing.html") - let onExc _ _ = return $ responseLBS status200 - [ ("content-type", "text/html") - , ("Refresh", "1") - ] - refreshHtml + let onExc _ req + | maybe False (("application/json" `elem`) . parseHttpAccept) + (lookup "accept" $ requestHeaders req) = + return $ responseLBS status503 + [ ("Retry-After", "1") + ] + "{\"message\":\"Recompiling\"}" + | otherwise = return $ responseLBS status200 + [ ("content-type", "text/html") + , ("Refresh", "1") + ] + refreshHtml let runProxy = run (develPort opts) $ waiProxyToSettings diff --git a/yesod-bin/yesod-bin.cabal b/yesod-bin/yesod-bin.cabal index 17c46606..0b4e7bf0 100644 --- a/yesod-bin/yesod-bin.cabal +++ b/yesod-bin/yesod-bin.cabal @@ -91,6 +91,7 @@ executable yesod , transformers , warp >= 1.3.7.5 , wai >= 1.4 + , wai-extra , data-default-class , streaming-commons From c5df0b0bf4f6d7211247d2bba2fc412881b954a3 Mon Sep 17 00:00:00 2001 From: Greg Weber Date: Fri, 25 Apr 2014 07:54:04 -0700 Subject: [PATCH 11/35] check for a colon and slashes after http --- yesod-static/Yesod/EmbeddedStatic/Css/Util.hs | 12 ++++++------ 1 file changed, 6 insertions(+), 6 deletions(-) diff --git a/yesod-static/Yesod/EmbeddedStatic/Css/Util.hs b/yesod-static/Yesod/EmbeddedStatic/Css/Util.hs index 9219cba6..6287eb1e 100644 --- a/yesod-static/Yesod/EmbeddedStatic/Css/Util.hs +++ b/yesod-static/Yesod/EmbeddedStatic/Css/Util.hs @@ -60,12 +60,12 @@ checkForImage n@("background-image") v = parseBackgroundImage n v checkForImage n v = (n, Left v) parseBackgroundImage :: T.Text -> T.Text -> EithUrl -parseBackgroundImage n v = case P.parseOnly parseUrl v of - Left _ -> (n, Left v) -- Can't parse url - Right url - | "http" `T.isPrefixOf` url -> (n, Left v) - | "/" `T.isPrefixOf` url -> (n, Left v) - | otherwise -> (n, Right $ UrlReference url) +parseBackgroundImage n v = (n, case P.parseOnly parseUrl v of + Left _ -> Left v -- Can't parse url + Right url -> + if any (`T.isPrefixOf` url) ["http://", "https://", "/"] + then Left v + else Right $ UrlReference url) parseCssWith :: (T.Text -> T.Text -> EithUrl) -> T.Text -> Either String Css parseCssWith urlParser contents = From 68c02c32896b167590f779e0cba54bd3edabbe84 Mon Sep 17 00:00:00 2001 From: Greg Weber Date: Fri, 25 Apr 2014 11:13:01 -0700 Subject: [PATCH 12/35] version bumpm for 503 json response --- yesod-bin/yesod-bin.cabal | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/yesod-bin/yesod-bin.cabal b/yesod-bin/yesod-bin.cabal index 0b4e7bf0..fa6244f7 100644 --- a/yesod-bin/yesod-bin.cabal +++ b/yesod-bin/yesod-bin.cabal @@ -1,5 +1,5 @@ name: yesod-bin -version: 1.2.9 +version: 1.2.9.1 license: MIT license-file: LICENSE author: Michael Snoyman From 8c183d9cdabd8bc7522fd179160884502dca419c Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Sun, 27 Apr 2014 11:21:43 +0300 Subject: [PATCH 13/35] Another fix for UTF8 paths --- yesod-test/Yesod/Test.hs | 2 +- yesod-test/test/main.hs | 5 +++++ yesod-test/yesod-test.cabal | 2 +- 3 files changed, 7 insertions(+), 2 deletions(-) diff --git a/yesod-test/Yesod/Test.hs b/yesod-test/Yesod/Test.hs index ebe37a52..dad5795f 100644 --- a/yesod-test/Yesod/Test.hs +++ b/yesod-test/Yesod/Test.hs @@ -504,7 +504,7 @@ setUrl url' = do let (urlPath, urlQuery) = T.break (== '?') url ST.modify $ \rbd -> rbd { rbdPath = - case DL.filter (/="") $ T.split (== '/') urlPath of + case DL.filter (/="") $ H.decodePathSegments $ TE.encodeUtf8 urlPath of ("http:":_:rest) -> rest ("https:":_:rest) -> rest x -> x diff --git a/yesod-test/test/main.hs b/yesod-test/test/main.hs index d7ec787c..318148bc 100644 --- a/yesod-test/test/main.hs +++ b/yesod-test/test/main.hs @@ -113,6 +113,11 @@ main = hspec $ do get ("/dynamic1/שלום" :: Text) statusIs 200 bodyEquals "שלום" + yit "from path, type-safe URL" $ do + get $ LiteAppRoute ["dynamic1", "שלום"] + statusIs 200 + printBody + bodyEquals "שלום" yit "from WAI" $ do get ("/dynamic2/שלום" :: Text) statusIs 200 diff --git a/yesod-test/yesod-test.cabal b/yesod-test/yesod-test.cabal index c83d1f51..e1c90492 100644 --- a/yesod-test/yesod-test.cabal +++ b/yesod-test/yesod-test.cabal @@ -1,5 +1,5 @@ name: yesod-test -version: 1.2.1.3 +version: 1.2.1.4 license: MIT license-file: LICENSE author: Nubis From c498c77cc33a40aec436a0a2211df13e25f8c35e Mon Sep 17 00:00:00 2001 From: Greg Weber Date: Sun, 27 Apr 2014 08:23:09 -0700 Subject: [PATCH 14/35] test absolute file paths in a cross-platform way --- yesod-static/Yesod/EmbeddedStatic/Css/Util.hs | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/yesod-static/Yesod/EmbeddedStatic/Css/Util.hs b/yesod-static/Yesod/EmbeddedStatic/Css/Util.hs index 6287eb1e..2b0bd504 100644 --- a/yesod-static/Yesod/EmbeddedStatic/Css/Util.hs +++ b/yesod-static/Yesod/EmbeddedStatic/Css/Util.hs @@ -7,7 +7,7 @@ import Control.Monad (void, foldM) import Data.Hashable (Hashable) import Data.Monoid import Network.Mime (MimeType, defaultMimeLookup) -import Filesystem.Path.CurrentOS (FilePath, directory, (), dropExtension, filename, toText, decodeString, encodeString, fromText) +import Filesystem.Path.CurrentOS (FilePath, directory, (), dropExtension, filename, toText, decodeString, encodeString, fromText, absolute) import Text.CSS.Parse (parseBlocks) import Language.Haskell.TH (litE, stringL) import Text.CSS.Render (renderBlocks) @@ -62,8 +62,8 @@ checkForImage n v = (n, Left v) parseBackgroundImage :: T.Text -> T.Text -> EithUrl parseBackgroundImage n v = (n, case P.parseOnly parseUrl v of Left _ -> Left v -- Can't parse url - Right url -> - if any (`T.isPrefixOf` url) ["http://", "https://", "/"] + Right url -> -- maybe we should find a uri parser + if any (`T.isPrefixOf` url) ["http://", "https://", "//"] || absolute (fromText url) then Left v else Right $ UrlReference url) From 098bff53ecdc55a8093d94d0a96856831f1f35d8 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Wed, 30 Apr 2014 07:40:27 +0300 Subject: [PATCH 15/35] Lower bound on hamlet-1.1.8 for yesod-form #727 --- yesod-form/yesod-form.cabal | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/yesod-form/yesod-form.cabal b/yesod-form/yesod-form.cabal index c69bfdf9..2a0c55ac 100644 --- a/yesod-form/yesod-form.cabal +++ b/yesod-form/yesod-form.cabal @@ -1,5 +1,5 @@ name: yesod-form -version: 1.3.8.2 +version: 1.3.8.3 license: MIT license-file: LICENSE author: Michael Snoyman @@ -17,7 +17,7 @@ library , yesod-core >= 1.2 && < 1.3 , yesod-persistent >= 1.2 && < 1.3 , time >= 1.1.4 - , hamlet >= 1.1 + , hamlet >= 1.1.8 , shakespeare , shakespeare-css >= 1.0 , shakespeare-js >= 1.0.2 From cbbeb3b7f6538eb20518ed976ce0879af71dca56 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Mon, 5 May 2014 21:20:26 +0300 Subject: [PATCH 16/35] exceptions 0.6 --- yesod-core/Yesod/Core/Types.hs | 9 +++++++++ yesod-core/yesod-core.cabal | 2 +- 2 files changed, 10 insertions(+), 1 deletion(-) diff --git a/yesod-core/Yesod/Core/Types.hs b/yesod-core/Yesod/Core/Types.hs index be73cad3..7e3fd0dd 100644 --- a/yesod-core/Yesod/Core/Types.hs +++ b/yesod-core/Yesod/Core/Types.hs @@ -17,6 +17,9 @@ import Control.Exception (Exception) import Control.Monad (liftM, ap) import Control.Monad.Base (MonadBase (liftBase)) import Control.Monad.Catch (MonadCatch (..)) +#if MIN_VERSION_exceptions(0,6,0) +import Control.Monad.Catch (MonadMask (..)) +#endif import Control.Monad.IO.Class (MonadIO (liftIO)) import Control.Monad.Logger (LogLevel, LogSource, MonadLogger (..)) @@ -419,6 +422,9 @@ instance MonadThrow m => MonadThrow (WidgetT site m) where instance MonadCatch m => MonadCatch (HandlerT site m) where catch (HandlerT m) c = HandlerT $ \r -> m r `catch` \e -> unHandlerT (c e) r +#if MIN_VERSION_exceptions(0,6,0) +instance MonadMask m => MonadMask (HandlerT site m) where +#endif mask a = HandlerT $ \e -> mask $ \u -> unHandlerT (a $ q u) e where q u (HandlerT b) = HandlerT (u . b) uninterruptibleMask a = @@ -426,6 +432,9 @@ instance MonadCatch m => MonadCatch (HandlerT site m) where where q u (HandlerT b) = HandlerT (u . b) instance MonadCatch m => MonadCatch (WidgetT site m) where catch (WidgetT m) c = WidgetT $ \r -> m r `catch` \e -> unWidgetT (c e) r +#if MIN_VERSION_exceptions(0,6,0) +instance MonadMask m => MonadMask (WidgetT site m) where +#endif mask a = WidgetT $ \e -> mask $ \u -> unWidgetT (a $ q u) e where q u (WidgetT b) = WidgetT (u . b) uninterruptibleMask a = diff --git a/yesod-core/yesod-core.cabal b/yesod-core/yesod-core.cabal index 0b83db47..c3b35da3 100644 --- a/yesod-core/yesod-core.cabal +++ b/yesod-core/yesod-core.cabal @@ -1,5 +1,5 @@ name: yesod-core -version: 1.2.15 +version: 1.2.15.1 license: MIT license-file: LICENSE author: Michael Snoyman From 60526676e5211136d1db251b62d7a62811dd7268 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Tue, 6 May 2014 08:25:33 +0300 Subject: [PATCH 17/35] Encode empty paths correctly #730 --- yesod-test/Yesod/Test.hs | 4 +++- yesod-test/test/main.hs | 20 ++++++++++++++++++++ yesod-test/yesod-test.cabal | 2 +- 3 files changed, 24 insertions(+), 2 deletions(-) diff --git a/yesod-test/Yesod/Test.hs b/yesod-test/Yesod/Test.hs index dad5795f..2ff05c15 100644 --- a/yesod-test/Yesod/Test.hs +++ b/yesod-test/Yesod/Test.hs @@ -539,7 +539,9 @@ request reqBuilder = do , rbdGets = [] , rbdHeaders = [] } - let path = TE.decodeUtf8 $ Builder.toByteString $ H.encodePathSegments rbdPath + let path + | null rbdPath = "/" + | otherwise = TE.decodeUtf8 $ Builder.toByteString $ H.encodePathSegments rbdPath -- expire cookies and filter them for the current path. TODO: support max age currentUtc <- liftIO getCurrentTime diff --git a/yesod-test/test/main.hs b/yesod-test/test/main.hs index 318148bc..acc83801 100644 --- a/yesod-test/test/main.hs +++ b/yesod-test/test/main.hs @@ -15,6 +15,7 @@ import Data.Text (Text) import Data.Monoid ((<>)) import Control.Applicative import Network.Wai (pathInfo) +import Data.Maybe (fromMaybe) import Data.ByteString.Lazy.Char8 () import qualified Data.Map as Map @@ -122,6 +123,16 @@ main = hspec $ do get ("/dynamic2/שלום" :: Text) statusIs 200 bodyEquals "שלום" + describe "cookies" $ yesodSpec cookieApp $ do + yit "should send the cookie #730" $ do + get ("/" :: Text) + statusIs 200 + post ("/cookie/foo" :: Text) + statusIs 302 + get ("/" :: Text) + statusIs 200 + printBody + bodyContains "Foo" instance RenderMessage LiteApp FormMessage where renderMessage _ _ = defaultFormMessage @@ -151,3 +162,12 @@ app = liteApp $ do case mfoo of FormSuccess (foo, _) -> return $ toHtml foo _ -> defaultLayout widget + +cookieApp :: LiteApp +cookieApp = liteApp $ do + dispatchTo $ fromMaybe "no message available" <$> getMessage + onStatic "cookie" $ do + onStatic "foo" $ dispatchTo $ do + setMessage "Foo" + redirect ("/cookie/home" :: Text) + return () diff --git a/yesod-test/yesod-test.cabal b/yesod-test/yesod-test.cabal index e1c90492..6de95874 100644 --- a/yesod-test/yesod-test.cabal +++ b/yesod-test/yesod-test.cabal @@ -1,5 +1,5 @@ name: yesod-test -version: 1.2.1.4 +version: 1.2.1.5 license: MIT license-file: LICENSE author: Nubis From 9f379bc219bd1fdf008e2c179b03e98a05b36401 Mon Sep 17 00:00:00 2001 From: andrewthad Date: Tue, 6 May 2014 09:34:56 -0400 Subject: [PATCH 18/35] Fix starting field number This commit makes starts the counter as `IntSingle 0` instead of `IntSingle 1`. This is needed because `newFormIdent` yield the incremented state value. Meaning: right now, all of my forms start at f2 instead of f1. This commit will make them start at f1 like I would expect them to. --- yesod-form/Yesod/Form/Functions.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/yesod-form/Yesod/Form/Functions.hs b/yesod-form/Yesod/Form/Functions.hs index 449b1205..6548cc76 100644 --- a/yesod-form/Yesod/Form/Functions.hs +++ b/yesod-form/Yesod/Form/Functions.hs @@ -182,7 +182,7 @@ runFormGeneric :: Monad m -> [Text] -> Maybe (Env, FileEnv) -> m (a, Enctype) -runFormGeneric form site langs env = evalRWST form (env, site, langs) (IntSingle 1) +runFormGeneric form site langs env = evalRWST form (env, site, langs) (IntSingle 0) -- | This function is used to both initially render a form and to later extract -- results from it. Note that, due to CSRF protection and a few other issues, From bd1b5b1ef144b90531d8e6f26386975818f9409c Mon Sep 17 00:00:00 2001 From: Axel Angel Date: Fri, 9 May 2014 00:17:16 +0200 Subject: [PATCH 19/35] Auth.Email: modern buttons, use translation RegisterLong --- yesod-auth/Yesod/Auth/Email.hs | 7 +++++-- 1 file changed, 5 insertions(+), 2 deletions(-) diff --git a/yesod-auth/Yesod/Auth/Email.hs b/yesod-auth/Yesod/Auth/Email.hs index 217ea9e4..ee407344 100644 --- a/yesod-auth/Yesod/Auth/Email.hs +++ b/yesod-auth/Yesod/Auth/Email.hs @@ -250,8 +250,11 @@ $newline never - - I don't have an account +