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

Merge remote-tracking branch 'origin/master' into persistent2-simpler-dispatch

Browse Source 
Conflicts:
	.gitignore
	yesod-core/yesod-core.cabal
This commit is contained in:
Michael Snoyman 2014-03-20 04:14:09 +02:00
commit 24e8e53f64
43 changed files with 1102 additions and 180 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
.gitignore vendored
View File

@ -1,3 +1,4 @@
*~
*.o
*.o_p
*.hi
@ -10,7 +11,7 @@ yesod/foobar/
.cabal-sandbox/
cabal.sandbox.config
/vendor/
/.shelly/
.shelly/
tarballs/
*.swp
dist

2
.travis.yml
View File

@ -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

2
package-list.sh
View File

@ -3,7 +3,7 @@
pkgs=( ./yesod-routes
./yesod-core
./yesod-json
./crypto-conduit
./cryptohash-conduit
./authenticate/authenticate
./yesod-static
./yesod-persistent

1
sources.txt
View File

@ -11,3 +11,4 @@
./yesod
./authenticate
./yesod-eventsource
./yesod-websockets

4
yesod-auth/Yesod/Auth.hs
View File

@ -111,7 +111,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
@ -379,7 +379,7 @@ setUltDestReferer' = lift $ do
master <- getYesod
when (redirectToReferer master) setUltDestReferer
getLoginR :: AuthHandler master RepHtml
getLoginR :: AuthHandler master Html
getLoginR = setUltDestReferer' >> loginHandler
getLogoutR :: AuthHandler master ()

17
yesod-auth/Yesod/Auth/BrowserId.hs
View File

@ -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

82
yesod-auth/Yesod/Auth/Email.hs
View File

@ -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)
@ -174,15 +179,49 @@ 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
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 ->
@ -218,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
@ -272,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
@ -350,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|
@ -394,7 +452,7 @@ postPasswordR = do
Just aid -> return aid
tm <- getRouteToParent
needOld <- lift $ needOldPassword aid
when needOld $ do
current <- lift $ runInputPost $ ireq textField "current"
@ -432,7 +490,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

2
yesod-auth/yesod-auth.cabal
View File

@ -1,5 +1,5 @@
name: yesod-auth
version: 1.2.5.3
version: 1.2.7
license: MIT
license-file: LICENSE
author: Michael Snoyman, Patrick Brisbin

2
yesod-bin/Devel.hs
View File

@ -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

23
yesod-bin/HsFile.hs Normal file
View File

