├── log └── .logs_go_here ├── static ├── css │ ├── .#chat.css │ ├── chat-small.css │ └── chat-large.css ├── img │ └── logo-small.png ├── index.html └── js │ ├── snap-chat.js │ ├── json2.js │ └── jquery-ui-1.8.16.custom.min.js ├── Setup.hs ├── src ├── Snap │ └── Chat │ │ ├── API │ │ ├── Types.hs │ │ └── Handlers.hs │ │ ├── Internal │ │ ├── Util.hs │ │ ├── Types.hs │ │ └── API │ │ │ └── Types.hs │ │ ├── Types.hs │ │ ├── Main.hs │ │ ├── Message.hs │ │ └── ChatRoom.hs └── System │ └── TimeoutManager.hs ├── sample-implementation └── Snap │ └── Chat │ ├── API │ ├── Types.hs │ └── Handlers.hs │ └── Internal │ ├── Types.hs │ └── API │ └── Types.hs ├── .gitignore ├── test ├── suite │ ├── TestSuite.hs │ └── Snap │ │ └── Chat │ │ ├── Types │ │ └── Tests.hs │ │ ├── Test │ │ └── Common.hs │ │ ├── ChatRoom │ │ └── Tests.hs │ │ └── Internal │ │ └── API │ │ └── Tests.hs ├── runTestsAndCoverage.sh ├── runTestsAndCoverage-sample.sh └── snap-chat-testsuite.cabal ├── examples └── JsonExample.hs ├── LICENSE ├── snap-chat.cabal └── README.md /log/.logs_go_here: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- /static/css/.#chat.css: -------------------------------------------------------------------------------- 1 | gdc@gdc-macbookpro.local.17400 -------------------------------------------------------------------------------- /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /static/img/logo-small.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/snapframework/cufp2011/HEAD/static/img/logo-small.png -------------------------------------------------------------------------------- /src/Snap/Chat/API/Types.hs: -------------------------------------------------------------------------------- 1 | module Snap.Chat.API.Types 2 | () where 3 | 4 | import Snap.Chat.Internal.API.Types 5 | -------------------------------------------------------------------------------- /sample-implementation/Snap/Chat/API/Types.hs: -------------------------------------------------------------------------------- 1 | module Snap.Chat.API.Types 2 | () where 3 | 4 | import Snap.Chat.Internal.API.Types 5 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | dist/** 2 | dist 3 | test/dist/** 4 | test/dist 5 | .hpc 6 | test/.hpc 7 | test/.hpc/** 8 | log/*.log 9 | *.tix 10 | *.aes 11 | *~ 12 | *# 13 | .#* 14 | #* 15 | -------------------------------------------------------------------------------- /src/Snap/Chat/Internal/Util.hs: -------------------------------------------------------------------------------- 1 | module Snap.Chat.Internal.Util 2 | ( seconds 3 | ) where 4 | 5 | 6 | ------------------------------------------------------------------------------ 7 | seconds :: Int -> Int 8 | seconds n = n * ((10::Int)^(6::Int)) 9 | 10 | -------------------------------------------------------------------------------- /src/Snap/Chat/Types.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE BangPatterns #-} 2 | {-# LANGUAGE DeriveDataTypeable #-} 3 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 4 | {-# LANGUAGE OverloadedStrings #-} 5 | 6 | module Snap.Chat.Types 7 | ( UserName 8 | 9 | , Message 10 | , MessageContents(..) 11 | , getMessageUserName 12 | , getMessageTime 13 | , getMessageContents 14 | 15 | , UserToken 16 | , User 17 | , getUserName 18 | , getUserToken 19 | 20 | , ChatRoom 21 | ) where 22 | 23 | import Snap.Chat.Internal.Types 24 | -------------------------------------------------------------------------------- /test/suite/TestSuite.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import Test.Framework (defaultMain, testGroup) 4 | 5 | import qualified Snap.Chat.ChatRoom.Tests 6 | import qualified Snap.Chat.Internal.API.Tests 7 | import qualified Snap.Chat.Types.Tests 8 | 9 | main :: IO () 10 | main = defaultMain tests 11 | where 12 | tests = [ 13 | testGroup "Snap.Chat.ChatRoom.Tests" Snap.Chat.ChatRoom.Tests.tests 14 | , testGroup "Snap.Chat.Internal.API.Tests" 15 | Snap.Chat.Internal.API.Tests.tests 16 | , testGroup "Snap.Chat.Types.Tests" Snap.Chat.Types.Tests.tests 17 | ] 18 | -------------------------------------------------------------------------------- /src/Snap/Chat/Main.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | module Main where 4 | 5 | import Snap.Chat.API.Handlers 6 | import Snap.Chat.ChatRoom 7 | import Snap.Chat.Types 8 | import Snap.Core 9 | import Snap.Http.Server 10 | import Snap.Util.FileServe 11 | import Web.ClientSession 12 | 13 | handler :: Key -> ChatRoom -> Snap () 14 | handler key chatRoom = route [ ("" , root ) 15 | , ("api" , apiHandlers key chatRoom) 16 | ] 17 | where 18 | root = serveDirectory "static" 19 | 20 | 21 | main :: IO () 22 | main = do 23 | key <- getDefaultKey 24 | withChatRoom 200 $ quickHttpServe . handler key 25 | -------------------------------------------------------------------------------- /test/runTestsAndCoverage.sh: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | 3 | set -e 4 | 5 | if [ -z "$DEBUG" ]; then 6 | export DEBUG="testsuite" 7 | fi 8 | 9 | SUITE=./dist/build/testsuite/testsuite 10 | 11 | export LC_ALL=C 12 | export LANG=C 13 | 14 | rm -f testsuite.tix 15 | 16 | if [ ! -f $SUITE ]; then 17 | cat </dev/null 2>&1 46 | 47 | rm -f testsuite.tix 48 | 49 | cat </dev/null 2>&1 46 | 47 | rm -f testsuite-sample.tix 48 | 49 | cat < 2 | 3 | 4 | Snap Chat 5 | 6 | 7 | 9 | 10 | 13 | 15 | 17 | 18 | 19 | 20 | 21 |
22 |
23 | 24 | 25 | -------------------------------------------------------------------------------- /examples/JsonExample.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | import Control.Applicative 4 | import Data.Aeson 5 | import Data.Attoparsec (parseOnly) 6 | import Data.ByteString.Char8 (ByteString) 7 | import qualified Data.ByteString.Char8 as S 8 | import qualified Data.ByteString.Lazy.Char8 as L 9 | 10 | 11 | ------------------------------------------------------------------------------ 12 | example1 :: ByteString -> Either String Coord 13 | example1 bs = parseOnly json bs >>= convert 14 | where 15 | convert value = case fromJSON value of 16 | (Error e) -> Left e 17 | (Success a) -> Right a 18 | 19 | example2 :: Coord -> ByteString 20 | example2 c = S.concat $ L.toChunks $ encode c 21 | 22 | 23 | ------------------------------------------------------------------------------ 24 | data Coord = Coord { _x :: Double, _y :: Double } 25 | deriving (Show, Eq) 26 | 27 | instance ToJSON Coord where 28 | toJSON (Coord x y) = object ["x" .= x, "y" .= y] 29 | 30 | 31 | instance FromJSON Coord where 32 | parseJSON (Object v) = Coord <$> 33 | v .: "x" <*> 34 | v .: "y" 35 | 36 | -- A non-Object value is of the wrong type, so use mzero to fail. 37 | parseJSON _ = empty 38 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c)2011, Gregory Collins 2 | 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions are met: 7 | 8 | * Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | 11 | * Redistributions in binary form must reproduce the above 12 | copyright notice, this list of conditions and the following 13 | disclaimer in the documentation and/or other materials provided 14 | with the distribution. 15 | 16 | * Neither the name of Gregory Collins nor the names of other 17 | contributors may be used to endorse or promote products derived 18 | from this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 31 | -------------------------------------------------------------------------------- /src/Snap/Chat/Message.hs: -------------------------------------------------------------------------------- 1 | module Snap.Chat.Message 2 | ( talk 3 | , action 4 | , join 5 | , leave 6 | , messageTime 7 | , messageUser 8 | , messageContents 9 | ) where 10 | 11 | ------------------------------------------------------------------------------ 12 | import Data.Text (Text) 13 | import System.PosixCompat.Time 14 | import System.Posix.Types 15 | ------------------------------------------------------------------------------ 16 | import Snap.Chat.Internal.Types 17 | 18 | 19 | ------------------------------------------------------------------------------ 20 | talk :: Text -> User -> IO Message 21 | talk = newMessage . Talk 22 | 23 | 24 | ------------------------------------------------------------------------------ 25 | action :: Text -> User -> IO Message 26 | action = newMessage . Action 27 | 28 | 29 | ------------------------------------------------------------------------------ 30 | leave :: Text -> User -> IO Message 31 | leave = newMessage . Leave 32 | 33 | 34 | ------------------------------------------------------------------------------ 35 | join :: User -> IO Message 36 | join = newMessage Join 37 | 38 | 39 | ------------------------------------------------------------------------------ 40 | newMessage :: MessageContents -> User -> IO Message 41 | newMessage c user = do 42 | now <- epochTime 43 | return $! Message userName now c 44 | where 45 | userName = _userName user 46 | 47 | 48 | ------------------------------------------------------------------------------ 49 | messageTime :: Message -> EpochTime 50 | messageTime = _messageTime 51 | 52 | 53 | ------------------------------------------------------------------------------ 54 | messageUser :: Message -> UserName 55 | messageUser = _messageUser 56 | 57 | 58 | ------------------------------------------------------------------------------ 59 | messageContents :: Message -> MessageContents 60 | messageContents = _messageContents 61 | -------------------------------------------------------------------------------- /test/snap-chat-testsuite.cabal: -------------------------------------------------------------------------------- 1 | name: snap-chat-testsuite 2 | version: 1.0 3 | build-type: Simple 4 | cabal-version: >= 1.6 5 | 6 | Executable testsuite 7 | hs-source-dirs: ../src suite 8 | main-is: TestSuite.hs 9 | 10 | Build-depends: 11 | base >= 4.2 && < 5, 12 | HUnit >= 1.2 && < 2, 13 | QuickCheck >= 2.3.0.2 && < 3.0, 14 | MonadCatchIO-transformers >= 0.2 && < 0.3, 15 | aeson >= 0.5 && < 0.6, 16 | attoparsec >= 0.10 && < 0.11, 17 | base16-bytestring >= 0.1 && < 0.2, 18 | bytestring >= 0.9 && < 0.10, 19 | clientsession >= 0.7 && < 0.8, 20 | containers >= 0.4 && < 0.5, 21 | deepseq >= 1.1 && < 1.3, 22 | hashtables >= 1.0 && < 1.1, 23 | mtl >= 2 && < 3, 24 | mwc-random >= 0.10 && < 0.11, 25 | snap-core >= 0.7 && < 0.8, 26 | stm >= 2.2 && < 2.3, 27 | test-framework >= 0.4 && < 0.5, 28 | test-framework-hunit >= 0.2.5 && < 0.3, 29 | test-framework-quickcheck2 >= 0.2.6 && < 0.3, 30 | text >= 0.11 && < 0.12, 31 | unix-compat >= 0.2 && < 0.4 32 | 33 | ghc-options: -O2 -Wall -fhpc -fwarn-tabs -funbox-strict-fields -threaded 34 | -fno-warn-unused-do-bind 35 | 36 | 37 | Executable testsuite-sample 38 | hs-source-dirs: ../sample-implementation ../src suite 39 | main-is: TestSuite.hs 40 | 41 | Build-depends: 42 | base >= 4.2 && < 5, 43 | HUnit >= 1.2 && < 2, 44 | QuickCheck >= 2.3.0.2 && < 3.0, 45 | MonadCatchIO-transformers >= 0.2 && < 0.3, 46 | aeson >= 0.5 && < 0.6, 47 | attoparsec >= 0.10 && < 0.11, 48 | base16-bytestring >= 0.1 && < 0.2, 49 | bytestring >= 0.9 && < 0.10, 50 | clientsession >= 0.7 && < 0.8, 51 | containers >= 0.4 && < 0.5, 52 | deepseq >= 1.1 && < 1.3, 53 | hashtables >= 1.0 && < 1.1, 54 | mtl >= 2 && < 3, 55 | mwc-random >= 0.10 && < 0.11, 56 | snap-core >= 0.7 && < 0.8, 57 | stm >= 2.2 && < 2.3, 58 | test-framework >= 0.4 && < 0.5, 59 | test-framework-hunit >= 0.2.5 && < 0.3, 60 | test-framework-quickcheck2 >= 0.2.6 && < 0.3, 61 | text >= 0.11 && < 0.12, 62 | unix-compat >= 0.2 && < 0.4, 63 | unordered-containers >= 0.1 && < 0.2 64 | 65 | ghc-options: -O2 -Wall -fhpc -fwarn-tabs -funbox-strict-fields -threaded 66 | -fno-warn-unused-do-bind 67 | 68 | -------------------------------------------------------------------------------- /snap-chat.cabal: -------------------------------------------------------------------------------- 1 | Name: snap-chat 2 | Version: 0.2 3 | License: BSD3 4 | License-file: LICENSE 5 | Author: Gregory Collins 6 | Maintainer: greg@gregorycollins.net 7 | Copyright: (c) 2011 Google, Inc. 8 | Category: Web 9 | Build-type: Simple 10 | 11 | Extra-source-files: 12 | README.md, 13 | test/suite/TestSuite.hs, 14 | test/suite/Snap/Chat/ChatRoom/Tests.hs, 15 | test/suite/Snap/Chat/Internal/API/Tests.hs, 16 | test/suite/Snap/Chat/Test/Common.hs, 17 | test/suite/Snap/Chat/Types/Tests.hs, 18 | test/runTestsAndCoverage.sh, 19 | test/runTestsAndCoverage-sample.sh, 20 | test/snap-chat-testsuite.cabal 21 | 22 | Cabal-version: >=1.2 23 | 24 | Executable snap-chat 25 | hs-source-dirs: src 26 | 27 | Main-is: Snap/Chat/Main.hs 28 | 29 | Build-depends: base >= 4.2 && < 5, 30 | aeson >= 0.5 && < 0.7, 31 | attoparsec >= 0.10 && < 0.11, 32 | base16-bytestring >= 0.1 && < 0.2, 33 | bytestring >= 0.9 && < 0.11, 34 | clientsession >= 0.7 && < 0.9, 35 | containers >= 0.4 && < 0.6, 36 | hashtables >= 1.0 && < 1.2, 37 | MonadCatchIO-transformers >= 0.2 && <0.4, 38 | mtl >= 2.0 && < 3.0, 39 | mwc-random >= 0.10 && < 0.13, 40 | snap-core >= 0.7 && < 0.10, 41 | snap-server >= 0.7 && < 0.10, 42 | stm >= 2.2 && < 2.5, 43 | text >= 0.11 && < 0.12, 44 | unix-compat >= 0.2 && < 0.5, 45 | unordered-containers >= 0.1.4 && < 0.3 46 | 47 | ghc-options: -O2 -Wall -fwarn-tabs -funbox-strict-fields -threaded 48 | -fno-warn-unused-do-bind 49 | 50 | 51 | Executable snap-chat-sample 52 | hs-source-dirs: sample-implementation src 53 | 54 | Main-is: Snap/Chat/Main.hs 55 | 56 | Build-depends: base >= 4.2 && < 5, 57 | aeson >= 0.5 && < 0.7, 58 | attoparsec >= 0.10 && < 0.11, 59 | base16-bytestring >= 0.1 && < 0.2, 60 | bytestring >= 0.9 && < 0.11, 61 | clientsession >= 0.7 && < 0.9, 62 | containers >= 0.4 && < 0.6, 63 | hashtables >= 1.0 && < 1.2, 64 | MonadCatchIO-transformers >= 0.2 && <0.4, 65 | mtl >= 2.0 && < 3.0, 66 | mwc-random >= 0.10 && < 0.13, 67 | snap-core >= 0.7 && < 0.10, 68 | snap-server >= 0.7 && < 0.10, 69 | stm >= 2.2 && < 2.5, 70 | text >= 0.11 && < 0.12, 71 | unix-compat >= 0.2 && < 0.5, 72 | unordered-containers >= 0.1.4 && < 0.3 73 | 74 | ghc-options: -O2 -Wall -fwarn-tabs -funbox-strict-fields -threaded 75 | -fno-warn-unused-do-bind 76 | 77 | -------------------------------------------------------------------------------- /src/Snap/Chat/Internal/Types.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE BangPatterns #-} 2 | {-# LANGUAGE DeriveDataTypeable #-} 3 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 4 | {-# LANGUAGE OverloadedStrings #-} 5 | 6 | module Snap.Chat.Internal.Types where 7 | 8 | ------------------------------------------------------------------------------ 9 | import Control.Applicative 10 | import Control.Concurrent.MVar 11 | import Control.Concurrent.STM 12 | import Data.Aeson 13 | import qualified Data.Aeson.Types as A 14 | import Data.ByteString (ByteString) 15 | import Data.Data 16 | import qualified Data.HashTable.IO as HT 17 | import qualified Data.Map as Map 18 | import Data.Monoid 19 | import Data.Text (Text) 20 | import System.Posix.Types 21 | ------------------------------------------------------------------------------ 22 | import System.TimeoutManager (TimeoutManager, TimeoutHandle) 23 | 24 | 25 | ------------------------------------------------------------------------------ 26 | toBeImplemented :: a 27 | toBeImplemented = error "*** TODO: implement this ***" 28 | 29 | 30 | ------------------------------------------------------------------------------ 31 | type UserName = Text 32 | 33 | 34 | ------------------------------------------------------------------------------ 35 | data MessageContents = Talk { _messageText :: !Text } 36 | | Action { _messageText :: !Text } 37 | | Join 38 | | Leave { _messageText :: !Text } 39 | deriving (Show, Eq) 40 | 41 | 42 | instance FromJSON MessageContents where 43 | parseJSON (Object obj) = toBeImplemented 44 | parseJSON _ = fail "MessageContents: JSON object of wrong type" 45 | 46 | 47 | ------------------------------------------------------------------------------ 48 | instance ToJSON MessageContents where 49 | toJSON (Talk t) = toBeImplemented 50 | toJSON (Action t) = toBeImplemented 51 | toJSON (Join) = toBeImplemented 52 | toJSON (Leave t) = toBeImplemented 53 | 54 | 55 | ------------------------------------------------------------------------------ 56 | data Message = Message { 57 | _messageUser :: !UserName 58 | , _messageTime :: !EpochTime 59 | , _messageContents :: !MessageContents 60 | } 61 | deriving (Show, Eq) 62 | 63 | 64 | ------------------------------------------------------------------------------ 65 | getMessageUserName :: Message -> UserName 66 | getMessageUserName = _messageUser 67 | 68 | getMessageTime :: Message -> EpochTime 69 | getMessageTime = _messageTime 70 | 71 | getMessageContents :: Message -> MessageContents 72 | getMessageContents = _messageContents 73 | 74 | 75 | ------------------------------------------------------------------------------ 76 | instance FromJSON Message where 77 | parseJSON (Object obj) = toBeImplemented 78 | parseJSON _ = fail "Message: JSON object of wrong type" 79 | 80 | instance ToJSON Message where 81 | toJSON (Message u t c) = toBeImplemented 82 | 83 | 84 | ------------------------------------------------------------------------------ 85 | newtype UserToken = UserToken ByteString 86 | deriving (Show, Eq, Data, Ord, Typeable, Monoid, FromJSON, ToJSON) 87 | 88 | 89 | ------------------------------------------------------------------------------ 90 | data User = User { 91 | _userName :: !UserName 92 | , _userMsgChan :: !(TChan Message) 93 | , _userToken :: !UserToken 94 | , _timeoutHandle :: !TimeoutHandle 95 | } 96 | 97 | 98 | ------------------------------------------------------------------------------ 99 | getUserName :: User -> UserName 100 | getUserName = _userName 101 | 102 | 103 | ------------------------------------------------------------------------------ 104 | getUserToken :: User -> UserToken 105 | getUserToken = _userToken 106 | 107 | 108 | ------------------------------------------------------------------------------ 109 | type HashTable k v = HT.CuckooHashTable k v 110 | 111 | 112 | ------------------------------------------------------------------------------ 113 | data ChatRoom = ChatRoom { 114 | _timeoutManager :: !TimeoutManager 115 | , _userMap :: !(MVar (HashTable UserName User)) 116 | , _chatChannel :: !(TChan Message) 117 | , _userTimeout :: !Int -- ^ how long users can remain 118 | -- inactive 119 | } 120 | -------------------------------------------------------------------------------- /test/suite/Snap/Chat/Types/Tests.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE BangPatterns #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | {-# OPTIONS_GHC -fno-warn-orphans #-} 4 | 5 | module Snap.Chat.Types.Tests (tests) where 6 | 7 | ------------------------------------------------------------------------------ 8 | import Control.Applicative 9 | import Control.Monad 10 | import Data.Aeson 11 | import Data.Aeson.Types 12 | import qualified Data.Attoparsec as A 13 | import qualified Data.ByteString.Char8 as S 14 | import qualified Data.ByteString.Lazy.Char8 as L 15 | import Data.Text (Text) 16 | import Test.Framework 17 | import Test.Framework.Providers.HUnit 18 | import Test.Framework.Providers.QuickCheck2 19 | ------------------------------------------------------------------------------ 20 | import Snap.Chat.Test.Common 21 | import Snap.Chat.Internal.Types 22 | 23 | ------------------------------------------------------------------------------ 24 | tests :: [Test] 25 | tests = [ testMessageJsonInvertible 26 | , testMessageJsonInstance 27 | , testTrivials 28 | ] 29 | 30 | 31 | ------------------------------------------------------------------------------ 32 | testMessageJsonInvertible :: Test 33 | testMessageJsonInvertible = testProperty "types/messageJsonInvertible" prop 34 | where 35 | prop :: Message -> Bool 36 | prop = propJSONInvertible 37 | 38 | 39 | ------------------------------------------------------------------------------ 40 | testMessageJsonInstance :: Test 41 | testMessageJsonInstance = testCase "types/messageJsonInstance" $ do 42 | !_ <- return $! res1 43 | !_ <- return $! res2 44 | !_ <- return $! res3 45 | !_ <- return $! res4 46 | return () 47 | 48 | where 49 | text1 = "foo-text-1" 50 | text2 = "foo-text-2" 51 | text4 = "foo-text-4" 52 | 53 | contents1 = Talk text1 54 | contents2 = Action text2 55 | contents3 = Join 56 | contents4 = Leave text4 57 | 58 | tm = 12345678 59 | 60 | msg1 = Message "user1" tm contents1 61 | msg2 = Message "user2" tm contents2 62 | msg3 = Message "user3" tm contents3 63 | msg4 = Message "user4" tm contents4 64 | 65 | str1 = S.concat $ L.toChunks $ encode msg1 66 | str2 = S.concat $ L.toChunks $ encode msg2 67 | str3 = S.concat $ L.toChunks $ encode msg3 68 | str4 = S.concat $ L.toChunks $ encode msg4 69 | 70 | (Object json1) = fromRight $ A.parseOnly json str1 71 | (Object json2) = fromRight $ A.parseOnly json str2 72 | (Object json3) = fromRight $ A.parseOnly json str3 73 | (Object json4) = fromRight $ A.parseOnly json str4 74 | 75 | check :: String -> (a -> Bool) -> Parser a -> Parser () 76 | check s f p = do 77 | v <- p 78 | if f v then return () else fail s 79 | 80 | p1 = do 81 | check "user not user1" (==("user1"::Text)) $ json1 .: "user" 82 | check "time doesn't match" (==tm) (toEnum <$> json1 .: "time") 83 | contents <- json1 .: "contents" 84 | check "type isn't talk" (==("talk"::Text)) $ contents .: "type" 85 | check "text doesn't match" (==text1) $ contents .: "text" 86 | return () 87 | 88 | p2 = do 89 | check "user not user2" (==("user2"::Text)) $ json2 .: "user" 90 | check "time doesn't match" (==tm) (toEnum <$> json2 .: "time") 91 | contents <- json2 .: "contents" 92 | check "type isn't action" (==("action"::Text)) $ contents .: "type" 93 | check "text doesn't match" (==text2) $ contents .: "text" 94 | return () 95 | 96 | p3 = do 97 | check "user not user3" (==("user3"::Text)) $ json3 .: "user" 98 | check "time doesn't match" (==tm) (toEnum <$> json3 .: "time") 99 | contents <- json3 .: "contents" 100 | check "type isn't join" (==("join"::Text)) $ contents .: "type" 101 | return () 102 | 103 | p4 = do 104 | check "user not user4" (==("user4"::Text)) $ json4 .: "user" 105 | check "time doesn't match" (==tm) (toEnum <$> json4 .: "time") 106 | contents <- json4 .: "contents" 107 | check "type isn't leave" (==("leave"::Text)) $ contents .: "type" 108 | check "text doesn't match" (==text4) $ contents .: "text" 109 | return () 110 | 111 | res1 = fromRight $ parseEither (const p1) () 112 | res2 = fromRight $ parseEither (const p2) () 113 | res3 = fromRight $ parseEither (const p3) () 114 | res4 = fromRight $ parseEither (const p4) () 115 | 116 | 117 | ------------------------------------------------------------------------------ 118 | testTrivials :: Test 119 | testTrivials = testCase "types/trivials" $ do 120 | mapM_ coverEqInstance contents 121 | mapM_ coverShowInstance contents 122 | mapM_ coverEqInstance messages 123 | mapM_ coverShowInstance messages 124 | where 125 | contents = [ Talk "" 126 | , Action "" 127 | , Join 128 | , Leave "" 129 | ] 130 | 131 | messages = map (Message "" 0) contents 132 | -------------------------------------------------------------------------------- /test/suite/Snap/Chat/Test/Common.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ScopedTypeVariables #-} 2 | {-# OPTIONS_GHC -fno-warn-orphans #-} 3 | 4 | module Snap.Chat.Test.Common 5 | ( coverEqInstance 6 | , coverOrdInstance 7 | , coverReadInstance 8 | , coverShowInstance 9 | , coverTypeableInstance 10 | , forceSameType 11 | , expectException 12 | , expectExceptionH 13 | , eatException 14 | , propJSONInvertible 15 | , fromRight 16 | ) where 17 | 18 | import Control.Applicative 19 | import Control.DeepSeq 20 | import Control.Exception (SomeException(..), evaluate) 21 | import Control.Monad 22 | import Control.Monad.CatchIO 23 | import Control.Monad.Trans 24 | import Data.Aeson 25 | import Data.ByteString.Char8 (ByteString) 26 | import qualified Data.ByteString.Char8 as S 27 | import Data.Typeable 28 | import Prelude hiding (catch) 29 | import qualified Data.Text as T 30 | import Data.Text (Text) 31 | import Test.QuickCheck hiding (Success) 32 | import qualified Test.QuickCheck.Monadic as QC 33 | import Test.QuickCheck.Monadic 34 | import Snap.Chat.Internal.Types 35 | 36 | 37 | ------------------------------------------------------------------------------ 38 | -- | Kill the false negative on derived show instances. 39 | coverShowInstance :: (Monad m, Show a) => a -> m () 40 | coverShowInstance x = a `deepseq` b `deepseq` c `deepseq` return () 41 | where 42 | a = showsPrec 0 x "" 43 | b = show x 44 | c = showList [x] "" 45 | 46 | 47 | eatException :: (MonadCatchIO m) => m a -> m () 48 | eatException a = (a >> return ()) `catch` handler 49 | where 50 | handler :: (MonadCatchIO m) => SomeException -> m () 51 | handler _ = return () 52 | 53 | 54 | forceSameType :: a -> a -> a 55 | forceSameType _ a = a 56 | 57 | 58 | coverReadInstance :: (MonadIO m, Read a) => a -> m () 59 | coverReadInstance x = do 60 | liftIO $ eatException $ evaluate $ forceSameType [(x,"")] $ readsPrec 0 "" 61 | liftIO $ eatException $ evaluate $ forceSameType [([x],"")] $ readList "" 62 | 63 | 64 | coverEqInstance :: (Monad m, Eq a) => a -> m () 65 | coverEqInstance x = a `seq` b `seq` return () 66 | where 67 | a = x == x 68 | b = x /= x 69 | 70 | 71 | coverOrdInstance :: (Monad m, Ord a) => a -> m () 72 | coverOrdInstance x = a `deepseq` b `deepseq` return () 73 | where 74 | a = [ x < x 75 | , x >= x 76 | , x > x 77 | , x <= x 78 | , compare x x == EQ ] 79 | 80 | b = min a $ max a a 81 | 82 | 83 | coverTypeableInstance :: (Monad m, Typeable a) => a -> m () 84 | coverTypeableInstance a = typeOf a `seq` return () 85 | 86 | 87 | expectException :: IO a -> PropertyM IO () 88 | expectException m = do 89 | e <- QC.run $ try m 90 | case e of 91 | Left (z::SomeException) -> (length $ show z) `seq` return () 92 | Right _ -> fail "expected exception, didn't get one" 93 | 94 | 95 | expectExceptionH :: IO a -> IO () 96 | expectExceptionH act = do 97 | e <- try act 98 | case e of 99 | Left (z::SomeException) -> (length $ show z) `seq` return () 100 | Right _ -> fail "expected exception, didn't get one" 101 | 102 | 103 | 104 | ------------------------------------------------------------------------------ 105 | instance Arbitrary Text where 106 | arbitrary = do 107 | -- we don't need a full character set here 108 | txt <- listOf $ elements $ ['a'..'z'] ++ ['0'..'9'] ++ " ._" 109 | return $ T.pack txt 110 | 111 | ------------------------------------------------------------------------------ 112 | instance Arbitrary ByteString where 113 | arbitrary = do 114 | -- we don't need a full character set here 115 | txt <- listOf $ elements $ ['a'..'z'] ++ ['0'..'9'] ++ " ._" 116 | return $ S.pack txt 117 | 118 | ------------------------------------------------------------------------------ 119 | instance Arbitrary MessageContents where 120 | arbitrary = do 121 | t <- arbitrary `suchThat` (not . T.null) 122 | f <- elements flist 123 | return $ f t 124 | where 125 | flist = [ Talk 126 | , Action 127 | , \_ -> Join 128 | , Leave ] 129 | 130 | 131 | ------------------------------------------------------------------------------ 132 | instance Arbitrary Message where 133 | arbitrary = Message <$> 134 | arbitrary `suchThat` (not . T.null) <*> 135 | (toEnum <$> choose (l,h)) <*> 136 | arbitrary 137 | where 138 | l = 1314070521 139 | h = 1344070521 140 | 141 | ------------------------------------------------------------------------------ 142 | propJSONInvertible :: (Eq a, FromJSON a, ToJSON a) => a -> Bool 143 | propJSONInvertible x = case result of 144 | Error _ -> False 145 | Success y -> x == y 146 | where 147 | result = fromJSON $ toJSON x 148 | 149 | 150 | ------------------------------------------------------------------------------ 151 | fromRight :: Either String a -> a 152 | fromRight (Left e) = error e 153 | fromRight (Right r) = r 154 | 155 | -------------------------------------------------------------------------------- /sample-implementation/Snap/Chat/Internal/Types.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE BangPatterns #-} 2 | {-# LANGUAGE DeriveDataTypeable #-} 3 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 4 | {-# LANGUAGE OverloadedStrings #-} 5 | 6 | module Snap.Chat.Internal.Types where 7 | 8 | ------------------------------------------------------------------------------ 9 | import Control.Applicative 10 | import Control.Concurrent.MVar 11 | import Control.Concurrent.STM 12 | import Data.Aeson 13 | import qualified Data.Aeson.Types as A 14 | import Data.ByteString (ByteString) 15 | import Data.Data 16 | import qualified Data.HashTable.IO as HT 17 | import qualified Data.HashMap.Strict as Map 18 | import Data.Monoid 19 | import Data.Text (Text) 20 | import System.Posix.Types 21 | ------------------------------------------------------------------------------ 22 | import System.TimeoutManager (TimeoutManager, TimeoutHandle) 23 | 24 | 25 | ------------------------------------------------------------------------------ 26 | type UserName = Text 27 | 28 | ------------------------------------------------------------------------------ 29 | data MessageContents = Talk { _messageText :: !Text } 30 | | Action { _messageText :: !Text } 31 | | Join 32 | | Leave { _messageText :: !Text } 33 | deriving (Show, Eq) 34 | 35 | 36 | instance FromJSON MessageContents where 37 | parseJSON (Object obj) = do 38 | ty <- (obj .: "type") :: A.Parser Text 39 | case ty of 40 | "talk" -> Talk <$> 41 | obj .: "text" 42 | 43 | "action" -> Action <$> 44 | obj .: "text" 45 | 46 | "join" -> pure Join 47 | 48 | "leave" -> Leave <$> 49 | obj .: "text" 50 | 51 | _ -> fail "bad type" 52 | 53 | parseJSON _ = fail "MessageContents: JSON object of wrong type" 54 | 55 | 56 | ------------------------------------------------------------------------------ 57 | instance ToJSON MessageContents where 58 | toJSON (Talk t) = 59 | Object $ Map.fromList [ ("type", toJSON ("talk"::Text)) 60 | , ("text", toJSON t ) 61 | ] 62 | 63 | toJSON (Action t) = 64 | Object $ Map.fromList [ ("type", toJSON ("action"::Text)) 65 | , ("text", toJSON t ) 66 | ] 67 | 68 | toJSON (Join) = 69 | Object $ Map.fromList [ ("type", toJSON ("join"::Text)) 70 | ] 71 | 72 | toJSON (Leave t) = 73 | Object $ Map.fromList [ ("type", toJSON ("leave"::Text)) 74 | , ("text", toJSON t ) 75 | ] 76 | 77 | 78 | ------------------------------------------------------------------------------ 79 | data Message = Message { 80 | _messageUser :: !UserName 81 | , _messageTime :: !EpochTime 82 | , _messageContents :: !MessageContents 83 | } 84 | deriving (Show, Eq) 85 | 86 | 87 | ------------------------------------------------------------------------------ 88 | getMessageUserName :: Message -> UserName 89 | getMessageUserName = _messageUser 90 | 91 | getMessageTime :: Message -> EpochTime 92 | getMessageTime = _messageTime 93 | 94 | getMessageContents :: Message -> MessageContents 95 | getMessageContents = _messageContents 96 | 97 | 98 | ------------------------------------------------------------------------------ 99 | instance FromJSON Message where 100 | parseJSON (Object obj) = 101 | Message <$> 102 | obj .: "user" <*> 103 | (toEnum <$> obj .: "time") <*> 104 | obj .: "contents" 105 | 106 | parseJSON _ = fail "Message: JSON object of wrong type" 107 | 108 | instance ToJSON Message where 109 | toJSON (Message u t c) = 110 | Object $ Map.fromList [ ("user" , toJSON u ) 111 | , ("time" , toJSON $ fromEnum t) 112 | , ("contents", toJSON c ) ] 113 | 114 | 115 | ------------------------------------------------------------------------------ 116 | newtype UserToken = UserToken ByteString 117 | deriving (Show, Eq, Data, Ord, Typeable, Monoid, FromJSON, ToJSON) 118 | 119 | 120 | ------------------------------------------------------------------------------ 121 | data User = User { 122 | _userName :: !UserName 123 | , _userMsgChan :: !(TChan Message) 124 | , _userToken :: !UserToken 125 | , _timeoutHandle :: !TimeoutHandle 126 | } 127 | 128 | 129 | ------------------------------------------------------------------------------ 130 | getUserName :: User -> UserName 131 | getUserName = _userName 132 | 133 | 134 | ------------------------------------------------------------------------------ 135 | getUserToken :: User -> UserToken 136 | getUserToken = _userToken 137 | 138 | 139 | ------------------------------------------------------------------------------ 140 | type HashTable k v = HT.CuckooHashTable k v 141 | 142 | 143 | ------------------------------------------------------------------------------ 144 | data ChatRoom = ChatRoom { 145 | _timeoutManager :: !TimeoutManager 146 | , _userMap :: !(MVar (HashTable UserName User)) 147 | , _chatChannel :: !(TChan Message) 148 | , _userTimeout :: !Int -- ^ how long users can remain 149 | -- inactive 150 | } 151 | -------------------------------------------------------------------------------- /src/Snap/Chat/API/Handlers.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | {-# LANGUAGE ScopedTypeVariables #-} 3 | 4 | module Snap.Chat.API.Handlers 5 | ( apiHandlers 6 | ) where 7 | 8 | ------------------------------------------------------------------------------ 9 | import Control.Exception (SomeException) 10 | import Control.Monad 11 | import Control.Monad.CatchIO 12 | import Control.Monad.Reader 13 | import Data.Aeson 14 | import Data.Aeson.Encode 15 | import Data.Attoparsec hiding (try) 16 | import Data.ByteString.Char8 (ByteString) 17 | import qualified Data.ByteString.Char8 as S 18 | import qualified Data.ByteString.Lazy.Char8 as L 19 | import Data.Char 20 | import qualified Data.Text as T 21 | import Prelude hiding (catch) 22 | import Snap.Iteratee (($$), consume, joinI, takeNoMoreThan) 23 | import Snap.Types 24 | import System.PosixCompat.Time 25 | import Web.ClientSession 26 | ------------------------------------------------------------------------------ 27 | import Snap.Chat.ChatRoom 28 | import Snap.Chat.Internal.Types 29 | import Snap.Chat.Internal.API.Types 30 | 31 | 32 | ------------------------------------------------------------------------------ 33 | apiHandlers :: Key -> ChatRoom -> Snap () 34 | apiHandlers key chatRoom = 35 | flip runReaderT chatRoom $ 36 | route [ ("join", apiCall $ handleJoin key ) 37 | , ("leave", authenticatingApiCall key handleLeave) 38 | , ("fetch", authenticatingApiCall key handleFetch) 39 | , ("write", authenticatingApiCall key handleWrite) 40 | ] 41 | 42 | 43 | ------------------------------------------------------------------------------ 44 | -- | Scaffold common to all api requests. Handles: 45 | -- 46 | -- * ensuring that the request is a POST with the correct MIME type 47 | -- (application/json) 48 | -- 49 | -- * decoding the request body 50 | -- 51 | -- * running the user request 52 | -- 53 | -- * if successful, encoding the response and sending it 54 | apiCall :: (FromJSON req, ToJSON resp) => 55 | (req -> ApiHandler (ApiResponse resp)) 56 | -> ApiHandler () 57 | apiCall f = method POST $ do 58 | -- Check that the content-type is JSON. Strip off any charset suffixes. 59 | ct <- liftM (fmap (S.takeWhile (\c -> c /= ';' && not (isSpace c))) 60 | . getHeader "Content-Type") getRequest 61 | 62 | when (ct /= Just "application/json") $ 63 | finishWith $ setResponseCode 415 emptyResponse 64 | 65 | 66 | -- Your code goes here. 67 | toBeImplemented 68 | 69 | where 70 | maxSize = 131072 -- 128 kB should be enough for anybody 71 | 72 | fetchRequestBody :: ApiHandler ByteString 73 | fetchRequestBody = liftM S.concat $ runRequestBody $ 74 | joinI $ takeNoMoreThan maxSize $$ consume 75 | 76 | 77 | ------------------------------------------------------------------------------ 78 | -- | Scaffold common to api requests that require an authenticated user. 79 | -- Handles: 80 | -- 81 | -- * Decoding the input session token 82 | -- 83 | -- * Looking up that the user is connected 84 | -- 85 | -- * Making sure the authentication token matches 86 | -- 87 | -- * Running the user request 88 | -- 89 | -- * Encoding the output session token 90 | authenticatingApiCall :: (HasStatus resp, FromJSON req, ToJSON resp) => 91 | Key 92 | -> (User -> req -> ApiHandler resp) 93 | -> ApiHandler () 94 | authenticatingApiCall key = apiCall . authenticate key 95 | 96 | 97 | ------------------------------------------------------------------------------ 98 | authenticate :: (FromJSON req, ToJSON resp, HasStatus resp) => 99 | Key 100 | -> (User -> req -> ApiHandler resp) 101 | -> ApiRequest req 102 | -> ApiHandler (ApiResponse resp) 103 | authenticate key f apiRequest = do 104 | -- Your code goes here. 105 | toBeImplemented 106 | 107 | 108 | ------------------------------------------------------------------------------ 109 | encodeSession :: Key -> User -> IO ByteString 110 | encodeSession key (User name _ token _) = epochTime >>= newEncodedSession 111 | where 112 | newEncodedSession now = do 113 | let newSession = EncodedSession token now name 114 | encryptIO key $ S.concat $ L.toChunks $ encode newSession 115 | 116 | 117 | ------------------------------------------------------------------------------ 118 | handleJoin :: Key 119 | -> JoinRequest 120 | -> ApiHandler (ApiResponse JoinResponse) 121 | handleJoin key (JoinRequest userName) = do 122 | -- Your code goes here. 123 | toBeImplemented 124 | 125 | ------------------------------------------------------------------------------ 126 | handleLeave :: User -> LeaveRequest -> ApiHandler LeaveResponse 127 | handleLeave user _ = do 128 | -- Your code goes here 129 | toBeImplemented 130 | 131 | 132 | ------------------------------------------------------------------------------ 133 | handleFetch :: User -> GetMessagesRequest -> ApiHandler GetMessagesResponse 134 | handleFetch user _ = do 135 | setTimeout $ defaultTimeout + 10 136 | -- Your code goes here. 137 | toBeImplemented 138 | 139 | 140 | ------------------------------------------------------------------------------ 141 | handleWrite :: User -> WriteMessageRequest -> ApiHandler WriteMessageResponse 142 | handleWrite user (WriteMessageRequest msg) = do 143 | -- Your code goes here. 144 | toBeImplemented 145 | 146 | 147 | ------------------------------------------------------------------------------ 148 | defaultTimeout :: Int 149 | defaultTimeout = 50 150 | -------------------------------------------------------------------------------- /test/suite/Snap/Chat/ChatRoom/Tests.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE BangPatterns #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | 4 | module Snap.Chat.ChatRoom.Tests (tests) where 5 | 6 | ------------------------------------------------------------------------------ 7 | import Control.Concurrent 8 | import qualified Data.ByteString.Char8 as S 9 | import System.PosixCompat.Time 10 | import Test.Framework 11 | import Test.Framework.Providers.HUnit 12 | import Test.HUnit hiding (Test) 13 | ------------------------------------------------------------------------------ 14 | import Snap.Chat.ChatRoom 15 | import Snap.Chat.Internal.Util 16 | import Snap.Chat.Test.Common 17 | import Snap.Chat.Internal.Types 18 | 19 | ------------------------------------------------------------------------------ 20 | tests :: [Test] 21 | tests = [ testConnectAndLookup 22 | , testUserTimeout 23 | , testConnectTwice 24 | , testAuthenticate 25 | ] 26 | 27 | 28 | ------------------------------------------------------------------------------ 29 | testConnectAndLookup :: Test 30 | testConnectAndLookup = testCase "chatroom/connectAndLookup" $ 31 | withChatRoom 10 proc 32 | where 33 | ------------------------------------------------------------------------ 34 | userName = "cufp2011" 35 | userName2 = "secondUser" 36 | 37 | ------------------------------------------------------------------------ 38 | isJoin :: MessageContents -> Bool 39 | isJoin Join = True 40 | isJoin _ = False 41 | 42 | 43 | ------------------------------------------------------------------------ 44 | isLeave :: MessageContents -> Bool 45 | isLeave (Leave x) = x `seq` True 46 | isLeave _ = False 47 | 48 | 49 | ------------------------------------------------------------------------ 50 | proc chatRoom = do 51 | now <- epochTime 52 | user <- joinUser userName chatRoom 53 | 54 | lookupUser userName chatRoom >>= 55 | maybe (assertBool "user not found" False) 56 | (\u2 -> do 57 | assertEqual "usernames don't match" 58 | userName 59 | (getUserName u2)) 60 | 61 | -- only message on the channel should be the join message 62 | msgs <- getMessages 1 user chatRoom 63 | assertEqual "only one message on channel" 1 $ length msgs 64 | let msg = head msgs 65 | 66 | assertEqual "message user doesn't match" 67 | userName 68 | (getMessageUserName msg) 69 | 70 | let timeDelta = getMessageTime msg - now 71 | assertBool "message time mismatch" (abs timeDelta <= 2) 72 | assertBool "message is a join" $ isJoin $ getMessageContents msg 73 | 74 | user2 <- joinUser userName2 chatRoom 75 | disconnectUser userName "goodbye" chatRoom 76 | lookupUser userName chatRoom >>= 77 | maybe (return ()) 78 | (\_ -> assertBool "user should be gone" False) 79 | msgs2 <- getMessages 1 user2 chatRoom 80 | assertEqual "two messages on channel" 2 $ length msgs2 81 | let [joinMsg, leaveMsg] = msgs2 82 | 83 | assertEqual "message user doesn't match" 84 | userName2 85 | (getMessageUserName joinMsg) 86 | assertBool "message is a join" $ isJoin $ getMessageContents joinMsg 87 | 88 | assertEqual "message user doesn't match" 89 | userName 90 | (getMessageUserName leaveMsg) 91 | assertBool "message is a leave" $ isLeave $ getMessageContents leaveMsg 92 | 93 | 94 | ------------------------------------------------------------------------------ 95 | testConnectTwice :: Test 96 | testConnectTwice = testCase "chatroom/connectTwice" $ 97 | withChatRoom 10 proc 98 | where 99 | ------------------------------------------------------------------------ 100 | userName = "cufp2011" 101 | 102 | ------------------------------------------------------------------------ 103 | proc chatRoom = do 104 | _ <- joinUser userName chatRoom 105 | expectExceptionH $ joinUser userName chatRoom 106 | 107 | 108 | ------------------------------------------------------------------------------ 109 | testUserTimeout :: Test 110 | testUserTimeout = testCase "chatroom/userTimeout" $ 111 | withChatRoom 1 proc 112 | where 113 | ------------------------------------------------------------------------ 114 | userName = "cufp2011" 115 | 116 | ------------------------------------------------------------------------ 117 | proc chatRoom = do 118 | _ <- joinUser userName chatRoom 119 | threadDelay $ seconds 3 120 | 121 | lookupUser userName chatRoom >>= 122 | maybe (return ()) 123 | (\_ -> assertBool "user didn't timeout" False) 124 | 125 | 126 | ------------------------------------------------------------------------------ 127 | testAuthenticate :: Test 128 | testAuthenticate = testCase "chatroom/authenticate" $ 129 | withChatRoom 10 proc 130 | where 131 | ------------------------------------------------------------------------ 132 | userName = "cufp2011" 133 | userName2 = "junk" 134 | 135 | ------------------------------------------------------------------------ 136 | proc chatRoom = do 137 | user <- joinUser userName chatRoom 138 | 139 | let oldToken = getUserToken user 140 | let (UserToken oldTokenBS) = oldToken 141 | let newToken = UserToken $ S.drop 1 oldTokenBS 142 | 143 | expectExceptionH $ authenticateUser userName newToken chatRoom 144 | expectExceptionH $ authenticateUser userName2 oldToken chatRoom 145 | user' <- authenticateUser userName oldToken chatRoom 146 | 147 | -- expect the token to not have changed. 148 | assertBool "token didn't change" $ getUserToken user' == oldToken 149 | -------------------------------------------------------------------------------- /src/Snap/Chat/Internal/API/Types.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | module Snap.Chat.Internal.API.Types where 4 | 5 | ------------------------------------------------------------------------------ 6 | import Control.Applicative 7 | import Control.Monad.Reader 8 | import Data.Aeson 9 | import qualified Data.Aeson.Types as A 10 | import Data.ByteString.Char8 (ByteString) 11 | import qualified Data.HashMap.Strict as Map 12 | import Data.Text (Text) 13 | import qualified Data.Text as T 14 | import Snap.Core 15 | import System.Posix.Types 16 | ------------------------------------------------------------------------------ 17 | import Snap.Chat.Internal.Types 18 | 19 | 20 | ------------------------------------------------------------------------------ 21 | type ApiHandler a = ReaderT ChatRoom Snap a 22 | 23 | 24 | ------------------------------------------------------------------------------ 25 | data ApiRequest req = ApiRequest { 26 | _encodedSession :: ByteString 27 | , _requestData :: req 28 | } 29 | deriving (Eq, Show) 30 | 31 | 32 | ------------------------------------------------------------------------------ 33 | data ApiResponse resp = ApiResponseSuccess { 34 | _newEncodedSession :: ByteString 35 | , _responseType :: resp 36 | } 37 | | ApiResponseFailure { 38 | _failureCode :: Text 39 | , _failureReason :: Text 40 | } 41 | deriving (Eq, Show) 42 | 43 | 44 | ------------------------------------------------------------------------------ 45 | authenticationFailure :: ApiResponse a 46 | authenticationFailure = 47 | ApiResponseFailure "authentication_failure" "Authentication failure." 48 | 49 | 50 | ------------------------------------------------------------------------------ 51 | data EncodedSession = EncodedSession { 52 | _sessionToken :: UserToken 53 | , _sessionTime :: EpochTime 54 | , _apiUser :: UserName 55 | } 56 | deriving (Eq, Show) 57 | 58 | instance FromJSON EncodedSession where 59 | parseJSON (Object obj) = toBeImplemented 60 | parseJSON _ = fail "EncodedSession: JSON object of wrong type" 61 | 62 | instance ToJSON EncodedSession where 63 | toJSON (EncodedSession tok time user) = toBeImplemented 64 | 65 | ------------------------------------------------------------------------------ 66 | class HasStatus a where 67 | isFailure :: a -> Bool 68 | isFailure _ = False 69 | 70 | failureCode :: a -> Text 71 | failureCode _ = "ok" 72 | 73 | failureReason :: a -> Text 74 | failureReason _ = "ok" 75 | 76 | 77 | ------------------------------------------------------------------------------ 78 | instance (FromJSON req) => FromJSON (ApiRequest req) where 79 | parseJSON (Object obj) = toBeImplemented 80 | parseJSON _ = fail "ApiRequest: JSON object of wrong type" 81 | 82 | 83 | ------------------------------------------------------------------------------ 84 | instance (ToJSON resp) => ToJSON (ApiResponse resp) where 85 | toJSON (ApiResponseSuccess s r) = toBeImplemented 86 | toJSON (ApiResponseFailure code reason) = toBeImplemented 87 | 88 | 89 | 90 | ------------------------------------------------------------------------------ 91 | data JoinRequest = JoinRequest { _desiredUserName :: Text } 92 | deriving (Eq, Show) 93 | 94 | data JoinResponse = JoinResponseOK 95 | | JoinResponseUserAlreadyExists 96 | deriving (Eq, Show) 97 | 98 | 99 | ------------------------------------------------------------------------------ 100 | instance HasStatus JoinResponse where 101 | isFailure JoinResponseOK = False 102 | isFailure JoinResponseUserAlreadyExists = True 103 | 104 | failureCode JoinResponseOK = "ok" 105 | failureCode JoinResponseUserAlreadyExists = "user_already_exists" 106 | 107 | failureReason JoinResponseOK = "ok" 108 | failureReason JoinResponseUserAlreadyExists = 109 | T.concat [ "Cannot log in; a user with that name is already connected " 110 | , "to the channel." 111 | ] 112 | 113 | 114 | ------------------------------------------------------------------------------ 115 | instance FromJSON JoinRequest where 116 | parseJSON (Object obj) = toBeImplemented 117 | parseJSON _ = fail "JoinRequest: JSON object of wrong type" 118 | 119 | instance ToJSON JoinResponse where 120 | toJSON _ = Object Map.empty 121 | 122 | 123 | ------------------------------------------------------------------------------ 124 | data LeaveRequest = LeaveRequest 125 | deriving (Eq, Show) 126 | 127 | data LeaveResponse = LeaveResponseOK 128 | deriving (Eq, Show) 129 | 130 | instance HasStatus LeaveResponse 131 | 132 | instance FromJSON LeaveRequest where 133 | parseJSON _ = pure LeaveRequest 134 | 135 | instance ToJSON LeaveResponse where 136 | toJSON _ = Object Map.empty 137 | 138 | 139 | ------------------------------------------------------------------------------ 140 | data GetMessagesRequest = GetMessagesRequest 141 | deriving (Eq, Show) 142 | 143 | -- authentication failures handled on a different level here, so this command 144 | -- cannot fail. 145 | data GetMessagesResponse = GetMessagesOK [Message] 146 | deriving (Eq, Show) 147 | 148 | instance HasStatus GetMessagesResponse 149 | 150 | instance FromJSON GetMessagesRequest where 151 | parseJSON _ = pure GetMessagesRequest 152 | 153 | instance ToJSON GetMessagesResponse where 154 | toJSON (GetMessagesOK msgs) = toBeImplemented 155 | 156 | 157 | ------------------------------------------------------------------------------ 158 | data WriteMessageRequest = WriteMessageRequest MessageContents 159 | deriving (Eq, Show) 160 | 161 | data WriteMessageResponse = WriteMessageResponseOK 162 | deriving (Eq, Show) 163 | 164 | instance HasStatus WriteMessageResponse 165 | 166 | instance FromJSON WriteMessageRequest where 167 | parseJSON obj = toBeImplemented 168 | 169 | instance ToJSON WriteMessageResponse where 170 | toJSON _ = Object Map.empty 171 | -------------------------------------------------------------------------------- /src/System/TimeoutManager.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE BangPatterns #-} 2 | 3 | module System.TimeoutManager 4 | ( TimeoutManager 5 | , TimeoutHandle 6 | , initialize 7 | , stop 8 | , register 9 | , tickle 10 | , cancel 11 | ) where 12 | 13 | ------------------------------------------------------------------------------ 14 | import Control.Concurrent 15 | import Control.Exception 16 | import Control.Monad 17 | import Data.IORef 18 | import Foreign.C.Types 19 | 20 | import Snap.Chat.Internal.Util 21 | 22 | 23 | ------------------------------------------------------------------------------ 24 | data State = Deadline !CTime 25 | | Canceled 26 | 27 | 28 | ------------------------------------------------------------------------------ 29 | data TimeoutHandle = TimeoutHandle { 30 | _killAction :: !(IO ()) 31 | , _state :: !(IORef State) 32 | , _hGetTime :: !(IO CTime) 33 | } 34 | 35 | 36 | ------------------------------------------------------------------------------ 37 | data TimeoutManager = TimeoutManager { 38 | _defaultTimeout :: !Int 39 | , _getTime :: !(IO CTime) 40 | , _connections :: !(IORef [TimeoutHandle]) 41 | , _inactivity :: !(IORef Bool) 42 | , _morePlease :: !(MVar ()) 43 | , _managerThread :: !(MVar ThreadId) 44 | } 45 | 46 | 47 | ------------------------------------------------------------------------------ 48 | -- | Create a new TimeoutManager. 49 | initialize :: Int -- ^ default timeout 50 | -> IO CTime -- ^ function to get current time 51 | -> IO TimeoutManager 52 | initialize defaultTimeout getTime = do 53 | conns <- newIORef [] 54 | inact <- newIORef False 55 | mp <- newEmptyMVar 56 | mthr <- newEmptyMVar 57 | 58 | let tm = TimeoutManager defaultTimeout getTime conns inact mp mthr 59 | 60 | thr <- forkIO $ managerThread tm 61 | putMVar mthr thr 62 | return tm 63 | 64 | 65 | ------------------------------------------------------------------------------ 66 | -- | Stop a TimeoutManager. 67 | stop :: TimeoutManager -> IO () 68 | stop tm = readMVar (_managerThread tm) >>= killThread 69 | 70 | 71 | ------------------------------------------------------------------------------ 72 | -- | Register a new connection with the TimeoutManager. 73 | register :: IO () -- ^ action to run when the timeout deadline is 74 | -- exceeded. 75 | -> TimeoutManager -- ^ manager to register with. 76 | -> IO TimeoutHandle 77 | register killAction tm = do 78 | now <- getTime 79 | let !state = Deadline $ now + toEnum defaultTimeout 80 | stateRef <- newIORef state 81 | 82 | let !h = TimeoutHandle killAction stateRef getTime 83 | atomicModifyIORef connections $ \x -> (h:x, ()) 84 | 85 | inact <- readIORef inactivity 86 | when inact $ do 87 | -- wake up manager thread 88 | writeIORef inactivity False 89 | _ <- tryPutMVar morePlease () 90 | return () 91 | return h 92 | 93 | where 94 | getTime = _getTime tm 95 | inactivity = _inactivity tm 96 | morePlease = _morePlease tm 97 | connections = _connections tm 98 | defaultTimeout = _defaultTimeout tm 99 | 100 | 101 | ------------------------------------------------------------------------------ 102 | -- | Tickle the timeout on a connection to be N seconds into the future. 103 | tickle :: TimeoutHandle -> Int -> IO () 104 | tickle th n = do 105 | now <- getTime 106 | 107 | let state = Deadline $ now + toEnum n 108 | writeIORef stateRef state 109 | 110 | where 111 | getTime = _hGetTime th 112 | stateRef = _state th 113 | 114 | 115 | ------------------------------------------------------------------------------ 116 | -- | Cancel a timeout. 117 | cancel :: TimeoutHandle -> IO () 118 | cancel h = writeIORef (_state h) Canceled 119 | 120 | 121 | ------------------------------------------------------------------------------ 122 | managerThread :: TimeoutManager -> IO () 123 | managerThread tm = loop `finally` (readIORef connections >>= destroyAll) 124 | where 125 | -------------------------------------------------------------------------- 126 | defaultTimeout = _defaultTimeout tm 127 | connections = _connections tm 128 | getTime = _getTime tm 129 | inactivity = _inactivity tm 130 | morePlease = _morePlease tm 131 | waitABit = threadDelay $ seconds $ min defaultTimeout 5 132 | 133 | -------------------------------------------------------------------------- 134 | loop = do 135 | waitABit 136 | handles <- atomicModifyIORef connections (\x -> ([],x)) 137 | 138 | if null handles 139 | then do 140 | -- we're inactive, go to sleep until we get new threads 141 | writeIORef inactivity True 142 | takeMVar morePlease 143 | else do 144 | now <- getTime 145 | dlist <- processHandles now handles id 146 | atomicModifyIORef connections (\x -> (dlist x, ())) 147 | 148 | loop 149 | 150 | -------------------------------------------------------------------------- 151 | processHandles !now handles initDlist = go handles initDlist 152 | where 153 | go [] !dlist = return dlist 154 | 155 | go (x:xs) !dlist = do 156 | state <- readIORef $ _state x 157 | !dlist' <- case state of 158 | Canceled -> return dlist 159 | Deadline t -> if t <= now 160 | then do 161 | _killAction x 162 | return dlist 163 | else return (dlist . (x:)) 164 | go xs dlist' 165 | 166 | -------------------------------------------------------------------------- 167 | destroyAll = mapM_ diediedie 168 | 169 | -------------------------------------------------------------------------- 170 | diediedie x = do 171 | state <- readIORef $ _state x 172 | case state of 173 | Canceled -> return () 174 | _ -> _killAction x 175 | -------------------------------------------------------------------------------- /sample-implementation/Snap/Chat/Internal/API/Types.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | module Snap.Chat.Internal.API.Types where 4 | 5 | ------------------------------------------------------------------------------ 6 | import Control.Applicative 7 | import Control.Monad.Reader 8 | import Data.Aeson 9 | import qualified Data.Aeson.Types as A 10 | import Data.ByteString.Char8 (ByteString) 11 | import qualified Data.HashMap.Strict as Map 12 | import Data.Text (Text) 13 | import qualified Data.Text as T 14 | import Snap.Core 15 | import System.Posix.Types 16 | ------------------------------------------------------------------------------ 17 | import Snap.Chat.Internal.Types 18 | 19 | 20 | ------------------------------------------------------------------------------ 21 | type ApiHandler a = ReaderT ChatRoom Snap a 22 | 23 | ------------------------------------------------------------------------------ 24 | data ApiRequest req = ApiRequest { 25 | _encodedSession :: ByteString 26 | , _requestData :: req 27 | } 28 | deriving (Eq, Show) 29 | 30 | ------------------------------------------------------------------------------ 31 | data ApiResponse resp = ApiResponseSuccess { 32 | _newEncodedSession :: ByteString 33 | , _responseType :: resp 34 | } 35 | | ApiResponseFailure { 36 | _failureCode :: Text 37 | , _failureReason :: Text 38 | } 39 | deriving (Eq, Show) 40 | 41 | ------------------------------------------------------------------------------ 42 | authenticationFailure :: ApiResponse a 43 | authenticationFailure = 44 | ApiResponseFailure "authentication_failure" "Authentication failure." 45 | 46 | 47 | ------------------------------------------------------------------------------ 48 | data EncodedSession = EncodedSession { 49 | _sessionToken :: UserToken 50 | , _sessionTime :: EpochTime 51 | , _apiUser :: UserName 52 | } 53 | deriving (Eq, Show) 54 | 55 | instance FromJSON EncodedSession where 56 | parseJSON (Object obj) = EncodedSession <$> 57 | obj .: "token" <*> 58 | (toEnum <$> obj .: "time") <*> 59 | obj .: "user" 60 | parseJSON _ = fail "EncodedSession: JSON object of wrong type" 61 | 62 | instance ToJSON EncodedSession where 63 | toJSON (EncodedSession tok time user) = 64 | Object $ Map.fromList [ ("token", toJSON tok ) 65 | , ("user", toJSON user ) 66 | , ("time", toJSON $ fromEnum time) 67 | ] 68 | 69 | ------------------------------------------------------------------------------ 70 | class HasStatus a where 71 | isFailure :: a -> Bool 72 | isFailure _ = False 73 | 74 | failureCode :: a -> Text 75 | failureCode _ = "ok" 76 | 77 | failureReason :: a -> Text 78 | failureReason _ = "ok" 79 | 80 | 81 | ------------------------------------------------------------------------------ 82 | instance (FromJSON req) => FromJSON (ApiRequest req) where 83 | parseJSON (Object obj) = ApiRequest <$> 84 | obj .: "session" <*> 85 | obj .: "requestData" 86 | 87 | parseJSON _ = fail "ApiRequest: JSON object of wrong type" 88 | 89 | 90 | ------------------------------------------------------------------------------ 91 | instance (ToJSON resp) => ToJSON (ApiResponse resp) where 92 | toJSON (ApiResponseSuccess s r) = 93 | Object $ Map.fromList [ ("status" , toJSON ("ok"::Text)) 94 | , ("session" , toJSON s ) 95 | , ("response", toJSON r ) 96 | ] 97 | 98 | toJSON (ApiResponseFailure code reason) = 99 | Object $ Map.fromList [ ("status" , toJSON ("failure"::Text)) 100 | , ("statusCode", toJSON code ) 101 | , ("reason" , toJSON reason ) 102 | ] 103 | 104 | 105 | ------------------------------------------------------------------------------ 106 | data JoinRequest = JoinRequest { _desiredUserName :: Text } 107 | deriving (Eq, Show) 108 | 109 | data JoinResponse = JoinResponseOK 110 | | JoinResponseUserAlreadyExists 111 | deriving (Eq, Show) 112 | 113 | 114 | ------------------------------------------------------------------------------ 115 | instance HasStatus JoinResponse where 116 | isFailure JoinResponseOK = False 117 | isFailure JoinResponseUserAlreadyExists = True 118 | 119 | failureCode JoinResponseOK = "ok" 120 | failureCode JoinResponseUserAlreadyExists = "user_already_exists" 121 | 122 | failureReason JoinResponseOK = "ok" 123 | failureReason JoinResponseUserAlreadyExists = 124 | T.concat [ "Cannot log in; a user with that name is already connected " 125 | , "to the channel." 126 | ] 127 | 128 | 129 | ------------------------------------------------------------------------------ 130 | instance FromJSON JoinRequest where 131 | parseJSON (Object obj) = JoinRequest <$> obj .: "desiredUserName" 132 | parseJSON _ = fail "JoinRequest: JSON object of wrong type" 133 | 134 | instance ToJSON JoinResponse where 135 | toJSON _ = Object Map.empty 136 | 137 | 138 | ------------------------------------------------------------------------------ 139 | data LeaveRequest = LeaveRequest 140 | deriving (Eq, Show) 141 | 142 | data LeaveResponse = LeaveResponseOK 143 | deriving (Eq, Show) 144 | 145 | instance HasStatus LeaveResponse 146 | 147 | instance FromJSON LeaveRequest where 148 | parseJSON _ = pure LeaveRequest 149 | 150 | instance ToJSON LeaveResponse where 151 | toJSON _ = Object Map.empty 152 | 153 | 154 | ------------------------------------------------------------------------------ 155 | data GetMessagesRequest = GetMessagesRequest 156 | deriving (Eq, Show) 157 | 158 | -- authentication failures handled on a different level here, so this command 159 | -- cannot fail. 160 | data GetMessagesResponse = GetMessagesOK [Message] 161 | deriving (Eq, Show) 162 | 163 | instance HasStatus GetMessagesResponse 164 | 165 | instance FromJSON GetMessagesRequest where 166 | parseJSON _ = pure GetMessagesRequest 167 | 168 | instance ToJSON GetMessagesResponse where 169 | toJSON (GetMessagesOK msgs) = 170 | Object $ Map.fromList [ ("messages", toJSON msgs) ] 171 | 172 | 173 | ------------------------------------------------------------------------------ 174 | data WriteMessageRequest = WriteMessageRequest MessageContents 175 | deriving (Eq, Show) 176 | 177 | data WriteMessageResponse = WriteMessageResponseOK 178 | deriving (Eq, Show) 179 | 180 | instance HasStatus WriteMessageResponse 181 | 182 | instance FromJSON WriteMessageRequest where 183 | parseJSON obj = WriteMessageRequest <$> parseJSON obj 184 | 185 | instance ToJSON WriteMessageResponse where 186 | toJSON _ = Object Map.empty 187 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # CUFP 2011 Tutorial: Web programming in Haskell with the Snap Framework 2 | 3 | This repository contains code for the CUFP 2011 tutorial 4 | [The Snap Framework for web applications in Haskell](http://cufp.org/conference/sessions/2011/t7-snap-framework-web-applications-haskell-gregory). 5 | You will be building a simplified web application implementing multi-user chat. 6 | 7 | 8 | ## Getting started 9 | 10 | From the project root directory, running `cabal install` should build the 11 | `snap-chat` and `snap-chat-sample` executables. You can find these executables 12 | in the `dist/build/` subdirectory. To run the sample application (to see what 13 | the result should look like), run 14 | `dist/build/snap-chat-sample/snap-chat-sample` and point your browser to 15 | [`http://localhost:8000/`](http://localhost:8000/). 16 | 17 | The sample implementation of the code you're expected to provide can be found 18 | in the `sample-implementation/` directory; however **please don't peek** unless 19 | you get really stuck. We'll be working through the code together. 20 | 21 | Test code (so you can test your implementation against the expected result) can 22 | be found in the `test/` directory; to run it: 23 | 24 | cd test 25 | cabal install 26 | ./runTestsAndCoverage.sh 27 | 28 | 29 | ## Specifications 30 | 31 | Snap Chat is split into three functional components: 32 | 33 | * a data model, consisting of Haskell code for interacting with a chat 34 | channel; see `src/Snap/Chat/Types.hs`, `src/Snap/Chat/ChatRoom.hs`, and 35 | `src/Snap/Chat/Message.hs` for the implementation here. 36 | 37 | * a JSON API that provides access to the data model; this consists of HTTP 38 | `POST` handlers for the URL endpoints: 39 | 40 | * `/api/join`, to join the chat channel 41 | * `/api/leave`, to leave the chat channel 42 | * `/api/fetch`, to fetch new messages written to the chat channel (using 43 | long-polling) 44 | * `/api/write`, to write a message to the chat channel. 45 | 46 | These API endpoints will be described in further detail later. 47 | 48 | * an HTML5/Javascript front end that calls the JSON api. 49 | 50 | For brevity and to bound the amount of work students are expected to do in the 51 | short tutorial, most of the code is already provided, including all of the 52 | JavaScript (this is a Haskell tutorial!), the data model code, and all of the 53 | datatypes. More advanced students who quickly breeze through the small amount 54 | of work provided can check out the "extra credit" section at the end of this 55 | document. 56 | 57 | 58 | ### API documentation 59 | 60 | Each of the four API calls (`/api/join`, `/api/leave`, `/api/fetch`, 61 | `/api/write`) share a similar structure: they all respond only to POST requests 62 | containing a UTF8-encoded JSON document as the request body; i.e. the 63 | `Content-Type` of the input request is `application/json`, and they all produce 64 | a JSON document as the result. The output responses have the following common 65 | structure: either they succeed, producing a document like the following: 66 | 67 | { 68 | "status": "ok", 69 | "session": "DF1642....038A=", 70 | "response": { ...some json object... } 71 | } 72 | 73 | When they fail, the output document looks like this: 74 | 75 | { 76 | "status": "failure", 77 | "statusCode": "some_failure", 78 | "reason": "blah blah blah blah." 79 | } 80 | 81 | The "session" variable above deserves some special mention: upon successfully 82 | joining the chat room, the user will receive an encrypted session token, which 83 | will be used on subsequent requests to re-authenticate the user with the chat 84 | room. Upon each response, a fresh session token will be generated. The contents 85 | of the session token are opaque to the API user, but can be decrypted on the 86 | server-side. 87 | 88 | The data type for the encoded session looks like this (see 89 | `src/Snap/Chat/Internal/API/Types.hs`): 90 | 91 | data EncodedSession = EncodedSession { 92 | _sessionToken :: UserToken 93 | , _sessionTime :: EpochTime 94 | , _apiUser :: UserName 95 | } 96 | 97 | A session will only be considered valid if: 98 | 99 | * the session time is not too old. 100 | 101 | * the user name and user token match what is contained in the chat room data 102 | model. 103 | 104 | 105 | #### /api/join 106 | 107 | The "join" command is responsible for connecting a user to the chat room with a 108 | given user name. 109 | 110 | Example request: 111 | 112 | { "desiredUserName": "george" } 113 | 114 | Example successful response: 115 | 116 | { 117 | "status": "ok", 118 | "session": "abc.....def", 119 | "response": {} 120 | } 121 | 122 | Example unsuccessful response: 123 | 124 | { 125 | "status": "failure", 126 | "statusCode": "user_already_exists", 127 | "reason": "Cannot log in; a user with that name is already connected \ 128 | to the channel." 129 | } 130 | 131 | 132 | #### /api/leave 133 | 134 | The "leave" command logs the user out of the chat room. 135 | 136 | Example request: 137 | 138 | { 139 | "session": "abc.....def", 140 | "requestData": {} 141 | } 142 | 143 | Example successful response: 144 | 145 | { 146 | "status": "ok", 147 | "session": "abc.....def", 148 | "response": {} 149 | } 150 | 151 | #### /api/fetch 152 | 153 | The "fetch" command gets new messages from the chat room, blocking for up to 50 154 | seconds before it returns with a list of new messages, possibly empty. 155 | 156 | Example request: 157 | 158 | { 159 | "session": "abc.....def", 160 | "requestData": {} 161 | } 162 | 163 | Example successful response: 164 | 165 | { 166 | "status": "ok", 167 | "session": "abc.....def", 168 | "response": { "messages": [ ...messages... ] } 169 | } 170 | 171 | The JSON type of messages is as follows: 172 | 173 | { "contents": { 174 | "type": <>, 175 | "text": "message text" 176 | }, 177 | "user": "fred", 178 | "time": <> 179 | } 180 | 181 | 182 | #### /api/write 183 | 184 | The "write" command writes a message to the chat room. 185 | 186 | Example request: 187 | 188 | { 189 | "session": "abc.....def", 190 | "requestData": { 191 | "type": <>, 192 | "text": "message text" 193 | } 194 | } 195 | 196 | Example successful response: 197 | 198 | { 199 | "status": "ok", 200 | "session": "abc.....def", 201 | "response": {} 202 | } 203 | 204 | 205 | ## What students must implement 206 | 207 | Several functions and instances in the source tree have been marked as 208 | "toBeImplemented". Tutorial attendees must implement: 209 | 210 | * `ToJSON` and `FromJSON` instances for the types in 211 | `src/Snap/Chat/Internal/API/Types.hs`. 212 | 213 | * `ToJSON` and `FromJSON` instances for the message types in 214 | `src/Snap/Chat/Internal/Types.hs`. 215 | 216 | * all of the stubbed-out functions in `src/Snap/Chat/API/Handlers.hs`. 217 | 218 | You'll need to use the functions from `src/Snap/Chat/ChatRoom.hs`, which 219 | contains all of the "business logic" for the chat rooms. 220 | 221 | 222 | ## Extra credit 223 | 224 | If you finish early and get bored, here are some ideas for "extra-credit" 225 | assignments: 226 | 227 | * extend the chat channel with a user list 228 | 229 | * add private user-to-user messages 230 | 231 | * support multiple chat rooms 232 | -------------------------------------------------------------------------------- /test/suite/Snap/Chat/Internal/API/Tests.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE BangPatterns #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | {-# OPTIONS_GHC -fno-warn-orphans #-} 4 | 5 | module Snap.Chat.Internal.API.Tests (tests) where 6 | 7 | ------------------------------------------------------------------------------ 8 | import Control.Applicative 9 | import Control.Monad 10 | import Data.Aeson 11 | import Data.Aeson.Types 12 | import qualified Data.Attoparsec as A 13 | import qualified Data.ByteString.Char8 as S 14 | import qualified Data.ByteString.Lazy.Char8 as L 15 | import qualified Data.HashMap.Strict as Map 16 | import Data.Maybe (isJust) 17 | import Data.Text (Text) 18 | import Test.Framework 19 | import Test.Framework.Providers.HUnit 20 | import Test.Framework.Providers.QuickCheck2 21 | import qualified Test.HUnit as H 22 | import Test.QuickCheck hiding (Success, Result, reason) 23 | ------------------------------------------------------------------------------ 24 | import Snap.Chat.Test.Common 25 | import Snap.Chat.Internal.API.Types 26 | import Snap.Chat.Internal.Types 27 | 28 | ------------------------------------------------------------------------------ 29 | tests :: [Test] 30 | tests = [ testApiRequestFromJson 31 | , testApiResponseToJson 32 | , testEncodedSessionJsonInvertible 33 | , testTrivialRequestsFromJson 34 | , testTrivialResponsesToJson 35 | , testWriteMessageRequestFromJson 36 | , testGetMessagesResponseToJson 37 | ] 38 | 39 | 40 | ------------------------------------------------------------------------------ 41 | instance (Arbitrary a) => Arbitrary (ApiResponse a) where 42 | arbitrary = do 43 | b <- arbitrary 44 | if b 45 | then ApiResponseSuccess <$> arbitrary <*> arbitrary 46 | else ApiResponseFailure <$> arbitrary <*> arbitrary 47 | 48 | instance Arbitrary EncodedSession where 49 | arbitrary = EncodedSession <$> 50 | (UserToken <$> arbitrary) <*> 51 | (toEnum <$> arbitrary) <*> 52 | arbitrary 53 | 54 | instance Arbitrary GetMessagesResponse where 55 | arbitrary = GetMessagesOK <$> arbitrary 56 | 57 | 58 | ------------------------------------------------------------------------------ 59 | testEncodedSessionJsonInvertible :: Test 60 | testEncodedSessionJsonInvertible = 61 | testProperty "api/encodedSessionJsonInvertible" prop 62 | where 63 | prop :: EncodedSession -> Bool 64 | prop = propJSONInvertible 65 | 66 | 67 | ------------------------------------------------------------------------------ 68 | testApiRequestFromJson :: Test 69 | testApiRequestFromJson = testCase "api/apiRequestFromJson" $ do 70 | let r = fromJSON $ fromRight $ A.parseOnly json jsonText 71 | case r of 72 | (Error e) -> error e 73 | (Success x) -> do 74 | H.assertEqual "session ok" "abcdefg" $ _encodedSession x 75 | H.assertEqual "string ok" ("foo"::Text) $ _requestData x 76 | where 77 | jsonText = "{ \"session\": \"abcdefg\", \"requestData\": \"foo\" }" 78 | 79 | 80 | ------------------------------------------------------------------------------ 81 | testApiResponseToJson :: Test 82 | testApiResponseToJson = testProperty "api/apiResponseFromJson" prop 83 | where 84 | prop :: ApiResponse Int -> Bool 85 | prop resp = p1 resp 86 | where 87 | p1 r@(ApiResponseSuccess session responseData) = 88 | let s = S.concat $ L.toChunks $ encode r 89 | (Object j) = fromRight $ A.parseOnly json s 90 | in and [ check "session doesn't match" (== session) 91 | (j .: "session") 92 | , check "status not ok" (== ("ok"::Text)) (j .: "status") 93 | , check "data not ok" (== responseData) (j .: "response") 94 | ] 95 | 96 | p1 r@(ApiResponseFailure code reason) = 97 | let s = S.concat $ L.toChunks $ encode r 98 | (Object j) = fromRight $ A.parseOnly json s 99 | in and [ check "status not failure" (== ("failure"::Text)) 100 | (j .: "status") 101 | , check "code not ok" (== code) (j .: "statusCode") 102 | , check "reason not ok" (== reason) (j .: "reason") 103 | ] 104 | 105 | 106 | ------------------------------------------------------------------------------ 107 | testTrivialRequestsFromJson :: Test 108 | testTrivialRequestsFromJson = testCase "api/trivialRequestsFromJson" $ do 109 | let r = fromJSON $ fromRight $ A.parseOnly json jsonText 110 | case r of 111 | (Error e) -> error e 112 | (Success x) -> do 113 | H.assertEqual "user ok" "fred" $ _desiredUserName x 114 | 115 | let r2 = fromJSON $ fromRight $ A.parseOnly json jsonText2 116 | case r2 of 117 | (Error e) -> error e 118 | (Success x) -> do 119 | H.assertEqual "leave ok" LeaveRequest x 120 | 121 | let r3 = fromJSON $ fromRight $ A.parseOnly json jsonText2 122 | case r3 of 123 | (Error e) -> error e 124 | (Success x) -> do 125 | H.assertEqual "GetMessagesRequest ok" GetMessagesRequest x 126 | 127 | where 128 | jsonText = "{ \"desiredUserName\": \"fred\" }" 129 | jsonText2 = "{}" 130 | 131 | 132 | 133 | ------------------------------------------------------------------------------ 134 | testTrivialResponsesToJson :: Test 135 | testTrivialResponsesToJson = testCase "api/trivialResponsesToJson" $ do 136 | let b = and [ prop JoinResponseOK 137 | , prop JoinResponseUserAlreadyExists 138 | , prop LeaveResponseOK 139 | , prop WriteMessageResponseOK 140 | ] 141 | H.assertBool "JoinResponse/LeaveResponse serialization should be empty map" b 142 | where 143 | prop :: ToJSON a => a -> Bool 144 | prop resp = j == Map.empty 145 | where 146 | s = S.concat $ L.toChunks $ encode resp 147 | (Object j) = fromRight $ A.parseOnly json s 148 | 149 | 150 | ------------------------------------------------------------------------------ 151 | testWriteMessageRequestFromJson :: Test 152 | testWriteMessageRequestFromJson = testCase "types/writeMessageFromJson" $ do 153 | H.assertEqual "talk" (WriteMessageRequest contents1) value1 154 | H.assertEqual "action" (WriteMessageRequest contents2) value2 155 | H.assertEqual "join" (WriteMessageRequest contents3) value3 156 | H.assertEqual "leave" (WriteMessageRequest contents4) value4 157 | return () 158 | 159 | where 160 | text1 = "foo-text-1" 161 | text2 = "foo-text-2" 162 | text4 = "foo-text-4" 163 | 164 | contents1 = Talk text1 165 | contents2 = Action text2 166 | contents3 = Join 167 | contents4 = Leave text4 168 | 169 | str1 = S.concat $ L.toChunks $ encode contents1 170 | str2 = S.concat $ L.toChunks $ encode contents2 171 | str3 = S.concat $ L.toChunks $ encode contents3 172 | str4 = S.concat $ L.toChunks $ encode contents4 173 | 174 | json1 = fromRight $ A.parseOnly json str1 175 | json2 = fromRight $ A.parseOnly json str2 176 | json3 = fromRight $ A.parseOnly json str3 177 | json4 = fromRight $ A.parseOnly json str4 178 | 179 | value1 = fromResult $ fromJSON json1 180 | value2 = fromResult $ fromJSON json2 181 | value3 = fromResult $ fromJSON json3 182 | value4 = fromResult $ fromJSON json4 183 | 184 | 185 | ------------------------------------------------------------------------------ 186 | testGetMessagesResponseToJson :: Test 187 | testGetMessagesResponseToJson = 188 | testProperty "api/getMessagesResponseToJson" prop 189 | where 190 | prop :: GetMessagesResponse -> Bool 191 | prop resp@(GetMessagesOK msgs) = 192 | let s = S.concat $ L.toChunks $ encode resp 193 | msgs' = fromResult $ fromJSON $ fromRight $ A.parseOnly json s 194 | in Just msgs == Map.lookup ("messages"::Text) msgs' 195 | 196 | 197 | ------------------------------------------------------------------------------ 198 | check :: String -> (a -> Bool) -> Parser a -> Bool 199 | check s f p = isJust $ parseMaybe (const p') () 200 | where 201 | p' = do 202 | v <- p 203 | if f v then return () else fail s 204 | 205 | 206 | ------------------------------------------------------------------------------ 207 | fromResult :: Result a -> a 208 | fromResult (Error e) = error e 209 | fromResult (Success s) = s 210 | 211 | -------------------------------------------------------------------------------- /sample-implementation/Snap/Chat/API/Handlers.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | {-# LANGUAGE ScopedTypeVariables #-} 3 | 4 | module Snap.Chat.API.Handlers 5 | ( apiHandlers 6 | ) where 7 | 8 | ------------------------------------------------------------------------------ 9 | import Control.Exception (SomeException) 10 | import Control.Monad 11 | import Control.Monad.CatchIO 12 | import Control.Monad.Reader 13 | import Data.Aeson 14 | import Data.Attoparsec hiding (try) 15 | import Data.ByteString.Char8 (ByteString) 16 | import qualified Data.ByteString.Char8 as S 17 | import qualified Data.ByteString.Lazy.Char8 as L 18 | import Data.Char 19 | import qualified Data.Text as T 20 | import Prelude hiding (catch) 21 | import Snap.Iteratee (($$), consume, joinI, takeNoMoreThan) 22 | import Snap.Core 23 | import System.PosixCompat.Time 24 | import Web.ClientSession 25 | ------------------------------------------------------------------------------ 26 | import Snap.Chat.ChatRoom 27 | import Snap.Chat.Internal.Types 28 | import Snap.Chat.Internal.API.Types 29 | 30 | 31 | ------------------------------------------------------------------------------ 32 | apiHandlers :: Key -> ChatRoom -> Snap () 33 | apiHandlers key chatRoom = 34 | flip runReaderT chatRoom $ 35 | route [ ("join", apiCall $ handleJoin key ) 36 | , ("leave", authenticatingApiCall key handleLeave) 37 | , ("fetch", authenticatingApiCall key handleFetch) 38 | , ("write", authenticatingApiCall key handleWrite) 39 | ] 40 | 41 | 42 | ------------------------------------------------------------------------------ 43 | -- | Scaffold common to all api requests. Handles: 44 | -- 45 | -- * ensuring that the request is a POST with the correct MIME type 46 | -- (application/json) 47 | -- 48 | -- * decoding the request body 49 | -- 50 | -- * running the user request 51 | -- 52 | -- * if successful, encoding the response and sending it 53 | apiCall :: (FromJSON req, ToJSON resp) => 54 | (req -> ApiHandler (ApiResponse resp)) 55 | -> ApiHandler () 56 | apiCall f = method POST $ do 57 | -- Check that the content-type is JSON. Strip off any charset suffixes. 58 | ct <- liftM (fmap (S.takeWhile (\c -> c /= ';' && not (isSpace c))) 59 | . getHeader "Content-Type") getRequest 60 | 61 | when (ct /= Just "application/json") $ 62 | finishWith $ setResponseCode 415 emptyResponse 63 | 64 | -- Grab the JSON request body 65 | jsonInput <- fetchRequestBody 66 | 67 | let parseResult = parseOnly json jsonInput 68 | either errorOut 69 | (\obj -> do 70 | let input = fromJSON obj 71 | case input of 72 | Error e -> errorOut e 73 | Success a -> do 74 | output <- f a 75 | modifyResponse $ setContentType "application/json" 76 | writeLBS $ encode $ toJSON output) 77 | parseResult 78 | where 79 | maxSize = 131072 -- 128 kB should be enough for anybody 80 | 81 | fetchRequestBody = liftM S.concat $ runRequestBody $ 82 | joinI $ takeNoMoreThan maxSize $$ consume 83 | 84 | errorOut e = do 85 | putResponse emptyResponse 86 | writeText $ "Error decoding JSON input:\n" 87 | writeText $ T.pack $ show e 88 | getResponse >>= finishWith . setResponseCode 415 89 | 90 | 91 | ------------------------------------------------------------------------------ 92 | -- | Scaffold common to api requests that require an authenticated user. 93 | -- Handles: 94 | -- 95 | -- * Decoding the input session token 96 | -- 97 | -- * Looking up that the user is connected 98 | -- 99 | -- * Making sure the authentication token matches 100 | -- 101 | -- * Running the user request 102 | -- 103 | -- * Encoding the output session token 104 | authenticatingApiCall :: (HasStatus resp, FromJSON req, ToJSON resp) => 105 | Key 106 | -> (User -> req -> ApiHandler resp) 107 | -> ApiHandler () 108 | authenticatingApiCall key = apiCall . authenticate key 109 | 110 | 111 | ------------------------------------------------------------------------------ 112 | authenticate :: (FromJSON req, ToJSON resp, HasStatus resp) => 113 | Key 114 | -> (User -> req -> ApiHandler resp) 115 | -> ApiRequest req 116 | -> ApiHandler (ApiResponse resp) 117 | authenticate key f apiRequest = do 118 | maybe (return authenticationFailure) 119 | (\txt -> either (const $ return authenticationFailure) 120 | (\obj -> do 121 | let input = fromJSON obj 122 | case input of 123 | Error _ -> return authenticationFailure 124 | Success sess -> auth sess) 125 | (parseOnly json txt)) 126 | mbDecryptedText 127 | 128 | where 129 | encodedSession = _encodedSession apiRequest 130 | requestData = _requestData apiRequest 131 | mbDecryptedText = decrypt key encodedSession 132 | 133 | auth (EncodedSession token oldTime userName) = do 134 | chatRoom <- ask :: ApiHandler ChatRoom 135 | now <- liftIO epochTime 136 | if now - oldTime > toEnum (_userTimeout chatRoom) 137 | then return authenticationFailure 138 | else do 139 | eUser <- try $ liftIO $ authenticateUser userName token 140 | chatRoom 141 | either (\(_::SomeException) -> return authenticationFailure) 142 | (\user -> do 143 | resp <- f user requestData 144 | newEncodedSession <- liftIO $ encodeSession key user 145 | if isFailure resp 146 | then return $ 147 | ApiResponseFailure (failureCode resp) 148 | (failureReason resp) 149 | else return $ 150 | ApiResponseSuccess newEncodedSession resp) 151 | eUser 152 | 153 | 154 | ------------------------------------------------------------------------------ 155 | encodeSession :: Key -> User -> IO ByteString 156 | encodeSession key (User name _ token _) = epochTime >>= newEncodedSession 157 | where 158 | newEncodedSession now = do 159 | let newSession = EncodedSession token now name 160 | encryptIO key $ S.concat $ L.toChunks $ encode newSession 161 | 162 | ------------------------------------------------------------------------------ 163 | handleJoin :: Key 164 | -> JoinRequest 165 | -> ApiHandler (ApiResponse JoinResponse) 166 | handleJoin key (JoinRequest userName) = do 167 | (ask >>= joinUp) `catch` \(_ :: UserAlreadyConnectedException) -> do 168 | return $ ApiResponseFailure (failureCode resp) (failureReason resp) 169 | where 170 | resp = JoinResponseUserAlreadyExists 171 | 172 | joinUp chatRoom = do 173 | user <- liftIO $ joinUser userName chatRoom 174 | newEncodedSession <- liftIO $ encodeSession key user 175 | return $ ApiResponseSuccess newEncodedSession JoinResponseOK 176 | 177 | 178 | ------------------------------------------------------------------------------ 179 | handleLeave :: User -> LeaveRequest -> ApiHandler LeaveResponse 180 | handleLeave user _ = do 181 | ask >>= liftIO . disconnectUser userName disconnectionReason 182 | return LeaveResponseOK 183 | where 184 | userName = _userName user 185 | disconnectionReason = T.concat [ " has left the channel." ] 186 | 187 | 188 | ------------------------------------------------------------------------------ 189 | handleFetch :: User -> GetMessagesRequest -> ApiHandler GetMessagesResponse 190 | handleFetch user _ = do 191 | setTimeout $ defaultTimeout + 10 192 | msgs <- ask >>= liftIO . getMessages defaultTimeout user 193 | return $ GetMessagesOK msgs 194 | 195 | 196 | ------------------------------------------------------------------------------ 197 | handleWrite :: User -> WriteMessageRequest -> ApiHandler WriteMessageResponse 198 | handleWrite user (WriteMessageRequest msg) = do 199 | ask >>= liftIO . writeMessageContents msg user 200 | return WriteMessageResponseOK 201 | 202 | 203 | ------------------------------------------------------------------------------ 204 | defaultTimeout :: Int 205 | defaultTimeout = 50 206 | -------------------------------------------------------------------------------- /src/Snap/Chat/ChatRoom.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE BangPatterns #-} 2 | {-# LANGUAGE DeriveDataTypeable #-} 3 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 4 | {-# LANGUAGE OverloadedStrings #-} 5 | 6 | module Snap.Chat.ChatRoom 7 | ( newChatRoom 8 | , destroyChatRoom 9 | , withChatRoom 10 | , joinUser 11 | , authenticateUser 12 | , lookupUser 13 | , disconnectUser 14 | , getMessages 15 | , writeMessage 16 | , writeMessageContents 17 | 18 | -- * Exceptions 19 | , UserAlreadyConnectedException 20 | , UserNotConnectedException 21 | , UserAuthenticationFailureException 22 | ) where 23 | 24 | 25 | ------------------------------------------------------------------------------ 26 | import Control.Applicative 27 | import Control.Concurrent.MVar 28 | import Control.Concurrent.STM 29 | import Control.Exception 30 | import Control.Monad 31 | import qualified Data.ByteString as S 32 | import qualified Data.ByteString.Base16 as B16 33 | import qualified Data.HashTable.IO as HT 34 | import Data.Maybe 35 | import Data.Text (Text) 36 | import qualified Data.Text as T 37 | import Data.Typeable 38 | import Data.Word (Word8) 39 | import System.PosixCompat.Time 40 | import System.Random.MWC 41 | import System.Timeout 42 | ------------------------------------------------------------------------------ 43 | import qualified Snap.Chat.Message as Msg 44 | import Snap.Chat.Internal.Types 45 | import Snap.Chat.Internal.Util 46 | import qualified System.TimeoutManager as TM 47 | 48 | 49 | ------------------------------------------------------------------------------ 50 | data UserAlreadyConnectedException = UserAlreadyConnectedException UserName 51 | deriving (Typeable) 52 | 53 | instance Show UserAlreadyConnectedException where 54 | show (UserAlreadyConnectedException u) = 55 | concat [ "User \"" 56 | , T.unpack u 57 | , "\" already connected." ] 58 | 59 | instance Exception UserAlreadyConnectedException 60 | 61 | 62 | ------------------------------------------------------------------------------ 63 | data UserNotConnectedException = UserNotConnectedException UserName 64 | deriving (Typeable) 65 | 66 | instance Show UserNotConnectedException where 67 | show (UserNotConnectedException u) = 68 | concat [ "User \"" 69 | , T.unpack u 70 | , "\" not connected." ] 71 | 72 | instance Exception UserNotConnectedException 73 | 74 | 75 | ------------------------------------------------------------------------------ 76 | data UserAuthenticationFailureException = 77 | UserAuthenticationFailureException UserName 78 | deriving (Typeable) 79 | 80 | instance Show UserAuthenticationFailureException where 81 | show (UserAuthenticationFailureException u) = 82 | concat [ "Authentication failed for user \"" 83 | , T.unpack u 84 | , "\"." ] 85 | 86 | instance Exception UserAuthenticationFailureException 87 | 88 | 89 | ------------------------------------------------------------------------------ 90 | newChatRoom :: Int -> IO ChatRoom 91 | newChatRoom userTimeout = 92 | ChatRoom <$> 93 | TM.initialize userTimeout epochTime <*> 94 | (HT.new >>= newMVar) <*> 95 | atomically newTChan <*> 96 | pure userTimeout 97 | 98 | 99 | 100 | ------------------------------------------------------------------------------ 101 | destroyChatRoom :: ChatRoom -> IO () 102 | destroyChatRoom = TM.stop . _timeoutManager 103 | 104 | 105 | ------------------------------------------------------------------------------ 106 | withChatRoom :: Int -> (ChatRoom -> IO a) -> IO a 107 | withChatRoom userTimeout = bracket (newChatRoom userTimeout) destroyChatRoom 108 | 109 | 110 | ------------------------------------------------------------------------------ 111 | -- | Connect a new user to the chat room. Throws UserAlreadyConnectedException 112 | -- if the user was already connected. 113 | joinUser :: Text -> ChatRoom -> IO User 114 | joinUser userName chatRoom = withMVar userMapMVar $ \userMap -> do 115 | HT.lookup userMap userName >>= 116 | maybe (return ()) 117 | (const $ throwIO $ UserAlreadyConnectedException userName) 118 | 119 | user <- User <$> 120 | pure userName <*> 121 | (atomically $ dupTChan chatChannel) <*> 122 | makeUserToken <*> 123 | TM.register (disconnectUser userName 124 | disconnectionMessage 125 | chatRoom) 126 | timeoutManager 127 | 128 | HT.insert userMap userName user 129 | joinMsg <- Msg.join user 130 | writeMessage joinMsg user chatRoom 131 | return user 132 | 133 | where 134 | disconnectionMessage = T.concat [ " has left the channel (timeout). " 135 | ] 136 | 137 | timeoutManager = _timeoutManager chatRoom 138 | userMapMVar = _userMap chatRoom 139 | chatChannel = _chatChannel chatRoom 140 | 141 | 142 | ------------------------------------------------------------------------------ 143 | makeUserToken :: IO UserToken 144 | makeUserToken = withSystemRandom $ \gen -> do 145 | xs <- (replicateM 16 $ uniform gen) :: IO [Word8] 146 | return $ UserToken $ B16.encode $ S.pack xs 147 | 148 | 149 | ------------------------------------------------------------------------------ 150 | disconnectUser :: UserName -> Text -> ChatRoom -> IO () 151 | disconnectUser userName disconnectionReason chatRoom = 152 | withMVar userMapMVar $ \userMap -> 153 | HT.lookup userMap userName >>= maybe (return ()) (destroy userMap) 154 | 155 | where 156 | userMapMVar = _userMap chatRoom 157 | 158 | destroy userMap user = do 159 | leaveMsg <- Msg.leave disconnectionReason user 160 | writeMessage leaveMsg user chatRoom 161 | TM.cancel $ _timeoutHandle user 162 | HT.delete userMap userName 163 | 164 | 165 | ------------------------------------------------------------------------------ 166 | lookupUser :: UserName -> ChatRoom -> IO (Maybe User) 167 | lookupUser userName chatRoom = withMVar userMapMVar $ flip HT.lookup userName 168 | where 169 | userMapMVar = _userMap chatRoom 170 | 171 | 172 | ------------------------------------------------------------------------------ 173 | authenticateUser :: UserName -> UserToken -> ChatRoom -> IO User 174 | authenticateUser userName userToken chatRoom = 175 | withMVar userMapMVar authenticate 176 | where 177 | userMapMVar = _userMap chatRoom 178 | 179 | authenticate userMap = do 180 | mbU <- HT.lookup userMap userName 181 | maybe (throwIO $ UserNotConnectedException userName) 182 | (\user -> 183 | if getUserToken user /= userToken 184 | then throwIO $ UserAuthenticationFailureException userName 185 | else return user) 186 | mbU 187 | 188 | 189 | ------------------------------------------------------------------------------ 190 | -- | Get new messages posted to the channel for the given connected user. If no 191 | -- messages are available, blocks for the given number of seconds, returning an 192 | -- empty list if the timeout expires. 193 | getMessages :: Int -> User -> ChatRoom -> IO [Message] 194 | getMessages timeoutInSeconds (User _ chan _ timeoutHandle) cr = do 195 | TM.tickle timeoutHandle userTimeout 196 | xs <- readAllFromChan timeoutInSeconds chan 197 | TM.tickle timeoutHandle userTimeout 198 | return xs 199 | 200 | where 201 | userTimeout = _userTimeout cr 202 | 203 | 204 | 205 | ------------------------------------------------------------------------------ 206 | -- | Write a message to the channel. 207 | writeMessage :: Message -> User -> ChatRoom -> IO () 208 | writeMessage msg user cr = do 209 | atomically $ writeTChan chan msg 210 | _ <- readAllFromChan 1 chan 211 | TM.tickle timeoutHandle userTimeout 212 | 213 | where 214 | chan = _chatChannel cr 215 | timeoutHandle = _timeoutHandle user 216 | userTimeout = _userTimeout cr 217 | 218 | 219 | ------------------------------------------------------------------------------ 220 | -- | Write a message to the channel. 221 | writeMessageContents :: MessageContents -> User -> ChatRoom -> IO () 222 | writeMessageContents msgContents user cr = do 223 | now <- epochTime 224 | let userName = _userName user 225 | writeMessage (Message userName now msgContents) user cr 226 | 227 | 228 | 229 | ------------------------------------------------------------------------------ 230 | readAllFromChan :: Int -> TChan a -> IO [a] 231 | readAllFromChan secondsToWait chan = do 232 | m <- timeout (seconds secondsToWait) $ atomically readAll 233 | return $ fromMaybe [] m 234 | where 235 | readAll = do 236 | v <- readTChan chan 237 | readRest (v:) 238 | 239 | readRest !dlist = do 240 | done <- isEmptyTChan chan 241 | 242 | if done 243 | then return $! dlist [] 244 | else do 245 | v <- readTChan chan 246 | readRest (dlist . (v:)) 247 | {-# INLINE readAllFromChan #-} 248 | -------------------------------------------------------------------------------- /static/css/chat-small.css: -------------------------------------------------------------------------------- 1 | /*---------------------------------------------------------------------------- 2 | http://meyerweb.com/eric/tools/css/reset/ 3 | v2.0 | 20110126 4 | License: none (public domain) 5 | ----------------------------------------------------------------------------*/ 6 | 7 | html, body, div, span, applet, object, iframe, 8 | h1, h2, h3, h4, h5, h6, p, blockquote, pre, 9 | a, abbr, acronym, address, big, cite, code, 10 | del, dfn, em, img, ins, kbd, q, s, samp, 11 | small, strike, strong, sub, sup, tt, var, 12 | b, u, i, center, 13 | dl, dt, dd, ol, ul, li, 14 | fieldset, form, label, legend, 15 | table, caption, tbody, tfoot, thead, tr, th, td, 16 | article, aside, canvas, details, embed, 17 | figure, figcaption, footer, header, hgroup, 18 | menu, nav, output, ruby, section, summary, 19 | time, mark, audio, video { 20 | margin: 0; 21 | padding: 0; 22 | border: 0; 23 | font-size: 100%; 24 | font: inherit; 25 | vertical-align: baseline; 26 | } 27 | /* HTML5 display-role reset for older browsers */ 28 | article, aside, details, figcaption, figure, 29 | footer, header, hgroup, menu, nav, section { 30 | display: block; 31 | } 32 | body { 33 | line-height: 1; 34 | } 35 | ol, ul { 36 | list-style: none; 37 | } 38 | blockquote, q { 39 | quotes: none; 40 | } 41 | blockquote:before, blockquote:after, 42 | q:before, q:after { 43 | content: ''; 44 | content: none; 45 | } 46 | table { 47 | border-collapse: collapse; 48 | border-spacing: 0; 49 | } 50 | 51 | 52 | /*--------------------------------------------------------------------------*/ 53 | 54 | html { 55 | font-family: sans-serif; 56 | font-size: small; 57 | background: #565; 58 | color: #222; 59 | } 60 | 61 | body { 62 | line-height: 1.4em; 63 | } 64 | 65 | 66 | a:link, a:hover, a:active, a:visited { 67 | color: #33d; 68 | text-decoration: none; 69 | } 70 | 71 | h1 { 72 | font-size: medium; 73 | font-weight: bold; 74 | margin: 0 0 1em 0; 75 | letter-spacing: -0.05em; 76 | } 77 | 78 | .loginwindow h1 { 79 | text-align: center; 80 | vertical-align: middle; 81 | } 82 | 83 | .loginwindow h1 span { vertical-align: middle; } 84 | .loginwindow h1 img { 85 | width: 48px; 86 | height: 41.5px; 87 | vertical-align: middle; 88 | } 89 | 90 | .loginwindow p.error { color: #911; } 91 | 92 | p { 93 | letter-spacing: -0.025em; 94 | margin-bottom: 1.4em; 95 | } 96 | 97 | .loginwindow { 98 | max-width: 70ex; 99 | width: 75%; 100 | height: auto; 101 | margin: 1em auto; 102 | padding: 1em; 103 | -moz-border-radius: 6px; -webkit-border-radius: 6px; border-radius: 6px; 104 | } 105 | 106 | .chatroom { 107 | position: relative; 108 | width: 85%; 109 | max-width: 800px; 110 | min-height: 100%; 111 | top:0; 112 | margin: 0 auto; 113 | text-align: left; 114 | } 115 | 116 | .chatroom .chatroom-buffer { 117 | position: relative; 118 | left: 0; 119 | top: 0; 120 | width: 100%; 121 | min-height: 100%; 122 | /* overflow: hidden;*/ 123 | } 124 | 125 | .chatroom .chatroom-buffer .buffer { 126 | position: relative; 127 | min-height: 100%; 128 | left: 0; top: 0; right: 0; height: auto; 129 | } 130 | 131 | .chatroom .chatroom-buffer .chattext { 132 | padding: 3em 1ex 2.75em 1ex; 133 | } 134 | 135 | .chatroom .chatroom-buffer .buffer p { 136 | margin: 0; padding: 0; 137 | } 138 | 139 | .chatroom p.message { 140 | font-size: small; 141 | background: #eee; 142 | } 143 | 144 | .chatroom p.meta { 145 | font-size: small; 146 | font-style: italic; 147 | background: #eee; 148 | } 149 | 150 | .chatroom p.message .time { 151 | color: #777; 152 | font-size: x-small; 153 | font-family: monospace; 154 | font-style: normal; 155 | padding-right: 1em; 156 | } 157 | 158 | .chatroom p.message .username { 159 | color: #005; 160 | font-weight: bold; 161 | padding-right: 0.5ex; 162 | } 163 | 164 | .chatroom .chatroom-input { 165 | position: fixed; 166 | left: 0; 167 | bottom: 0; 168 | width: 100%; 169 | height: 2.75em; 170 | line-height: 2.75em; 171 | background: #cdc; 172 | } 173 | 174 | .chatroom .chatroom-input form { 175 | position: absolute; 176 | height: 2.75em; 177 | top: 0; 178 | left: 0; 179 | width: 100%; 180 | text-align: center; 181 | vertical-align: middle; 182 | line-height: 2.75em; 183 | } 184 | 185 | .chatroom .chatroom-input table { 186 | width: 100%; 187 | text-align: left; 188 | margin: 0 auto; 189 | } 190 | 191 | .chatroom .chatroom-input form td.inputcell { 192 | padding: 0 1ex; 193 | } 194 | 195 | .chatroom .chatroom-input form td.buttoncell { 196 | padding: 0 1ex 0 0; 197 | } 198 | 199 | .chatroom .chatroom-input form button { 200 | width: 100%; 201 | font-size: x-small !important; 202 | vertical-align: middle; 203 | } 204 | 205 | .chatroom .chatroom-input form input.chatinput { 206 | height: 1.25em; 207 | font-size: small; 208 | width: 98%; 209 | border: solid 1px 9a9; 210 | vertical-align: middle; 211 | } 212 | 213 | input.disabled { 214 | background: #999 !important; 215 | color: #999 !important; 216 | border: 0; 217 | } 218 | 219 | .chatroom .chatroom-top { 220 | text-align: left; 221 | position: fixed; 222 | top: 0; 223 | left: 0; 224 | width: 100%; 225 | height: 3em; 226 | line-height: 3em; 227 | background: #454; 228 | z-index: 5000; 229 | } 230 | 231 | .chatroom .chatroom-top form { 232 | position:absolute; 233 | top:1.5em; 234 | left:2em; 235 | height:2.5em; 236 | margin-top: -1.25em; 237 | vertical-align: middle; 238 | } 239 | 240 | .chatroom .chatroom-top div.top-header { 241 | position: absolute; 242 | color: white; 243 | font-weight: bold; 244 | height: 3em; 245 | width: auto; 246 | top: 0; right: 2em; 247 | vertical-align: middle; 248 | } 249 | 250 | .chatroom .chatroom-top div.top-header span { 251 | font-size: x-small; 252 | vertical-align: middle; 253 | } 254 | 255 | .chatroom .chatroom-top div.top-header img { 256 | width: 19.2px; 257 | height: 16.6px; 258 | vertical-align: middle; 259 | } 260 | 261 | .chatroom .chatroom-top form button { 262 | position:absolute; 263 | font-size: x-small !important; 264 | top:0; left:0; bottom:0; width: 9em; 265 | vertical-align: middle; 266 | } 267 | 268 | #chat-frame { 269 | width: 100%; height: 100%; position: absolute; top:0; left: 0; 270 | text-align: center; 271 | } 272 | 273 | .chatwindow { 274 | background: #eee; 275 | } 276 | 277 | .loginwindow div.form { 278 | border: 2px outset #999; 279 | -moz-border-radius: 6px; -webkit-border-radius: 6px; border-radius: 6px; 280 | width: 90%; 281 | margin: 1.4em auto; 282 | text-align: center; 283 | } 284 | 285 | .loginwindow .form form { 286 | padding: 1.5em; 287 | } 288 | 289 | .loginwindow .form form label { 290 | color: #777; 291 | text-shadow: 1px 1px 0px #fff; 292 | padding-right: 1ex; 293 | } 294 | 295 | .loginwindow .form form input.username { 296 | font-size: medium; 297 | border: solid 1px 9a9; 298 | padding: 4px; 299 | width: 60%; 300 | margin: 1ex auto; 301 | } 302 | 303 | 304 | 305 | /*---------------------------------------------------------------------------- 306 | CSS buttons borrowed from https://github.com/ubuwaits/css3-buttons 307 | 308 | Copyright (c) 2011 Chad Mazzola 309 | 310 | Permission is hereby granted, free of charge, to any person obtaining a copy 311 | of this software and associated documentation files (the "Software"), to deal 312 | in the Software without restriction, including without limitation the rights 313 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 314 | copies of the Software, and to permit persons to whom the Software is 315 | furnished to do so, subject to the following conditions: 316 | 317 | The above copyright notice and this permission notice shall be included in 318 | all copies or substantial portions of the Software. 319 | 320 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 321 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 322 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 323 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 324 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 325 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 326 | SOFTWARE. 327 | ----------------------------------------------------------------------------*/ 328 | 329 | button.cupid-green { 330 | background-color: #7fbf4d; 331 | background-image: -webkit-gradient(linear, left top, left bottom, from(#7fbf4d), to(#63a62f)); 332 | /* Saf4+, Chrome */ 333 | background-image: -webkit-linear-gradient(top, #7fbf4d, #63a62f); 334 | background-image: -moz-linear-gradient(top, #7fbf4d, #63a62f); 335 | background-image: -ms-linear-gradient(top, #7fbf4d, #63a62f); 336 | background-image: -o-linear-gradient(top, #7fbf4d, #63a62f); 337 | background-image: linear-gradient(top, #7fbf4d, #63a62f); 338 | border: 1px solid #63a62f; 339 | border-bottom: 1px solid #5b992b; 340 | -webkit-border-radius: 3px; 341 | -moz-border-radius: 3px; 342 | -ms-border-radius: 3px; 343 | -o-border-radius: 3px; 344 | border-radius: 3px; 345 | -webkit-box-shadow: inset 0 1px 0 0 #96ca6d; 346 | -moz-box-shadow: inset 0 1px 0 0 #96ca6d; 347 | -ms-box-shadow: inset 0 1px 0 0 #96ca6d; 348 | -o-box-shadow: inset 0 1px 0 0 #96ca6d; 349 | box-shadow: inset 0 1px 0 0 #96ca6d; 350 | color: #fff; 351 | /*font-weight: bold;*/ 352 | font-size: small; 353 | line-height: 1; 354 | padding: 7px 15px 8px 15px; 355 | text-align: center; 356 | text-shadow: 0 -1px 0 #4c9021; 357 | width: auto; } 358 | button.cupid-green:hover { 359 | background-color: #76b347; 360 | background-image: -webkit-gradient(linear, left top, left bottom, from(#76b347), to(#5e9e2e)); 361 | /* Saf4+, Chrome */ 362 | background-image: -webkit-linear-gradient(top, #76b347, #5e9e2e); 363 | background-image: -moz-linear-gradient(top, #76b347, #5e9e2e); 364 | background-image: -ms-linear-gradient(top, #76b347, #5e9e2e); 365 | background-image: -o-linear-gradient(top, #76b347, #5e9e2e); 366 | background-image: linear-gradient(top, #76b347, #5e9e2e); 367 | -webkit-box-shadow: inset 0 1px 0 0 #8dbf67; 368 | -moz-box-shadow: inset 0 1px 0 0 #8dbf67; 369 | -ms-box-shadow: inset 0 1px 0 0 #8dbf67; 370 | -o-box-shadow: inset 0 1px 0 0 #8dbf67; 371 | box-shadow: inset 0 1px 0 0 #8dbf67; 372 | cursor: pointer; } 373 | button.cupid-green:active { 374 | border: 1px solid #5b992b; 375 | border-bottom: 1px solid #538c27; 376 | -webkit-box-shadow: inset 0 0 8px 4px #548c29, 0 1px 0 0 #eeeeee; 377 | -moz-box-shadow: inset 0 0 8px 4px #548c29, 0 1px 0 0 #eeeeee; 378 | -ms-box-shadow: inset 0 0 8px 4px #548c29, 0 1px 0 0 #eeeeee; 379 | -o-box-shadow: inset 0 0 8px 4px #548c29, 0 1px 0 0 #eeeeee; 380 | box-shadow: inset 0 0 8px 4px #548c29, 0 1px 0 0 #eeeeee; } 381 | 382 | 383 | button.cupid-disabled { 384 | background-color: #777; 385 | background-image: -webkit-gradient(linear, left top, left bottom, from(#777), to(#666)); 386 | /* Saf4+, Chrome */ 387 | background-image: -webkit-linear-gradient(top, #777, #666); 388 | background-image: -moz-linear-gradient(top, #777, #666); 389 | background-image: -ms-linear-gradient(top, #777, #666); 390 | background-image: -o-linear-gradient(top, #777, #666); 391 | background-image: linear-gradient(top, #777, #666); 392 | border: 1px solid #666; 393 | border-bottom: 1px solid #5b992b; 394 | -webkit-border-radius: 3px; 395 | -moz-border-radius: 3px; 396 | -ms-border-radius: 3px; 397 | -o-border-radius: 3px; 398 | border-radius: 3px; 399 | -webkit-box-shadow: inset 0 1px 0 0 #999; 400 | -moz-box-shadow: inset 0 1px 0 0 #999; 401 | -ms-box-shadow: inset 0 1px 0 0 #999; 402 | -o-box-shadow: inset 0 1px 0 0 #999; 403 | box-shadow: inset 0 1px 0 0 #999; 404 | color: #fff; 405 | /*font-weight: bold;*/ 406 | font-size: small; 407 | line-height: 1; 408 | padding: 7px 15px 8px 15px; 409 | text-align: center; 410 | text-shadow: 0 -1px 0 #4c9021; 411 | width: auto; 412 | cursor: default; 413 | } 414 | -------------------------------------------------------------------------------- /static/css/chat-large.css: -------------------------------------------------------------------------------- 1 | /*---------------------------------------------------------------------------- 2 | http://meyerweb.com/eric/tools/css/reset/ 3 | v2.0 | 20110126 4 | License: none (public domain) 5 | ----------------------------------------------------------------------------*/ 6 | 7 | html, body, div, span, applet, object, iframe, 8 | h1, h2, h3, h4, h5, h6, p, blockquote, pre, 9 | a, abbr, acronym, address, big, cite, code, 10 | del, dfn, em, img, ins, kbd, q, s, samp, 11 | small, strike, strong, sub, sup, tt, var, 12 | b, u, i, center, 13 | dl, dt, dd, ol, ul, li, 14 | fieldset, form, label, legend, 15 | table, caption, tbody, tfoot, thead, tr, th, td, 16 | article, aside, canvas, details, embed, 17 | figure, figcaption, footer, header, hgroup, 18 | menu, nav, output, ruby, section, summary, 19 | time, mark, audio, video { 20 | margin: 0; 21 | padding: 0; 22 | border: 0; 23 | font-size: 100%; 24 | font: inherit; 25 | vertical-align: baseline; 26 | } 27 | /* HTML5 display-role reset for older browsers */ 28 | article, aside, details, figcaption, figure, 29 | footer, header, hgroup, menu, nav, section { 30 | display: block; 31 | } 32 | body { 33 | line-height: 1; 34 | } 35 | ol, ul { 36 | list-style: none; 37 | } 38 | blockquote, q { 39 | quotes: none; 40 | } 41 | blockquote:before, blockquote:after, 42 | q:before, q:after { 43 | content: ''; 44 | content: none; 45 | } 46 | table { 47 | border-collapse: collapse; 48 | border-spacing: 0; 49 | } 50 | 51 | /*--------------------------------------------------------------------------*/ 52 | 53 | html { 54 | font-family: sans-serif; 55 | font-size: x-large; 56 | background: #565; 57 | color: #222; 58 | } 59 | 60 | body { 61 | line-height: 1.4em; 62 | } 63 | 64 | 65 | a:link, a:hover, a:active, a:visited { 66 | color: #33d; 67 | text-decoration: none; 68 | } 69 | 70 | a:hover, a:active { 71 | /* text-decoration: underline;*/ 72 | text-shadow: 1px 1px 0px #fff; /* CSS3 */ 73 | } 74 | 75 | h1 { 76 | font-size: xx-large; 77 | font-weight: bold; 78 | margin: 0 0 1em 0; 79 | letter-spacing: -0.05em; 80 | } 81 | 82 | .loginwindow h1 { 83 | text-align: center; 84 | vertical-align: middle; 85 | } 86 | 87 | .loginwindow h1 span { vertical-align: middle; } 88 | .loginwindow h1 img { 89 | width: 96px; 90 | height: 83px; 91 | vertical-align: middle; 92 | } 93 | 94 | .loginwindow p.error { color: #911; } 95 | 96 | p { 97 | letter-spacing: -0.025em; 98 | margin-bottom: 1.4em; 99 | } 100 | 101 | .loginwindow { 102 | min-width: 400px; 103 | max-width: 70ex; 104 | width: 60%; 105 | height: auto; 106 | margin: 4em auto; 107 | padding: 40px; 108 | -moz-border-radius: 6px; -webkit-border-radius: 6px; border-radius: 6px; 109 | } 110 | 111 | .chatroom { 112 | position: relative; 113 | width: 80%; 114 | min-width: 400px; 115 | height: 100%; 116 | top:0; 117 | margin: 0 auto; 118 | overflow: hidden; 119 | text-align: left; 120 | } 121 | 122 | .chatroom .chatroom-buffer { 123 | position: absolute; 124 | left: 0; 125 | bottom: 2.75em; 126 | top: 2em; 127 | width: 100%; 128 | overflow: hidden; 129 | } 130 | 131 | .chatroom .chatroom-buffer .buffer { 132 | position: absolute; 133 | top: 0; left: 0; bottom: 0; right: 0; 134 | overflow: auto; 135 | } 136 | 137 | .chatroom .chatroom-buffer .chattext { 138 | padding: 0 1ex; 139 | } 140 | 141 | .chatroom .chatroom-buffer .buffer p { 142 | margin: 0; padding: 0; 143 | } 144 | 145 | .chatroom p.message { 146 | font-size: medium; 147 | background: #eee; 148 | } 149 | 150 | .chatroom p.meta { 151 | font-size: medium; 152 | font-style: italic; 153 | background: #eee; 154 | } 155 | 156 | .chatroom p.message .time { 157 | color: #777; 158 | font-size: small; 159 | font-family: monospace; 160 | font-style: normal; 161 | padding-right: 1em; 162 | } 163 | 164 | .chatroom p.message .username { 165 | color: #005; 166 | font-weight: bold; 167 | padding-right: 0.5ex; 168 | } 169 | 170 | .chatroom .chatroom-input { 171 | position: absolute; 172 | left: 0; 173 | bottom: 0; 174 | width: 100%; 175 | height: 2.75em; 176 | line-height: 2.75em; 177 | background: #cdc; 178 | } 179 | 180 | .chatroom .chatroom-input form { 181 | position: absolute; 182 | height: 2.75em; 183 | top: 0; 184 | left: 0; 185 | width: 100%; 186 | text-align: center; 187 | vertical-align: middle; 188 | line-height: 2.75em; 189 | } 190 | 191 | .chatroom .chatroom-input table { 192 | width: 100%; 193 | text-align: left; 194 | margin: 0 auto; 195 | } 196 | 197 | .chatroom .chatroom-input form td.inputcell { 198 | padding: 0 1ex; 199 | } 200 | 201 | .chatroom .chatroom-input form td.buttoncell { 202 | padding: 0 1ex 0 0; 203 | } 204 | 205 | .chatroom .chatroom-input form button { 206 | width: 100%; 207 | vertical-align: middle; 208 | } 209 | 210 | .chatroom .chatroom-input form input.chatinput { 211 | height: 1.25em; 212 | font-size: large; 213 | width: 98%; 214 | border: solid 1px 9a9; 215 | vertical-align: middle; 216 | } 217 | 218 | input.disabled { 219 | background: #999 !important; 220 | color: #999 !important; 221 | border: 0; 222 | } 223 | 224 | .chatroom .chatroom-top { 225 | text-align: left; 226 | position: fixed; 227 | top: 0; 228 | left: 0; 229 | width: 100%; 230 | height: 2em; 231 | line-height: 2em; 232 | background: #454; 233 | z-index: 5000; 234 | } 235 | 236 | .chatroom .chatroom-top form { 237 | position:absolute; 238 | top:1em; 239 | left:2em; 240 | height:1.6em; 241 | margin-top: -0.8em; 242 | vertical-align: middle; 243 | } 244 | 245 | .chatroom .chatroom-top div.top-header { 246 | position: absolute; 247 | color: white; 248 | font-weight: bold; 249 | height: 2.75em; 250 | width: auto; 251 | top: 0; right: 2em; 252 | vertical-align: middle; 253 | } 254 | 255 | .chatroom .chatroom-top div.top-header span { 256 | font-size: small; 257 | vertical-align: middle; 258 | } 259 | 260 | .chatroom .chatroom-top div.top-header img { 261 | width: 32px; 262 | height: 27.66px; 263 | vertical-align: middle; 264 | } 265 | 266 | .chatroom .chatroom-top form button { 267 | position:absolute; 268 | top:0; left:0; bottom:0; width: 13em; 269 | vertical-align: middle; 270 | } 271 | 272 | #chat-frame { 273 | width: 100%; height: 100%; position: absolute; top:0; left: 0; 274 | text-align: center; 275 | } 276 | 277 | .chatwindow { 278 | background: #eee; 279 | -moz-box-shadow: 0 0 10px #111; /* Firefox */ 280 | -webkit-box-shadow: 0 0 10px #111; /* Safari, Chrome */ 281 | box-shadow: 0 0 10px #111; /* CSS3 */ 282 | } 283 | 284 | .loginwindow div.form { 285 | border: 2px outset #999; 286 | -moz-box-shadow: 0 0 2px #333; 287 | -webkit-box-shadow: 0 0 2px #333; 288 | box-shadow: 0 0 2px #333; 289 | -moz-border-radius: 6px; -webkit-border-radius: 6px; border-radius: 6px; 290 | width: 90%; 291 | margin: 1.4em auto; 292 | text-align: center; 293 | } 294 | 295 | .loginwindow .form form { 296 | padding: 1.5em; 297 | } 298 | 299 | .loginwindow .form form label { 300 | color: #777; 301 | text-shadow: 1px 1px 0px #fff; 302 | padding-right: 1ex; 303 | } 304 | 305 | .loginwindow .form form input.username { 306 | font-size: x-large; 307 | border: solid 1px 9a9; 308 | padding: 4px; 309 | width: 60%; 310 | margin: 1ex auto; 311 | } 312 | 313 | 314 | 315 | /*---------------------------------------------------------------------------- 316 | CSS buttons borrowed from https://github.com/ubuwaits/css3-buttons 317 | 318 | Copyright (c) 2011 Chad Mazzola 319 | 320 | Permission is hereby granted, free of charge, to any person obtaining a copy 321 | of this software and associated documentation files (the "Software"), to deal 322 | in the Software without restriction, including without limitation the rights 323 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 324 | copies of the Software, and to permit persons to whom the Software is 325 | furnished to do so, subject to the following conditions: 326 | 327 | The above copyright notice and this permission notice shall be included in 328 | all copies or substantial portions of the Software. 329 | 330 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 331 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 332 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 333 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 334 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 335 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 336 | SOFTWARE. 337 | ----------------------------------------------------------------------------*/ 338 | 339 | button.cupid-green { 340 | background-color: #7fbf4d; 341 | background-image: -webkit-gradient(linear, left top, left bottom, from(#7fbf4d), to(#63a62f)); 342 | /* Saf4+, Chrome */ 343 | background-image: -webkit-linear-gradient(top, #7fbf4d, #63a62f); 344 | background-image: -moz-linear-gradient(top, #7fbf4d, #63a62f); 345 | background-image: -ms-linear-gradient(top, #7fbf4d, #63a62f); 346 | background-image: -o-linear-gradient(top, #7fbf4d, #63a62f); 347 | background-image: linear-gradient(top, #7fbf4d, #63a62f); 348 | border: 1px solid #63a62f; 349 | border-bottom: 1px solid #5b992b; 350 | -webkit-border-radius: 3px; 351 | -moz-border-radius: 3px; 352 | -ms-border-radius: 3px; 353 | -o-border-radius: 3px; 354 | border-radius: 3px; 355 | -webkit-box-shadow: inset 0 1px 0 0 #96ca6d; 356 | -moz-box-shadow: inset 0 1px 0 0 #96ca6d; 357 | -ms-box-shadow: inset 0 1px 0 0 #96ca6d; 358 | -o-box-shadow: inset 0 1px 0 0 #96ca6d; 359 | box-shadow: inset 0 1px 0 0 #96ca6d; 360 | color: #fff; 361 | /*font-weight: bold;*/ 362 | font-size: large; 363 | line-height: 1; 364 | padding: 7px 15px 8px 15px; 365 | text-align: center; 366 | text-shadow: 0 -1px 0 #4c9021; 367 | width: auto; } 368 | button.cupid-green:hover { 369 | background-color: #76b347; 370 | background-image: -webkit-gradient(linear, left top, left bottom, from(#76b347), to(#5e9e2e)); 371 | /* Saf4+, Chrome */ 372 | background-image: -webkit-linear-gradient(top, #76b347, #5e9e2e); 373 | background-image: -moz-linear-gradient(top, #76b347, #5e9e2e); 374 | background-image: -ms-linear-gradient(top, #76b347, #5e9e2e); 375 | background-image: -o-linear-gradient(top, #76b347, #5e9e2e); 376 | background-image: linear-gradient(top, #76b347, #5e9e2e); 377 | -webkit-box-shadow: inset 0 1px 0 0 #8dbf67; 378 | -moz-box-shadow: inset 0 1px 0 0 #8dbf67; 379 | -ms-box-shadow: inset 0 1px 0 0 #8dbf67; 380 | -o-box-shadow: inset 0 1px 0 0 #8dbf67; 381 | box-shadow: inset 0 1px 0 0 #8dbf67; 382 | cursor: pointer; } 383 | button.cupid-green:active { 384 | border: 1px solid #5b992b; 385 | border-bottom: 1px solid #538c27; 386 | -webkit-box-shadow: inset 0 0 8px 4px #548c29, 0 1px 0 0 #eeeeee; 387 | -moz-box-shadow: inset 0 0 8px 4px #548c29, 0 1px 0 0 #eeeeee; 388 | -ms-box-shadow: inset 0 0 8px 4px #548c29, 0 1px 0 0 #eeeeee; 389 | -o-box-shadow: inset 0 0 8px 4px #548c29, 0 1px 0 0 #eeeeee; 390 | box-shadow: inset 0 0 8px 4px #548c29, 0 1px 0 0 #eeeeee; } 391 | 392 | 393 | button.cupid-disabled { 394 | background-color: #777; 395 | background-image: -webkit-gradient(linear, left top, left bottom, from(#777), to(#666)); 396 | /* Saf4+, Chrome */ 397 | background-image: -webkit-linear-gradient(top, #777, #666); 398 | background-image: -moz-linear-gradient(top, #777, #666); 399 | background-image: -ms-linear-gradient(top, #777, #666); 400 | background-image: -o-linear-gradient(top, #777, #666); 401 | background-image: linear-gradient(top, #777, #666); 402 | border: 1px solid #666; 403 | border-bottom: 1px solid #5b992b; 404 | -webkit-border-radius: 3px; 405 | -moz-border-radius: 3px; 406 | -ms-border-radius: 3px; 407 | -o-border-radius: 3px; 408 | border-radius: 3px; 409 | -webkit-box-shadow: inset 0 1px 0 0 #999; 410 | -moz-box-shadow: inset 0 1px 0 0 #999; 411 | -ms-box-shadow: inset 0 1px 0 0 #999; 412 | -o-box-shadow: inset 0 1px 0 0 #999; 413 | box-shadow: inset 0 1px 0 0 #999; 414 | color: #fff; 415 | /*font-weight: bold;*/ 416 | font-size: large; 417 | line-height: 1; 418 | padding: 7px 15px 8px 15px; 419 | text-align: center; 420 | text-shadow: 0 -1px 0 #4c9021; 421 | width: auto; 422 | cursor: default; 423 | } 424 | -------------------------------------------------------------------------------- /static/js/snap-chat.js: -------------------------------------------------------------------------------- 1 | (function( $ ){ 2 | var loginHTML = '
\ 3 |

