Source code of the Yesod presentation at the Haskell User Group Frankfurt.

Chat.hs

-- The source code in this file is an adapated version of the chat example in the Yesod Book. See
-- http://www.yesodweb.com/book/wiki-chat-example 

{-# LANGUAGE OverloadedStrings, TypeFamilies, QuasiQuotes,
             TemplateHaskell, FlexibleInstances, MultiParamTypeClasses,
             FlexibleContexts
 #-}

module Chat where

import Blaze.ByteString.Builder.Char.Utf8 (fromText)
import Control.Concurrent.Chan (Chan, writeChan)
import Data.Monoid (mappend)
import Data.Text (Text)
import Language.Haskell.TH.Syntax (Type (VarT), Pred (ClassP), mkName)
import Network.Wai.EventSource (ServerEvent (..), eventSourceAppChan)
import Text.Julius (rawJS)
import Yesod

data Chat = Chat (Chan ServerEvent)

class (Yesod master, RenderMessage master FormMessage) => YesodChat master where
      getUserName :: GHandler sub master Text
      isLoggedIn :: GHandler sub master Bool
      
mkYesodSub "Chat"
           [ ClassP ''YesodChat [VarT $ mkName "master"]
           ] [parseRoutes|
           /send SendR POST
           /recv RecvR GET
           |]
           
postSendR :: YesodChat master => GHandler Chat master ()
postSendR = do
          from <- getUserName
          body <- runInputGet $ ireq textField "message"
          Chat chan <- getYesodSub
          liftIO $ writeChan chan $ ServerEvent Nothing Nothing $ return $
                 fromText from `mappend` fromText ": " `mappend` fromText body
                 
getRecvR :: GHandler Chat master ()
getRecvR = do
         Chat chan <- getYesodSub
         req <- waiRequest
         res <- lift $ eventSourceAppChan chan req
         sendWaiResponse res
         
chatWidget :: YesodChat master => (Route Chat -> Route master) -> GWidget sub master ()
chatWidget toMaster = do
           chat <- lift newIdent
           output <- lift newIdent
           input <- lift newIdent
           ili <- lift isLoggedIn
           if ili
              then do
                   [whamlet|
                   <div ##{chat}>
                        <h2>Chat
                        <div ##{output}>
                        <input ##{input} type=text placeholder="Enter Message">
                   |]
                   toWidget [lucius|
                   ##{chat} {
                            position: absolute;
                            top: 2em;
                            right: 2em;
                   }
                   ##{output} {
                            width: 200px;
                            height: 300px;
                            border: 1px solid #999;
                            overflow: auto;
                   }
                   |]
                   toWidgetBody [julius|
                   var output = document.getElementById("#{rawJS output}");
                   var src = new EventSource("@{toMaster RecvR}");
                   src.onmessage = function(msg) {
                        var p = document.createElement("p");
                        p.appendChild(document.createTextNode(msg.data));
                        output.appendChild(p);
                        output.scrollTop = output.scrollHeight;
                        
                   };
                   
                   var input = document.getElementById("#{rawJS input}");
                   input.onkeyup = function(event) {
                        var keycode = (event.keyCode ? event.keyCode : event.which);
                        if (keycode == '13') {
                           var xhr = new XMLHttpRequest();
                           var val = input.value;
                           input.value = "";
                           var params = "?message=" + encodeURI(val);
                           xhr.open("POST", "@{toMaster SendR}" + params);
                           xhr.send(null);
                        }
                   };
                   |]
               else do
                    master <- lift getYesod
                    [whamlet|
                    <p>
                        You must be #
                        $maybe ar <- authRoute master
                             <a href=@{ar}>logged in
                        $nothing
                             logged in
                        \ to chat.
                     |]

demo.hs