@ -0,0 +1,23 @@
{-# 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 )
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 = CL.map $ \i -> (i, liftIO $ BS.readFile $ encodeString i)

11
yesod-bin/hsfiles/mongo.hsfiles
View File

@ -14,6 +14,7 @@ cabal-dev/
yesod-devel/
.cabal-sandbox
cabal.sandbox.config
.DS_Store
{-# START_FILE Application.hs #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
@ -419,11 +420,11 @@ library
, shakespeare-text >= 1.0 && < 1.1
, hjsmin >= 0.1 && < 0.2
, monad-control >= 0.3 && < 0.4
, wai-extra >= 2.0 && < 2.1
, wai-extra >= 2.1 && < 2.2
, yaml >= 0.8 && < 0.9
, http-conduit >= 2.0 && < 2.1
, directory >= 1.1 && < 1.3
, warp >= 2.0 && < 2.1
, warp >= 2.1 && < 2.2
, data-default
, aeson >= 0.6 && < 0.8
, conduit >= 1.0 && < 2.0
@ -807,7 +808,7 @@ web: ./dist/build/PROJECTNAME/PROJECTNAME production -p $PORT
{-# LANGUAGE PackageImports #-}
import "PROJECTNAME" Application (getApplicationDev)
import Network.Wai.Handler.Warp
(runSettings, defaultSettings, settingsPort)
(runSettings, defaultSettings, setPort)
import Control.Concurrent (forkIO)
import System.Directory (doesFileExist, removeFile)
import System.Exit (exitSuccess)
@ -817,9 +818,7 @@ main :: IO ()
main = do
putStrLn "Starting devel application"
(port, app) <- getApplicationDev
forkIO $ runSettings defaultSettings
{ settingsPort = port
} app
forkIO $ runSettings (setPort port defaultSettings) app
loop
loop :: IO ()

11
yesod-bin/hsfiles/mysql.hsfiles
View File

@ -14,6 +14,7 @@ cabal-dev/
yesod-devel/
.cabal-sandbox
cabal.sandbox.config
.DS_Store
{-# START_FILE Application.hs #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
@ -423,11 +424,11 @@ library
, shakespeare-text >= 1.0 && < 1.1
, hjsmin >= 0.1 && < 0.2
, monad-control >= 0.3 && < 0.4
, wai-extra >= 2.0 && < 2.1
, wai-extra >= 2.1 && < 2.2
, yaml >= 0.8 && < 0.9
, http-conduit >= 2.0 && < 2.1
, directory >= 1.1 && < 1.3
, warp >= 2.0 && < 2.1
, warp >= 2.1 && < 2.2
, data-default
, aeson >= 0.6 && < 0.8
, conduit >= 1.0 && < 2.0
@ -837,7 +838,7 @@ web: ./dist/build/PROJECTNAME/PROJECTNAME production -p $PORT
{-# LANGUAGE PackageImports #-}
import "PROJECTNAME" Application (getApplicationDev)
import Network.Wai.Handler.Warp
(runSettings, defaultSettings, settingsPort)
(runSettings, defaultSettings, setPort)
import Control.Concurrent (forkIO)
import System.Directory (doesFileExist, removeFile)
import System.Exit (exitSuccess)
@ -847,9 +848,7 @@ main :: IO ()
main = do
putStrLn "Starting devel application"
(port, app) <- getApplicationDev
forkIO $ runSettings defaultSettings
{ settingsPort = port
} app
forkIO $ runSettings (setPort port defaultSettings) app
loop
loop :: IO ()

11
yesod-bin/hsfiles/postgres-fay.hsfiles
View File

@ -15,6 +15,7 @@ cabal-dev/
yesod-devel/
.cabal-sandbox
cabal.sandbox.config
.DS_Store
{-# START_FILE Application.hs #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
@ -460,11 +461,11 @@ library
, shakespeare-js >= 1.2 && < 1.3
, shakespeare-text >= 1.0 && < 1.1
, monad-control >= 0.3 && < 0.4
, wai-extra >= 2.0 && < 2.1
, wai-extra >= 2.1 && < 2.2
, yaml >= 0.8 && < 0.9
, http-conduit >= 2.0 && < 2.1
, directory >= 1.1 && < 1.3
, warp >= 2.0 && < 2.1
, warp >= 2.1 && < 2.2
, data-default
, aeson >= 0.6 && < 0.8
, conduit >= 1.0 && < 2.0
@ -861,7 +862,7 @@ web: ./dist/build/PROJECTNAME/PROJECTNAME production -p $PORT
{-# LANGUAGE PackageImports #-}
import "PROJECTNAME" Application (getApplicationDev)
import Network.Wai.Handler.Warp
(runSettings, defaultSettings, settingsPort)
(runSettings, defaultSettings, setPort)
import Control.Concurrent (forkIO)
import System.Directory (doesFileExist, removeFile)
import System.Exit (exitSuccess)
@ -871,9 +872,7 @@ main :: IO ()
main = do
putStrLn "Starting devel application"
(port, app) <- getApplicationDev
forkIO $ runSettings defaultSettings
{ settingsPort = port
} app
forkIO $ runSettings (setPort port defaultSettings) app
loop
loop :: IO ()

11
yesod-bin/hsfiles/postgres.hsfiles
View File

@ -14,6 +14,7 @@ cabal-dev/
yesod-devel/
.cabal-sandbox
cabal.sandbox.config
.DS_Store
{-# START_FILE Application.hs #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
@ -423,11 +424,11 @@ library
, shakespeare-text >= 1.0 && < 1.1
, hjsmin >= 0.1 && < 0.2
, monad-control >= 0.3 && < 0.4
, wai-extra >= 2.0 && < 2.1
, wai-extra >= 2.1 && < 2.2
, yaml >= 0.8 && < 0.9
, http-conduit >= 2.0 && < 2.1
, directory >= 1.1 && < 1.3
, warp >= 2.0 && < 2.1
, warp >= 2.1 && < 2.2
, data-default
, aeson >= 0.6 && < 0.8
, conduit >= 1.0 && < 2.0
@ -811,7 +812,7 @@ web: ./dist/build/PROJECTNAME/PROJECTNAME production -p $PORT
{-# LANGUAGE PackageImports #-}
import "PROJECTNAME" Application (getApplicationDev)
import Network.Wai.Handler.Warp
(runSettings, defaultSettings, settingsPort)
(runSettings, defaultSettings, setPort)
import Control.Concurrent (forkIO)
import System.Directory (doesFileExist, removeFile)
import System.Exit (exitSuccess)
@ -821,9 +822,7 @@ main :: IO ()
main = do
putStrLn "Starting devel application"
(port, app) <- getApplicationDev
forkIO $ runSettings defaultSettings
{ settingsPort = port
} app
forkIO $ runSettings (setPort port defaultSettings) app
loop
loop :: IO ()

11
yesod-bin/hsfiles/simple.hsfiles
View File

@ -14,6 +14,7 @@ cabal-dev/
yesod-devel/
.cabal-sandbox
cabal.sandbox.config
.DS_Store
{-# START_FILE Application.hs #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
@ -347,11 +348,11 @@ library
, shakespeare-text >= 1.0 && < 1.1
, hjsmin >= 0.1 && < 0.2
, monad-control >= 0.3 && < 0.4
, wai-extra >= 2.0 && < 2.1
, wai-extra >= 2.1 && < 2.2
, yaml >= 0.8 && < 0.9
, http-conduit >= 2.0 && < 2.1
, directory >= 1.1 && < 1.3
, warp >= 2.0 && < 2.1
, warp >= 2.1 && < 2.2
, data-default
, aeson >= 0.6 && < 0.8
, conduit >= 1.0 && < 2.0
@ -685,7 +686,7 @@ web: ./dist/build/PROJECTNAME/PROJECTNAME production -p $PORT
{-# LANGUAGE PackageImports #-}
import "PROJECTNAME" Application (getApplicationDev)
import Network.Wai.Handler.Warp
(runSettings, defaultSettings, settingsPort)
(runSettings, defaultSettings, setPort)
import Control.Concurrent (forkIO)
import System.Directory (doesFileExist, removeFile)
import System.Exit (exitSuccess)
@ -695,9 +696,7 @@ main :: IO ()
main = do
putStrLn "Starting devel application"
(port, app) <- getApplicationDev
forkIO $ runSettings defaultSettings
{ settingsPort = port
} app
forkIO $ runSettings (setPort port defaultSettings) app
loop
loop :: IO ()

11
yesod-bin/hsfiles/sqlite.hsfiles
View File

@ -14,6 +14,7 @@ cabal-dev/
yesod-devel/
.cabal-sandbox
cabal.sandbox.config
.DS_Store
{-# START_FILE Application.hs #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
@ -423,11 +424,11 @@ library
, shakespeare-text >= 1.0 && < 1.1
, hjsmin >= 0.1 && < 0.2
, monad-control >= 0.3 && < 0.4
, wai-extra >= 2.0 && < 2.1
, wai-extra >= 2.1 && < 2.2
, yaml >= 0.8 && < 0.9
, http-conduit >= 2.0 && < 2.1
, directory >= 1.1 && < 1.3
, warp >= 2.0 && < 2.1
, warp >= 2.1 && < 2.2
, data-default
, aeson >= 0.6 && < 0.8
, conduit >= 1.0 && < 2.0
@ -807,7 +808,7 @@ web: ./dist/build/PROJECTNAME/PROJECTNAME production -p $PORT
{-# LANGUAGE PackageImports #-}
import "PROJECTNAME" Application (getApplicationDev)
import Network.Wai.Handler.Warp
(runSettings, defaultSettings, settingsPort)
(runSettings, defaultSettings, setPort)
import Control.Concurrent (forkIO)
import System.Directory (doesFileExist, removeFile)
import System.Exit (exitSuccess)
@ -817,9 +818,7 @@ main :: IO ()
main = do
putStrLn "Starting devel application"
(port, app) <- getApplicationDev
forkIO $ runSettings defaultSettings
{ settingsPort = port
} app
forkIO $ runSettings (setPort port defaultSettings) app
loop
loop :: IO ()

7
yesod-bin/main.hs
View File

@ -21,6 +21,7 @@ import Options.Applicative.Types (ReadM (ReadM))
import Options.Applicative.Builder.Internal (Mod, OptionFields)
#endif
import HsFile (mkHsFile)
#ifndef WINDOWS
import Build (touch)
@ -47,6 +48,7 @@ data Options = Options
deriving (Show, Eq)
data Command = Init { _initBare :: Bool }
| HsFiles
| Configure
| Build { buildExtraArgs :: [String] }
| Touch
@ -96,6 +98,7 @@ main = do
let cabal = rawSystem' (cabalCommand o)
case optCommand o of
Init bare -> scaffold bare
HsFiles -> mkHsFile
Configure -> cabal ["configure"]
Build es -> touch' >> cabal ("build":es)
Touch -> touch'
@ -124,8 +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"))
(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)

6
yesod-bin/yesod-bin.cabal
View File

@ -1,5 +1,5 @@
name: yesod-bin
version: 1.2.6
version: 1.2.7.2
license: MIT
license-file: LICENSE
author: Michael Snoyman <michael@snoyman.com>
@ -89,7 +89,8 @@ executable yesod
, transformers
, warp >= 1.3.7.5
, wai >= 1.4
, data-default
, data-default-class
, filesystem-conduit >= 1.0 && < 2.0
ghc-options: -Wall -threaded
main-is: main.hs
@ -101,6 +102,7 @@ executable yesod
AddHandler
Paths_yesod_bin
Options
HsFile
source-repository head
type: git

59
yesod-core/Yesod/Core/Handler.hs
View File

@ -89,6 +89,9 @@ module Yesod.Core.Handler
, sendResponseStatus
, sendResponseCreated
, sendWaiResponse
#if MIN_VERSION_wai(2, 1, 0)
, sendRawResponse
#endif
-- * Different representations
-- $representations
, selectRep
@ -134,6 +137,7 @@ module Yesod.Core.Handler
, newIdent
-- * Lifting
, handlerToIO
, forkHandler
-- * i18n
, getMessageRender
-- * Per-request caching
@ -146,18 +150,17 @@ import Yesod.Core.Internal.Request (langKey, mkFileInfoFile,
mkFileInfoLBS, mkFileInfoSource)
import Control.Applicative ((<$>), (<|>))
import Control.Exception (evaluate)
import Control.Exception (evaluate, SomeException)
import Control.Exception.Lifted (handle)
import Control.Monad (liftM)
import Control.Monad (liftM, void)
import qualified Control.Monad.Trans.Writer as Writer
import Control.Monad.IO.Class (MonadIO, liftIO)
import Control.Monad.Trans.Resource (MonadResource, liftResourceT, InternalState)
import qualified Network.HTTP.Types as H
import qualified Network.Wai as W
import Control.Monad.Trans.Class (lift)
import Data.Conduit (transPipe, Flush (Flush), yield, Producer)
import qualified Data.Text as T
import Data.Text.Encoding (decodeUtf8With, encodeUtf8)
@ -170,10 +173,8 @@ import qualified Data.ByteString as S
import qualified Data.ByteString.Lazy as L
import qualified Data.Map as Map
import Data.Conduit (Source)
import Control.Arrow ((***))
import qualified Data.ByteString.Char8 as S8
import Data.Maybe (mapMaybe)
import Data.Monoid (Endo (..), mappend, mempty)
import Data.Text (Text)
import qualified Network.Wai.Parse as NWP
@ -183,10 +184,9 @@ import Yesod.Core.Content (ToTypedContent (..), simpleConte
import Yesod.Core.Internal.Util (formatRFC1123)
import Text.Blaze.Html (preEscapedToMarkup, toHtml)
import Control.Monad.Trans.Resource (ResourceT, runResourceT, withInternalState, getInternalState, liftResourceT)
import Data.Dynamic (fromDynamic, toDyn)
import qualified Data.IORef.Lifted as I
import Data.Maybe (listToMaybe)
import Data.Maybe (listToMaybe, mapMaybe)
import Data.Typeable (Typeable, typeOf)
import Yesod.Core.Class.Handler
import Yesod.Core.Types
@ -195,9 +195,23 @@ import Control.Failure (failure)
import Blaze.ByteString.Builder (Builder)
import Safe (headMay)
import Data.CaseInsensitive (CI)
import Control.Monad.Trans.Resource (MonadResource, InternalState, runResourceT, withInternalState, getInternalState, liftResourceT, resourceForkIO
#if MIN_VERSION_wai(2, 0, 0)
#else
, ResourceT
#endif
)
#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 (control, MonadBaseControl)
#endif
import Data.Conduit (Source, transPipe, Flush (Flush), yield, Producer
#if MIN_VERSION_wai(2, 1, 0)
, Sink
#endif
)
get :: MonadHandler m => m GHState
get = liftHandlerT $ HandlerT $ I.readIORef . handlerState
@ -382,6 +396,18 @@ handlerToIO =
}
liftIO (f newHandlerData)
-- | forkIO for a Handler (run an action in the background)
--
-- Uses 'handlerToIO', liftResourceT, and resourceForkIO
-- for correctness and efficiency
--
-- Since 1.2.8
forkHandler :: (SomeException -> HandlerT site IO ()) -- ^ error handler
-> HandlerT site IO ()
-> HandlerT site IO ()
forkHandler onErr handler = do
yesRunner <- handlerToIO
void $ liftResourceT $ resourceForkIO $ yesRunner $ handle onErr handler
-- | Redirect to the given route.
-- HTTP status code 303 for HTTP 1.1 clients and 302 for HTTP 1.0
@ -547,6 +573,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

17
yesod-core/Yesod/Core/Internal/Response.hs
View File

@ -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
@ -128,7 +139,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

9
yesod-core/Yesod/Core/Json.hs
View File

@ -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]

59
yesod-core/widget-benchmark.hs → yesod-core/bench/widget.hs
View File

@ -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|
<table
bigTableHtml rows = L.length $ Utf8.renderHtml $ ($ id) [hamlet|
<table>
$forall row <- rows
<tr
<tr>
$forall cell <- row
<td>#{show cell}
|]
bigTableHamlet rows = L.length $ renderHamlet id [$hamlet|
<table
bigTableHamlet rows = L.length $ Utf8.renderHtml $ ($ id) [hamlet|
<table>
$forall row <- rows
<tr
<tr>
$forall cell <- row
<td>#{show cell}
|]
bigTableWidget rows = L.length $ renderHtml $ (run [$hamlet|
<table
bigTableWidget rows = fmap (L.length . Utf8.renderHtml . ($ render)) (run [whamlet|
<table>
$forall row <- rows
<tr
<tr>
$forall cell <- row
<td>#{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

7
yesod-core/test/YesodCoreTest.hs
View File

@ -1,3 +1,4 @@
{-# LANGUAGE CPP #-}
module YesodCoreTest (specs) where
import YesodCoreTest.CleanPath
@ -14,6 +15,9 @@ import qualified YesodCoreTest.Redirect as Redirect
import qualified YesodCoreTest.JsLoader as JsLoader
import qualified YesodCoreTest.RequestBodySize as RequestBodySize
import qualified YesodCoreTest.Json as Json
#if MIN_VERSION_wai(2, 1, 0)
import qualified YesodCoreTest.RawResponse as RawResponse
#endif
import qualified YesodCoreTest.Streaming as Streaming
import qualified YesodCoreTest.Reps as Reps
import qualified YesodCoreTest.Auth as Auth
@ -37,6 +41,9 @@ specs = do
JsLoader.specs
RequestBodySize.specs
Json.specs
#if MIN_VERSION_wai(2, 1, 0)
RawResponse.specs
#endif
Streaming.specs
Reps.specs
Auth.specs

19
yesod-core/test/YesodCoreTest/ErrorHandling.hs
View File

@ -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

2
yesod-core/test/YesodCoreTest/Json.hs
View File

@ -19,7 +19,7 @@ instance Yesod App
getHomeR :: Handler RepPlain
getHomeR = do
val <- parseJsonBody_
val <- requireJsonBody
case Map.lookup ("foo" :: Text) val of
Nothing -> invalidArgs ["foo not found"]
Just foo -> return $ RepPlain $ toContent (foo :: Text)

62
yesod-core/test/YesodCoreTest/RawResponse.hs Normal file
View File

@ -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")

19
yesod-core/yesod-core.cabal
View File

@ -1,5 +1,5 @@
name: yesod-core
version: 1.2.7
version: 1.2.8
license: MIT
license-file: LICENSE
author: Michael Snoyman <michael@snoyman.com>
@ -122,9 +122,26 @@ test-suite tests
, containers
, lifted-base
, resourcet
, network-conduit
, network
, async
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

262
yesod-form/Yesod/Form/Bootstrap3.hs Normal file
View File

@ -0,0 +1,262 @@
{-# 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 qualified Data.Text as T
import Yesod.Form.Types
import Yesod.Form.Functions
-- | Create a new 'FieldSettings' with the classes that are
-- required by Bootstrap v3.
--
-- Since: yesod-form 1.3.8
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.
--
-- Since: yesod-form 1.3.8
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.
--
-- Since: yesod-form 1.3.8
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.
--
-- Since: yesod-form 1.3.8
withLargeInput :: FieldSettings site -> FieldSettings site
withLargeInput fs = fs { fsAttrs = newAttrs }
where newAttrs = addClass "input-lg" (fsAttrs fs)
-- | Add the @input-sm@ CSS class to a field.
--
-- Since: yesod-form 1.3.8
withSmallInput :: FieldSettings site -> FieldSettings site
withSmallInput fs = fs { fsAttrs = newAttrs }
where newAttrs = addClass "input-sm" (fsAttrs fs)
addClass :: Text -> [(Text, Text)] -> [(Text, Text)]
addClass klass [] = [("class", klass)]
addClass klass (("class", old):rest) = ("class", T.concat [old, " ", klass]) : rest
addClass klass (other :rest) = other : addClass klass rest
-- | How many bootstrap grid columns should be taken (see
-- 'BootstrapFormLayout').
--
-- Since: yesod-form 1.3.8
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.
--
-- Since: yesod-form 1.3.8
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':
--
-- > <form .form-horizontal role=form method=post action=@{ActionR} enctype=#{formEnctype}>
-- > ^{formWidget}
-- > ^{bootstrapSubmit MsgSubmit}
--
-- Since: yesod-form 1.3.8
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}
$forall view <- views
<div .form-group :fvRequired view:.required :not $ fvRequired view:.optional :has $ fvErrors view:.has-error>
$case formLayout
$of BootstrapBasicForm
$if fvId view /= bootstrapSubmitId
<label for=#{fvId view}>#{fvLabel view}
^{fvInput view}
^{helpWidget view}
$of BootstrapInlineForm
$if fvId view /= bootstrapSubmitId
<label .sr-only for=#{fvId view}>#{fvLabel view}
^{fvInput view}
^{helpWidget view}
$of BootstrapHorizontalForm labelOffset labelSize inputOffset inputSize
$if fvId view /= bootstrapSubmitId
<label .control-label .#{toOffset labelOffset} .#{toColumn labelSize} for=#{fvId view}>#{fvLabel view}
<div .#{toOffset inputOffset} .#{toColumn inputSize}>
^{fvInput view}
^{helpWidget view}
$else
<div .#{toOffset (addGO inputOffset (addGO labelOffset labelSize))} .#{toColumn inputSize}>
^{fvInput view}
^{helpWidget view}
|]
return (res, widget)
-- | (Internal) Render a help widget for tooltips and errors.
helpWidget :: FieldView site -> WidgetT site IO ()
helpWidget view = [whamlet|
$maybe tt <- fvTooltip view
<span .help-block>#{tt}
$maybe err <- fvErrors view
<span .help-block>#{err}
|]
-- | How the 'bootstrapSubmit' button should be rendered.
--
-- Since: yesod-form 1.3.8
data BootstrapSubmit msg =
BootstrapSubmit
{ bsValue :: msg
-- ^ The text of the submit button.
, bsClasses :: Text
-- ^ Classes added to the @<button>@.
, bsAttrs :: [(Text, Text)]
-- ^ Attributes added to the @<button>@.
} deriving (Show)
instance IsString msg => IsString (BootstrapSubmit msg) where
fromString msg = BootstrapSubmit (fromString msg) " btn-default " []
-- | A Bootstrap v3 submit button disguised as a field for
-- convenience. For example, if your form currently is:
--
-- > Person <$> areq textField "Name" Nothing
-- > <*> areq textField "Surname" Nothing
--
-- Then just change it to:
--
-- > Person <$> areq textField "Name" Nothing
-- > <*> areq textField "Surname" Nothing
-- > <* bootstrapSubmit "Register"
--
-- (Note that @<*@ is not a typo.)
--
-- Alternatively, you may also just create the submit button
-- manually as well in order to have more control over its
-- layout.
--
-- Since: yesod-form 1.3.8
bootstrapSubmit
:: (RenderMessage site msg, HandlerSite m ~ site, MonadHandler m)
=> BootstrapSubmit msg -> AForm m ()
bootstrapSubmit = formToAForm . liftM (second return) . mbootstrapSubmit
-- | Same as 'bootstrapSubmit' but for monadic forms. This isn't
-- as useful since you're not going to use 'renderBootstrap3'
-- anyway.
--
-- Since: yesod-form 1.3.8
mbootstrapSubmit
:: (RenderMessage site msg, HandlerSite m ~ site, MonadHandler m)
=> BootstrapSubmit msg -> MForm m (FormResult (), FieldView site)
mbootstrapSubmit (BootstrapSubmit msg classes attrs) =
let res = FormSuccess ()
widget = [whamlet|<button class="btn #{classes}" type=submit *{attrs}>_{msg}|]
fv = FieldView { fvLabel = ""
, fvTooltip = Nothing
, fvId = bootstrapSubmitId
, fvInput = widget
, fvErrors = Nothing
, fvRequired = False }
in return (res, fv)
-- | A royal hack. Magic id used to identify whether a field
-- should have no label. A valid HTML4 id which is probably not
-- going to clash with any other id should someone use
-- 'bootstrapSubmit' outside 'renderBootstrap3'.
bootstrapSubmitId :: Text
bootstrapSubmitId = "b:ootstrap___unique__:::::::::::::::::submit-id"

31
yesod-form/Yesod/Form/Fields.hs
View File

@ -18,6 +18,7 @@ module Yesod.Form.Fields
, timeField
, htmlField
, emailField
, multiEmailField
, searchField
, AutoFocus
, urlField
@ -68,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.Either (partitionEithers)
import Data.Maybe (listToMaybe, fromMaybe)
import qualified Blaze.ByteString.Builder.Html.Utf8 as B
@ -82,7 +84,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 as T (Text, concat, intercalate, unpack, pack, splitOn)
import qualified Data.Text.Read
import qualified Data.Map as Map
@ -306,12 +308,37 @@ $newline never
, fieldEnctype = UrlEncoded
}
-- |
--
-- Since 1.3.7
multiEmailField :: Monad m => RenderMessage (HandlerSite m) FormMessage => Field m [Text]
multiEmailField = Field
{ fieldParse = parseHelper $
\s ->
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
<input id="#{theId}" name="#{name}" *{attrs} type="email" multiple :isReq:required="" value="#{either id cat val}">
|]
, fieldEnctype = UrlEncoded
}
where
-- 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
searchField autoFocus = Field
{ fieldParse = parseHelper Right
, fieldView = \theId name attrs val isReq -> do
[whamlet|\
[whamlet|
$newline never
<input id="#{theId}" name="#{name}" *{attrs} type="search" :isReq:required="" :autoFocus:autofocus="" value="#{either id id val}">
|]

80
yesod-form/Yesod/Form/Functions.hs
View File

@ -24,6 +24,8 @@ module Yesod.Form.Functions
-- * Generate a blank form
, generateFormPost
, generateFormGet
-- * More than one form on a handler
, identifyForm
-- * Rendering
, FormRender
, renderTable
@ -39,15 +41,16 @@ module Yesod.Form.Functions
-- * Utilities
, fieldSettingsLabel
, parseHelper
, parseHelperGen
) where
import Yesod.Form.Types
import Data.Text (Text, pack)
import Control.Arrow (second)
import Control.Monad.Trans.RWS (ask, get, put, runRWST, tell, evalRWST)
import Control.Monad.Trans.RWS (ask, get, put, runRWST, tell, evalRWST, local)
import Control.Monad.Trans.Class
import Control.Monad (liftM, join)
import Crypto.Classes (constTimeEq)
import Data.Byteable (constEqBytes)
import Text.Blaze (Markup, toMarkup)
#define Html Markup
#define toHtml toMarkup
@ -220,7 +223,7 @@ postHelper form env = do
| not (Map.lookup tokenKey params === reqToken req) ->
FormFailure [renderMessage m langs MsgCsrfWarning]
_ -> res
where (Just [t1]) === (Just t2) = TE.encodeUtf8 t1 `constTimeEq` TE.encodeUtf8 t2
where (Just [t1]) === (Just t2) = TE.encodeUtf8 t1 `constEqBytes` TE.encodeUtf8 t2
Nothing === Nothing = True -- It's important to use constTimeEq
_ === _ = False -- in order to avoid timing attacks.
return ((res', xml), enctype)
@ -284,6 +287,57 @@ getHelper form env = do
m <- getYesod
runFormGeneric (form fragment) m langs env
-- | Creates a hidden field on the form that identifies it. This
-- identification is then used to distinguish between /missing/
-- and /wrong/ form data when a single handler contains more than
-- one form.
--
-- For instance, if you have the following code on your handler:
--
-- > ((fooRes, fooWidget), fooEnctype) <- runFormPost fooForm
-- > ((barRes, barWidget), barEnctype) <- runFormPost barForm
--
-- Then replace it with
--
-- > ((fooRes, fooWidget), fooEnctype) <- runFormPost $ identifyForm "foo" fooForm
-- > ((barRes, barWidget), barEnctype) <- runFormPost $ identifyForm "bar" barForm
--
-- Note that it's your responsibility to ensure that the
-- identification strings are unique (using the same one twice on a
-- single handler will not generate any errors). This allows you
-- to create a variable number of forms and still have them work
-- even if their number or order change between the HTML
-- generation and the form submission.
identifyForm
:: Monad m
=> Text -- ^ Form identification string.
-> (Html -> MForm m (FormResult a, WidgetT (HandlerSite m) IO ()))
-> (Html -> MForm m (FormResult a, WidgetT (HandlerSite m) IO ()))
identifyForm identVal form = \fragment -> do
-- Create hidden <input>.
let fragment' =
[shamlet|
<input type=hidden name=#{identifyFormKey} value=#{identVal}>
#{fragment}
|]
-- Check if we got its value back.
mp <- askParams
let missing = (mp >>= Map.lookup identifyFormKey) /= Just [identVal]
-- Run the form proper (with our hidden <input>). If the
-- data is missing, then do not provide any params to the
-- form, which will turn its result into FormMissing. Also,
-- doing this avoids having lots of fields with red errors.
let eraseParams | missing = local (\(_, h, l) -> (Nothing, h, l))
| otherwise = id
eraseParams (form fragment')
identifyFormKey :: Text
identifyFormKey = "_formid"
type FormRender m a =
AForm m a
-> Html
@ -333,7 +387,9 @@ $forall view <- views
|]
return (res, widget)
-- | Render a form using Bootstrap-friendly shamlet syntax.
-- | Render a form using Bootstrap v2-friendly shamlet syntax.
-- If you're using Bootstrap v3, then you should use the
-- functions from module "Yesod.Form.Bootstrap3".
--
-- Sample Hamlet:
--
@ -368,6 +424,7 @@ renderBootstrap aform fragment = do
<span .help-block>#{err}
|]
return (res, widget)
{-# DEPRECATED renderBootstrap "Please use the Yesod.Form.Bootstrap3 module." #-}
check :: (Monad m, RenderMessage (HandlerSite m) msg)
=> (a -> Either msg a)
@ -428,6 +485,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

2
yesod-form/Yesod/Form/Types.hs
View File

@ -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'

3
yesod-form/hello-forms.hs
View File

@ -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

5
yesod-form/yesod-form.cabal
View File

@ -1,5 +1,5 @@
name: yesod-form
version: 1.3.5.1
version: 1.3.8
license: MIT
license-file: LICENSE
author: Michael Snoyman <michael@snoyman.com>
@ -35,13 +35,14 @@ library
, blaze-html >= 0.5
, blaze-markup >= 0.5.1
, attoparsec >= 0.10
, crypto-api >= 0.8
, byteable
, aeson
, resourcet
exposed-modules: Yesod.Form
Yesod.Form.Types
Yesod.Form.Functions
Yesod.Form.Bootstrap3
Yesod.Form.Input
Yesod.Form.Fields
Yesod.Form.Jquery

2
yesod-platform/make-cabal.sh
View File

@ -7,4 +7,4 @@ then
cabal install cabal-nirvana -fgenerate
fi
cabal-nirvana-generate yesod yesod-static hjsmin blaze-html yesod-test shakespeare-text esqueleto warp-tls hjsmin | runghc to-cabal.hs > yesod-platform.cabal
cabal-nirvana-generate yesod yesod-static hjsmin blaze-html yesod-test shakespeare-text esqueleto warp-tls hjsmin http-reverse-proxy | runghc to-cabal.hs > yesod-platform.cabal

90
yesod-platform/yesod-platform.cabal
View File

@ -1,5 +1,5 @@
name: yesod-platform
version: 1.2.7.1
version: 1.2.8
license: MIT
license-file: LICENSE
author: Michael Snoyman <michael@snoyman.com>
@ -14,17 +14,21 @@ homepage: http://www.yesodweb.com/
library
build-depends: base >= 4 && < 5
, ReadArgs == 1.2.1
, SHA == 1.6.4
, aeson == 0.7.0.1
, aeson == 0.7.0.2
, ansi-terminal == 0.6.1.1
, asn1-encoding == 0.8.1.2
, ansi-wl-pprint == 0.6.7.1
, asn1-encoding == 0.8.1.3
, asn1-parse == 0.8.1
, asn1-types == 0.2.3
, attoparsec == 0.11.1.0
, async == 2.0.1.5
, attoparsec == 0.11.2.1
, attoparsec-conduit == 1.0.1.2
, authenticate == 1.3.2.6
, base-unicode-symbols == 0.2.2.4
, base64-bytestring == 1.0.0.1
, basic-prelude == 0.3.6.0
, blaze-builder == 0.3.3.2
, blaze-builder-conduit == 1.0.0
, blaze-html == 0.7.0.1
@ -33,39 +37,38 @@ library
, byteorder == 1.0.4
, case-insensitive == 1.1.0.3
, cereal == 0.4.0.1
, cipher-aes == 0.2.6
, cipher-aes == 0.2.7
, cipher-rc4 == 0.1.4
, clientsession == 0.9.0.3
, conduit == 1.0.14
, conduit == 1.0.15.1
, connection == 0.2.0
, control-monad-loop == 0.1
, cookie == 0.4.0.1
, cprng-aes == 0.5.2
, crypto-api == 0.13
, crypto-cipher-types == 0.0.9
, crypto-conduit == 0.5.2.2
, crypto-numbers == 0.2.3
, crypto-pubkey == 0.2.4
, crypto-pubkey-types == 0.4.1
, crypto-pubkey-types == 0.4.2.2
, crypto-random == 0.0.7
, cryptohash == 0.11.2
, cryptohash-cryptoapi == 0.1.0
, css-text == 0.1.1
, cryptohash-conduit == 0.1.0
, css-text == 0.1.2.1
, data-default == 0.5.3
, data-default-class == 0.0.1
, data-default-instances-base == 0.0.1
, data-default-instances-containers == 0.0.1
, data-default-instances-dlist == 0.0.1
, data-default-instances-old-locale == 0.0.1
, dlist == 0.6.0.1
, dlist == 0.7
, email-validate == 2.0.1
, entropy == 0.2.2.4
, esqueleto == 1.3.4.5
, esqueleto == 1.3.5
, failure == 0.2.0.1
, fast-logger == 2.1.5
, file-embed == 0.0.6
, filesystem-conduit == 1.0.0.1
, hamlet == 1.1.7.7
, hamlet == 1.1.9.2
, hjsmin == 0.1.4.5
, hspec == 1.8.3
, hspec-expectations == 0.5.0.1
@ -73,54 +76,55 @@ library
, http-client == 0.2.2.2
, http-client-conduit == 0.2.0.1
, http-client-tls == 0.2.1.1
, http-conduit == 2.0.0.5
, http-conduit == 2.0.0.8
, http-date == 0.0.4
, http-reverse-proxy == 0.3.1.1
, http-types == 0.8.3
, language-javascript == 0.5.8
, lifted-base == 0.2.2.0
, mime-mail == 0.4.4
, language-javascript == 0.5.9
, lifted-base == 0.2.2.1
, mime-mail == 0.4.4.1
, mime-types == 0.1.0.3
, mmorph == 1.0.2
, monad-control == 0.3.2.3
, monad-logger == 0.3.4.0
, monad-loops == 0.4.2
, network-conduit == 1.0.2.2
, network-conduit == 1.0.4
, optparse-applicative == 0.7.0.2
, path-pieces == 0.1.3.1
, pem == 0.2.1
, persistent == 1.3.0.2
, persistent-template == 1.3.1.1
, pool-conduit == 0.1.2
, primitive == 0.5.1.0
, persistent == 1.3.0.3
, persistent-template == 1.3.1.2
, pool-conduit == 0.1.2.1
, primitive == 0.5.2.1
, process-conduit == 1.0.0.1
, publicsuffixlist == 0.1
, pureMD5 == 2.1.2.1
, pwstore-fast == 2.4.1
, quickcheck-io == 0.1.0
, resource-pool == 0.2.1.1
, resourcet == 0.4.10
, resourcet == 0.4.10.1
, safe == 0.3.4
, scientific == 0.2.0.1
, scientific == 0.2.0.2
, securemem == 0.1.3
, semigroups == 0.12.2
, setenv == 0.1.1.1
, shakespeare == 1.2.0.4
, shakespeare-css == 1.0.6.6
, shakespeare == 1.2.1.1
, shakespeare-css == 1.0.7.1
, shakespeare-i18n == 1.0.0.5
, shakespeare-js == 1.2.0.3
, shakespeare-text == 1.0.1
, shakespeare-js == 1.2.0.4
, shakespeare-text == 1.0.2
, silently == 1.2.4.1
, simple-sendfile == 0.2.13
, skein == 1.0.8.1
, skein == 1.0.9
, socks == 0.5.4
, stm-chans == 3.0.0
, stringsearch == 0.3.6.5
, system-fileio == 0.3.12
, system-filepath == 0.4.9
, tagged == 0.7
, tagged == 0.7.1
, tagsoup == 0.13.1
, tagstream-conduit == 0.5.5
, text-stream-decode == 0.1.0.3
, text-stream-decode == 0.1.0.4
, tls == 1.2.2
, transformers-base == 0.4.1
, unix-compat == 0.4.1.1
@ -129,29 +133,29 @@ library
, utf8-string == 0.3.7
, vector == 0.10.9.1
, void == 0.6.1
, wai == 2.0.0
, wai-app-static == 2.0.0.2
, wai-extra == 2.0.3.3
, wai == 2.1.0
, wai-app-static == 2.0.0.4
, wai-extra == 2.1.0.1
, wai-logger == 2.1.1
, wai-test == 2.0.0.1
, warp == 2.0.3.2
, warp-tls == 2.0.2
, wai-test == 2.0.0.2
, warp == 2.1.1.2
, warp-tls == 2.0.3.1
, word8 == 0.0.4
, x509 == 1.4.7
, x509 == 1.4.11
, x509-store == 1.4.4
, x509-system == 1.4.2
, x509-validation == 1.5.0
, xml-conduit == 1.1.0.9
, xml-types == 0.3.4
, xss-sanitize == 0.3.4.2
, xss-sanitize == 0.3.5
, yaml == 0.8.7.2
, yesod == 1.2.5
, yesod-auth == 1.2.5.3
, yesod-core == 1.2.6.7
, yesod-form == 1.3.5.1
, yesod-auth == 1.2.7
, yesod-core == 1.2.8
, yesod-form == 1.3.8
, yesod-persistent == 1.2.2.1
, yesod-routes == 1.2.0.6
, yesod-static == 1.2.2.1
, yesod-static == 1.2.2.2
, yesod-test == 1.2.1
, zlib-bindings == 0.1.1.3
, zlib-conduit == 1.0.0

10
yesod-static/Yesod/Static.hs
View File

@ -73,14 +73,14 @@ import Data.List (intercalate)
import Language.Haskell.TH
import Language.Haskell.TH.Syntax as TH
import Crypto.Conduit (hashFile, sinkHash)
import Crypto.Hash.CryptoAPI (MD5)
import Crypto.Hash.Conduit (hashFile, sinkHash)
import Crypto.Hash (MD5, Digest)
import Control.Monad.Trans.State
import qualified Data.Byteable as Byteable
import qualified Data.ByteString.Base64
import qualified Data.ByteString.Char8 as S8
import qualified Data.ByteString.Lazy as L
import qualified Data.Serialize
import Data.Text (Text, pack)
import qualified Data.Text as T
import qualified Data.Map as M
@ -359,7 +359,7 @@ mkStaticFilesList fp fs routeConName makeHash = do
base64md5File :: Prelude.FilePath -> IO String
base64md5File = fmap (base64 . encode) . hashFile
where encode d = Data.Serialize.encode (d :: MD5)
where encode d = Byteable.toBytes (d :: Digest MD5)
base64md5 :: L.ByteString -> String
base64md5 lbs =
@ -367,7 +367,7 @@ base64md5 lbs =
$ runIdentity
$ sourceList (L.toChunks lbs) $$ sinkHash
where
encode d = Data.Serialize.encode (d :: MD5)
encode d = Byteable.toBytes (d :: Digest MD5)
base64 :: S.ByteString -> String
base64 = map tr

14
yesod-static/yesod-static.cabal
View File

@ -1,5 +1,5 @@
name: yesod-static
version: 1.2.2.1
version: 1.2.2.2
license: MIT
license-file: LICENSE
author: Michael Snoyman <michael@snoyman.com>
@ -29,7 +29,7 @@ library
, old-time >= 1.0
, yesod-core >= 1.2 && < 1.3
, base64-bytestring >= 0.1.0.1
, cereal >= 0.3
, byteable >= 0.1
, bytestring >= 0.9.1.4
, template-haskell
, directory >= 1.0
@ -41,8 +41,8 @@ library
, http-types >= 0.7
, unix-compat >= 0.2
, conduit >= 0.5
, crypto-conduit >= 0.4
, cryptohash-cryptoapi >= 0.1.0
, cryptohash-conduit >= 0.1
, cryptohash >= 0.11
, system-filepath >= 0.4.6 && < 0.5
, system-fileio >= 0.3
, data-default
@ -80,8 +80,8 @@ test-suite tests
, old-time
, yesod-core
, base64-bytestring
, cereal
, bytestring
, byteable
, template-haskell
, directory
, transformers
@ -92,8 +92,8 @@ test-suite tests
, http-types
, unix-compat
, conduit
, crypto-conduit
, cryptohash-cryptoapi
, cryptohash-conduit
, cryptohash
, system-filepath
, system-fileio
, data-default

20
yesod-websockets/LICENSE Normal file
View File

@ -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.

2
yesod-websockets/Setup.hs Normal file
View File

@ -0,0 +1,2 @@
import Distribution.Simple
main = defaultMain

124
yesod-websockets/Yesod/WebSockets.hs Normal file
View File

@ -0,0 +1,124 @@
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE MultiParamTypeClasses #-}
module Yesod.WebSockets
( -- * Core API
WebSocketsT
, webSockets
, receiveData
, sendTextData
, sendBinaryData
-- * Conduit API
, sourceWS
, sinkWSText
, sinkWSBinary
-- * Async helpers
, race
, race_
, concurrently
, concurrently_
) where
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
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
-- | 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
-- | 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)

88
yesod-websockets/chat.hs Normal file
View File

@ -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|
<div #output>
<form #form>
<input #input autofocus>
|]
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

49
yesod-websockets/sample.hs Normal file
View File

@ -0,0 +1,49 @@
{-# LANGUAGE QuasiQuotes, TemplateHaskell, TypeFamilies #-}
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
instance Yesod App
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 $ race_
(sourceWS $$ mapC TL.toUpper =$ sinkWSText)
(timeSource $$ sinkWSText)
defaultLayout $
toWidget
[julius|
var conn = new WebSocket("ws://localhost:3000/");
conn.onopen = function() {
document.write("<p>open!</p>");
document.write("<button id=button>Send another message</button>")
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("<p>" + e.data + "</p>");
};
|]
main :: IO ()
main = warp 3000 App

30
yesod-websockets/yesod-websockets.cabal Normal file
View File

@ -0,0 +1,30 @@
-- 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
, conduit >= 1.0.15.1
, async >= 2.0.1.5
source-repository head
type: git
location: https://github.com/yesodweb/yesod