Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Newer
Older
100644 86 lines (68 sloc) 2.698 kb
c2ecac6 @yihuang hlint
authored
1 {-# LANGUAGE OverloadedStrings #-}
d435e7c @yihuang refactor code
authored
2 module Apps where
3
4228521 @yihuang big rewrite, NEXT: handle heartbeat correctly.
authored
4 import Control.Exception (fromException)
5 import Control.Monad (forever, when, forM_)
6 import Control.Monad.IO.Class (liftIO)
7 import Control.Applicative
8 import Control.Concurrent.MVar
9
10 import Data.Map (Map)
d435e7c @yihuang refactor code
authored
11 import qualified Data.Map as M
4228521 @yihuang big rewrite, NEXT: handle heartbeat correctly.
authored
12 import Data.Monoid (mappend, mconcat)
13 import Data.Attoparsec
14 import Data.Attoparsec.Char8 (skipSpace)
15 import Data.ByteString (ByteString)
16 import qualified Data.ByteString.Char8 as S
17
18 import Network.WebSockets.Lite
19
20 echo :: WSLite ()
21 echo = forever $ recvBS >>= send
d435e7c @yihuang refactor code
authored
22
4228521 @yihuang big rewrite, NEXT: handle heartbeat correctly.
authored
23 close' :: WSLite ()
24 close' = return ()
d435e7c @yihuang refactor code
authored
25
4228521 @yihuang big rewrite, NEXT: handle heartbeat correctly.
authored
26 data ChatMessage = ChatJoin ByteString
27 | ChatData ByteString
28 | ChatError ByteString
d435e7c @yihuang refactor code
authored
29
4228521 @yihuang big rewrite, NEXT: handle heartbeat correctly.
authored
30 chatParser :: Parser ChatMessage
31 chatParser = ChatJoin <$> (string "join" *> skipSpace *> takeByteString)
32 <|> ChatData <$> takeByteString
b4d1ba3 @yihuang stage
authored
33
4228521 @yihuang big rewrite, NEXT: handle heartbeat correctly.
authored
34 instance UpProtocol ChatMessage where
c2ecac6 @yihuang hlint
authored
35 decode = parseOnly chatParser
d435e7c @yihuang refactor code
authored
36
4228521 @yihuang big rewrite, NEXT: handle heartbeat correctly.
authored
37 instance DownProtocol ChatMessage where
38 encode (ChatData s) = s
39 encode (ChatError e) = "error: " `mappend` e
40 encode (ChatJoin name) = name `mappend` " joined"
d435e7c @yihuang refactor code
authored
41
4228521 @yihuang big rewrite, NEXT: handle heartbeat correctly.
authored
42 type ChatState = MVar (Map ByteString Sink)
d435e7c @yihuang refactor code
authored
43
4228521 @yihuang big rewrite, NEXT: handle heartbeat correctly.
authored
44 newChatState :: IO ChatState
45 newChatState = newMVar M.empty
d435e7c @yihuang refactor code
authored
46
4228521 @yihuang big rewrite, NEXT: handle heartbeat correctly.
authored
47 chat :: ChatState -> WSLite ()
48 chat clients = do
49 name <- recvJoin
d435e7c @yihuang refactor code
authored
50 sink <- getSink
c2ecac6 @yihuang hlint
authored
51 exists <- liftIO $ modifyMVar clients $ \cs ->
4228521 @yihuang big rewrite, NEXT: handle heartbeat correctly.
authored
52 case M.lookup name cs of
53 Nothing -> return (M.insert name sink cs, False)
54 Just _ -> return (cs, True)
55 when exists $ fail' "User already exists."
56
57 flip catchError (handleDisconnect name) $ do
58 welcome name
59 broadcast $ ChatJoin name
60 forever $ do
61 msg <- recv
62 case msg of
63 ChatData s -> broadcast $ ChatData $ mconcat [name, ": ", s]
64 _ -> fail' "invalid message."
d435e7c @yihuang refactor code
authored
65 where
4228521 @yihuang big rewrite, NEXT: handle heartbeat correctly.
authored
66 fail' s = send (ChatError s) >> close
67 recvJoin = do msg <- recv
68 case msg of
69 ChatJoin name -> return name
70 _ -> fail' "invalid message."
71
72 broadcast msg = do
73 sinks <- M.elems <$> liftIO (readMVar clients)
c2ecac6 @yihuang hlint
authored
74 forM_ sinks (`sendSink` msg)
4228521 @yihuang big rewrite, NEXT: handle heartbeat correctly.
authored
75
76 welcome name = do
77 users <- filter (/=name) . M.keys <$> liftIO (readMVar clients)
78 send $ ChatData $ "Welcome! Users: " `mappend` S.intercalate ", " users
79
80 handleDisconnect name e = case fromException e of
81 Just ConnectionClosed -> do
82 liftIO $ modifyMVar_ clients $ return . M.delete name
83 broadcast $ ChatData $ mconcat [name, " disconnected."]
d435e7c @yihuang refactor code
authored
84 _ -> return ()
85
Something went wrong with that request. Please try again.