{-# LANGUAGE FlexibleContexts      #-}
{-# LANGUAGE GADTs                 #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings     #-}
{-# LANGUAGE QuasiQuotes           #-}
{-# LANGUAGE TemplateHaskell       #-}
{-# LANGUAGE TypeFamilies          #-}

import           Control.Applicative
import           Control.Concurrent.Chan      (Chan, newChan)
import           Control.Monad.Logger
import           Control.Monad.Trans.Resource
import           Data.Text                    (Text)
import qualified Data.Text                    (length)
import           Database.Persist.Sqlite
import           Yesod
import           Yesod.Auth
import           Yesod.Auth.Dummy

import           Chat

data Demo = Demo {
     getConnectionPool :: ConnectionPool,
     getChat           :: Chat
     }

share [mkPersist sqlSettings, mkMigrate "migrateAll"] [persistUpperCase|
Author
  name Text
  UniqueAuthor name

Post
  title Text
  body Text
  author AuthorId
|]

mkYesod "Demo" [parseRoutes|
/ HomeR GET
/auth AuthR Auth getAuth
/post/#PostId PostR GET
/new-post     NewPostR GET POST
/chat ChatR Chat getChat
|]

instance Yesod Demo where
  authRoute _ = Just $ AuthR LoginR
  defaultLayout widget = do
    pc <- widgetToPageContent $ widget >> chatWidget ChatR
    mmsg <- getMessage
    hamletToRepHtml [hamlet|
    $doctype 5
    <html>
      <head>
        <title>#{pageTitle pc}
        ^{pageHead pc}
      <body>
        $maybe msg <- mmsg
          <div .message>#{msg}
        <a href=@{AuthR LoginR}>Login
        <a href=@{AuthR LogoutR}>Logout
        <br>
        ^{pageBody pc}
     |]

instance YesodPersist Demo where
  type YesodPersistBackend Demo = SqlPersist
  runDB action = do
        Demo pool chan <- getYesod
        runSqlPool action pool

instance YesodAuth Demo where
  type AuthId Demo = AuthorId
  authPlugins _ = [authDummy]
  loginDest _ = HomeR
  logoutDest _ = HomeR
  getAuthId creds = runDB $ do
        x <- getBy $ UniqueAuthor $ credsIdent creds
        case x of
            Just (Entity uid _) -> return $ Just uid
            Nothing -> do
                fmap Just $ insert $ Author (credsIdent creds)
  authHttpManager = error "authHttpManager"

instance YesodChat Demo where
  getUserName = requireAuthId >>= runDB . get404 >>= return . authorName
  isLoggedIn = maybeAuthId >>= return . maybe False (const True)

instance RenderMessage Demo FormMessage where
         renderMessage _ _ = defaultFormMessage

getHomeR :: Handler RepHtml
getHomeR = do
         posts <- runDB $ selectList [] []
         defaultLayout [whamlet|
Hello World!
<a href=@{HomeR}>Go Home

$if null posts
    <p>Keine Einträge vorhanden
$else
    <ul>
    $forall Entity id post <- posts
      <li>
        <a href=@{PostR id}>#{postTitle post}
|]

getPostR :: PostId -> Handler RepHtml
getPostR id = do
         post <- runDB $ get404 id
         author <- runDB $ get404 $ postAuthor post
         defaultLayout $ do
            setTitle $ toHtml $ postTitle post
            [whamlet|
Title: #{postTitle post}
<br>
Author: #{authorName author}
<br>
Body: #{postBody post}
|]

postFormular :: AuthorId -> Html -> MForm Demo Demo (FormResult Post, Widget)
postFormular aid = renderDivs $ Post
           <$> areq textFieldCheck "Title" Nothing
           <*> areq textField "Body"  Nothing
           <*> pure aid
  where
    errorMsg :: Text
    errorMsg = "Der Titel hat mehr als 20 Zeichen"
    textFieldCheck = checkBool ((<21) . Data.Text.length) errorMsg textField

getNewPostR :: Handler RepHtml
getNewPostR = do
            aid <- requireAuthId
            ((res, form), enctype) <- runFormPost $ postFormular aid
            defaultLayout $ do
              [whamlet|
              <form method=post enctype=#{enctype}>
                ^{form}
                <input type=submit value="Abschicken">
              |]

postNewPostR :: Handler RepHtml
postNewPostR = do
            aid <- requireAuthId
            ((res, form), enctype) <- runFormPost $ postFormular aid
            case res of
              FormSuccess post -> do
                postId <- runDB $ insert post
                redirect $ PostR postId
              _ -> defaultLayout $ do
                [whamlet|
                <form method=post enctype=#{enctype}>
                  ^{form}
                  <input type=submit value="Abschicken">
                |]


openConnectionCount :: Int
openConnectionCount = 1

main :: IO ()
main = do
     withSqlitePool ":memory:" openConnectionCount $ \pool -> do
     runNoLoggingT $ runSqlPool (runMigration migrateAll) pool
     runNoLoggingT $ runResourceT $ flip runSqlPool pool $ do
        aid <- insert $ Author "Pascal"
        insert $ Post "Test Entry" "This is a test." aid
     chan <- newChan
     warpDebug 3000 $ Demo pool (Chat chan)