Permalink
Browse files

First working version of chat app.

  • Loading branch information...
1 parent dd24f2f commit 86c2744f976c9ee029b39c8f2b436c81f737d436 @gregorycollins gregorycollins committed Sep 7, 2011
View
@@ -2,8 +2,11 @@ dist/**
dist
test/dist/**
test/dist
+.hpc
test/.hpc
test/.hpc/**
+log/*.log
+*.aes
*~
*#
#*
View
@@ -1,4 +1,24 @@
+{-# LANGUAGE OverloadedStrings #-}
+
module Main where
+import Snap.Chat.API.Handlers
+import Snap.Chat.ChatRoom
+import Snap.Chat.Types
+import Snap.Http.Server
+import Snap.Types
+import Snap.Util.FileServe
+import Web.ClientSession
+
+handler :: Key -> ChatRoom -> Snap ()
+handler key chatRoom = route [ ("" , root )
+ , ("api" , apiHandlers key chatRoom)
+ ]
+ where
+ root = serveDirectory "static"
+
+
main :: IO ()
-main = return ()
+main = do
+ key <- getDefaultKey
+ withChatRoom 240 $ quickHttpServe . handler key
@@ -1,23 +1,26 @@
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
-module Snap.Chat.API.Handlers
+module Snap.Chat.API.Handlers
( apiHandlers
) where
------------------------------------------------------------------------------
+import Control.Applicative
import Control.Exception (SomeException)
import Control.Monad
import Control.Monad.CatchIO
import Control.Monad.Reader
import Data.Aeson
import Data.Aeson.Encode
import Data.Attoparsec hiding (try)
+import Data.ByteString.Char8 (ByteString)
import qualified Data.ByteString.Char8 as S
import qualified Data.ByteString.Lazy.Char8 as L
import qualified Data.Text as T
import Prelude hiding (catch)
import Snap.Types
+import System.PosixCompat.Time
import Web.ClientSession
------------------------------------------------------------------------------
import Snap.Chat.ChatRoom
@@ -29,7 +32,7 @@ import Snap.Chat.Internal.API.Types
apiHandlers :: Key -> ChatRoom -> Snap ()
apiHandlers key chatRoom =
flip runReaderT chatRoom $
- route [ ("join", apiCall handleJoin )
+ route [ ("join", apiCall $ handleJoin key )
, ("leave", authenticatingApiCall key handleLeave)
, ("fetch", authenticatingApiCall key handleFetch)
, ("write", authenticatingApiCall key handleWrite)
@@ -75,7 +78,7 @@ apiCall f = method POST $ do
putResponse emptyResponse
writeText $ "Error decoding JSON input:\n"
writeText $ T.pack $ show e
- getResponse >>= finishWith . setResponseCode 415
+ getResponse >>= finishWith . setResponseCode 415
------------------------------------------------------------------------------
@@ -114,44 +117,82 @@ authenticate key f apiRequest = do
Success sess -> auth sess)
(parseOnly json txt))
mbDecryptedText
-
+
where
encodedSession = _encodedSession apiRequest
requestData = _requestData apiRequest
mbDecryptedText = decrypt key encodedSession
- auth (EncodedSession token userName) = do
+ auth (EncodedSession token oldTime userName) = do
chatRoom <- ask :: ApiHandler ChatRoom
- eUser <- try $ liftIO $ authenticateUser userName token chatRoom
- either (\(_::SomeException) -> return authenticationFailure)
- (\user -> do
- resp <- f user requestData
- let newSession = EncodedSession (_userToken user) userName
- let newEncodedSession = S.concat $ L.toChunks $
- encode newSession
- if isFailure resp
- then return $ ApiResponseFailure (failureCode resp)
- (failureReason resp)
- else return $ ApiResponseSuccess newEncodedSession resp)
- eUser
+ now <- liftIO epochTime
+ if now - oldTime > toEnum (_userTimeout chatRoom)
+ then return authenticationFailure
+ else do
+ eUser <- try $ liftIO $ authenticateUser userName token
+ chatRoom
+ either (\(_::SomeException) -> return authenticationFailure)
+ (\user -> do
+ resp <- f user requestData
+ newEncodedSession <- liftIO $ encodeSession key user
+ if isFailure resp
+ then return $
+ ApiResponseFailure (failureCode resp)
+ (failureReason resp)
+ else return $
+ ApiResponseSuccess newEncodedSession resp)
+ eUser
------------------------------------------------------------------------------
-handleJoin :: JoinRequest
+encodeSession :: Key -> User -> IO ByteString
+encodeSession key (User name _ token _) = epochTime >>= newEncodedSession
+ where
+ newEncodedSession now = do
+ let newSession = EncodedSession token now name
+ encryptIO key $ S.concat $ L.toChunks $ encode newSession
+
+------------------------------------------------------------------------------
+handleJoin :: Key
+ -> JoinRequest
-> ApiHandler (ApiResponse JoinResponse)
-handleJoin = undefined
+handleJoin key (JoinRequest userName) = do
+ (ask >>= joinUp) `catch` \(_ :: UserAlreadyConnectedException) -> do
+ return $ ApiResponseFailure (failureCode resp) (failureReason resp)
+ where
+ resp = JoinResponseUserAlreadyExists
+
+ joinUp chatRoom = do
+ user <- liftIO $ joinUser userName chatRoom
+ newEncodedSession <- liftIO $ encodeSession key user
+ return $ ApiResponseSuccess newEncodedSession JoinResponseOK
------------------------------------------------------------------------------
handleLeave :: User -> LeaveRequest -> ApiHandler LeaveResponse
-handleLeave = undefined
+handleLeave user _ = do
+ ask >>= liftIO . disconnectUser userName disconnectionReason
+ return LeaveResponseOK
+ where
+ userName = _userName user
+ disconnectionReason = T.concat [ " has left the channel." ]
------------------------------------------------------------------------------
handleFetch :: User -> GetMessagesRequest -> ApiHandler GetMessagesResponse
-handleFetch = undefined
+handleFetch user _ = do
+ setTimeout $ defaultTimeout + 10
+ msgs <- ask >>= liftIO . getMessages defaultTimeout user
+ return $ GetMessagesOK msgs
------------------------------------------------------------------------------
handleWrite :: User -> WriteMessageRequest -> ApiHandler WriteMessageResponse
-handleWrite = undefined
+handleWrite user (WriteMessageRequest msg) = do
+ ask >>= liftIO . writeMessageContents msg user
+ return WriteMessageResponseOK
+
+
+------------------------------------------------------------------------------
+defaultTimeout :: Int
+defaultTimeout = 50
@@ -13,6 +13,7 @@ module Snap.Chat.ChatRoom
, disconnectUser
, getMessages
, writeMessage
+ , writeMessageContents
-- * Exceptions
, UserAlreadyConnectedException
@@ -130,9 +131,7 @@ joinUser userName chatRoom = withMVar userMapMVar $ \userMap -> do
return user
where
- disconnectionMessage = T.concat [ "User "
- , userName
- , " has left the channel (timeout). "
+ disconnectionMessage = T.concat [ " has left the channel (timeout). "
]
timeoutManager = _timeoutManager chatRoom
@@ -183,13 +182,8 @@ authenticateUser userName userToken chatRoom =
(\user ->
if getUserToken user /= userToken
then throwIO $ UserAuthenticationFailureException userName
- else do
- newToken <- makeUserToken
- let u' = user { _userToken = newToken }
- HT.insert userMap userName u'
- return u')
+ else return user)
mbU
-
------------------------------------------------------------------------------
@@ -222,6 +216,14 @@ writeMessage msg user cr = do
userTimeout = _userTimeout cr
+------------------------------------------------------------------------------
+-- | Write a message to the channel.
+writeMessageContents :: MessageContents -> User -> ChatRoom -> IO ()
+writeMessageContents msgContents user cr = do
+ now <- epochTime
+ let userName = _userName user
+ writeMessage (Message userName now msgContents) user cr
+
------------------------------------------------------------------------------
@@ -12,6 +12,7 @@ import qualified Data.Map as Map
import Data.Text (Text)
import qualified Data.Text as T
import Snap.Types
+import System.Posix.Types
------------------------------------------------------------------------------
import Snap.Chat.Internal.Types
@@ -46,19 +47,22 @@ authenticationFailure =
------------------------------------------------------------------------------
data EncodedSession = EncodedSession {
_sessionToken :: UserToken
+ , _sessionTime :: EpochTime
, _apiUser :: UserName
}
instance FromJSON EncodedSession where
- parseJSON (Object obj) = EncodedSession <$>
- obj .: "token" <*>
+ parseJSON (Object obj) = EncodedSession <$>
+ obj .: "token" <*>
+ (toEnum <$> obj .: "time") <*>
obj .: "user"
parseJSON _ = fail "EncodedSession: JSON object of wrong type"
instance ToJSON EncodedSession where
- toJSON (EncodedSession tok user) =
- Object $ Map.fromList [ ("token", toJSON tok )
- , ("user", toJSON user)
+ toJSON (EncodedSession tok time user) =
+ Object $ Map.fromList [ ("token", toJSON tok )
+ , ("user", toJSON user )
+ , ("time", toJSON $ fromEnum time)
]
------------------------------------------------------------------------------
@@ -155,7 +159,7 @@ instance ToJSON GetMessagesResponse where
------------------------------------------------------------------------------
-data WriteMessageRequest = WriteMessageRequest Message
+data WriteMessageRequest = WriteMessageRequest MessageContents
data WriteMessageResponse = WriteMessageResponseOK
instance HasStatus WriteMessageResponse
View
No changes.
View
@@ -48,7 +48,7 @@ Library
Snap.Chat.Internal.Util,
System.TimeoutManager
- ghc-options: -O2 -Wall -fhpc -fwarn-tabs -funbox-strict-fields -threaded
+ ghc-options: -O2 -Wall -fwarn-tabs -funbox-strict-fields -threaded
-fno-warn-unused-do-bind
@@ -71,5 +71,5 @@ Executable snap-chat
text >= 0.11 && < 0.12,
unix-compat >= 0.2 && < 0.4
- ghc-options: -O2 -Wall -fhpc -fwarn-tabs -funbox-strict-fields -threaded
+ ghc-options: -O2 -Wall -fwarn-tabs -funbox-strict-fields -threaded
-fno-warn-unused-do-bind
Oops, something went wrong.

0 comments on commit 86c2744

Please sign in to comment.