WebsocketChat.hs

{-# LANGUAGE FlexibleContexts, FlexibleInstances, GADTs, GeneralizedNewtypeDeriving, MultiParamTypeClasses,
    OverloadedStrings, QuasiQuotes, TemplateHaskell, TypeFamilies, TypeSynonymInstances #-}
import           ClassyPrelude                      (catchAnyDeep)
import           Conduit
import           Control.Applicative                ((<$>))
import           Control.Concurrent.STM.Lifted
import           Control.Monad                      (forM_, forever, void)
import           Control.Monad.Logger               (runStderrLoggingT)
import           Data.Aeson
import           Data.Text                          (Text, pack)
import           Data.Text.Lazy                     (toStrict)
import           Data.Text.Lazy.Encoding            (decodeUtf8)
import           Data.Time
import           Database.Persist.Sqlite
import           System.Locale
import           Yesod
import           Yesod.WebSockets
import           Text.HTML.TagSoup                  (escapeHTML)

share [mkPersist sqlSettings, mkMigrate "migrateAll"] [persistLowerCase|
Message
    time    ZonedTime
    content Text
    deriving Show
|]

myFormatTime :: ZonedTime -> Text
myFormatTime = pack . formatTime defaultTimeLocale "%H:%M:%S"

instance ToJSON Message where
  toJSON (Message now msg) = object ["time" .= myFormatTime now, "text" .= msg]

data App = App { wsChan     :: TChan Value
               , chatOnline :: TVar Int
               , appPool    :: ConnectionPool
               }

mkYesod "App" [parseRoutes|
/ ChatR GET
|]

instance Yesod App

instance YesodPersist App where
    type YesodPersistBackend App = SqlPersistT
    runDB action = do
        App _ _ pool <- getYesod
        runSqlPool action pool

instance RenderMessage App FormMessage where
    renderMessage _ _ = defaultFormMessage

encode' :: Value -> Text
encode' = toStrict . decodeUtf8 . encode

sendOnline chan n = atomically $ writeTChan chan $ object ["online" .= n]

chatApp :: [Message] -> WebSocketsT Handler ()
chatApp history = flip catchAnyDeep connectException $ do
  App writeChan online _ <- getYesod

  forM_ history (sendTextData . encode' . toJSON)

  readChan <- atomically $ dupTChan writeChan
  sendOnline writeChan =<< atomically (modifyTVar' online (+1) >> readTVar online)

  race_
    (forever $ atomically (readTChan readChan) >>= sendTextData . encode')
    (sourceWS $$ mapM_C (\msg -> if msg == "костыль920831605865718"
                                 then return ()
                                 else do
                                   now <- liftIO getZonedTime
                                   let m = Message now (escapeHTML msg)
                                   void $ lift $ runDB $ insert m
                                   atomically $ writeTChan writeChan $ toJSON m))
  where dec x = x - 1
        dec :: Int -> Int
        connectException _ = do
          App writeChan online _ <- getYesod
          sendOnline writeChan =<< atomically (modifyTVar' online dec >> readTVar online)


getChatR :: Handler Html
getChatR = do
  history <- fmap entityVal <$> runDB (selectList [] [LimitTo 100, Asc MessageTime])
  webSockets $ chatApp history
  defaultLayout $ do
    setTitle "Yesod chat"
    toWidget
      [julius|
       var url = document.URL;
       url = url.replace("http:", "ws:").replace("https:", "wss:");
       var ws = new WebSocket(url);
       ws.onerror = function(e) {
          alert("Connection error"+". Возможно, это фаерфоксопроблемы. ");
       };
       ws.onclose = function(e) {
          alert("Connection closed. "+e.reason+" "+e.code);
       };
       ws.onmessage = function(msg) {
          var m = JSON.parse(msg.data);
          if (!m.online) {
              var msgDiv = document.createElement("div");
              msgDiv.className = "msg";
              msgDiv.innerHTML = "<time>"+m.time+"</time>"+"<div class='text'><p>"+m.text+"</p></div>";
              document.getElementById("messages").appendChild(msgDiv);
              window.scrollTo(0,document.body.scrollHeight);
          } else {
              console.log("online: "+m.online);
              document.getElementById("online").innerHTML = "online: "+m.online;
          }
       };
       setTimeout(function(){ setInterval(function() { ws.send("костыль920831605865718") } , 30000); }, 10000);
       document.getElementsByTagName("textarea")[0].onkeypress = function(e) {
           if (e.keyCode == 13 && this.value == '') return false;
           if (e.keyCode == 13) {
               ws.send(this.value);
               this.value = "";
               return false;
           }
       };
      |]
    toWidget
      [lucius|
        body {
            color: #600000;
            background-color: #FFFFEE;
        }
        h1 {
            text-align: center;
        }
        textarea {
            width: 99%;
            height: 80px;
            position: fixed;
            bottom: 2px;
            left: 2px;
        }
        #form-container {
            height: 80px;
        }
        .msg {
            margin: 2px;
        }
        .msg .text {
            padding: 3px;
            background-color: #F0E0D6;
            width: 100%;
        }
        .text p {
            margin: 0;
        }
        .msg time {
            background-color: #EEAA88;
            padding: 3px;
            float: left;
            margin-right: 3px;
        }
        #online {
           position: fixed;
           right: 5px;
           top: 5px;
        }
    |]
    [whamlet|
        <h1>Yesod chat
        <div #online>
        <div #messages>
        <div #form-container>
            <textarea placeholder="Enter a message and press enter">
    |]

openConnectionCount :: Int
openConnectionCount = 500

main :: IO ()
main = withSqlitePool "chat.sqlite" openConnectionCount $ \pool -> do
  runResourceT $ runStderrLoggingT $ flip runSqlPool pool $ do
    runMigration migrateAll
    now <- liftIO getZonedTime
    void $ insert $ Message now "Chat restarted"
  chan   <- atomically newBroadcastTChan
  online <- atomically $ newTVar 0
  warp 3666 $ App chan online pool