\ 4 | Welcome to Snap Chat!\ 5 |

\ 6 |

\ 7 | Snap Chat is\ 8 | a tutorial application demonstrating long-polling JSON calls using\ 9 | the Snap Framework. To begin\ 10 | chatting, please enter your desired username.

\ 11 | \ 12 |
\ 13 |
\ 14 | \ 15 | \ 17 | \ 18 |
\ 19 |
\ 20 |
'; 21 | 22 | var chatRoomHTML = '
\ 23 |
\ 24 |
\ 25 | \ 26 |
\ 27 |
\ 28 |
\ 29 |
\ 30 |
\ 31 |
\ 32 |
\ 33 |
\ 34 |
\ 35 |
\ 36 | \ 37 | \ 38 |
\ 39 |
\ 40 |
\ 41 |
'; 42 | 43 | var scrollToBottom = function(dataObj) { 44 | var chatDiv = dataObj['chatDiv']; 45 | var $buffer = $('.buffer', chatDiv); 46 | var ov = $buffer.css('overflow'); 47 | if (ov == 'auto') { 48 | /* we're on a normal computer */ 49 | $b = $buffer; 50 | threshold = 10; 51 | oh = $buffer.outerHeight(); 52 | } else { 53 | /* we're on a handheld here. */ 54 | $b = $('body'); 55 | threshold = 30; 56 | oh = $(window).height(); 57 | } 58 | 59 | $b.scrollTop($b.prop('scrollHeight') - oh); 60 | } 61 | 62 | var addMessageToBuffer = function(dataObj, message) { 63 | var chatDiv = dataObj['chatDiv']; 64 | var $buffer = $('.buffer', chatDiv); 65 | /* Are we at the bottom already? */ 66 | var atBottom = false; 67 | var ov = $buffer.css('overflow'); 68 | var $b, threshold, oh; 69 | 70 | if (ov == 'auto') { 71 | /* we're on a normal computer */ 72 | $b = $buffer; 73 | threshold = 10; 74 | oh = $buffer.outerHeight(); 75 | } else { 76 | /* we're on a handheld here. */ 77 | $b = $('body'); 78 | threshold = 30; 79 | oh = $(window).height(); 80 | } 81 | 82 | 83 | if ($b.prop('scrollTop') + oh >= 84 | $b.prop('scrollHeight') - threshold) { 85 | atBottom = true; 86 | } 87 | 88 | var $text = $('.chattext', chatDiv); 89 | $text.append(message); 90 | 91 | if (atBottom) { 92 | setTimeout(function() { 93 | scrollToBottom(dataObj); 94 | }, 1); 95 | } 96 | 97 | $(message).effect("highlight", {}, 3000); 98 | dataObj.numMessages = dataObj.numMessages + 1; 99 | 100 | // limit browser memory usage. 101 | if (dataObj.numMessages > 200) { 102 | $('.message:first-child').remove(); 103 | } 104 | } 105 | 106 | var withZero = function(t) { 107 | /* javascript, y u no have sprintf()? */ 108 | if (t >= 0 && t < 10) { 109 | return '0' + t.toString(); 110 | } else { 111 | return t.toString(); 112 | } 113 | } 114 | 115 | var fmtTime = function(posixtime) { 116 | var dt = new Date(parseInt(posixtime) * 1000); 117 | var y = dt.getFullYear(); 118 | var mo = withZero(dt.getMonth()); 119 | var d = withZero(dt.getDate()); 120 | var h = withZero(dt.getHours()); 121 | var m = withZero(dt.getMinutes()); 122 | var s = withZero(dt.getSeconds()); 123 | 124 | return ('[' + y + '/' + mo + '/' + d + ' ' + h + ':' + m + ':' + s 125 | + ']'); 126 | } 127 | 128 | var cleanupOutstandingRequests = function(dataObj) { 129 | dataObj['suppress_error'] = true; 130 | 131 | if (dataObj['fetcher']) { 132 | dataObj['fetcher'].abort(); 133 | } 134 | } 135 | 136 | var mkMsg = function(posixtime, user, message, extraClass) { 137 | var cls = "message"; 138 | if (extraClass) { cls = cls + " " + extraClass; } 139 | var p = $('

'); 140 | var t = $(''); 141 | var u = $(''); 142 | var m = $(''); 143 | $(t).text(fmtTime(posixtime)); 144 | $(u).text(user); 145 | $(m).text(message); 146 | $(p).append(t).append(u).append(m); 147 | return p; 148 | } 149 | 150 | var gotMessage = function(dataObj, msg) { 151 | var msgs = msg.messages; 152 | for (var i in msgs) { 153 | var src = msgs[i]; 154 | var type = src.contents.type; 155 | var msg; 156 | if (type == 'join') { 157 | msg = mkMsg(src.time, src.user, "has joined the channel.", 158 | 'meta'); 159 | } else if (type == 'leave') { 160 | msg = mkMsg(src.time, src.user, src.contents.text, 'meta'); 161 | } else if (type == 'talk') { 162 | msg = mkMsg(src.time, '<' + src.user + '>', src.contents.text); 163 | } else { 164 | msg = mkMsg(src.time, src.user, src.contents.text); 165 | } 166 | 167 | addMessageToBuffer(dataObj, msg); 168 | } 169 | 170 | fetchMessages(dataObj); 171 | return this; 172 | } 173 | 174 | var fetchError = function(dataObj, obj, reason) { 175 | if (dataObj.suppress_error) return; 176 | var now = (new Date()).valueOf() / 1000; 177 | var msg = mkMsg(now, '', 178 | 'You have been disconnected from the channel. ' + 179 | 'Please leave the channel and log on again.', 'meta'); 180 | var msg2 = mkMsg(now, '', 'Error message: ' + reason, 'meta'); 181 | addMessageToBuffer(dataObj, msg); 182 | addMessageToBuffer(dataObj, msg2); 183 | $('.chatinput', dataObj['chatDiv']).prop('disabled', true). 184 | addClass('disabled'); 185 | $('.write_message', dataObj['chatDiv']).prop( 186 | 'disabled', true).removeClass().addClass('cupid-disabled'); 187 | $(dataObj['chatDiv']).focus(); 188 | } 189 | 190 | var sendMessage = function(dataObj) { 191 | var chatDiv = dataObj['chatDiv']; 192 | var messageText = $('.chatinput', chatDiv).val(); 193 | messageText = messageText.replace(/^\s+/, '').replace(/\s+$/, ''); 194 | if (messageText == '') return; 195 | 196 | $('.chatinput', chatDiv).val('').focus(); 197 | 198 | var now = (new Date()).valueOf() / 1000; 199 | var msg; 200 | if (messageText.match(/^\/me /)) { 201 | messageText = messageText.replace(/^\/me /, ''); 202 | msg = { 'type': 'action', 203 | 'text': messageText }; 204 | } else { 205 | msg = { 'type': 'talk', 206 | 'text': messageText }; 207 | } 208 | 209 | scrollToBottom(dataObj); 210 | 211 | ajaxCall('/api/write', 212 | dataObj, 213 | msg, 214 | function(data) {}, 215 | function(data, msg) { 216 | fetchError(dataObj, data, reason); 217 | cleanupOutstandingRequests(dataObj); 218 | }); 219 | } 220 | 221 | var ajaxCall = function(url, dataObj, json, success, failure, 222 | skipApiWrap) { 223 | var sess = ''; 224 | if (dataObj.session != '') sess = dataObj.session; 225 | var req; 226 | if (skipApiWrap) { 227 | req = JSON.stringify(json); 228 | } else { 229 | req = JSON.stringify({ session: sess, 230 | requestData: json }); 231 | } 232 | 233 | var wrapSuccess = function(data, textStatus, jqXHR) { 234 | if (data.status != 'ok') { 235 | failure(data, data.reason); 236 | } else { 237 | dataObj['session'] = data.session; 238 | success(data.response); 239 | } 240 | }; 241 | 242 | var wrapFailure = function(jqXHR, textStatus, errorThrown) { 243 | var obj = { status: 'failure', 244 | statusCode: 'textStatus', 245 | reason: errorThrown }; 246 | failure(obj, obj.reason); 247 | } 248 | 249 | return $.ajax({ 250 | url: url, 251 | data: req, 252 | success: wrapSuccess, 253 | error: wrapFailure, 254 | type: 'POST', 255 | cache: false, 256 | contentType: 'application/json', 257 | dataType: 'json', 258 | processData: false, 259 | timeout: 120 * 1000 260 | }); 261 | } 262 | 263 | var handleLogin = function(dataObj) { 264 | var loginDiv = dataObj['loginDiv']; 265 | var userName = $('.username', loginDiv).val(); 266 | userName = userName.replace(/^\s+/, '').replace(/\s+$/, ''); 267 | dataObj['desiredUserName'] = userName; 268 | var $errorDiv = $('.error', loginDiv); 269 | var $helloDiv = $('.hello', loginDiv); 270 | 271 | var showError = function (msg) { 272 | $helloDiv.hide(); 273 | $errorDiv.text(msg); 274 | $errorDiv.show('fade', 250).delay( 275 | 5000).hide('fade', function() { 276 | $helloDiv.show(); 277 | }); 278 | } 279 | 280 | if (userName == '') { 281 | showError("Error: username must not be empty."); 282 | return; 283 | } 284 | 285 | ajaxCall('/api/join', 286 | dataObj, 287 | { desiredUserName: userName }, 288 | function(data) { setupChatRoom(dataObj); }, 289 | function(data, msg) { showError(msg); }, 290 | true); 291 | } 292 | 293 | var setupChatRoom = function(dataObj) { 294 | var loginDiv = dataObj['loginDiv']; 295 | var chatDiv = dataObj['chatDiv']; 296 | $(loginDiv).hide('fade', {}, 300, function() { 297 | $(chatDiv).show('fade', {}, 300); 298 | }); 299 | var $buf = $('.chattext', chatDiv); 300 | var $button = $('.write_message', chatDiv); 301 | var $input = $('.chatinput', chatDiv); 302 | 303 | $('.top-message',chatDiv).text( 304 | dataObj['desiredUserName'] + '@snap-chat'); 305 | 306 | $button.click(function () { 307 | sendMessage(dataObj); 308 | }); 309 | 310 | $input.keypress(function(e) { 311 | if (e.which == 13) { 312 | sendMessage(dataObj); 313 | e.preventDefault(); 314 | } 315 | }); 316 | 317 | // $input.focusin(function() { 318 | // scrollToBottom(dataObj); 319 | // }); 320 | 321 | $input.bind('touchmove',function(e){ 322 | e.preventDefault(); 323 | }); 324 | 325 | setTimeout(function() { $input.focus(); }, 500); 326 | fetchMessages(dataObj); 327 | return this; 328 | } 329 | 330 | var fetchMessages = function(dataObj) { 331 | dataObj['fetcher'] = ajaxCall( 332 | "/api/fetch", dataObj, {}, 333 | function(data) { gotMessage(dataObj, data); }, 334 | function(data, reason) { fetchError(dataObj, data, reason); } 335 | ); 336 | } 337 | 338 | var handleLogout = function(dataObj) { 339 | cleanupOutstandingRequests(dataObj); 340 | var loginDiv = dataObj['loginDiv']; 341 | var chatDiv = dataObj['chatDiv']; 342 | ajaxCall( 343 | '/api/leave', 344 | dataObj, 345 | {}, 346 | function(data) {}, 347 | function(data) {}); 348 | 349 | $(chatDiv).hide('fade', {}, 300, function() { 350 | initialize(dataObj.target); 351 | }); 352 | } 353 | 354 | var initialize = function(obj) { 355 | obj.html(''); 356 | var _loginDiv = $(loginHTML); 357 | obj.hide(); 358 | obj.append(_loginDiv); 359 | var _chatDiv = $(chatRoomHTML); 360 | _chatDiv.hide(); 361 | obj.append(_chatDiv); 362 | obj.show("fade", {}, 200); 363 | 364 | var dataObj = { loginDiv: _loginDiv, 365 | chatDiv: _chatDiv, 366 | target: obj, 367 | session: '', 368 | numMessages: 0 369 | }; 370 | 371 | setTimeout(function() { 372 | var $u = $('.username', _loginDiv); 373 | $u.focus().effect("highlight", 2000); 374 | }, 500); 375 | 376 | $('.username', _loginDiv).keypress(function(e) { 377 | if (e.which == 13) { 378 | handleLogin(dataObj); 379 | e.preventDefault(); 380 | } 381 | }); 382 | 383 | $(':button', _loginDiv).click(function() { handleLogin(dataObj) }); 384 | $('.logoutButton', _chatDiv).click(function() { handleLogout(dataObj) }); 385 | 386 | return(dataObj); 387 | } 388 | 389 | $.fn.snapChat = function() { 390 | var dataObj = initialize(this); 391 | var $this = $(this); 392 | this.data($this, 'snap_chat', dataObj); 393 | return this; 394 | }; 395 | 396 | })( jQuery ); 397 | -------------------------------------------------------------------------------- /static/js/json2.js: -------------------------------------------------------------------------------- 1 | /* 2 | http://www.JSON.org/json2.js 3 | 2011-02-23 4 | 5 | Public Domain. 6 | 7 | NO WARRANTY EXPRESSED OR IMPLIED. USE AT YOUR OWN RISK. 8 | 9 | See http://www.JSON.org/js.html 10 | 11 | 12 | This code should be minified before deployment. 13 | See http://javascript.crockford.com/jsmin.html 14 | 15 | USE YOUR OWN COPY. IT IS EXTREMELY UNWISE TO LOAD CODE FROM SERVERS YOU DO 16 | NOT CONTROL. 17 | 18 | 19 | This file creates a global JSON object containing two methods: stringify 20 | and parse. 21 | 22 | JSON.stringify(value, replacer, space) 23 | value any JavaScript value, usually an object or array. 24 | 25 | replacer an optional parameter that determines how object 26 | values are stringified for objects. It can be a 27 | function or an array of strings. 28 | 29 | space an optional parameter that specifies the indentation 30 | of nested structures. If it is omitted, the text will 31 | be packed without extra whitespace. If it is a number, 32 | it will specify the number of spaces to indent at each 33 | level. If it is a string (such as '\t' or ' '), 34 | it contains the characters used to indent at each level. 35 | 36 | This method produces a JSON text from a JavaScript value. 37 | 38 | When an object value is found, if the object contains a toJSON 39 | method, its toJSON method will be called and the result will be 40 | stringified. A toJSON method does not serialize: it returns the 41 | value represented by the name/value pair that should be serialized, 42 | or undefined if nothing should be serialized. The toJSON method 43 | will be passed the key associated with the value, and this will be 44 | bound to the value 45 | 46 | For example, this would serialize Dates as ISO strings. 47 | 48 | Date.prototype.toJSON = function (key) { 49 | function f(n) { 50 | // Format integers to have at least two digits. 51 | return n < 10 ? '0' + n : n; 52 | } 53 | 54 | return this.getUTCFullYear() + '-' + 55 | f(this.getUTCMonth() + 1) + '-' + 56 | f(this.getUTCDate()) + 'T' + 57 | f(this.getUTCHours()) + ':' + 58 | f(this.getUTCMinutes()) + ':' + 59 | f(this.getUTCSeconds()) + 'Z'; 60 | }; 61 | 62 | You can provide an optional replacer method. It will be passed the 63 | key and value of each member, with this bound to the containing 64 | object. The value that is returned from your method will be 65 | serialized. If your method returns undefined, then the member will 66 | be excluded from the serialization. 67 | 68 | If the replacer parameter is an array of strings, then it will be 69 | used to select the members to be serialized. It filters the results 70 | such that only members with keys listed in the replacer array are 71 | stringified. 72 | 73 | Values that do not have JSON representations, such as undefined or 74 | functions, will not be serialized. Such values in objects will be 75 | dropped; in arrays they will be replaced with null. You can use 76 | a replacer function to replace those with JSON values. 77 | JSON.stringify(undefined) returns undefined. 78 | 79 | The optional space parameter produces a stringification of the 80 | value that is filled with line breaks and indentation to make it 81 | easier to read. 82 | 83 | If the space parameter is a non-empty string, then that string will 84 | be used for indentation. If the space parameter is a number, then 85 | the indentation will be that many spaces. 86 | 87 | Example: 88 | 89 | text = JSON.stringify(['e', {pluribus: 'unum'}]); 90 | // text is '["e",{"pluribus":"unum"}]' 91 | 92 | 93 | text = JSON.stringify(['e', {pluribus: 'unum'}], null, '\t'); 94 | // text is '[\n\t"e",\n\t{\n\t\t"pluribus": "unum"\n\t}\n]' 95 | 96 | text = JSON.stringify([new Date()], function (key, value) { 97 | return this[key] instanceof Date ? 98 | 'Date(' + this[key] + ')' : value; 99 | }); 100 | // text is '["Date(---current time---)"]' 101 | 102 | 103 | JSON.parse(text, reviver) 104 | This method parses a JSON text to produce an object or array. 105 | It can throw a SyntaxError exception. 106 | 107 | The optional reviver parameter is a function that can filter and 108 | transform the results. It receives each of the keys and values, 109 | and its return value is used instead of the original value. 110 | If it returns what it received, then the structure is not modified. 111 | If it returns undefined then the member is deleted. 112 | 113 | Example: 114 | 115 | // Parse the text. Values that look like ISO date strings will 116 | // be converted to Date objects. 117 | 118 | myData = JSON.parse(text, function (key, value) { 119 | var a; 120 | if (typeof value === 'string') { 121 | a = 122 | /^(\d{4})-(\d{2})-(\d{2})T(\d{2}):(\d{2}):(\d{2}(?:\.\d*)?)Z$/.exec(value); 123 | if (a) { 124 | return new Date(Date.UTC(+a[1], +a[2] - 1, +a[3], +a[4], 125 | +a[5], +a[6])); 126 | } 127 | } 128 | return value; 129 | }); 130 | 131 | myData = JSON.parse('["Date(09/09/2001)"]', function (key, value) { 132 | var d; 133 | if (typeof value === 'string' && 134 | value.slice(0, 5) === 'Date(' && 135 | value.slice(-1) === ')') { 136 | d = new Date(value.slice(5, -1)); 137 | if (d) { 138 | return d; 139 | } 140 | } 141 | return value; 142 | }); 143 | 144 | 145 | This is a reference implementation. You are free to copy, modify, or 146 | redistribute. 147 | */ 148 | 149 | /*jslint evil: true, strict: false, regexp: false */ 150 | 151 | /*members "", "\b", "\t", "\n", "\f", "\r", "\"", JSON, "\\", apply, 152 | call, charCodeAt, getUTCDate, getUTCFullYear, getUTCHours, 153 | getUTCMinutes, getUTCMonth, getUTCSeconds, hasOwnProperty, join, 154 | lastIndex, length, parse, prototype, push, replace, slice, stringify, 155 | test, toJSON, toString, valueOf 156 | */ 157 | 158 | 159 | // Create a JSON object only if one does not already exist. We create the 160 | // methods in a closure to avoid creating global variables. 161 | 162 | var JSON; 163 | if (!JSON) { 164 | JSON = {}; 165 | } 166 | 167 | (function () { 168 | "use strict"; 169 | 170 | function f(n) { 171 | // Format integers to have at least two digits. 172 | return n < 10 ? '0' + n : n; 173 | } 174 | 175 | if (typeof Date.prototype.toJSON !== 'function') { 176 | 177 | Date.prototype.toJSON = function (key) { 178 | 179 | return isFinite(this.valueOf()) ? 180 | this.getUTCFullYear() + '-' + 181 | f(this.getUTCMonth() + 1) + '-' + 182 | f(this.getUTCDate()) + 'T' + 183 | f(this.getUTCHours()) + ':' + 184 | f(this.getUTCMinutes()) + ':' + 185 | f(this.getUTCSeconds()) + 'Z' : null; 186 | }; 187 | 188 | String.prototype.toJSON = 189 | Number.prototype.toJSON = 190 | Boolean.prototype.toJSON = function (key) { 191 | return this.valueOf(); 192 | }; 193 | } 194 | 195 | var cx = /[\u0000\u00ad\u0600-\u0604\u070f\u17b4\u17b5\u200c-\u200f\u2028-\u202f\u2060-\u206f\ufeff\ufff0-\uffff]/g, 196 | escapable = /[\\\"\x00-\x1f\x7f-\x9f\u00ad\u0600-\u0604\u070f\u17b4\u17b5\u200c-\u200f\u2028-\u202f\u2060-\u206f\ufeff\ufff0-\uffff]/g, 197 | gap, 198 | indent, 199 | meta = { // table of character substitutions 200 | '\b': '\\b', 201 | '\t': '\\t', 202 | '\n': '\\n', 203 | '\f': '\\f', 204 | '\r': '\\r', 205 | '"' : '\\"', 206 | '\\': '\\\\' 207 | }, 208 | rep; 209 | 210 | 211 | function quote(string) { 212 | 213 | // If the string contains no control characters, no quote characters, and no 214 | // backslash characters, then we can safely slap some quotes around it. 215 | // Otherwise we must also replace the offending characters with safe escape 216 | // sequences. 217 | 218 | escapable.lastIndex = 0; 219 | return escapable.test(string) ? '"' + string.replace(escapable, function (a) { 220 | var c = meta[a]; 221 | return typeof c === 'string' ? c : 222 | '\\u' + ('0000' + a.charCodeAt(0).toString(16)).slice(-4); 223 | }) + '"' : '"' + string + '"'; 224 | } 225 | 226 | 227 | function str(key, holder) { 228 | 229 | // Produce a string from holder[key]. 230 | 231 | var i, // The loop counter. 232 | k, // The member key. 233 | v, // The member value. 234 | length, 235 | mind = gap, 236 | partial, 237 | value = holder[key]; 238 | 239 | // If the value has a toJSON method, call it to obtain a replacement value. 240 | 241 | if (value && typeof value === 'object' && 242 | typeof value.toJSON === 'function') { 243 | value = value.toJSON(key); 244 | } 245 | 246 | // If we were called with a replacer function, then call the replacer to 247 | // obtain a replacement value. 248 | 249 | if (typeof rep === 'function') { 250 | value = rep.call(holder, key, value); 251 | } 252 | 253 | // What happens next depends on the value's type. 254 | 255 | switch (typeof value) { 256 | case 'string': 257 | return quote(value); 258 | 259 | case 'number': 260 | 261 | // JSON numbers must be finite. Encode non-finite numbers as null. 262 | 263 | return isFinite(value) ? String(value) : 'null'; 264 | 265 | case 'boolean': 266 | case 'null': 267 | 268 | // If the value is a boolean or null, convert it to a string. Note: 269 | // typeof null does not produce 'null'. The case is included here in 270 | // the remote chance that this gets fixed someday. 271 | 272 | return String(value); 273 | 274 | // If the type is 'object', we might be dealing with an object or an array or 275 | // null. 276 | 277 | case 'object': 278 | 279 | // Due to a specification blunder in ECMAScript, typeof null is 'object', 280 | // so watch out for that case. 281 | 282 | if (!value) { 283 | return 'null'; 284 | } 285 | 286 | // Make an array to hold the partial results of stringifying this object value. 287 | 288 | gap += indent; 289 | partial = []; 290 | 291 | // Is the value an array? 292 | 293 | if (Object.prototype.toString.apply(value) === '[object Array]') { 294 | 295 | // The value is an array. Stringify every element. Use null as a placeholder 296 | // for non-JSON values. 297 | 298 | length = value.length; 299 | for (i = 0; i < length; i += 1) { 300 | partial[i] = str(i, value) || 'null'; 301 | } 302 | 303 | // Join all of the elements together, separated with commas, and wrap them in 304 | // brackets. 305 | 306 | v = partial.length === 0 ? '[]' : gap ? 307 | '[\n' + gap + partial.join(',\n' + gap) + '\n' + mind + ']' : 308 | '[' + partial.join(',') + ']'; 309 | gap = mind; 310 | return v; 311 | } 312 | 313 | // If the replacer is an array, use it to select the members to be stringified. 314 | 315 | if (rep && typeof rep === 'object') { 316 | length = rep.length; 317 | for (i = 0; i < length; i += 1) { 318 | if (typeof rep[i] === 'string') { 319 | k = rep[i]; 320 | v = str(k, value); 321 | if (v) { 322 | partial.push(quote(k) + (gap ? ': ' : ':') + v); 323 | } 324 | } 325 | } 326 | } else { 327 | 328 | // Otherwise, iterate through all of the keys in the object. 329 | 330 | for (k in value) { 331 | if (Object.prototype.hasOwnProperty.call(value, k)) { 332 | v = str(k, value); 333 | if (v) { 334 | partial.push(quote(k) + (gap ? ': ' : ':') + v); 335 | } 336 | } 337 | } 338 | } 339 | 340 | // Join all of the member texts together, separated with commas, 341 | // and wrap them in braces. 342 | 343 | v = partial.length === 0 ? '{}' : gap ? 344 | '{\n' + gap + partial.join(',\n' + gap) + '\n' + mind + '}' : 345 | '{' + partial.join(',') + '}'; 346 | gap = mind; 347 | return v; 348 | } 349 | } 350 | 351 | // If the JSON object does not yet have a stringify method, give it one. 352 | 353 | if (typeof JSON.stringify !== 'function') { 354 | JSON.stringify = function (value, replacer, space) { 355 | 356 | // The stringify method takes a value and an optional replacer, and an optional 357 | // space parameter, and returns a JSON text. The replacer can be a function 358 | // that can replace values, or an array of strings that will select the keys. 359 | // A default replacer method can be provided. Use of the space parameter can 360 | // produce text that is more easily readable. 361 | 362 | var i; 363 | gap = ''; 364 | indent = ''; 365 | 366 | // If the space parameter is a number, make an indent string containing that 367 | // many spaces. 368 | 369 | if (typeof space === 'number') { 370 | for (i = 0; i < space; i += 1) { 371 | indent += ' '; 372 | } 373 | 374 | // If the space parameter is a string, it will be used as the indent string. 375 | 376 | } else if (typeof space === 'string') { 377 | indent = space; 378 | } 379 | 380 | // If there is a replacer, it must be a function or an array. 381 | // Otherwise, throw an error. 382 | 383 | rep = replacer; 384 | if (replacer && typeof replacer !== 'function' && 385 | (typeof replacer !== 'object' || 386 | typeof replacer.length !== 'number')) { 387 | throw new Error('JSON.stringify'); 388 | } 389 | 390 | // Make a fake root object containing our value under the key of ''. 391 | // Return the result of stringifying the value. 392 | 393 | return str('', {'': value}); 394 | }; 395 | } 396 | 397 | 398 | // If the JSON object does not yet have a parse method, give it one. 399 | 400 | if (typeof JSON.parse !== 'function') { 401 | JSON.parse = function (text, reviver) { 402 | 403 | // The parse method takes a text and an optional reviver function, and returns 404 | // a JavaScript value if the text is a valid JSON text. 405 | 406 | var j; 407 | 408 | function walk(holder, key) { 409 | 410 | // The walk method is used to recursively walk the resulting structure so 411 | // that modifications can be made. 412 | 413 | var k, v, value = holder[key]; 414 | if (value && typeof value === 'object') { 415 | for (k in value) { 416 | if (Object.prototype.hasOwnProperty.call(value, k)) { 417 | v = walk(value, k); 418 | if (v !== undefined) { 419 | value[k] = v; 420 | } else { 421 | delete value[k]; 422 | } 423 | } 424 | } 425 | } 426 | return reviver.call(holder, key, value); 427 | } 428 | 429 | 430 | // Parsing happens in four stages. In the first stage, we replace certain 431 | // Unicode characters with escape sequences. JavaScript handles many characters 432 | // incorrectly, either silently deleting them, or treating them as line endings. 433 | 434 | text = String(text); 435 | cx.lastIndex = 0; 436 | if (cx.test(text)) { 437 | text = text.replace(cx, function (a) { 438 | return '\\u' + 439 | ('0000' + a.charCodeAt(0).toString(16)).slice(-4); 440 | }); 441 | } 442 | 443 | // In the second stage, we run the text against regular expressions that look 444 | // for non-JSON patterns. We are especially concerned with '()' and 'new' 445 | // because they can cause invocation, and '=' because it can cause mutation. 446 | // But just to be safe, we want to reject all unexpected forms. 447 | 448 | // We split the second stage into 4 regexp operations in order to work around 449 | // crippling inefficiencies in IE's and Safari's regexp engines. First we 450 | // replace the JSON backslash pairs with '@' (a non-JSON character). Second, we 451 | // replace all simple value tokens with ']' characters. Third, we delete all 452 | // open brackets that follow a colon or comma or that begin the text. Finally, 453 | // we look to see that the remaining characters are only whitespace or ']' or 454 | // ',' or ':' or '{' or '}'. If that is so, then the text is safe for eval. 455 | 456 | if (/^[\],:{}\s]*$/ 457 | .test(text.replace(/\\(?:["\\\/bfnrt]|u[0-9a-fA-F]{4})/g, '@') 458 | .replace(/"[^"\\\n\r]*"|true|false|null|-?\d+(?:\.\d*)?(?:[eE][+\-]?\d+)?/g, ']') 459 | .replace(/(?:^|:|,)(?:\s*\[)+/g, ''))) { 460 | 461 | // In the third stage we use the eval function to compile the text into a 462 | // JavaScript structure. The '{' operator is subject to a syntactic ambiguity 463 | // in JavaScript: it can begin a block or an object literal. We wrap the text 464 | // in parens to eliminate the ambiguity. 465 | 466 | j = eval('(' + text + ')'); 467 | 468 | // In the optional fourth stage, we recursively walk the new structure, passing 469 | // each name/value pair to a reviver function for possible transformation. 470 | 471 | return typeof reviver === 'function' ? 472 | walk({'': j}, '') : j; 473 | } 474 | 475 | // If the text is not JSON parseable, then a SyntaxError is thrown. 476 | 477 | throw new SyntaxError('JSON.parse'); 478 | }; 479 | } 480 | }()); 481 | -------------------------------------------------------------------------------- /static/js/jquery-ui-1.8.16.custom.min.js: -------------------------------------------------------------------------------- 1 | /* 2 | * jQuery UI Effects 1.8.16 3 | * 4 | * Copyright 2011, AUTHORS.txt (http://jqueryui.com/about) 5 | * Dual licensed under the MIT or GPL Version 2 licenses. 6 | * http://jquery.org/license 7 | * 8 | * http://docs.jquery.com/UI/Effects/ 9 | */ 10 | jQuery.effects||function(f,j){function m(c){var a;if(c&&c.constructor==Array&&c.length==3)return c;if(a=/rgb\(\s*([0-9]{1,3})\s*,\s*([0-9]{1,3})\s*,\s*([0-9]{1,3})\s*\)/.exec(c))return[parseInt(a[1],10),parseInt(a[2],10),parseInt(a[3],10)];if(a=/rgb\(\s*([0-9]+(?:\.[0-9]+)?)\%\s*,\s*([0-9]+(?:\.[0-9]+)?)\%\s*,\s*([0-9]+(?:\.[0-9]+)?)\%\s*\)/.exec(c))return[parseFloat(a[1])*2.55,parseFloat(a[2])*2.55,parseFloat(a[3])*2.55];if(a=/#([a-fA-F0-9]{2})([a-fA-F0-9]{2})([a-fA-F0-9]{2})/.exec(c))return[parseInt(a[1], 11 | 16),parseInt(a[2],16),parseInt(a[3],16)];if(a=/#([a-fA-F0-9])([a-fA-F0-9])([a-fA-F0-9])/.exec(c))return[parseInt(a[1]+a[1],16),parseInt(a[2]+a[2],16),parseInt(a[3]+a[3],16)];if(/rgba\(0, 0, 0, 0\)/.exec(c))return n.transparent;return n[f.trim(c).toLowerCase()]}function s(c,a){var b;do{b=f.curCSS(c,a);if(b!=""&&b!="transparent"||f.nodeName(c,"body"))break;a="backgroundColor"}while(c=c.parentNode);return m(b)}function o(){var c=document.defaultView?document.defaultView.getComputedStyle(this,null):this.currentStyle, 12 | a={},b,d;if(c&&c.length&&c[0]&&c[c[0]])for(var e=c.length;e--;){b=c[e];if(typeof c[b]=="string"){d=b.replace(/\-(\w)/g,function(g,h){return h.toUpperCase()});a[d]=c[b]}}else for(b in c)if(typeof c[b]==="string")a[b]=c[b];return a}function p(c){var a,b;for(a in c){b=c[a];if(b==null||f.isFunction(b)||a in t||/scrollbar/.test(a)||!/color/i.test(a)&&isNaN(parseFloat(b)))delete c[a]}return c}function u(c,a){var b={_:0},d;for(d in a)if(c[d]!=a[d])b[d]=a[d];return b}function k(c,a,b,d){if(typeof c=="object"){d= 13 | a;b=null;a=c;c=a.effect}if(f.isFunction(a)){d=a;b=null;a={}}if(typeof a=="number"||f.fx.speeds[a]){d=b;b=a;a={}}if(f.isFunction(b)){d=b;b=null}a=a||{};b=b||a.duration;b=f.fx.off?0:typeof b=="number"?b:b in f.fx.speeds?f.fx.speeds[b]:f.fx.speeds._default;d=d||a.complete;return[c,a,b,d]}function l(c){if(!c||typeof c==="number"||f.fx.speeds[c])return true;if(typeof c==="string"&&!f.effects[c])return true;return false}f.effects={};f.each(["backgroundColor","borderBottomColor","borderLeftColor","borderRightColor", 14 | "borderTopColor","borderColor","color","outlineColor"],function(c,a){f.fx.step[a]=function(b){if(!b.colorInit){b.start=s(b.elem,a);b.end=m(b.end);b.colorInit=true}b.elem.style[a]="rgb("+Math.max(Math.min(parseInt(b.pos*(b.end[0]-b.start[0])+b.start[0],10),255),0)+","+Math.max(Math.min(parseInt(b.pos*(b.end[1]-b.start[1])+b.start[1],10),255),0)+","+Math.max(Math.min(parseInt(b.pos*(b.end[2]-b.start[2])+b.start[2],10),255),0)+")"}});var n={aqua:[0,255,255],azure:[240,255,255],beige:[245,245,220],black:[0, 15 | 0,0],blue:[0,0,255],brown:[165,42,42],cyan:[0,255,255],darkblue:[0,0,139],darkcyan:[0,139,139],darkgrey:[169,169,169],darkgreen:[0,100,0],darkkhaki:[189,183,107],darkmagenta:[139,0,139],darkolivegreen:[85,107,47],darkorange:[255,140,0],darkorchid:[153,50,204],darkred:[139,0,0],darksalmon:[233,150,122],darkviolet:[148,0,211],fuchsia:[255,0,255],gold:[255,215,0],green:[0,128,0],indigo:[75,0,130],khaki:[240,230,140],lightblue:[173,216,230],lightcyan:[224,255,255],lightgreen:[144,238,144],lightgrey:[211, 16 | 211,211],lightpink:[255,182,193],lightyellow:[255,255,224],lime:[0,255,0],magenta:[255,0,255],maroon:[128,0,0],navy:[0,0,128],olive:[128,128,0],orange:[255,165,0],pink:[255,192,203],purple:[128,0,128],violet:[128,0,128],red:[255,0,0],silver:[192,192,192],white:[255,255,255],yellow:[255,255,0],transparent:[255,255,255]},q=["add","remove","toggle"],t={border:1,borderBottom:1,borderColor:1,borderLeft:1,borderRight:1,borderTop:1,borderWidth:1,margin:1,padding:1};f.effects.animateClass=function(c,a,b, 17 | d){if(f.isFunction(b)){d=b;b=null}return this.queue(function(){var e=f(this),g=e.attr("style")||" ",h=p(o.call(this)),r,v=e.attr("class");f.each(q,function(w,i){c[i]&&e[i+"Class"](c[i])});r=p(o.call(this));e.attr("class",v);e.animate(u(h,r),{queue:false,duration:a,easing:b,complete:function(){f.each(q,function(w,i){c[i]&&e[i+"Class"](c[i])});if(typeof e.attr("style")=="object"){e.attr("style").cssText="";e.attr("style").cssText=g}else e.attr("style",g);d&&d.apply(this,arguments);f.dequeue(this)}})})}; 18 | f.fn.extend({_addClass:f.fn.addClass,addClass:function(c,a,b,d){return a?f.effects.animateClass.apply(this,[{add:c},a,b,d]):this._addClass(c)},_removeClass:f.fn.removeClass,removeClass:function(c,a,b,d){return a?f.effects.animateClass.apply(this,[{remove:c},a,b,d]):this._removeClass(c)},_toggleClass:f.fn.toggleClass,toggleClass:function(c,a,b,d,e){return typeof a=="boolean"||a===j?b?f.effects.animateClass.apply(this,[a?{add:c}:{remove:c},b,d,e]):this._toggleClass(c,a):f.effects.animateClass.apply(this, 19 | [{toggle:c},a,b,d])},switchClass:function(c,a,b,d,e){return f.effects.animateClass.apply(this,[{add:a,remove:c},b,d,e])}});f.extend(f.effects,{version:"1.8.16",save:function(c,a){for(var b=0;b").addClass("ui-effects-wrapper").css({fontSize:"100%",background:"transparent",border:"none",margin:0,padding:0}), 21 | d=document.activeElement;c.wrap(b);if(c[0]===d||f.contains(c[0],d))f(d).focus();b=c.parent();if(c.css("position")=="static"){b.css({position:"relative"});c.css({position:"relative"})}else{f.extend(a,{position:c.css("position"),zIndex:c.css("z-index")});f.each(["top","left","bottom","right"],function(e,g){a[g]=c.css(g);if(isNaN(parseInt(a[g],10)))a[g]="auto"});c.css({position:"relative",top:0,left:0,right:"auto",bottom:"auto"})}return b.css(a).show()},removeWrapper:function(c){var a,b=document.activeElement; 22 | if(c.parent().is(".ui-effects-wrapper")){a=c.parent().replaceWith(c);if(c[0]===b||f.contains(c[0],b))f(b).focus();return a}return c},setTransition:function(c,a,b,d){d=d||{};f.each(a,function(e,g){unit=c.cssUnit(g);if(unit[0]>0)d[g]=unit[0]*b+unit[1]});return d}});f.fn.extend({effect:function(c){var a=k.apply(this,arguments),b={options:a[1],duration:a[2],callback:a[3]};a=b.options.mode;var d=f.effects[c];if(f.fx.off||!d)return a?this[a](b.duration,b.callback):this.each(function(){b.callback&&b.callback.call(this)}); 23 | return d.call(this,b)},_show:f.fn.show,show:function(c){if(l(c))return this._show.apply(this,arguments);else{var a=k.apply(this,arguments);a[1].mode="show";return this.effect.apply(this,a)}},_hide:f.fn.hide,hide:function(c){if(l(c))return this._hide.apply(this,arguments);else{var a=k.apply(this,arguments);a[1].mode="hide";return this.effect.apply(this,a)}},__toggle:f.fn.toggle,toggle:function(c){if(l(c)||typeof c==="boolean"||f.isFunction(c))return this.__toggle.apply(this,arguments);else{var a=k.apply(this, 24 | arguments);a[1].mode="toggle";return this.effect.apply(this,a)}},cssUnit:function(c){var a=this.css(c),b=[];f.each(["em","px","%","pt"],function(d,e){if(a.indexOf(e)>0)b=[parseFloat(a),e]});return b}});f.easing.jswing=f.easing.swing;f.extend(f.easing,{def:"easeOutQuad",swing:function(c,a,b,d,e){return f.easing[f.easing.def](c,a,b,d,e)},easeInQuad:function(c,a,b,d,e){return d*(a/=e)*a+b},easeOutQuad:function(c,a,b,d,e){return-d*(a/=e)*(a-2)+b},easeInOutQuad:function(c,a,b,d,e){if((a/=e/2)<1)return d/ 25 | 2*a*a+b;return-d/2*(--a*(a-2)-1)+b},easeInCubic:function(c,a,b,d,e){return d*(a/=e)*a*a+b},easeOutCubic:function(c,a,b,d,e){return d*((a=a/e-1)*a*a+1)+b},easeInOutCubic:function(c,a,b,d,e){if((a/=e/2)<1)return d/2*a*a*a+b;return d/2*((a-=2)*a*a+2)+b},easeInQuart:function(c,a,b,d,e){return d*(a/=e)*a*a*a+b},easeOutQuart:function(c,a,b,d,e){return-d*((a=a/e-1)*a*a*a-1)+b},easeInOutQuart:function(c,a,b,d,e){if((a/=e/2)<1)return d/2*a*a*a*a+b;return-d/2*((a-=2)*a*a*a-2)+b},easeInQuint:function(c,a,b, 26 | d,e){return d*(a/=e)*a*a*a*a+b},easeOutQuint:function(c,a,b,d,e){return d*((a=a/e-1)*a*a*a*a+1)+b},easeInOutQuint:function(c,a,b,d,e){if((a/=e/2)<1)return d/2*a*a*a*a*a+b;return d/2*((a-=2)*a*a*a*a+2)+b},easeInSine:function(c,a,b,d,e){return-d*Math.cos(a/e*(Math.PI/2))+d+b},easeOutSine:function(c,a,b,d,e){return d*Math.sin(a/e*(Math.PI/2))+b},easeInOutSine:function(c,a,b,d,e){return-d/2*(Math.cos(Math.PI*a/e)-1)+b},easeInExpo:function(c,a,b,d,e){return a==0?b:d*Math.pow(2,10*(a/e-1))+b},easeOutExpo:function(c, 27 | a,b,d,e){return a==e?b+d:d*(-Math.pow(2,-10*a/e)+1)+b},easeInOutExpo:function(c,a,b,d,e){if(a==0)return b;if(a==e)return b+d;if((a/=e/2)<1)return d/2*Math.pow(2,10*(a-1))+b;return d/2*(-Math.pow(2,-10*--a)+2)+b},easeInCirc:function(c,a,b,d,e){return-d*(Math.sqrt(1-(a/=e)*a)-1)+b},easeOutCirc:function(c,a,b,d,e){return d*Math.sqrt(1-(a=a/e-1)*a)+b},easeInOutCirc:function(c,a,b,d,e){if((a/=e/2)<1)return-d/2*(Math.sqrt(1-a*a)-1)+b;return d/2*(Math.sqrt(1-(a-=2)*a)+1)+b},easeInElastic:function(c,a,b, 28 | d,e){c=1.70158;var g=0,h=d;if(a==0)return b;if((a/=e)==1)return b+d;g||(g=e*0.3);if(h").css({position:"absolute",visibility:"visible",left:-f*(h/d),top:-e*(i/c)}).parent().addClass("ui-effects-explode").css({position:"absolute",overflow:"hidden",width:h/d,height:i/c,left:g.left+f*(h/d)+(a.options.mode=="show"?(f-Math.floor(d/2))*(h/d):0),top:g.top+e*(i/c)+(a.options.mode=="show"?(e-Math.floor(c/2))*(i/c):0),opacity:a.options.mode=="show"?0:1}).animate({left:g.left+f*(h/d)+(a.options.mode=="show"?0:(f-Math.floor(d/2))*(h/d)),top:g.top+ 103 | e*(i/c)+(a.options.mode=="show"?0:(e-Math.floor(c/2))*(i/c)),opacity:a.options.mode=="show"?1:0},a.duration||500);setTimeout(function(){a.options.mode=="show"?b.css({visibility:"visible"}):b.css({visibility:"visible"}).hide();a.callback&&a.callback.apply(b[0]);b.dequeue();j("div.ui-effects-explode").remove()},a.duration||500)})}})(jQuery); 104 | ;/* 105 | * jQuery UI Effects Fade 1.8.16 106 | * 107 | * Copyright 2011, AUTHORS.txt (http://jqueryui.com/about) 108 | * Dual licensed under the MIT or GPL Version 2 licenses. 109 | * http://jquery.org/license 110 | * 111 | * http://docs.jquery.com/UI/Effects/Fade 112 | * 113 | * Depends: 114 | * jquery.effects.core.js 115 | */ 116 | (function(b){b.effects.fade=function(a){return this.queue(function(){var c=b(this),d=b.effects.setMode(c,a.options.mode||"hide");c.animate({opacity:d},{queue:false,duration:a.duration,easing:a.options.easing,complete:function(){a.callback&&a.callback.apply(this,arguments);c.dequeue()}})})}})(jQuery); 117 | ;/* 118 | * jQuery UI Effects Fold 1.8.16 119 | * 120 | * Copyright 2011, AUTHORS.txt (http://jqueryui.com/about) 121 | * Dual licensed under the MIT or GPL Version 2 licenses. 122 | * http://jquery.org/license 123 | * 124 | * http://docs.jquery.com/UI/Effects/Fold 125 | * 126 | * Depends: 127 | * jquery.effects.core.js 128 | */ 129 | (function(c){c.effects.fold=function(a){return this.queue(function(){var b=c(this),j=["position","top","bottom","left","right"],d=c.effects.setMode(b,a.options.mode||"hide"),g=a.options.size||15,h=!!a.options.horizFirst,k=a.duration?a.duration/2:c.fx.speeds._default/2;c.effects.save(b,j);b.show();var e=c.effects.createWrapper(b).css({overflow:"hidden"}),f=d=="show"!=h,l=f?["width","height"]:["height","width"];f=f?[e.width(),e.height()]:[e.height(),e.width()];var i=/([0-9]+)%/.exec(g);if(i)g=parseInt(i[1], 130 | 10)/100*f[d=="hide"?0:1];if(d=="show")e.css(h?{height:0,width:g}:{height:g,width:0});h={};i={};h[l[0]]=d=="show"?f[0]:g;i[l[1]]=d=="show"?f[1]:0;e.animate(h,k,a.options.easing).animate(i,k,a.options.easing,function(){d=="hide"&&b.hide();c.effects.restore(b,j);c.effects.removeWrapper(b);a.callback&&a.callback.apply(b[0],arguments);b.dequeue()})})}})(jQuery); 131 | ;/* 132 | * jQuery UI Effects Highlight 1.8.16 133 | * 134 | * Copyright 2011, AUTHORS.txt (http://jqueryui.com/about) 135 | * Dual licensed under the MIT or GPL Version 2 licenses. 136 | * http://jquery.org/license 137 | * 138 | * http://docs.jquery.com/UI/Effects/Highlight 139 | * 140 | * Depends: 141 | * jquery.effects.core.js 142 | */ 143 | (function(b){b.effects.highlight=function(c){return this.queue(function(){var a=b(this),e=["backgroundImage","backgroundColor","opacity"],d=b.effects.setMode(a,c.options.mode||"show"),f={backgroundColor:a.css("backgroundColor")};if(d=="hide")f.opacity=0;b.effects.save(a,e);a.show().css({backgroundImage:"none",backgroundColor:c.options.color||"#ffff99"}).animate(f,{queue:false,duration:c.duration,easing:c.options.easing,complete:function(){d=="hide"&&a.hide();b.effects.restore(a,e);d=="show"&&!b.support.opacity&& 144 | this.style.removeAttribute("filter");c.callback&&c.callback.apply(this,arguments);a.dequeue()}})})}})(jQuery); 145 | ;/* 146 | * jQuery UI Effects Pulsate 1.8.16 147 | * 148 | * Copyright 2011, AUTHORS.txt (http://jqueryui.com/about) 149 | * Dual licensed under the MIT or GPL Version 2 licenses. 150 | * http://jquery.org/license 151 | * 152 | * http://docs.jquery.com/UI/Effects/Pulsate 153 | * 154 | * Depends: 155 | * jquery.effects.core.js 156 | */ 157 | (function(d){d.effects.pulsate=function(a){return this.queue(function(){var b=d(this),c=d.effects.setMode(b,a.options.mode||"show");times=(a.options.times||5)*2-1;duration=a.duration?a.duration/2:d.fx.speeds._default/2;isVisible=b.is(":visible");animateTo=0;if(!isVisible){b.css("opacity",0).show();animateTo=1}if(c=="hide"&&isVisible||c=="show"&&!isVisible)times--;for(c=0;c').appendTo(document.body).addClass(a.options.className).css({top:d.top,left:d.left,height:b.innerHeight(),width:b.innerWidth(),position:"absolute"}).animate(c,a.duration,a.options.easing,function(){f.remove();a.callback&&a.callback.apply(b[0],arguments); 220 | b.dequeue()})})}})(jQuery); 221 | ; --------------------------------------------------------------------------------