From ec8edc92f116d39b0f3179d167c9938b367bddc6 Mon Sep 17 00:00:00 2001 From: HugoDaniel Date: Thu, 7 Nov 2013 09:58:34 +0000 Subject: [PATCH 01/56] Listing files into a hsfiles file is now simpler --- yesod-bin/HsFile.hs | 24 ++++++++++++++++++++++++ yesod-bin/main.hs | 8 +++++--- yesod-bin/yesod-bin.cabal | 2 ++ 3 files changed, 31 insertions(+), 3 deletions(-) create mode 100644 yesod-bin/HsFile.hs diff --git a/yesod-bin/HsFile.hs b/yesod-bin/HsFile.hs new file mode 100644 index 00000000..4bc6849b --- /dev/null +++ b/yesod-bin/HsFile.hs @@ -0,0 +1,24 @@ +{-# LANGUAGE TupleSections, OverloadedStrings #-} +module HsFile (mkHsFile) where +import Text.ProjectTemplate (createTemplate) +import Data.Conduit + ( ($$), (=$), runResourceT, ResourceT, ConduitM, awaitForever, yield ) +import Data.Conduit.Filesystem (traverse, sourceFile) +import Prelude hiding (FilePath) +import Filesystem.Path ( FilePath ) +import Filesystem.Path.CurrentOS ( encodeString ) +import qualified Data.ByteString as BS +import Control.Monad.IO.Class (liftIO) + +mkHsFile :: IO () +mkHsFile = runResourceT $ traverse False "." + $$ readIt + =$ createTemplate + =$ awaitForever (liftIO . BS.putStr) + +-- Reads a filepath from upstream and dumps a pair of (filepath, filecontents) +readIt :: ConduitM FilePath (FilePath, ResourceT IO BS.ByteString) (ResourceT IO) () +readIt = awaitForever $ \i -> do bs <- liftIO $ BS.readFile (encodeString i) + yield (i, return bs) + + diff --git a/yesod-bin/main.hs b/yesod-bin/main.hs index f0f4e4b0..caab60a9 100755 --- a/yesod-bin/main.hs +++ b/yesod-bin/main.hs @@ -22,6 +22,7 @@ import Options.Applicative.Types (ReadM (ReadM)) #ifndef WINDOWS import Build (touch) +import HsFile (mkHsFile) touch' :: IO () touch' = touch @@ -45,7 +46,7 @@ data Options = Options } deriving (Show, Eq) -data Command = Init { _initBare :: Bool } +data Command = Init { _initBare, _initHsFiles :: Bool } | Configure | Build { buildExtraArgs :: [String] } | Touch @@ -92,7 +93,7 @@ main = do ] optParser' let cabal xs = rawSystem' (cabalCommand o) xs case optCommand o of - Init bare -> scaffold bare + Init bare hsfiles -> if hsfiles then mkHsFile else scaffold bare Configure -> cabal ["configure"] Build es -> touch' >> cabal ("build":es) Touch -> touch' @@ -113,7 +114,8 @@ optParser = Options <$> flag Cabal CabalDev ( long "dev" <> short 'd' <> help "use cabal-dev" ) <*> switch ( long "verbose" <> short 'v' <> help "More verbose output" ) <*> subparser ( command "init" - (info (Init <$> (switch (long "bare" <> help "Create files in current folder"))) + (info (Init <$> (switch (long "bare" <> help "Create files in current folder")) + <*> (switch (long "hsfiles" <> help "Create a hsfiles file for the current folder"))) (progDesc "Scaffold a new site")) <> command "configure" (info (pure Configure) (progDesc "Configure a project for building")) diff --git a/yesod-bin/yesod-bin.cabal b/yesod-bin/yesod-bin.cabal index b65134b4..05baa09d 100644 --- a/yesod-bin/yesod-bin.cabal +++ b/yesod-bin/yesod-bin.cabal @@ -87,6 +87,7 @@ executable yesod , transformers , warp >= 1.3.7.5 , wai >= 1.4 + , filesystem-conduit >= 1.0 && < 2.0 ghc-options: -Wall -threaded main-is: main.hs @@ -98,6 +99,7 @@ executable yesod AddHandler Paths_yesod_bin Options + HsFile source-repository head type: git From 178a0c8052e341a018351fa7f5d29041892cad84 Mon Sep 17 00:00:00 2001 From: HugoDaniel Date: Thu, 7 Nov 2013 11:15:40 +0000 Subject: [PATCH 02/56] Using CL.map in readIt --- yesod-bin/HsFile.hs | 7 +++---- 1 file changed, 3 insertions(+), 4 deletions(-) diff --git a/yesod-bin/HsFile.hs b/yesod-bin/HsFile.hs index 4bc6849b..29095d85 100644 --- a/yesod-bin/HsFile.hs +++ b/yesod-bin/HsFile.hs @@ -1,8 +1,9 @@ -{-# LANGUAGE TupleSections, OverloadedStrings #-} +{-# LANGUAGE OverloadedStrings #-} module HsFile (mkHsFile) where import Text.ProjectTemplate (createTemplate) import Data.Conduit ( ($$), (=$), runResourceT, ResourceT, ConduitM, awaitForever, yield ) +import qualified Data.Conduit.List as CL import Data.Conduit.Filesystem (traverse, sourceFile) import Prelude hiding (FilePath) import Filesystem.Path ( FilePath ) @@ -18,7 +19,5 @@ mkHsFile = runResourceT $ traverse False "." -- Reads a filepath from upstream and dumps a pair of (filepath, filecontents) readIt :: ConduitM FilePath (FilePath, ResourceT IO BS.ByteString) (ResourceT IO) () -readIt = awaitForever $ \i -> do bs <- liftIO $ BS.readFile (encodeString i) - yield (i, return bs) - +readIt = CL.map $ \i -> (i, liftIO $ BS.readFile $ encodeString i) From b32be57fe85fe8d9c2504279cee29aa0a9f96483 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Mon, 24 Feb 2014 19:02:04 +0200 Subject: [PATCH 03/56] Added widgets benchmark --- .../{widget-benchmark.hs => bench/widget.hs} | 59 ++++++++----------- yesod-core/yesod-core.cabal | 14 +++++ 2 files changed, 38 insertions(+), 35 deletions(-) rename yesod-core/{widget-benchmark.hs => bench/widget.hs} (52%) diff --git a/yesod-core/widget-benchmark.hs b/yesod-core/bench/widget.hs similarity index 52% rename from yesod-core/widget-benchmark.hs rename to yesod-core/bench/widget.hs index 9be4acd8..59b18922 100644 --- a/yesod-core/widget-benchmark.hs +++ b/yesod-core/bench/widget.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE OverloadedStrings #-} -- | BigTable benchmark implemented using Hamlet. -- {-# LANGUAGE QuasiQuotes #-} @@ -7,19 +8,22 @@ import Criterion.Main import Text.Hamlet import Numeric (showInt) import qualified Data.ByteString.Lazy as L -import qualified Text.Blaze.Renderer.Utf8 as Utf8 +import qualified Text.Blaze.Html.Renderer.Utf8 as Utf8 import Data.Monoid (mconcat) import Text.Blaze.Html5 (table, tr, td) -import Yesod.Widget +import Text.Blaze.Html (toHtml) +import Yesod.Core.Widget import Control.Monad.Trans.Writer import Control.Monad.Trans.RWS import Data.Functor.Identity -import Yesod.Internal +import Yesod.Core.Types +import Data.Monoid +import Data.IORef main = defaultMain [ bench "bigTable html" $ nf bigTableHtml bigTableData , bench "bigTable hamlet" $ nf bigTableHamlet bigTableData - , bench "bigTable widget" $ nf bigTableWidget bigTableData + , bench "bigTable widget" $ nfIO (bigTableWidget bigTableData) , bench "bigTable blaze" $ nf bigTableBlaze bigTableData ] where @@ -30,50 +34,35 @@ main = defaultMain bigTableData = replicate rows [1..10] {-# NOINLINE bigTableData #-} -bigTableHtml rows = L.length $ renderHtml [$hamlet| - $forall row <- rows - $forall cell <- row
#{show cell} |] -bigTableHamlet rows = L.length $ renderHamlet id [$hamlet| - $forall row <- rows - $forall cell <- row
#{show cell} |] -bigTableWidget rows = L.length $ renderHtml $ (run [$hamlet| - $forall row <- rows - $forall cell <- row
#{show cell} -|]) (\_ _ -> "foo") +|]) where - run (GWidget w) = - let (_, _, GWData (Body x) _ _ _ _ _ _) = runRWS w () 0 - in x - {- - run (GWidget w) = runIdentity $ do - w' <- flip evalStateT 0 - $ runWriterT $ runWriterT $ runWriterT $ runWriterT - $ runWriterT $ runWriterT $ runWriterT w - let ((((((((), - Body body), - _), - _), - _), - _), - _), - _) = w' + render _ _ = "foo" + run (WidgetT w) = do + (_, GWData { gwdBody = Body x }) <- w undefined + return x - return body - -} - -bigTableBlaze t = L.length $ renderHtml $ table $ mconcat $ map row t +bigTableBlaze t = L.length $ Utf8.renderHtml $ table $ mconcat $ map row t where - row r = tr $ mconcat $ map (td . string . show) r + row r = tr $ mconcat $ map (td . toHtml . show) r diff --git a/yesod-core/yesod-core.cabal b/yesod-core/yesod-core.cabal index 80467d19..557362d8 100644 --- a/yesod-core/yesod-core.cabal +++ b/yesod-core/yesod-core.cabal @@ -125,6 +125,20 @@ test-suite tests ghc-options: -Wall extensions: TemplateHaskell +benchmark widgets + type: exitcode-stdio-1.0 + hs-source-dirs: bench + build-depends: base + , criterion + , bytestring + , text + , hamlet + , transformers + , yesod-core + , blaze-html + main-is: widget.hs + ghc-options: -Wall -O2 + source-repository head type: git location: https://github.com/yesodweb/yesod From 167b29db8dc38121ac27375e4e194977dabb1712 Mon Sep 17 00:00:00 2001 From: arpunk Date: Mon, 24 Feb 2014 23:18:46 -0500 Subject: [PATCH 04/56] Remove deprecated RepHtml content type --- yesod-auth/Yesod/Auth.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/yesod-auth/Yesod/Auth.hs b/yesod-auth/Yesod/Auth.hs index 0fb6dedc..044ba534 100644 --- a/yesod-auth/Yesod/Auth.hs +++ b/yesod-auth/Yesod/Auth.hs @@ -110,7 +110,7 @@ class (Yesod master, PathPiece (AuthId master), RenderMessage master FormMessage authPlugins :: master -> [AuthPlugin master] -- | What to show on the login page. - loginHandler :: AuthHandler master RepHtml + loginHandler :: AuthHandler master Html loginHandler = do tp <- getRouteToParent lift $ authLayout $ do @@ -340,7 +340,7 @@ setUltDestReferer' = lift $ do master <- getYesod when (redirectToReferer master) setUltDestReferer -getLoginR :: AuthHandler master RepHtml +getLoginR :: AuthHandler master Html getLoginR = setUltDestReferer' >> loginHandler getLogoutR :: AuthHandler master () From 71558d3342ed7e00bf01dcd5ac28c9d97087296a Mon Sep 17 00:00:00 2001 From: Felipe Lessa Date: Tue, 25 Feb 2014 19:08:50 -0300 Subject: [PATCH 05/56] Increase Yesod.Auth.Email pwstore strength to the recommended minimum of 14. --- yesod-auth/Yesod/Auth/Email.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/yesod-auth/Yesod/Auth/Email.hs b/yesod-auth/Yesod/Auth/Email.hs index 7270119f..d9cb51e1 100644 --- a/yesod-auth/Yesod/Auth/Email.hs +++ b/yesod-auth/Yesod/Auth/Email.hs @@ -432,7 +432,7 @@ saltLength = 5 -- | Salt a password with a randomly generated salt. saltPass :: Text -> IO Text saltPass = fmap (decodeUtf8With lenientDecode) - . flip PS.makePassword 12 + . flip PS.makePassword 14 . encodeUtf8 saltPass' :: String -> String -> String From 9f7031d9ddd3e5c8026f5da556fa13d98e9812d0 Mon Sep 17 00:00:00 2001 From: Felipe Lessa Date: Tue, 25 Feb 2014 19:10:02 -0300 Subject: [PATCH 06/56] Whitespace. --- yesod-auth/Yesod/Auth/Email.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/yesod-auth/Yesod/Auth/Email.hs b/yesod-auth/Yesod/Auth/Email.hs index d9cb51e1..14c94741 100644 --- a/yesod-auth/Yesod/Auth/Email.hs +++ b/yesod-auth/Yesod/Auth/Email.hs @@ -394,7 +394,7 @@ postPasswordR = do Just aid -> return aid tm <- getRouteToParent - + needOld <- lift $ needOldPassword aid when needOld $ do current <- lift $ runInputPost $ ireq textField "current" From 9e6db27be28d769d5b417a8b145ea8625b6ca81d Mon Sep 17 00:00:00 2001 From: Felipe Lessa Date: Tue, 25 Feb 2014 19:11:44 -0300 Subject: [PATCH 07/56] Sync normalizeEmailAddress' doc to current code. --- yesod-auth/Yesod/Auth/Email.hs | 5 +---- 1 file changed, 1 insertion(+), 4 deletions(-) diff --git a/yesod-auth/Yesod/Auth/Email.hs b/yesod-auth/Yesod/Auth/Email.hs index 14c94741..8ce5e9c7 100644 --- a/yesod-auth/Yesod/Auth/Email.hs +++ b/yesod-auth/Yesod/Auth/Email.hs @@ -174,10 +174,7 @@ class (YesodAuth site, PathPiece (AuthEmailId site)) => YesodAuthEmail site wher -- | Additional normalization of email addresses, besides standard canonicalization. -- - -- Default: do nothing. Note that in future versions of Yesod, the default - -- will change to lower casing the email address. At that point, you will - -- need to either ensure your database values are migrated to lower case, - -- or change this default back to doing nothing. + -- Default: Lower case the email address. -- -- Since 1.2.3 normalizeEmailAddress :: site -> Text -> Text From 6f7e8c8e043247166d9632e691fa48694a4a43fd Mon Sep 17 00:00:00 2001 From: Felipe Lessa Date: Tue, 25 Feb 2014 19:28:09 -0300 Subject: [PATCH 08/56] Allow Yesod.Auth.Email handlers to be overriden. The main purpose is to allow more customization of the Yesod.Auth.Email handlers by not only changing the CSS but also the DOM. --- yesod-auth/Yesod/Auth/Email.hs | 73 +++++++++++++++++++++++++++++++--- 1 file changed, 67 insertions(+), 6 deletions(-) diff --git a/yesod-auth/Yesod/Auth/Email.hs b/yesod-auth/Yesod/Auth/Email.hs index 8ce5e9c7..6acf45ee 100644 --- a/yesod-auth/Yesod/Auth/Email.hs +++ b/yesod-auth/Yesod/Auth/Email.hs @@ -2,6 +2,7 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE PatternGuards #-} +{-# LANGUAGE Rank2Types #-} module Yesod.Auth.Email ( -- * Plugin authEmail @@ -24,6 +25,10 @@ module Yesod.Auth.Email -- * Misc , loginLinkKey , setLoginLinkKey + -- * Default handlers + , defaultRegisterHandler + , defaultForgotPasswordHandler + , defaultSetPasswordHandler ) where import Network.Mail.Mime (randomString) @@ -180,6 +185,43 @@ class (YesodAuth site, PathPiece (AuthEmailId site)) => YesodAuthEmail site wher normalizeEmailAddress :: site -> Text -> Text normalizeEmailAddress _ = TS.toLower + -- | Handler called to render the registration page. The + -- default works fine, but you may want to override it in + -- order to have a different DOM. + -- + -- Default: 'defaultRegisterHandler'. + -- + -- Since: 1.2.6. + registerHandler :: AuthHandler site Html + registerHandler = defaultRegisterHandler + + -- | Handler called to render the \"forgot password\" page. + -- The default works fine, but you may want to override it in + -- order to have a different DOM. + -- + -- Default: 'defaultForgotPasswordHandler'. + -- + -- Since: 1.2.6. + forgotPasswordHandler :: AuthHandler site Html + forgotPasswordHandler = defaultForgotPasswordHandler + + -- | Handler called to render the \"set password\" page. The + -- default works fine, but you may want to override it in + -- order to have a different DOM. + -- + -- Default: 'defaultSetPasswordHandler'. + -- + -- Since: 1.2.6. + setPasswordHandler :: + Bool + -- ^ Whether the old password is needed. If @True@, a + -- field for the old password should be presented. + -- Otherwise, just two fields for the new password are + -- needed. + -> AuthHandler site Html + setPasswordHandler = defaultSetPasswordHandler + + authEmail :: YesodAuthEmail m => AuthPlugin m authEmail = AuthPlugin "email" dispatch $ \tm -> @@ -215,7 +257,13 @@ $newline never dispatch _ _ = notFound getRegisterR :: YesodAuthEmail master => HandlerT Auth (HandlerT master IO) Html -getRegisterR = do +getRegisterR = registerHandler + +-- | Default implementation of 'registerHandler'. +-- +-- Since: 1.2.6 +defaultRegisterHandler :: YesodAuthEmail master => AuthHandler master Html +defaultRegisterHandler = do email <- newIdent tp <- getRouteToParent lift $ authLayout $ do @@ -269,7 +317,13 @@ postRegisterR :: YesodAuthEmail master => HandlerT Auth (HandlerT master IO) Htm postRegisterR = registerHelper False registerR getForgotPasswordR :: YesodAuthEmail master => HandlerT Auth (HandlerT master IO) Html -getForgotPasswordR = do +getForgotPasswordR = forgotPasswordHandler + +-- | Default implementation of 'forgotPasswordHandler'. +-- +-- Since: 1.2.6 +defaultForgotPasswordHandler :: YesodAuthEmail master => AuthHandler master Html +defaultForgotPasswordHandler = do tp <- getRouteToParent email <- newIdent lift $ authLayout $ do @@ -347,14 +401,21 @@ postLoginR = do getPasswordR :: YesodAuthEmail master => HandlerT Auth (HandlerT master IO) Html getPasswordR = do maid <- lift maybeAuthId - pass0 <- newIdent - pass1 <- newIdent - pass2 <- newIdent case maid of Just _ -> return () Nothing -> loginErrorMessageI LoginR Msg.BadSetPass - tp <- getRouteToParent needOld <- maybe (return True) (lift . needOldPassword) maid + setPasswordHandler needOld + +-- | Default implementation of 'setPasswordHandler'. +-- +-- Since: 1.2.6 +defaultSetPasswordHandler :: YesodAuthEmail master => Bool -> AuthHandler master Html +defaultSetPasswordHandler needOld = do + tp <- getRouteToParent + pass0 <- newIdent + pass1 <- newIdent + pass2 <- newIdent lift $ authLayout $ do setTitleI Msg.SetPassTitle [whamlet| From 59d7bc969c0574e03592983926e14a600c16fe95 Mon Sep 17 00:00:00 2001 From: Felipe Lessa Date: Tue, 25 Feb 2014 19:29:33 -0300 Subject: [PATCH 09/56] yesod-auth: Bump version to 1.2.6. --- yesod-auth/yesod-auth.cabal | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/yesod-auth/yesod-auth.cabal b/yesod-auth/yesod-auth.cabal index 059ebd9f..9c1d666d 100644 --- a/yesod-auth/yesod-auth.cabal +++ b/yesod-auth/yesod-auth.cabal @@ -1,5 +1,5 @@ name: yesod-auth -version: 1.2.5.3 +version: 1.2.6 license: MIT license-file: LICENSE author: Michael Snoyman, Patrick Brisbin From 12ddec8b8c33157c0d7751a73c7404d2465c0e4d Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Wed, 26 Feb 2014 07:54:01 +0200 Subject: [PATCH 10/56] Fix pure for AForm #672 --- yesod-form/Yesod/Form/Types.hs | 2 +- yesod-form/yesod-form.cabal | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/yesod-form/Yesod/Form/Types.hs b/yesod-form/Yesod/Form/Types.hs index f5a75008..a5800efb 100644 --- a/yesod-form/Yesod/Form/Types.hs +++ b/yesod-form/Yesod/Form/Types.hs @@ -98,7 +98,7 @@ instance Monad m => Functor (AForm m) where where go (w, x, y, z) = (fmap f w, x, y, z) instance Monad m => Applicative (AForm m) where - pure x = AForm $ const $ const $ \ints -> return (FormSuccess x, mempty, ints, mempty) + pure x = AForm $ const $ const $ \ints -> return (FormSuccess x, id, ints, mempty) (AForm f) <*> (AForm g) = AForm $ \mr env ints -> do (a, b, ints', c) <- f mr env ints (x, y, ints'', z) <- g mr env ints' diff --git a/yesod-form/yesod-form.cabal b/yesod-form/yesod-form.cabal index 8665c89f..98fc12c9 100644 --- a/yesod-form/yesod-form.cabal +++ b/yesod-form/yesod-form.cabal @@ -1,5 +1,5 @@ name: yesod-form -version: 1.3.5.1 +version: 1.3.5.2 license: MIT license-file: LICENSE author: Michael Snoyman From 198e65d222d84135cf4c3e9583c4197a5aa729e1 Mon Sep 17 00:00:00 2001 From: Ian Graves Date: Sat, 1 Mar 2014 14:16:44 -0600 Subject: [PATCH 11/56] Switching to Data.Default.Class in yesod-bin. --- yesod-bin/Devel.hs | 2 +- yesod-bin/yesod-bin.cabal | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/yesod-bin/Devel.hs b/yesod-bin/Devel.hs index 097cc0fb..60890291 100644 --- a/yesod-bin/Devel.hs +++ b/yesod-bin/Devel.hs @@ -69,7 +69,7 @@ import Data.Conduit.Network (HostPreference (HostIPv4 import Network (withSocketsDo) #if MIN_VERSION_http_conduit(2, 0, 0) import Network.HTTP.Conduit (conduitManagerSettings, newManager) -import Data.Default (def) +import Data.Default.Class (def) #else import Network.HTTP.Conduit (def, newManager) #endif diff --git a/yesod-bin/yesod-bin.cabal b/yesod-bin/yesod-bin.cabal index 95fcfa2f..535e48b2 100644 --- a/yesod-bin/yesod-bin.cabal +++ b/yesod-bin/yesod-bin.cabal @@ -89,7 +89,7 @@ executable yesod , transformers , warp >= 1.3.7.5 , wai >= 1.4 - , data-default + , data-default-class ghc-options: -Wall -threaded main-is: main.hs From 2819821b2ee09966341c09d7e625781047b31f8d Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Sun, 2 Mar 2014 07:51:55 +0200 Subject: [PATCH 12/56] Version bump --- 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 535e48b2..71c1967a 100644 --- a/yesod-bin/yesod-bin.cabal +++ b/yesod-bin/yesod-bin.cabal @@ -1,5 +1,5 @@ name: yesod-bin -version: 1.2.6 +version: 1.2.6.1 license: MIT license-file: LICENSE author: Michael Snoyman From f4bbe1cc528149be8c04f8a0aeed4e54294c4c9a Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Sun, 2 Mar 2014 14:30:46 +0200 Subject: [PATCH 13/56] Set content-length whenever evaluating a response body --- yesod-core/Yesod/Core/Internal/Response.hs | 4 +++- .../test/YesodCoreTest/ErrorHandling.hs | 19 +++++++++++++++++++ 2 files changed, 22 insertions(+), 1 deletion(-) diff --git a/yesod-core/Yesod/Core/Internal/Response.hs b/yesod-core/Yesod/Core/Internal/Response.hs index fce9e2e7..73fe107d 100644 --- a/yesod-core/Yesod/Core/Internal/Response.hs +++ b/yesod-core/Yesod/Core/Internal/Response.hs @@ -128,7 +128,9 @@ headerToPair (Header key value) = (CI.mk key, value) evaluateContent :: Content -> IO (Either ErrorResponse Content) evaluateContent (ContentBuilder b mlen) = handle f $ do let lbs = toLazyByteString b - L.length lbs `seq` return (Right $ ContentBuilder (fromLazyByteString lbs) mlen) + len = L.length lbs + mlen' = maybe (Just $ fromIntegral len) Just mlen + len `seq` return (Right $ ContentBuilder (fromLazyByteString lbs) mlen') where f :: SomeException -> IO (Either ErrorResponse Content) f = return . Left . InternalError . T.pack . show diff --git a/yesod-core/test/YesodCoreTest/ErrorHandling.hs b/yesod-core/test/YesodCoreTest/ErrorHandling.hs index 333d2b89..0bb294fb 100644 --- a/yesod-core/test/YesodCoreTest/ErrorHandling.hs +++ b/yesod-core/test/YesodCoreTest/ErrorHandling.hs @@ -13,6 +13,8 @@ import qualified Data.ByteString.Lazy as L import qualified Data.ByteString.Char8 as S8 import Control.Exception (SomeException, try) import Network.HTTP.Types (mkStatus) +import Blaze.ByteString.Builder (Builder, fromByteString, toLazyByteString) +import Data.Monoid (mconcat) data App = App @@ -29,6 +31,8 @@ mkYesod "App" [parseRoutes| /builder BuilderR GET /file-bad-len FileBadLenR GET /file-bad-name FileBadNameR GET + +/good-builder GoodBuilderR GET |] overrideStatus = mkStatus 15 "OVERRIDE" @@ -88,6 +92,12 @@ getFileBadLenR = return $ TypedContent "ignored" $ ContentFile "yesod-core.cabal getFileBadNameR :: Handler TypedContent getFileBadNameR = return $ TypedContent "ignored" $ ContentFile (error "filebadname") Nothing +goodBuilderContent :: Builder +goodBuilderContent = mconcat $ replicate 100 $ fromByteString "This is a test\n" + +getGoodBuilderR :: Handler TypedContent +getGoodBuilderR = return $ TypedContent "text/plain" $ toContent goodBuilderContent + errorHandlingTest :: Spec errorHandlingTest = describe "Test.ErrorHandling" $ do it "says not found" caseNotFound @@ -99,6 +109,7 @@ errorHandlingTest = describe "Test.ErrorHandling" $ do it "builder" caseBuilder it "file with bad len" caseFileBadLen it "file with bad name" caseFileBadName + it "builder includes content-length" caseGoodBuilder runner :: Session () -> IO () runner f = toWaiApp App >>= runSession f @@ -175,3 +186,11 @@ caseFileBadName = runner $ do res <- request defaultRequest { pathInfo = ["file-bad-name"] } assertStatus 500 res assertBodyContains "filebadname" res + +caseGoodBuilder :: IO () +caseGoodBuilder = runner $ do + res <- request defaultRequest { pathInfo = ["good-builder"] } + assertStatus 200 res + let lbs = toLazyByteString goodBuilderContent + assertBody lbs res + assertHeader "content-length" (S8.pack $ show $ L.length lbs) res From a62157097ce0bfa6b65f98df468a5dda4c86ae35 Mon Sep 17 00:00:00 2001 From: Greg Weber Date: Tue, 4 Mar 2014 10:06:56 -0800 Subject: [PATCH 14/56] parseJsonBody_ -> requireJsonBody. closes #678 --- yesod-core/Yesod/Core/Json.hs | 9 ++++++++- 1 file changed, 8 insertions(+), 1 deletion(-) diff --git a/yesod-core/Yesod/Core/Json.hs b/yesod-core/Yesod/Core/Json.hs index d0c0b383..48855b3f 100644 --- a/yesod-core/Yesod/Core/Json.hs +++ b/yesod-core/Yesod/Core/Json.hs @@ -10,6 +10,7 @@ module Yesod.Core.Json -- * Convert to a JSON value , parseJsonBody , parseJsonBody_ + , requireJsonBody -- * Produce JSON values , J.Value (..) @@ -99,7 +100,13 @@ parseJsonBody = do -- | Same as 'parseJsonBody', but return an invalid args response on a parse -- error. parseJsonBody_ :: (MonadHandler m, J.FromJSON a) => m a -parseJsonBody_ = do +parseJsonBody_ = requireJsonBody +{-# DEPRECATED parseJsonBody_ "Use requireJsonBody instead" #-} + +-- | Same as 'parseJsonBody', but return an invalid args response on a parse +-- error. +requireJsonBody :: (MonadHandler m, J.FromJSON a) => m a +requireJsonBody = do ra <- parseJsonBody case ra of J.Error s -> invalidArgs [pack s] From 6182ecb256d64e57137edf8586b057a3f2a6b2d4 Mon Sep 17 00:00:00 2001 From: "Max Cantor (MBPr)" Date: Tue, 4 Mar 2014 14:59:30 -0800 Subject: [PATCH 15/56] Correct Cabal Version and Added createOnClickOverride to BrowserId --- yesod-auth/Yesod/Auth/BrowserId.hs | 17 +++++++++++++---- yesod-auth/yesod-auth.cabal | 2 +- 2 files changed, 14 insertions(+), 5 deletions(-) diff --git a/yesod-auth/Yesod/Auth/BrowserId.hs b/yesod-auth/Yesod/Auth/BrowserId.hs index ee7617b9..8ac5b15b 100644 --- a/yesod-auth/Yesod/Auth/BrowserId.hs +++ b/yesod-auth/Yesod/Auth/BrowserId.hs @@ -4,7 +4,7 @@ {-# LANGUAGE RecordWildCards #-} module Yesod.Auth.BrowserId ( authBrowserId - , createOnClick + , createOnClick, createOnClickOverride , def , BrowserIdSettings , bisAudience @@ -107,14 +107,16 @@ $newline never -- | Generates a function to handle on-click events, and returns that function -- name. -createOnClick :: BrowserIdSettings +createOnClickOverride :: BrowserIdSettings -> (Route Auth -> Route master) + -> Maybe (Route master) -> WidgetT master IO Text -createOnClick BrowserIdSettings {..} toMaster = do +createOnClickOverride BrowserIdSettings {..} toMaster mOnRegistration = do unless bisLazyLoad $ addScriptRemote browserIdJs onclick <- newIdent render <- getUrlRender - let login = toJSON $ getPath $ render (toMaster LoginR) + let login = toJSON $ getPath $ render loginRoute -- (toMaster LoginR) + loginRoute = maybe (toMaster LoginR) id mOnRegistration toWidget [julius| function #{rawJS onclick}() { if (navigator.id) { @@ -152,3 +154,10 @@ createOnClick BrowserIdSettings {..} toMaster = do getPath t = fromMaybe t $ do uri <- parseURI $ T.unpack t return $ T.pack $ uriPath uri + +-- | Generates a function to handle on-click events, and returns that function +-- name. +createOnClick :: BrowserIdSettings + -> (Route Auth -> Route master) + -> WidgetT master IO Text +createOnClick bidSettings toMaster = createOnClickOverride bidSettings toMaster Nothing diff --git a/yesod-auth/yesod-auth.cabal b/yesod-auth/yesod-auth.cabal index 9c1d666d..47461c3c 100644 --- a/yesod-auth/yesod-auth.cabal +++ b/yesod-auth/yesod-auth.cabal @@ -1,5 +1,5 @@ name: yesod-auth -version: 1.2.6 +version: 1.2.7 license: MIT license-file: LICENSE author: Michael Snoyman, Patrick Brisbin From bcff12bed1414418efd1c7b6a2a08d344ccaa2a0 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Wed, 5 Mar 2014 06:59:57 +0200 Subject: [PATCH 16/56] parseHelperGen --- yesod-form/Yesod/Form/Functions.hs | 16 +++++++++++++--- yesod-form/yesod-form.cabal | 2 +- 2 files changed, 14 insertions(+), 4 deletions(-) diff --git a/yesod-form/Yesod/Form/Functions.hs b/yesod-form/Yesod/Form/Functions.hs index 8a36710e..282e57c9 100644 --- a/yesod-form/Yesod/Form/Functions.hs +++ b/yesod-form/Yesod/Form/Functions.hs @@ -39,6 +39,7 @@ module Yesod.Form.Functions -- * Utilities , fieldSettingsLabel , parseHelper + , parseHelperGen ) where import Yesod.Form.Types @@ -428,6 +429,15 @@ fieldSettingsLabel msg = FieldSettings (SomeMessage msg) Nothing Nothing Nothing parseHelper :: (Monad m, RenderMessage site FormMessage) => (Text -> Either FormMessage a) -> [Text] -> [FileInfo] -> m (Either (SomeMessage site) (Maybe a)) -parseHelper _ [] _ = return $ Right Nothing -parseHelper _ ("":_) _ = return $ Right Nothing -parseHelper f (x:_) _ = return $ either (Left . SomeMessage) (Right . Just) $ f x +parseHelper = parseHelperGen + +-- | A generalized version of 'parseHelper', allowing any type for the message +-- indicating a bad parse. +-- +-- Since 1.3.6 +parseHelperGen :: (Monad m, RenderMessage site msg) + => (Text -> Either msg a) + -> [Text] -> [FileInfo] -> m (Either (SomeMessage site) (Maybe a)) +parseHelperGen _ [] _ = return $ Right Nothing +parseHelperGen _ ("":_) _ = return $ Right Nothing +parseHelperGen f (x:_) _ = return $ either (Left . SomeMessage) (Right . Just) $ f x diff --git a/yesod-form/yesod-form.cabal b/yesod-form/yesod-form.cabal index 98fc12c9..21aa9b9d 100644 --- a/yesod-form/yesod-form.cabal +++ b/yesod-form/yesod-form.cabal @@ -1,5 +1,5 @@ name: yesod-form -version: 1.3.5.2 +version: 1.3.6 license: MIT license-file: LICENSE author: Michael Snoyman From a719dee9ba3498942238599fc494d1c615e06ded Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Thu, 6 Mar 2014 07:23:12 +0200 Subject: [PATCH 17/56] warp 2.0.3.3 --- yesod-platform/yesod-platform.cabal | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/yesod-platform/yesod-platform.cabal b/yesod-platform/yesod-platform.cabal index a580a35c..4f3dc86e 100644 --- a/yesod-platform/yesod-platform.cabal +++ b/yesod-platform/yesod-platform.cabal @@ -1,5 +1,5 @@ name: yesod-platform -version: 1.2.7.1 +version: 1.2.7.2 license: MIT license-file: LICENSE author: Michael Snoyman @@ -134,7 +134,7 @@ library , wai-extra == 2.0.3.3 , wai-logger == 2.1.1 , wai-test == 2.0.0.1 - , warp == 2.0.3.2 + , warp == 2.0.3.3 , warp-tls == 2.0.2 , word8 == 0.0.4 , x509 == 1.4.7 From d2745fc277bd30cf905bad36a976bd85ce043910 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Thu, 6 Mar 2014 07:35:05 +0200 Subject: [PATCH 18/56] Separate hsfiles command --- yesod-bin/main.hs | 11 +++++++---- 1 file changed, 7 insertions(+), 4 deletions(-) diff --git a/yesod-bin/main.hs b/yesod-bin/main.hs index 387b2f83..f4db16b6 100755 --- a/yesod-bin/main.hs +++ b/yesod-bin/main.hs @@ -47,7 +47,8 @@ data Options = Options } deriving (Show, Eq) -data Command = Init { _initBare, _initHsFiles :: Bool } +data Command = Init { _initBare :: Bool } + | HsFiles | Configure | Build { buildExtraArgs :: [String] } | Touch @@ -96,7 +97,8 @@ main = do ] optParser' let cabal = rawSystem' (cabalCommand o) case optCommand o of - Init bare hsfiles -> if hsfiles then mkHsFile else scaffold bare + Init bare -> scaffold bare + HsFiles -> mkHsFile Configure -> cabal ["configure"] Build es -> touch' >> cabal ("build":es) Touch -> touch' @@ -125,9 +127,10 @@ optParser = Options <$> flag Cabal CabalDev ( long "dev" <> short 'd' <> help "use cabal-dev" ) <*> switch ( long "verbose" <> short 'v' <> help "More verbose output" ) <*> subparser ( command "init" - (info (Init <$> (switch (long "bare" <> help "Create files in current folder")) - <*> (switch (long "hsfiles" <> help "Create a hsfiles file for the current folder"))) + (info (Init <$> (switch (long "bare" <> help "Create files in current folder"))) (progDesc "Scaffold a new site")) + <> command "hsfiles" (info (pure HsFiles) + (progDesc "Create a hsfiles file for the current folder")) <> command "configure" (info (pure Configure) (progDesc "Configure a project for building")) <> command "build" (info (Build <$> extraCabalArgs) From 11a35799b538847a3c4c246d7e66fa7dff4ddd3d Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Thu, 6 Mar 2014 07:49:21 +0200 Subject: [PATCH 19/56] Version bump --- 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 a39669f9..72d08c1d 100644 --- a/yesod-bin/yesod-bin.cabal +++ b/yesod-bin/yesod-bin.cabal @@ -1,5 +1,5 @@ name: yesod-bin -version: 1.2.6.1 +version: 1.2.7 license: MIT license-file: LICENSE author: Michael Snoyman From 56e42936b0b6378ec2e01c47109646943848fa96 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Thu, 6 Mar 2014 16:34:27 +0200 Subject: [PATCH 20/56] sendRawResponse --- yesod-core/Yesod/Core/Handler.hs | 25 +++++++- yesod-core/Yesod/Core/Internal/Response.hs | 13 +++- yesod-core/test/YesodCoreTest.hs | 2 + yesod-core/test/YesodCoreTest/RawResponse.hs | 62 ++++++++++++++++++++ yesod-core/yesod-core.cabal | 5 +- 5 files changed, 104 insertions(+), 3 deletions(-) create mode 100644 yesod-core/test/YesodCoreTest/RawResponse.hs diff --git a/yesod-core/Yesod/Core/Handler.hs b/yesod-core/Yesod/Core/Handler.hs index 7c561c52..6b72a4d5 100644 --- a/yesod-core/Yesod/Core/Handler.hs +++ b/yesod-core/Yesod/Core/Handler.hs @@ -89,6 +89,9 @@ module Yesod.Core.Handler , sendResponseStatus , sendResponseCreated , sendWaiResponse +#if MIN_VERSION_wai(2, 1, 0) + , sendRawResponse +#endif -- * Different representations -- $representations , selectRep @@ -170,7 +173,7 @@ import qualified Data.ByteString as S import qualified Data.ByteString.Lazy as L import qualified Data.Map as Map -import Data.Conduit (Source) +import Data.Conduit (Source, Sink) import Control.Arrow ((***)) import qualified Data.ByteString.Char8 as S8 import Data.Maybe (mapMaybe) @@ -198,6 +201,9 @@ import Data.CaseInsensitive (CI) #if MIN_VERSION_wai(2, 0, 0) import qualified System.PosixCompat.Files as PC #endif +#if MIN_VERSION_wai(2, 1, 0) +import Control.Monad.Trans.Control (MonadBaseControl, control) +#endif get :: MonadHandler m => m GHState get = liftHandlerT $ HandlerT $ I.readIORef . handlerState @@ -547,6 +553,23 @@ sendResponseCreated url = do sendWaiResponse :: MonadHandler m => W.Response -> m b sendWaiResponse = handlerError . HCWai +#if MIN_VERSION_wai(2, 1, 0) +-- | Send a raw response. This is used for cases such as WebSockets. Requires +-- WAI 2.1 or later, and a web server which supports raw responses (e.g., +-- Warp). +-- +-- Since 1.2.7 +sendRawResponse :: (MonadHandler m, MonadBaseControl IO m) + => (Source IO S8.ByteString -> Sink S8.ByteString IO () -> m ()) + -> m a +sendRawResponse raw = control $ \runInIO -> + runInIO $ sendWaiResponse $ flip W.responseRaw fallback + $ \src sink -> runInIO (raw src sink) >> return () + where + fallback = W.responseLBS H.status500 [("Content-Type", "text/plain")] + "sendRawResponse: backend does not support raw responses" +#endif + -- | Return a 404 not found page. Also denotes no handler available. notFound :: MonadHandler m => m a notFound = hcError NotFound diff --git a/yesod-core/Yesod/Core/Internal/Response.hs b/yesod-core/Yesod/Core/Internal/Response.hs index 73fe107d..3f06ac23 100644 --- a/yesod-core/Yesod/Core/Internal/Response.hs +++ b/yesod-core/Yesod/Core/Internal/Response.hs @@ -47,9 +47,20 @@ yarToResponse (YRWai a) _ _ _ is = case a of ResponseSource s hs w -> return $ ResponseSource s hs $ \f -> w f `finally` closeInternalState is - _ -> do + ResponseBuilder{} -> do closeInternalState is return a + ResponseFile{} -> do + closeInternalState is + return a +#if MIN_VERSION_wai(2, 1, 0) + -- Ignore the fallback provided, in case it refers to a ResourceT state + -- in a ResponseSource. + ResponseRaw raw _ -> return $ ResponseRaw + (\f -> raw f `finally` closeInternalState is) + (responseLBS H.status500 [("Content-Type", "text/plain")] + "yarToResponse: backend does not support raw responses") +#endif #else yarToResponse (YRWai a) _ _ _ = return a #endif diff --git a/yesod-core/test/YesodCoreTest.hs b/yesod-core/test/YesodCoreTest.hs index 60a1cb2e..e0175991 100644 --- a/yesod-core/test/YesodCoreTest.hs +++ b/yesod-core/test/YesodCoreTest.hs @@ -14,6 +14,7 @@ import qualified YesodCoreTest.Redirect as Redirect import qualified YesodCoreTest.JsLoader as JsLoader import qualified YesodCoreTest.RequestBodySize as RequestBodySize import qualified YesodCoreTest.Json as Json +import qualified YesodCoreTest.RawResponse as RawResponse import qualified YesodCoreTest.Streaming as Streaming import qualified YesodCoreTest.Reps as Reps import qualified YesodCoreTest.Auth as Auth @@ -37,6 +38,7 @@ specs = do JsLoader.specs RequestBodySize.specs Json.specs + RawResponse.specs Streaming.specs Reps.specs Auth.specs diff --git a/yesod-core/test/YesodCoreTest/RawResponse.hs b/yesod-core/test/YesodCoreTest/RawResponse.hs new file mode 100644 index 00000000..8b768ca2 --- /dev/null +++ b/yesod-core/test/YesodCoreTest/RawResponse.hs @@ -0,0 +1,62 @@ +{-# LANGUAGE OverloadedStrings, TemplateHaskell, QuasiQuotes, TypeFamilies, MultiParamTypeClasses, ScopedTypeVariables #-} +module YesodCoreTest.RawResponse (specs, Widget) where + +import Yesod.Core +import Test.Hspec +import qualified Data.Map as Map +import Network.Wai.Test +import Data.Text (Text) +import Data.ByteString.Lazy (ByteString) +import qualified Data.Conduit.List as CL +import qualified Data.ByteString.Char8 as S8 +import Data.Conduit +import qualified Data.Conduit.Binary as CB +import Data.Char (toUpper) +import Control.Exception (try, IOException) +import Data.Conduit.Network +import Network.Socket (sClose) +import Control.Concurrent (threadDelay) +import Control.Concurrent.Async (withAsync) +import Control.Monad.Trans.Resource (register) +import Data.IORef + +data App = App + +mkYesod "App" [parseRoutes| +/ HomeR GET +|] + +instance Yesod App + +getHomeR :: Handler () +getHomeR = do + ref <- liftIO $ newIORef 0 + _ <- register $ writeIORef ref 1 + sendRawResponse $ \src sink -> liftIO $ do + val <- readIORef ref + yield (S8.pack $ show val) $$ sink + src $$ CL.map (S8.map toUpper) =$ sink + +getFreePort :: IO Int +getFreePort = do + loop 43124 + where + loop port = do + esocket <- try $ bindPort port "*" + case esocket of + Left (_ :: IOException) -> loop (succ port) + Right socket -> do + sClose socket + return port + +specs :: Spec +specs = describe "RawResponse" $ do + it "works" $ do + port <- getFreePort + withAsync (warp port App) $ \_ -> do + threadDelay 100000 + runTCPClient (clientSettings port "127.0.0.1") $ \ad -> do + yield "GET / HTTP/1.1\r\n\r\nhello" $$ appSink ad + (appSource ad $$ CB.take 6) >>= (`shouldBe` "0HELLO") + yield "WORLd" $$ appSink ad + (appSource ad $$ await) >>= (`shouldBe` Just "WORLD") diff --git a/yesod-core/yesod-core.cabal b/yesod-core/yesod-core.cabal index 557362d8..3bc47dd1 100644 --- a/yesod-core/yesod-core.cabal +++ b/yesod-core/yesod-core.cabal @@ -1,5 +1,5 @@ name: yesod-core -version: 1.2.6.7 +version: 1.2.7 license: MIT license-file: LICENSE author: Michael Snoyman @@ -122,6 +122,9 @@ test-suite tests , containers , lifted-base , resourcet + , network-conduit + , network + , async ghc-options: -Wall extensions: TemplateHaskell From 13976667ed1a1e47e5c5ea982418231b3900706c Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Thu, 6 Mar 2014 18:00:46 +0200 Subject: [PATCH 21/56] Initial yesod-websockets Pinging @gregwebs and @meteficha. Greg: I know you were talking about Sockets.IO support, and Felipe: I thought you might be curious about this relative to yesod-eventsource. Comments welcome :) --- yesod-websockets/LICENSE | 20 +++++++++ yesod-websockets/Setup.hs | 2 + yesod-websockets/Yesod/WebSockets.hs | 60 +++++++++++++++++++++++++ yesod-websockets/sample.hs | 39 ++++++++++++++++ yesod-websockets/yesod-websockets.cabal | 28 ++++++++++++ 5 files changed, 149 insertions(+) create mode 100644 yesod-websockets/LICENSE create mode 100644 yesod-websockets/Setup.hs create mode 100644 yesod-websockets/Yesod/WebSockets.hs create mode 100644 yesod-websockets/sample.hs create mode 100644 yesod-websockets/yesod-websockets.cabal diff --git a/yesod-websockets/LICENSE b/yesod-websockets/LICENSE new file mode 100644 index 00000000..38956985 --- /dev/null +++ b/yesod-websockets/LICENSE @@ -0,0 +1,20 @@ +Copyright (c) 2014 Michael Snoyman, http://www.yesodweb.com/ + +Permission is hereby granted, free of charge, to any person obtaining +a copy of this software and associated documentation files (the +"Software"), to deal in the Software without restriction, including +without limitation the rights to use, copy, modify, merge, publish, +distribute, sublicense, and/or sell copies of the Software, and to +permit persons to whom the Software is furnished to do so, subject to +the following conditions: + +The above copyright notice and this permission notice shall be +included in all copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND +NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE +LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION +OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION +WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. diff --git a/yesod-websockets/Setup.hs b/yesod-websockets/Setup.hs new file mode 100644 index 00000000..9a994af6 --- /dev/null +++ b/yesod-websockets/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/yesod-websockets/Yesod/WebSockets.hs b/yesod-websockets/Yesod/WebSockets.hs new file mode 100644 index 00000000..e8f90c64 --- /dev/null +++ b/yesod-websockets/Yesod/WebSockets.hs @@ -0,0 +1,60 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE MultiParamTypeClasses #-} +module Yesod.WebSockets + ( WebsocketsT + , webSockets + , receiveData + , sendTextData + , sendBinaryData + ) where + +import Control.Monad (when) +import Control.Monad.IO.Class (MonadIO (liftIO)) +import Control.Monad.Trans.Control (control) +import Control.Monad.Trans.Reader (ReaderT (ReaderT, runReaderT)) +import qualified Network.Wai.Handler.WebSockets as WaiWS +import qualified Network.WebSockets as WS +import qualified Yesod.Core as Y + +-- | A transformer for a WebSockets handler. +-- +-- Since 0.1.0 +type WebsocketsT = ReaderT WS.Connection + +-- | Attempt to run a WebSockets handler. This function first checks if the +-- client initiated a WebSockets connection and, if so, runs the provided +-- application, short-circuiting the rest of your handler. If the client did +-- not request a WebSockets connection, the rest of your handler will be called +-- instead. +-- +-- Since 0.1.0 +webSockets :: (Y.MonadBaseControl IO m, Y.MonadHandler m) => WebsocketsT m () -> m () +webSockets inner = do + req <- Y.waiRequest + when (WaiWS.isWebSocketsReq req) $ + Y.sendRawResponse $ \src sink -> control $ \runInIO -> WaiWS.runWebSockets + WS.defaultConnectionOptions + (WaiWS.getRequestHead req) + (\pconn -> do + conn <- WS.acceptRequest pconn + runInIO $ runReaderT inner conn) + src + sink + +-- | Receive a piece of data from the client. +-- +-- Since 0.1.0 +receiveData :: (MonadIO m, WS.WebSocketsData a) => WebsocketsT m a +receiveData = ReaderT $ liftIO . WS.receiveData + +-- | Send a textual messsage to the client. +-- +-- Since 0.1.0 +sendTextData :: (MonadIO m, WS.WebSocketsData a) => a -> WebsocketsT m () +sendTextData x = ReaderT $ liftIO . flip WS.sendTextData x + +-- | Send a binary messsage to the client. +-- +-- Since 0.1.0 +sendBinaryData :: (MonadIO m, WS.WebSocketsData a) => a -> WebsocketsT m () +sendBinaryData x = ReaderT $ liftIO . flip WS.sendBinaryData x diff --git a/yesod-websockets/sample.hs b/yesod-websockets/sample.hs new file mode 100644 index 00000000..86e6630b --- /dev/null +++ b/yesod-websockets/sample.hs @@ -0,0 +1,39 @@ +{-# LANGUAGE QuasiQuotes, TemplateHaskell, TypeFamilies #-} +import Yesod.Core +import Yesod.WebSockets +import qualified Data.Text.Lazy as TL +import Control.Monad (forever) + +data App = App + +instance Yesod App + +mkYesod "App" [parseRoutes| +/ HomeR GET +|] + +getHomeR :: Handler Html +getHomeR = do + webSockets $ forever $ do + msg <- receiveData + sendTextData $ TL.toUpper msg + defaultLayout $ + toWidget + [julius| + var conn = new WebSocket("ws://localhost:3000/"); + conn.onopen = function() { + document.write("

open!

"); + document.write("") + document.getElementById("button").addEventListener("click", function(){ + var msg = prompt("Enter a message for the server"); + conn.send(msg); + }); + conn.send("hello world"); + }; + conn.onmessage = function(e) { + document.write("

" + e.data + "

"); + }; + |] + +main :: IO () +main = warp 3000 App diff --git a/yesod-websockets/yesod-websockets.cabal b/yesod-websockets/yesod-websockets.cabal new file mode 100644 index 00000000..f72ce660 --- /dev/null +++ b/yesod-websockets/yesod-websockets.cabal @@ -0,0 +1,28 @@ +-- Initial yesod-websockets.cabal generated by cabal init. For further +-- documentation, see http://haskell.org/cabal/users-guide/ + +name: yesod-websockets +version: 0.1.0.0 +synopsis: WebSockets support for Yesod +description: WebSockets support for Yesod +homepage: https://github.com/yesodweb/yesod +license: MIT +license-file: LICENSE +author: Michael Snoyman +maintainer: michael@snoyman.com +category: Web +build-type: Simple +cabal-version: >=1.8 + +library + exposed-modules: Yesod.WebSockets + build-depends: base >= 4.5 && < 5 + , wai-websockets >= 2.1 + , websockets >= 0.8 + , transformers >= 0.2 + , yesod-core >= 1.2.7 + , monad-control >= 0.3 + +source-repository head + type: git + location: https://github.com/yesodweb/yesod From 0a2c3a1d7a8851d0949ce3d320c0068a03d07e83 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Fri, 7 Mar 2014 07:15:30 +0200 Subject: [PATCH 22/56] Updated gitignore --- .gitignore | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/.gitignore b/.gitignore index 205ace6b..9c3ee276 100644 --- a/.gitignore +++ b/.gitignore @@ -10,8 +10,8 @@ yesod/foobar/ .cabal-sandbox/ cabal.sandbox.config /vendor/ -/.shelly/ -/tarballs/ +.shelly/ +tarballs/ *.swp dist client_session_key.aes From 15b509fcab47f986e5bf3ade3389345396b7893c Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Fri, 7 Mar 2014 07:19:24 +0200 Subject: [PATCH 23/56] Added conduit API --- yesod-websockets/Yesod/WebSockets.hs | 29 +++++++++++++++++++++++-- yesod-websockets/yesod-websockets.cabal | 1 + 2 files changed, 28 insertions(+), 2 deletions(-) diff --git a/yesod-websockets/Yesod/WebSockets.hs b/yesod-websockets/Yesod/WebSockets.hs index e8f90c64..0750dd57 100644 --- a/yesod-websockets/Yesod/WebSockets.hs +++ b/yesod-websockets/Yesod/WebSockets.hs @@ -1,17 +1,24 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE MultiParamTypeClasses #-} module Yesod.WebSockets - ( WebsocketsT + ( -- * Core API + WebsocketsT , webSockets , receiveData , sendTextData , sendBinaryData + -- * Conduit API + , sourceWS + , sinkWSText + , sinkWSBinary ) where -import Control.Monad (when) +import Control.Monad (when, forever) import Control.Monad.IO.Class (MonadIO (liftIO)) import Control.Monad.Trans.Control (control) import Control.Monad.Trans.Reader (ReaderT (ReaderT, runReaderT)) +import qualified Data.Conduit as C +import qualified Data.Conduit.List as CL import qualified Network.Wai.Handler.WebSockets as WaiWS import qualified Network.WebSockets as WS import qualified Yesod.Core as Y @@ -58,3 +65,21 @@ sendTextData x = ReaderT $ liftIO . flip WS.sendTextData x -- Since 0.1.0 sendBinaryData :: (MonadIO m, WS.WebSocketsData a) => a -> WebsocketsT m () sendBinaryData x = ReaderT $ liftIO . flip WS.sendBinaryData x + +-- | A @Source@ of WebSockets data from the user. +-- +-- Since 0.1.0 +sourceWS :: (MonadIO m, WS.WebSocketsData a) => C.Producer (WebsocketsT m) a +sourceWS = forever $ Y.lift receiveData >>= C.yield + +-- | A @Sink@ for sending textual data to the user. +-- +-- Since 0.1.0 +sinkWSText :: (MonadIO m, WS.WebSocketsData a) => C.Consumer a (WebsocketsT m) () +sinkWSText = CL.mapM_ sendTextData + +-- | A @Sink@ for sending binary data to the user. +-- +-- Since 0.1.0 +sinkWSBinary :: (MonadIO m, WS.WebSocketsData a) => C.Consumer a (WebsocketsT m) () +sinkWSBinary = CL.mapM_ sendBinaryData diff --git a/yesod-websockets/yesod-websockets.cabal b/yesod-websockets/yesod-websockets.cabal index f72ce660..c47b8c86 100644 --- a/yesod-websockets/yesod-websockets.cabal +++ b/yesod-websockets/yesod-websockets.cabal @@ -22,6 +22,7 @@ library , transformers >= 0.2 , yesod-core >= 1.2.7 , monad-control >= 0.3 + , conduit >= 1.0.15.1 source-repository head type: git From 065c1887ad1d1aac01d3f2a282785bc08399456a Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Fri, 7 Mar 2014 07:19:51 +0200 Subject: [PATCH 24/56] WebsocketsT ==> WebSocketsT --- yesod-websockets/Yesod/WebSockets.hs | 18 +++++++++--------- 1 file changed, 9 insertions(+), 9 deletions(-) diff --git a/yesod-websockets/Yesod/WebSockets.hs b/yesod-websockets/Yesod/WebSockets.hs index 0750dd57..a08e644b 100644 --- a/yesod-websockets/Yesod/WebSockets.hs +++ b/yesod-websockets/Yesod/WebSockets.hs @@ -2,7 +2,7 @@ {-# LANGUAGE MultiParamTypeClasses #-} module Yesod.WebSockets ( -- * Core API - WebsocketsT + WebSocketsT , webSockets , receiveData , sendTextData @@ -26,7 +26,7 @@ import qualified Yesod.Core as Y -- | A transformer for a WebSockets handler. -- -- Since 0.1.0 -type WebsocketsT = ReaderT WS.Connection +type WebSocketsT = ReaderT WS.Connection -- | Attempt to run a WebSockets handler. This function first checks if the -- client initiated a WebSockets connection and, if so, runs the provided @@ -35,7 +35,7 @@ type WebsocketsT = ReaderT WS.Connection -- instead. -- -- Since 0.1.0 -webSockets :: (Y.MonadBaseControl IO m, Y.MonadHandler m) => WebsocketsT m () -> m () +webSockets :: (Y.MonadBaseControl IO m, Y.MonadHandler m) => WebSocketsT m () -> m () webSockets inner = do req <- Y.waiRequest when (WaiWS.isWebSocketsReq req) $ @@ -51,35 +51,35 @@ webSockets inner = do -- | Receive a piece of data from the client. -- -- Since 0.1.0 -receiveData :: (MonadIO m, WS.WebSocketsData a) => WebsocketsT m a +receiveData :: (MonadIO m, WS.WebSocketsData a) => WebSocketsT m a receiveData = ReaderT $ liftIO . WS.receiveData -- | Send a textual messsage to the client. -- -- Since 0.1.0 -sendTextData :: (MonadIO m, WS.WebSocketsData a) => a -> WebsocketsT m () +sendTextData :: (MonadIO m, WS.WebSocketsData a) => a -> WebSocketsT m () sendTextData x = ReaderT $ liftIO . flip WS.sendTextData x -- | Send a binary messsage to the client. -- -- Since 0.1.0 -sendBinaryData :: (MonadIO m, WS.WebSocketsData a) => a -> WebsocketsT m () +sendBinaryData :: (MonadIO m, WS.WebSocketsData a) => a -> WebSocketsT m () sendBinaryData x = ReaderT $ liftIO . flip WS.sendBinaryData x -- | A @Source@ of WebSockets data from the user. -- -- Since 0.1.0 -sourceWS :: (MonadIO m, WS.WebSocketsData a) => C.Producer (WebsocketsT m) a +sourceWS :: (MonadIO m, WS.WebSocketsData a) => C.Producer (WebSocketsT m) a sourceWS = forever $ Y.lift receiveData >>= C.yield -- | A @Sink@ for sending textual data to the user. -- -- Since 0.1.0 -sinkWSText :: (MonadIO m, WS.WebSocketsData a) => C.Consumer a (WebsocketsT m) () +sinkWSText :: (MonadIO m, WS.WebSocketsData a) => C.Consumer a (WebSocketsT m) () sinkWSText = CL.mapM_ sendTextData -- | A @Sink@ for sending binary data to the user. -- -- Since 0.1.0 -sinkWSBinary :: (MonadIO m, WS.WebSocketsData a) => C.Consumer a (WebsocketsT m) () +sinkWSBinary :: (MonadIO m, WS.WebSocketsData a) => C.Consumer a (WebSocketsT m) () sinkWSBinary = CL.mapM_ sendBinaryData From f1ca43e7c60c070f09dd847bc23ecb32e7cfa32f Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Fri, 7 Mar 2014 07:34:00 +0200 Subject: [PATCH 25/56] Include async helpers --- yesod-websockets/Yesod/WebSockets.hs | 41 ++++++++++++++++++++++++- yesod-websockets/sample.hs | 16 ++++++++-- yesod-websockets/yesod-websockets.cabal | 1 + 3 files changed, 54 insertions(+), 4 deletions(-) diff --git a/yesod-websockets/Yesod/WebSockets.hs b/yesod-websockets/Yesod/WebSockets.hs index a08e644b..eebe9202 100644 --- a/yesod-websockets/Yesod/WebSockets.hs +++ b/yesod-websockets/Yesod/WebSockets.hs @@ -11,11 +11,18 @@ module Yesod.WebSockets , sourceWS , sinkWSText , sinkWSBinary + -- * Async helpers + , race + , race_ + , concurrently + , concurrently_ ) where -import Control.Monad (when, forever) +import qualified Control.Concurrent.Async as A +import Control.Monad (forever, void, when) import Control.Monad.IO.Class (MonadIO (liftIO)) import Control.Monad.Trans.Control (control) +import Control.Monad.Trans.Control (MonadBaseControl (liftBaseWith, restoreM)) import Control.Monad.Trans.Reader (ReaderT (ReaderT, runReaderT)) import qualified Data.Conduit as C import qualified Data.Conduit.List as CL @@ -83,3 +90,35 @@ sinkWSText = CL.mapM_ sendTextData -- Since 0.1.0 sinkWSBinary :: (MonadIO m, WS.WebSocketsData a) => C.Consumer a (WebSocketsT m) () sinkWSBinary = CL.mapM_ sendBinaryData + +-- | Generalized version of 'A.race'. +-- +-- Since 0.1.0 +race :: MonadBaseControl IO m => m a -> m b -> m (Either a b) +race x y = liftBaseWith (\run -> A.race (run x) (run y)) + >>= either (fmap Left . restoreM) (fmap Right . restoreM) + +-- | Generalized version of 'A.race_'. +-- +-- Since 0.1.0 +race_ :: MonadBaseControl IO m => m a -> m b -> m () +race_ x y = void $ race x y + +-- | Generalized version of 'A.concurrently'. Note that if your underlying +-- monad has some kind of mutable state, the state from the second action will +-- overwrite the state from the first. +-- +-- Since 0.1.0 +concurrently :: MonadBaseControl IO m => m a -> m b -> m (a, b) +concurrently x y = do + (resX, resY) <- liftBaseWith $ \run -> A.concurrently (run x) (run y) + x' <- restoreM resX + y' <- restoreM resY + return (x', y') + +-- | Run two actions concurrently (like 'A.concurrently'), but discard their +-- results and any modified monadic state. +-- +-- Since 0.1.0 +concurrently_ :: MonadBaseControl IO m => m a -> m b -> m () +concurrently_ x y = void $ liftBaseWith $ \run -> A.concurrently (run x) (run y) diff --git a/yesod-websockets/sample.hs b/yesod-websockets/sample.hs index 86e6630b..e369a99e 100644 --- a/yesod-websockets/sample.hs +++ b/yesod-websockets/sample.hs @@ -3,6 +3,10 @@ import Yesod.Core import Yesod.WebSockets import qualified Data.Text.Lazy as TL import Control.Monad (forever) +import Control.Monad.Trans.Reader +import Control.Concurrent (threadDelay) +import Data.Time +import Conduit data App = App @@ -12,11 +16,17 @@ mkYesod "App" [parseRoutes| / HomeR GET |] +timeSource :: MonadIO m => Source m TL.Text +timeSource = forever $ do + now <- liftIO getCurrentTime + yield $ TL.pack $ show now + liftIO $ threadDelay 5000000 + getHomeR :: Handler Html getHomeR = do - webSockets $ forever $ do - msg <- receiveData - sendTextData $ TL.toUpper msg + webSockets $ race_ + (sourceWS $$ mapC TL.toUpper =$ sinkWSText) + (timeSource $$ sinkWSText) defaultLayout $ toWidget [julius| diff --git a/yesod-websockets/yesod-websockets.cabal b/yesod-websockets/yesod-websockets.cabal index c47b8c86..49fb58b5 100644 --- a/yesod-websockets/yesod-websockets.cabal +++ b/yesod-websockets/yesod-websockets.cabal @@ -23,6 +23,7 @@ library , yesod-core >= 1.2.7 , monad-control >= 0.3 , conduit >= 1.0.15.1 + , async >= 2.0.1.5 source-repository head type: git From 9eeefca36aa66f3af8beab5599a98f41dda58fb4 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Fri, 7 Mar 2014 09:16:14 +0200 Subject: [PATCH 26/56] Added chat example --- yesod-websockets/chat.hs | 88 ++++++++++++++++++++++++++++++++++++++++ 1 file changed, 88 insertions(+) create mode 100644 yesod-websockets/chat.hs diff --git a/yesod-websockets/chat.hs b/yesod-websockets/chat.hs new file mode 100644 index 00000000..73f4df10 --- /dev/null +++ b/yesod-websockets/chat.hs @@ -0,0 +1,88 @@ +{-# LANGUAGE QuasiQuotes, TemplateHaskell, TypeFamilies, OverloadedStrings #-} +import Yesod.Core +import Yesod.WebSockets +import qualified Data.Text.Lazy as TL +import Control.Monad (forever) +import Control.Monad.Trans.Reader +import Control.Concurrent (threadDelay) +import Data.Time +import Conduit +import Data.Monoid ((<>)) +import Control.Concurrent.STM.Lifted +import Data.Text (Text) + +data App = App (TChan Text) + +instance Yesod App + +mkYesod "App" [parseRoutes| +/ HomeR GET +|] + +chatApp :: WebSocketsT Handler () +chatApp = do + sendTextData ("Welcome to the chat server, please enter your name." :: Text) + name <- receiveData + sendTextData $ "Welcome, " <> name + App writeChan <- getYesod + readChan <- atomically $ do + writeTChan writeChan $ name <> " has joined the chat" + dupTChan writeChan + race_ + (forever $ atomically (readTChan readChan) >>= sendTextData) + (sourceWS $$ mapM_C (\msg -> + atomically $ writeTChan writeChan $ name <> ": " <> msg)) + +getHomeR :: Handler Html +getHomeR = do + webSockets chatApp + defaultLayout $ do + [whamlet| +
+
+ + |] + toWidget [lucius| + \#output { + width: 600px; + height: 400px; + border: 1px solid black; + margin-bottom: 1em; + p { + margin: 0 0 0.5em 0; + padding: 0 0 0.5em 0; + border-bottom: 1px dashed #99aa99; + } + } + \#input { + width: 600px; + display: block; + } + |] + toWidget [julius| + var url = document.URL, + output = document.getElementById("output"), + form = document.getElementById("form"), + input = document.getElementById("input"), + conn; + + url = url.replace("http:", "ws:").replace("https:", "wss:"); + conn = new WebSocket(url); + + conn.onmessage = function(e) { + var p = document.createElement("p"); + p.appendChild(document.createTextNode(e.data)); + output.appendChild(p); + }; + + form.addEventListener("submit", function(e){ + conn.send(input.value); + input.value = ""; + e.preventDefault(); + }); + |] + +main :: IO () +main = do + chan <- atomically newBroadcastTChan + warp 3000 $ App chan From 010ecffa1b2d67233df85ca3a2e0ab0c8349bcaf Mon Sep 17 00:00:00 2001 From: Toby Goodwin Date: Fri, 7 Mar 2014 18:28:35 +0000 Subject: [PATCH 27/56] implement multiEmailField --- yesod-form/Yesod/Form/Fields.hs | 24 ++++++++++++++++++++++-- 1 file changed, 22 insertions(+), 2 deletions(-) diff --git a/yesod-form/Yesod/Form/Fields.hs b/yesod-form/Yesod/Form/Fields.hs index 97d00346..77d4ab00 100644 --- a/yesod-form/Yesod/Form/Fields.hs +++ b/yesod-form/Yesod/Form/Fields.hs @@ -18,6 +18,7 @@ module Yesod.Form.Fields , timeField , htmlField , emailField + , multiEmailField , searchField , AutoFocus , urlField @@ -68,7 +69,7 @@ import Database.Persist.Sql (PersistField, PersistFieldSql (..)) import Database.Persist (Entity (..), SqlType (SqlString)) import Text.HTML.SanitizeXSS (sanitizeBalance) import Control.Monad (when, unless) -import Data.Maybe (listToMaybe, fromMaybe) +import Data.Maybe (listToMaybe, fromJust, fromMaybe, isNothing) import qualified Blaze.ByteString.Builder.Html.Utf8 as B import Blaze.ByteString.Builder (writeByteString, toLazyByteString) @@ -78,7 +79,7 @@ import Database.Persist (PersistMonadBackend, PersistEntityBackend) import Text.Blaze.Html.Renderer.String (renderHtml) import qualified Data.ByteString as S import qualified Data.ByteString.Lazy as L -import Data.Text (Text, unpack, pack) +import Data.Text (Text, intercalate, unpack, pack, splitOn) import qualified Data.Text.Read import qualified Data.Map as Map @@ -302,6 +303,25 @@ $newline never , fieldEnctype = UrlEncoded } +multiEmailField :: Monad m => RenderMessage (HandlerSite m) FormMessage => Field m [Text] +multiEmailField = Field + { fieldParse = parseHelper $ + \s -> + let canons = map (Email.canonicalizeEmail . encodeUtf8) $ + splitOn "," s + in if any isNothing canons + then Left $ MsgInvalidEmail s + else Right $ + map (decodeUtf8With lenientDecode . fromJust) canons + , fieldView = \theId name attrs val isReq -> toWidget [hamlet| +$newline never + +|] + , fieldEnctype = UrlEncoded + } + where + cat = intercalate ", " + type AutoFocus = Bool searchField :: Monad m => RenderMessage (HandlerSite m) FormMessage => AutoFocus -> Field m Text searchField autoFocus = Field From 1acd48079c05ec3f422615108c5438c59828aa2b Mon Sep 17 00:00:00 2001 From: Toby Goodwin Date: Fri, 7 Mar 2014 18:57:29 +0000 Subject: [PATCH 28/56] improve error handling to report particular errs --- yesod-form/Yesod/Form/Fields.hs | 13 +++++++------ 1 file changed, 7 insertions(+), 6 deletions(-) diff --git a/yesod-form/Yesod/Form/Fields.hs b/yesod-form/Yesod/Form/Fields.hs index 77d4ab00..a2b77fa2 100644 --- a/yesod-form/Yesod/Form/Fields.hs +++ b/yesod-form/Yesod/Form/Fields.hs @@ -69,6 +69,7 @@ import Database.Persist.Sql (PersistField, PersistFieldSql (..)) import Database.Persist (Entity (..), SqlType (SqlString)) import Text.HTML.SanitizeXSS (sanitizeBalance) import Control.Monad (when, unless) +import Data.List (findIndices) import Data.Maybe (listToMaybe, fromJust, fromMaybe, isNothing) import qualified Blaze.ByteString.Builder.Html.Utf8 as B @@ -307,12 +308,12 @@ multiEmailField :: Monad m => RenderMessage (HandlerSite m) FormMessage => Field multiEmailField = Field { fieldParse = parseHelper $ \s -> - let canons = map (Email.canonicalizeEmail . encodeUtf8) $ - splitOn "," s - in if any isNothing canons - then Left $ MsgInvalidEmail s - else Right $ - map (decodeUtf8With lenientDecode . fromJust) canons + let addrs = splitOn "," s + canons = map (Email.canonicalizeEmail . encodeUtf8) addrs + in case findIndices isNothing canons of + [] -> Right $ + map (decodeUtf8With lenientDecode . fromJust) canons + errs -> Left $ MsgInvalidEmail $ cat $ map (addrs !!) errs , fieldView = \theId name attrs val isReq -> toWidget [hamlet| $newline never From 414236481f3450c5caa7da2d7d19958d876d4c9b Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Sun, 9 Mar 2014 07:56:51 +0200 Subject: [PATCH 29/56] Add yesod-websockets to sources.txt --- sources.txt | 1 + 1 file changed, 1 insertion(+) diff --git a/sources.txt b/sources.txt index 46a8d82b..e06080b6 100644 --- a/sources.txt +++ b/sources.txt @@ -11,3 +11,4 @@ ./yesod ./authenticate ./yesod-eventsource +./yesod-websockets From e2a6ef31ed2e59ed0412f2e2ba05d54ba166e760 Mon Sep 17 00:00:00 2001 From: Toby Goodwin Date: Sun, 9 Mar 2014 16:20:39 +0000 Subject: [PATCH 30/56] eschew `fromJust`, better error reporting --- yesod-form/Yesod/Form/Fields.hs | 23 +++++++++++++---------- 1 file changed, 13 insertions(+), 10 deletions(-) diff --git a/yesod-form/Yesod/Form/Fields.hs b/yesod-form/Yesod/Form/Fields.hs index a2b77fa2..d1642321 100644 --- a/yesod-form/Yesod/Form/Fields.hs +++ b/yesod-form/Yesod/Form/Fields.hs @@ -69,8 +69,8 @@ import Database.Persist.Sql (PersistField, PersistFieldSql (..)) import Database.Persist (Entity (..), SqlType (SqlString)) import Text.HTML.SanitizeXSS (sanitizeBalance) import Control.Monad (when, unless) -import Data.List (findIndices) -import Data.Maybe (listToMaybe, fromJust, fromMaybe, isNothing) +import Data.Either (partitionEithers) +import Data.Maybe (listToMaybe, fromMaybe) import qualified Blaze.ByteString.Builder.Html.Utf8 as B import Blaze.ByteString.Builder (writeByteString, toLazyByteString) @@ -80,7 +80,7 @@ import Database.Persist (PersistMonadBackend, PersistEntityBackend) import Text.Blaze.Html.Renderer.String (renderHtml) import qualified Data.ByteString as S import qualified Data.ByteString.Lazy as L -import Data.Text (Text, intercalate, unpack, pack, splitOn) +import Data.Text as T (Text, concat, intercalate, unpack, pack, splitOn) import qualified Data.Text.Read import qualified Data.Map as Map @@ -308,12 +308,10 @@ multiEmailField :: Monad m => RenderMessage (HandlerSite m) FormMessage => Field multiEmailField = Field { fieldParse = parseHelper $ \s -> - let addrs = splitOn "," s - canons = map (Email.canonicalizeEmail . encodeUtf8) addrs - in case findIndices isNothing canons of - [] -> Right $ - map (decodeUtf8With lenientDecode . fromJust) canons - errs -> Left $ MsgInvalidEmail $ cat $ map (addrs !!) errs + let addrs = map validate $ splitOn "," s + in case partitionEithers addrs of + ([], good) -> Right good + (bad, _) -> Left $ MsgInvalidEmail $ cat bad , fieldView = \theId name attrs val isReq -> toWidget [hamlet| $newline never @@ -321,7 +319,12 @@ $newline never , fieldEnctype = UrlEncoded } where - cat = intercalate ", " + -- report offending address along with error + validate a = case Email.validate $ encodeUtf8 a of + Left e -> Left $ T.concat [a, " (", pack e, ")"] + Right r -> Right $ emailToText r + cat = intercalate ", " + emailToText = decodeUtf8With lenientDecode . Email.toByteString type AutoFocus = Bool searchField :: Monad m => RenderMessage (HandlerSite m) FormMessage => AutoFocus -> Field m Text From 566060df8eb1f3027323c90f79cbc32168666a29 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Sun, 9 Mar 2014 18:53:57 +0200 Subject: [PATCH 31/56] Remove redundant script in travis.yml --- .travis.yml | 2 -- 1 file changed, 2 deletions(-) diff --git a/.travis.yml b/.travis.yml index e249b05e..2f2db5f7 100644 --- a/.travis.yml +++ b/.travis.yml @@ -11,5 +11,3 @@ script: - mega-sdist --test - cabal install mega-sdist hspec cabal-meta cabal-src - cabal-meta install --force-reinstalls - -script: mega-sdist --test From 43eb8d83f0ab08b0a5d38eecbacb659026f0b19a Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Sun, 9 Mar 2014 18:56:25 +0200 Subject: [PATCH 32/56] Update hello-forms to use multi email field --- yesod-form/Yesod/Form/Fields.hs | 3 +++ yesod-form/hello-forms.hs | 3 ++- yesod-form/yesod-form.cabal | 2 +- 3 files changed, 6 insertions(+), 2 deletions(-) diff --git a/yesod-form/Yesod/Form/Fields.hs b/yesod-form/Yesod/Form/Fields.hs index d1642321..bc6ebee4 100644 --- a/yesod-form/Yesod/Form/Fields.hs +++ b/yesod-form/Yesod/Form/Fields.hs @@ -304,6 +304,9 @@ $newline never , fieldEnctype = UrlEncoded } +-- | +-- +-- Since 1.3.7 multiEmailField :: Monad m => RenderMessage (HandlerSite m) FormMessage => Field m [Text] multiEmailField = Field { fieldParse = parseHelper $ diff --git a/yesod-form/hello-forms.hs b/yesod-form/hello-forms.hs index 2fef48dd..eb766abc 100644 --- a/yesod-form/hello-forms.hs +++ b/yesod-form/hello-forms.hs @@ -23,7 +23,7 @@ mkYesod "HelloForms" [parseRoutes| /file FileR GET POST |] -myForm = fixType $ runFormGet $ renderDivs $ pure (,,,,,,,,) +myForm = fixType $ runFormGet $ renderDivs $ pure (,,,,,,,,,) <*> areq boolField "Bool field" Nothing <*> aopt boolField "Opt bool field" Nothing <*> areq textField "Text field" Nothing @@ -33,6 +33,7 @@ myForm = fixType $ runFormGet $ renderDivs $ pure (,,,,,,,,) <*> aopt (multiSelectFieldList fruits) "Opt multi select field" Nothing <*> aopt intField "Opt int field" Nothing <*> aopt (radioFieldList fruits) "Opt radio" Nothing + <*> aopt multiEmailField "Opt multi email" Nothing data HelloForms = HelloForms diff --git a/yesod-form/yesod-form.cabal b/yesod-form/yesod-form.cabal index 21aa9b9d..4bf8754e 100644 --- a/yesod-form/yesod-form.cabal +++ b/yesod-form/yesod-form.cabal @@ -1,5 +1,5 @@ name: yesod-form -version: 1.3.6 +version: 1.3.7 license: MIT license-file: LICENSE author: Michael Snoyman From 64547ba773590b140bbbfc82a6366f2ab4e47671 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Tue, 11 Mar 2014 06:29:51 +0200 Subject: [PATCH 33/56] Import mkHsFile for Windows as well --- yesod-bin/main.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/yesod-bin/main.hs b/yesod-bin/main.hs index f4db16b6..2202fb54 100755 --- a/yesod-bin/main.hs +++ b/yesod-bin/main.hs @@ -21,9 +21,9 @@ import Options.Applicative.Types (ReadM (ReadM)) import Options.Applicative.Builder.Internal (Mod, OptionFields) #endif +import HsFile (mkHsFile) #ifndef WINDOWS import Build (touch) -import HsFile (mkHsFile) touch' :: IO () touch' = touch From c86823b1cea8e15ed733fe6daef785909ed11ac0 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Tue, 11 Mar 2014 18:38:21 +0200 Subject: [PATCH 34/56] Version bump --- 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 72d08c1d..6e9275bd 100644 --- a/yesod-bin/yesod-bin.cabal +++ b/yesod-bin/yesod-bin.cabal @@ -1,5 +1,5 @@ name: yesod-bin -version: 1.2.7 +version: 1.2.7.1 license: MIT license-file: LICENSE author: Michael Snoyman From 12a527a9d53472e8a41791198779426c4aa880d0 Mon Sep 17 00:00:00 2001 From: Felipe Lessa Date: Tue, 11 Mar 2014 17:08:41 -0300 Subject: [PATCH 35/56] New Yesod.Form.Bootstrap3 module. The original renderBootstrap code was heavily modified by Mladen Srdic [1]. I took his code and modified it as well, and the result is this commit. [1] https://www.fpcomplete.com/user/msrdic/bootstrap-3-forms-with-yesod-1 --- yesod-form/Yesod/Form/Bootstrap3.hs | 243 ++++++++++++++++++++++++++++ yesod-form/yesod-form.cabal | 1 + 2 files changed, 244 insertions(+) create mode 100644 yesod-form/Yesod/Form/Bootstrap3.hs diff --git a/yesod-form/Yesod/Form/Bootstrap3.hs b/yesod-form/Yesod/Form/Bootstrap3.hs new file mode 100644 index 00000000..ceec0da6 --- /dev/null +++ b/yesod-form/Yesod/Form/Bootstrap3.hs @@ -0,0 +1,243 @@ +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE OverloadedStrings #-} +-- | Helper functions for creating forms when using Bootstrap v3. +module Yesod.Form.Bootstrap3 + ( -- * Rendering forms + renderBootstrap3 + , BootstrapFormLayout(..) + , BootstrapGridOptions(..) + -- * Field settings + , bfs + , withPlaceholder + , withAutofocus + , withLargeInput + , withSmallInput + -- * Submit button + , bootstrapSubmit + , mbootstrapSubmit + , BootstrapSubmit(..) + ) where + +import Control.Arrow (second) +import Control.Monad (liftM) +import Data.Text (Text) +import Data.String (IsString(..)) +import Yesod.Core + +import Yesod.Form.Types +import Yesod.Form.Functions + +-- | Create a new 'FieldSettings' with the classes that are +-- required by Bootstrap v3. +bfs :: RenderMessage site msg => msg -> FieldSettings site +bfs msg = + FieldSettings (SomeMessage msg) Nothing Nothing Nothing [("class", "form-control")] + + +-- | Add a placeholder attribute to a field. If you need i18n +-- for the placeholder, currently you\'ll need to do a hack and +-- use 'getMessageRender' manually. +withPlaceholder :: Text -> FieldSettings site -> FieldSettings site +withPlaceholder placeholder fs = fs { fsAttrs = newAttrs } + where newAttrs = ("placeholder", placeholder) : fsAttrs fs + + +-- | Add an autofocus attribute to a field. +withAutofocus :: FieldSettings site -> FieldSettings site +withAutofocus fs = fs { fsAttrs = newAttrs } + where newAttrs = ("autofocus", "autofocus") : fsAttrs fs + + +-- | Add the @input-lg@ CSS class to a field. +withLargeInput :: FieldSettings site -> FieldSettings site +withLargeInput fs = fs { fsAttrs = newAttrs } + where newAttrs = ("class", " input-lg ") : fsAttrs fs + + +-- | Add the @input-sm@ CSS class to a field. +withSmallInput :: FieldSettings site -> FieldSettings site +withSmallInput fs = fs { fsAttrs = newAttrs } + where newAttrs = ("class", " input-sm ") : fsAttrs fs + + +-- | How many bootstrap grid columns should be taken (see +-- 'BootstrapFormLayout'). +data BootstrapGridOptions = + ColXs !Int + | ColSm !Int + | ColMd !Int + | ColLg !Int + deriving (Eq, Ord, Show) + +toColumn :: BootstrapGridOptions -> String +toColumn (ColXs 0) = "" +toColumn (ColSm 0) = "" +toColumn (ColMd 0) = "" +toColumn (ColLg 0) = "" +toColumn (ColXs columns) = "col-xs-" ++ show columns +toColumn (ColSm columns) = "col-sm-" ++ show columns +toColumn (ColMd columns) = "col-md-" ++ show columns +toColumn (ColLg columns) = "col-lg-" ++ show columns + +toOffset :: BootstrapGridOptions -> String +toOffset (ColXs 0) = "" +toOffset (ColSm 0) = "" +toOffset (ColMd 0) = "" +toOffset (ColLg 0) = "" +toOffset (ColXs columns) = "col-xs-offset-" ++ show columns +toOffset (ColSm columns) = "col-sm-offset-" ++ show columns +toOffset (ColMd columns) = "col-md-offset-" ++ show columns +toOffset (ColLg columns) = "col-lg-offset-" ++ show columns + +addGO :: BootstrapGridOptions -> BootstrapGridOptions -> BootstrapGridOptions +addGO (ColXs a) (ColXs b) = ColXs (a+b) +addGO (ColSm a) (ColSm b) = ColSm (a+b) +addGO (ColMd a) (ColMd b) = ColMd (a+b) +addGO (ColLg a) (ColLg b) = ColLg (a+b) +addGO a b | a > b = addGO b a +addGO (ColXs a) other = addGO (ColSm a) other +addGO (ColSm a) other = addGO (ColMd a) other +addGO (ColMd a) other = addGO (ColLg a) other +addGO (ColLg _) _ = error "Yesod.Form.Bootstrap.addGO: never here" + + +-- | The layout used for the bootstrap form. +data BootstrapFormLayout = + BootstrapBasicForm + | BootstrapInlineForm + | BootstrapHorizontalForm + { bflLabelOffset :: !BootstrapGridOptions + , bflLabelSize :: !BootstrapGridOptions + , bflInputOffset :: !BootstrapGridOptions + , bflInputSize :: !BootstrapGridOptions + } + deriving (Show) + + +-- | Render the given form using Bootstrap v3 conventions. +-- +-- Sample Hamlet for 'BootstrapHorizontalForm': +-- +-- > +-- > ^{formWidget} +-- > ^{bootstrapSubmit MsgSubmit} +renderBootstrap3 :: Monad m => BootstrapFormLayout -> FormRender m a +renderBootstrap3 formLayout aform fragment = do + (res, views') <- aFormToForm aform + let views = views' [] + has (Just _) = True + has Nothing = False + widget = [whamlet| + $newline never + #{fragment} + ^{formFailureWidget res} + $forall view <- views +
+ $case formLayout + $of BootstrapBasicForm + $if fvId view /= bootstrapSubmitId +