【发布时间】：2017-09-01 11:25:27
【问题描述】：
如何将 websockets 合并到 Yesod 中？
我使用 yesod-postgres 模板创建了一个项目。
stack new rl yesod-postgres
Handler/Home.hs 文件如下所示（尚未修改）：
module Handler.Home where
import Import
import qualified Data.Text.Lazy as TL
import Yesod.Form.Bootstrap3 (BootstrapFormLayout (..), renderBootstrap3)
import Text.Julius (RawJS (..))
-- Define our data that will be used for creating the form.
data FileForm = FileForm
{ fileInfo :: FileInfo
, fileDescription :: Text
}
getHomeR :: Handler Html
getHomeR = do
(formWidget, formEnctype) <- generateFormPost sampleForm
let submission = Nothing :: Maybe FileForm
handlerName = "getHomeR" :: Text
defaultLayout $ do
let (commentFormId, commentTextareaId, commentListId) = commentIds
aDomId <- newIdent
setTitle "Welcome To Yesod!"
$(widgetFile "homepage")
postHomeR :: Handler Html
postHomeR = do
((result, formWidget), formEnctype) <- runFormPost sampleForm
let handlerName = "postHomeR" :: Text
submission = case result of
FormSuccess res -> Just res
_ -> Nothing
defaultLayout $ do
let (commentFormId, commentTextareaId, commentListId) = commentIds
aDomId <- newIdent
setTitle "Welcome To Yesod!"
$(widgetFile "homepage")
sampleForm :: Form FileForm
sampleForm = renderBootstrap3 BootstrapBasicForm $ FileForm
<$> fileAFormReq "Choose a file"
<*> areq textField textSettings Nothing
-- Add attributes like the placeholder and CSS classes.
where textSettings = FieldSettings
{ fsLabel = "What's on the file?"
, fsTooltip = Nothing
, fsId = Nothing
, fsName = Nothing
, fsAttrs =
[ ("class", "form-control")
, ("placeholder", "File description")
]
}
commentIds :: (Text, Text, Text)
commentIds = ("js-commentForm", "js-createCommentTextarea", "js-commentList")
这是来自github 的 websockets 示例：
{-# LANGUAGE QuasiQuotes, TemplateHaskell, TypeFamilies, OverloadedStrings #-}
import Yesod.Core
import Yesod.WebSockets
import qualified Data.Text.Lazy as TL
import Control.Monad (forever)
import Control.Concurrent (threadDelay)
import Data.Time
import Data.Conduit
import qualified Data.Conduit.List
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 $$ Data.Conduit.List.map 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>");
};
conn.onclose = function () {
document.write("<p>Connection Closed</p>");
};
|]
main :: IO ()
main = warp 3000 App
基于上面的示例，我尝试将下面的这些代码插入到 Handler/Home.hs 中。
...
import qualified Data.Text.Lazy as TL
....
timeSource :: MonadIO m => Source m TL.Text
timeSource = forever $ do
now <- liftIO getCurrentTime
yield $ TL.pack $ show now
liftIO $ threadDelay 5000000
....
getHomeR = do
webSockets $ race_
(sourceWS $$ Data.Conduit.List.map TL.toUpper =$ sinkWSText)
(timeSource $$ sinkWSText)
...
...
postHomeR = do
webSockets $ race_
(sourceWS $$ Data.Conduit.List.map TL.toUpper =$ sinkWSText)
(timeSource $$ sinkWSText)
这是最终结果：
{-# LANGUAGE QuasiQuotes, TemplateHaskell, TypeFamilies, OverloadedStrings #-}
module Handler.Home where
import Import
import qualified Data.Text.Lazy as TL
import qualified Data.Conduit.List
import Yesod.Form.Bootstrap3 (BootstrapFormLayout (..), renderBootstrap3)
import Text.Julius (RawJS (..))
-- Define our data that will be used for creating the form.
data FileForm = FileForm
{ fileInfo :: FileInfo
, fileDescription :: Text
}
-- This is a handler function for the GET request method on the HomeR
-- resource pattern. All of your resource patterns are defined in
-- config/routes
--
-- The majority of the code you will write in Yesod lives in these handler
-- functions. You can spread them across multiple files if you are so
-- inclined, or create a single monolithic file.
--
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
(formWidget, formEnctype) <- generateFormPost sampleForm
let submission = Nothing :: Maybe FileForm
handlerName = "getHomeR" :: Text
webSockets $ race_
(sourceWS $$ Data.Conduit.List.map TL.toUpper =$ sinkWSText)
(timeSource $$ sinkWSText)
defaultLayout $ do
let (commentFormId, commentTextareaId, commentListId) = commentIds
aDomId <- newIdent
setTitle "Welcome To Yesod!"
$(widgetFile "homepage")
postHomeR :: Handler Html
postHomeR = do
((result, formWidget), formEnctype) <- runFormPost sampleForm
let handlerName = "postHomeR" :: Text
submission = case result of
FormSuccess res -> Just res
_ -> Nothing
webSockets $ race_
(sourceWS $$ Data.Conduit.List.map TL.toUpper =$ sinkWSText)
(timeSource $$ sinkWSText)
defaultLayout $ do
let (commentFormId, commentTextareaId, commentListId) = commentIds
aDomId <- newIdent
setTitle "Welcome To Yesod!"
$(widgetFile "homepage")
sampleForm :: Form FileForm
sampleForm = renderBootstrap3 BootstrapBasicForm $ FileForm
<$> fileAFormReq "Choose a file"
<*> areq textField textSettings Nothing
-- Add attributes like the placeholder and CSS classes.
where textSettings = FieldSettings
{ fsLabel = "What's on the file?"
, fsTooltip = Nothing
, fsId = Nothing
, fsName = Nothing
, fsAttrs =
[ ("class", "form-control")
, ("placeholder", "File description")
]
}
commentIds :: (Text, Text, Text)
commentIds = ("js-commentForm", "js-createCommentTextarea", "js-commentList")
但是当我做stack build 时，我得到了这些错误：
rl-0.0.0: build (lib + exe)
Preprocessing library rl-0.0.0...
[10 of 11] Compiling Handler.Home ( Handler/Home.hs, .stack-work/dist/x86_64-osx/Cabal-1.24.2.0/build/Handler/Home.o )
/Users/ee/Projects/Haskell Projects/rl/Handler/Home.hs:37:5: error:
Variable not in scope: webSockets :: m0 () -> HandlerT App IO a0
/Users/ee/Projects/Haskell Projects/rl/Handler/Home.hs:37:18: error:
• Couldn't match type ‘StM
m0 (constraints-0.9.1:Data.Constraint.Forall.Skolem (Pure m0))’
with ‘constraints-0.9.1:Data.Constraint.Forall.Skolem (Pure m0)’
arising from a use of ‘race_’
The type variable ‘m0’ is ambiguous
• In the second argument of ‘($)’, namely
‘race_
(sourceWS $$ Data.Conduit.List.map TL.toUpper =$ sinkWSText)
(timeSource $$ sinkWSText)’
In a stmt of a 'do' block:
webSockets
$ race_
(sourceWS $$ Data.Conduit.List.map TL.toUpper =$ sinkWSText)
(timeSource $$ sinkWSText)
In the expression:
do { (formWidget, formEnctype) <- generateFormPost sampleForm;
let submission = ...
handlerName = ...;
webSockets
$ race_
(sourceWS $$ Data.Conduit.List.map TL.toUpper =$ sinkWSText)
(timeSource $$ sinkWSText);
defaultLayout
$ do { let ...;
aDomId <- newIdent;
.... } }
关于如何使 websocket 与 yesod-postgres 一起工作的任何想法？
PS：我目前正在使用 ghc-8.02。如果你想尝试上面的代码并拥有相同的 ghc，你可能会遇到 websockets 的 stm-lifted 依赖问题。解压stm-lifted 并修改其cabal 文件（更改transformers 版本）。
更新 1：
以下代码已编译。我会尝试添加一些julius。我稍后会发布更新。
{-# LANGUAGE QuasiQuotes, TemplateHaskell, TypeFamilies, OverloadedStrings #-}
module Handler.Home where
import Import
import qualified Yesod.WebSockets as YW
import qualified Data.Text.Lazy as TL
--import Control.Concurrent (threadDelay)
--import Data.Time
--import Data.Conduit
import qualified Data.Conduit.List
import Yesod.Form.Bootstrap3 (BootstrapFormLayout (..), renderBootstrap3)
import Text.Julius (RawJS (..))
-- Define our data that will be used for creating the form.
data FileForm = FileForm
{ fileInfo :: FileInfo
, fileDescription :: Text
}
-- This is a handler function for the GET request method on the HomeR
-- resource pattern. All of your resource patterns are defined in
-- config/routes
--
-- The majority of the code you will write in Yesod lives in these handler
-- functions. You can spread them across multiple files if you are so
-- inclined, or create a single monolithic file.
--
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
(formWidget, formEnctype) <- generateFormPost sampleForm
let submission = Nothing :: Maybe FileForm
handlerName = "getHomeR" :: Text
YW.webSockets $ YW.race_
(YW.sourceWS $$ Data.Conduit.List.map TL.toUpper =$ YW.sinkWSText)
(timeSource $$ YW.sinkWSText)
defaultLayout $ do
let (commentFormId, commentTextareaId, commentListId) = commentIds
aDomId <- newIdent
setTitle "Welcome To Yesod!"
$(widgetFile "homepage")
postHomeR :: Handler Html
postHomeR = do
((result, formWidget), formEnctype) <- runFormPost sampleForm
let handlerName = "postHomeR" :: Text
submission = case result of
FormSuccess res -> Just res
_ -> Nothing
YW.webSockets $ YW.race_
(YW.sourceWS $$ Data.Conduit.List.map TL.toUpper =$ YW.sinkWSText)
(timeSource $$ YW.sinkWSText)
defaultLayout $ do
let (commentFormId, commentTextareaId, commentListId) = commentIds
aDomId <- newIdent
setTitle "Welcome To Yesod!"
$(widgetFile "homepage")
sampleForm :: Form FileForm
sampleForm = renderBootstrap3 BootstrapBasicForm $ FileForm
<$> fileAFormReq "Choose a file"
<*> areq textField textSettings Nothing
-- Add attributes like the placeholder and CSS classes.
where textSettings = FieldSettings
{ fsLabel = "What's on the file?"
, fsTooltip = Nothing
, fsId = Nothing
, fsName = Nothing
, fsAttrs =
[ ("class", "form-control")
, ("placeholder", "File description")
]
}
commentIds :: (Text, Text, Text)
commentIds = ("js-commentForm", "js-createCommentTextarea", "js-commentList")
【问题讨论】：
标签： haskell yesod haskell-stack