Permalink
Browse files

First check-in of chat backend.

  • Loading branch information...
gregorycollins committed Sep 1, 2011
0 parents commit 5c0406cc7eb9d018cc7d91e513c4e1da0ee648d1
@@ -0,0 +1,5 @@
+dist/**
+dist
+*~
+*#
+#*
30 LICENSE
@@ -0,0 +1,30 @@
+Copyright (c)2011, Gregory Collins
+
+All rights reserved.
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions are met:
+
+ * Redistributions of source code must retain the above copyright
+ notice, this list of conditions and the following disclaimer.
+
+ * Redistributions in binary form must reproduce the above
+ copyright notice, this list of conditions and the following
+ disclaimer in the documentation and/or other materials provided
+ with the distribution.
+
+ * Neither the name of Gregory Collins nor the names of other
+ contributors may be used to endorse or promote products derived
+ from this software without specific prior written permission.
+
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
@@ -0,0 +1,2 @@
+import Distribution.Simple
+main = defaultMain
@@ -0,0 +1,37 @@
+Name: snap-chat
+Version: 0.1
+License: BSD3
+License-file: LICENSE
+Author: Gregory Collins
+Maintainer: greg@gregorycollins.net
+Copyright: (c) 2011 Google, Inc.
+Category: Web
+Build-type: Simple
+
+-- Extra-source-files:
+
+Cabal-version: >=1.2
+
+Library
+ hs-source-dirs: src
+ -- Main-is:
+
+ Build-depends: base >= 4.2 && < 5,
+ aeson >= 0.3 && < 0.4,
+ base16-bytestring >= 0.1 && < 0.2,
+ bytestring >= 0.9 && < 0.10,
+ containers >= 0.4 && < 0.5,
+ hashtables >= 1.0 && < 1.1,
+ mwc-random >= 0.10 && < 0.11,
+ stm >= 2.2 && < 2.3,
+ text >= 0.11 && < 0.12,
+ unix-compat >= 0.3 && < 0.4
+
+ Exposed-Modules: Snap.Chat.Types,
+ Snap.Chat.ChatRoom,
+ Snap.Chat.Message
+ Other-modules: Snap.Chat.Internal.Types,
+ Snap.Chat.Internal.Util,
+ System.TimeoutManager
+
+
@@ -0,0 +1,190 @@
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE OverloadedStrings #-}
+
+module Snap.Chat.ChatRoom
+ ( newChatRoom
+ , destroyChatRoom
+ , withChatRoom
+ , joinUser
+ , lookupUser
+ , disconnectUser
+ , getMessages
+ , writeMessage
+
+ -- * Exceptions
+ , UserAlreadyConnectedException
+ ) where
+
+
+------------------------------------------------------------------------------
+import Control.Applicative
+import Control.Concurrent.MVar
+import Control.Concurrent.STM
+import Control.Exception
+import Control.Monad
+import qualified Data.ByteString as S
+import qualified Data.ByteString.Base16 as B16
+import qualified Data.HashTable.IO as HT
+import Data.Maybe
+import Data.Text (Text)
+import qualified Data.Text as T
+import Data.Typeable
+import Data.Word (Word8)
+import System.PosixCompat.Time
+import System.Random.MWC
+import System.Timeout
+------------------------------------------------------------------------------
+import qualified Snap.Chat.Message as Msg
+import Snap.Chat.Internal.Types
+import Snap.Chat.Internal.Util
+import qualified System.TimeoutManager as TM
+
+
+------------------------------------------------------------------------------
+data UserAlreadyConnectedException = UserAlreadyConnectedException UserName
+ deriving (Typeable)
+
+instance Show UserAlreadyConnectedException where
+ show (UserAlreadyConnectedException u) =
+ concat [ "User \""
+ , T.unpack u
+ , "\" already connected." ]
+
+instance Exception UserAlreadyConnectedException
+
+
+------------------------------------------------------------------------------
+newChatRoom :: Int -> IO ChatRoom
+newChatRoom userTimeout =
+ ChatRoom <$>
+ TM.initialize userTimeout epochTime <*>
+ (HT.new >>= newMVar) <*>
+ atomically newTChan <*>
+ pure userTimeout
+
+
+
+------------------------------------------------------------------------------
+destroyChatRoom :: ChatRoom -> IO ()
+destroyChatRoom = TM.stop . _timeoutManager
+
+
+------------------------------------------------------------------------------
+withChatRoom :: Int -> (ChatRoom -> IO a) -> IO a
+withChatRoom userTimeout = bracket (newChatRoom userTimeout) destroyChatRoom
+
+
+------------------------------------------------------------------------------
+-- | Connect a new user to the chat room. Throws UserAlreadyConnectedException
+-- if the user was already connected.
+joinUser :: Text -> ChatRoom -> IO User
+joinUser userName chatRoom = withMVar userMapMVar $ \userMap -> do
+ HT.lookup userMap userName >>=
+ maybe (return ())
+ (const $ throwIO $ UserAlreadyConnectedException userName)
+
+ user <- User <$>
+ pure userName <*>
+ (atomically $ dupTChan chatChannel) <*>
+ mkToken <*>
+ TM.register (disconnectUser userName
+ disconnectionMessage
+ chatRoom)
+ timeoutManager
+
+ HT.insert userMap userName user
+ joinMsg <- Msg.join user
+ writeMessage joinMsg user chatRoom
+ return user
+
+ where
+ disconnectionMessage = T.concat [ "User "
+ , userName
+ , " has left the channel (timeout). "
+ ]
+
+ mkToken = withSystemRandom $ \gen -> do
+ xs <- (replicateM 16 $ uniform gen) :: IO [Word8]
+ return $ UserToken $ B16.encode $ S.pack xs
+
+ timeoutManager = _timeoutManager chatRoom
+ userMapMVar = _userMap chatRoom
+ chatChannel = _chatChannel chatRoom
+
+
+------------------------------------------------------------------------------
+disconnectUser :: UserName -> Text -> ChatRoom -> IO ()
+disconnectUser userName disconnectionReason chatRoom =
+ withMVar userMapMVar $ \userMap ->
+ HT.lookup userMap userName >>= maybe (return ()) (destroy userMap)
+
+ where
+ userMapMVar = _userMap chatRoom
+
+ destroy userMap user = do
+ leaveMsg <- Msg.leave disconnectionReason user
+ writeMessage leaveMsg user chatRoom
+ TM.cancel $ _timeoutHandle user
+ HT.delete userMap userName
+
+
+------------------------------------------------------------------------------
+lookupUser :: UserName -> ChatRoom -> IO (Maybe User)
+lookupUser userName chatRoom = withMVar userMapMVar $ flip HT.lookup userName
+ where
+ userMapMVar = _userMap chatRoom
+
+
+------------------------------------------------------------------------------
+-- | Get new messages posted to the channel for the given connected user. If no
+-- messages are available, blocks for the given number of seconds, returning an
+-- empty list if the timeout expires.
+getMessages :: Int -> User -> ChatRoom -> IO [Message]
+getMessages timeoutInSeconds (User _ chan _ timeoutHandle) cr = do
+ TM.tickle timeoutHandle userTimeout
+ xs <- readAllFromChan timeoutInSeconds chan
+ TM.tickle timeoutHandle userTimeout
+ return xs
+
+ where
+ userTimeout = _userTimeout cr
+
+
+
+------------------------------------------------------------------------------
+-- | Write a message to the channel.
+writeMessage :: Message -> User -> ChatRoom -> IO ()
+writeMessage msg user cr = do
+ atomically $ writeTChan chan msg
+ _ <- readAllFromChan 1 chan
+ TM.tickle timeoutHandle userTimeout
+
+ where
+ chan = _chatChannel cr
+ timeoutHandle = _timeoutHandle user
+ userTimeout = _userTimeout cr
+
+
+
+
+------------------------------------------------------------------------------
+readAllFromChan :: Int -> TChan a -> IO [a]
+readAllFromChan secondsToWait chan = do
+ m <- timeout (seconds secondsToWait) $ atomically readAll
+ return $ fromMaybe [] m
+ where
+ readAll = do
+ v <- readTChan chan
+ readRest (v:)
+
+ readRest !dlist = do
+ done <- isEmptyTChan chan
+
+ if done
+ then return $! dlist []
+ else do
+ v <- readTChan chan
+ readRest (dlist . (v:))
+{-# INLINE readAllFromChan #-}
@@ -0,0 +1,121 @@
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE OverloadedStrings #-}
+
+module Snap.Chat.Internal.Types where
+
+------------------------------------------------------------------------------
+import Control.Applicative
+import Control.Concurrent.MVar
+import Control.Concurrent.STM
+import Data.Aeson
+import qualified Data.Aeson.Types as A
+import Data.ByteString (ByteString)
+import Data.Data
+import qualified Data.HashTable.IO as HT
+import qualified Data.Map as Map
+import Data.Monoid
+import Data.Text (Text)
+import System.Posix.Types
+------------------------------------------------------------------------------
+import System.TimeoutManager (TimeoutManager, TimeoutHandle)
+
+
+------------------------------------------------------------------------------
+type UserName = Text
+
+------------------------------------------------------------------------------
+data MessageContents = Talk { _messageText :: !Text }
+ | Action { _messageText :: !Text }
+ | Join
+ | Leave { _messageText :: !Text }
+ deriving (Show)
+
+
+instance FromJSON MessageContents where
+ parseJSON (Object obj) = do
+ ty <- (obj .: "type") :: A.Parser Text
+ case ty of
+ "talk" -> Talk <$>
+ obj .: "text"
+
+ "action" -> Action <$>
+ obj .: "text"
+
+ "join" -> pure Join
+
+ "leave" -> Leave <$>
+ obj .: "text"
+
+ _ -> fail "bad type"
+
+ parseJSON _ = fail "MessageContents: JSON object of wrong type"
+
+
+instance ToJSON MessageContents where
+ toJSON (Talk t) =
+ Object $ Map.fromList [ ("type", toJSON ("talk"::Text))
+ , ("text", toJSON t ) ]
+ toJSON (Action t) =
+ Object $ Map.fromList [ ("type", toJSON ("action"::Text))
+ , ("text", toJSON t ) ]
+
+ toJSON (Join) =
+ Object $ Map.fromList [ ("type", toJSON ("join"::Text)) ]
+
+ toJSON (Leave t) =
+ Object $ Map.fromList [ ("type", toJSON ("leave"::Text))
+ , ("text", toJSON t ) ]
+
+
+------------------------------------------------------------------------------
+data Message = Message {
+ _messageUser :: !UserName
+ , _messageTime :: !EpochTime
+ , _messageContents :: !MessageContents
+ }
+ deriving (Show)
+
+instance FromJSON Message where
+ parseJSON (Object obj) =
+ Message <$>
+ obj .: "user" <*>
+ (toEnum <$> obj .: "time") <*>
+ obj .: "contents"
+
+ parseJSON _ = fail "Message: JSON object of wrong type"
+
+instance ToJSON Message where
+ toJSON (Message u t c) =
+ Object $ Map.fromList [ ("user" , toJSON u )
+ , ("time" , toJSON $ fromEnum t)
+ , ("contents", toJSON c ) ]
+
+
+------------------------------------------------------------------------------
+newtype UserToken = UserToken ByteString
+ deriving (Show, Eq, Data, Ord, Typeable, Monoid, FromJSON, ToJSON)
+
+
+------------------------------------------------------------------------------
+data User = User {
+ _userName :: !UserName
+ , _userMsgChan :: !(TChan Message)
+ , _userToken :: !UserToken
+ , _timeoutHandle :: !TimeoutHandle
+}
+
+
+------------------------------------------------------------------------------
+type HashTable k v = HT.CuckooHashTable k v
+
+
+------------------------------------------------------------------------------
+data ChatRoom = ChatRoom {
+ _timeoutManager :: !TimeoutManager
+ , _userMap :: !(MVar (HashTable UserName User))
+ , _chatChannel :: !(TChan Message)
+ , _userTimeout :: !Int -- ^ how long users can remain
+ -- inactive
+}
Oops, something went wrong.

0 comments on commit 5c0406c

Please sign in to comment.