将 websockets 整合到 Yesod

Question

如何将 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，你可能运行进入 stm-lifted 的 websockets 依赖问题。解压 stm-lifted 并修改其 cabal 文件（更改 transformers 版本）。

更新 1：

以下代码已编译。我会尝试添加一些 julius。我会post稍后更新。

{-# 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")

Answer 1

这里我解决了问题：

{-# 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 100000

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

然后我将下面的代码添加到 homepage.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>");
                };

结果如下：

将 websockets 整合到 Yesod

Incorporate websockets into Yesod

haskell

yesod

haskell-stack

更新 1：