netserver/Miscutils.hs
author unc0rr
Thu, 01 May 2008 14:30:12 +0000
changeset 894 2ca76a7f3121
parent 890 1d8c4a5ec622
child 895 6aee2f335726
permissions -rw-r--r--
- Fixed some bugs - Introduce client protocol number field - Handle PROTO command
Ignore whitespace changes - Everywhere: Within whitespace: At end of lines:
849
82ac0596aa3c Start work on standalone server in Haskell
unc0rr
parents:
diff changeset
     1
module Miscutils where
82ac0596aa3c Start work on standalone server in Haskell
unc0rr
parents:
diff changeset
     2
82ac0596aa3c Start work on standalone server in Haskell
unc0rr
parents:
diff changeset
     3
import IO
82ac0596aa3c Start work on standalone server in Haskell
unc0rr
parents:
diff changeset
     4
import System.IO
82ac0596aa3c Start work on standalone server in Haskell
unc0rr
parents:
diff changeset
     5
import Control.Concurrent
82ac0596aa3c Start work on standalone server in Haskell
unc0rr
parents:
diff changeset
     6
import Control.Concurrent.STM
82ac0596aa3c Start work on standalone server in Haskell
unc0rr
parents:
diff changeset
     7
import Control.Exception (finally)
894
2ca76a7f3121 - Fixed some bugs
unc0rr
parents: 890
diff changeset
     8
import Data.Word
2ca76a7f3121 - Fixed some bugs
unc0rr
parents: 890
diff changeset
     9
import Data.Char
849
82ac0596aa3c Start work on standalone server in Haskell
unc0rr
parents:
diff changeset
    10
851
8ffa4ad0d8ea Introduce function to atomically change both lists
unc0rr
parents: 849
diff changeset
    11
data ClientInfo =
8ffa4ad0d8ea Introduce function to atomically change both lists
unc0rr
parents: 849
diff changeset
    12
	ClientInfo
8ffa4ad0d8ea Introduce function to atomically change both lists
unc0rr
parents: 849
diff changeset
    13
	{
889
3bf9dc791f45 Some work on newhwserv
unc0rr
parents: 852
diff changeset
    14
		chan :: TChan String,
851
8ffa4ad0d8ea Introduce function to atomically change both lists
unc0rr
parents: 849
diff changeset
    15
		handle :: Handle,
8ffa4ad0d8ea Introduce function to atomically change both lists
unc0rr
parents: 849
diff changeset
    16
		nick :: String,
894
2ca76a7f3121 - Fixed some bugs
unc0rr
parents: 890
diff changeset
    17
		protocol :: Word16,
851
8ffa4ad0d8ea Introduce function to atomically change both lists
unc0rr
parents: 849
diff changeset
    18
		room :: String,
8ffa4ad0d8ea Introduce function to atomically change both lists
unc0rr
parents: 849
diff changeset
    19
		isMaster :: Bool
8ffa4ad0d8ea Introduce function to atomically change both lists
unc0rr
parents: 849
diff changeset
    20
	}
8ffa4ad0d8ea Introduce function to atomically change both lists
unc0rr
parents: 849
diff changeset
    21
8ffa4ad0d8ea Introduce function to atomically change both lists
unc0rr
parents: 849
diff changeset
    22
data RoomInfo =
8ffa4ad0d8ea Introduce function to atomically change both lists
unc0rr
parents: 849
diff changeset
    23
	RoomInfo
8ffa4ad0d8ea Introduce function to atomically change both lists
unc0rr
parents: 849
diff changeset
    24
	{
8ffa4ad0d8ea Introduce function to atomically change both lists
unc0rr
parents: 849
diff changeset
    25
		name :: String,
8ffa4ad0d8ea Introduce function to atomically change both lists
unc0rr
parents: 849
diff changeset
    26
		password :: String
8ffa4ad0d8ea Introduce function to atomically change both lists
unc0rr
parents: 849
diff changeset
    27
	}
8ffa4ad0d8ea Introduce function to atomically change both lists
unc0rr
parents: 849
diff changeset
    28
8ffa4ad0d8ea Introduce function to atomically change both lists
unc0rr
parents: 849
diff changeset
    29
849
82ac0596aa3c Start work on standalone server in Haskell
unc0rr
parents:
diff changeset
    30
sendMsg :: Handle -> String -> IO()
82ac0596aa3c Start work on standalone server in Haskell
unc0rr
parents:
diff changeset
    31
sendMsg clientHandle str = finally (return ()) (hPutStrLn clientHandle str >> hFlush clientHandle) -- catch exception when client tries to send to other
82ac0596aa3c Start work on standalone server in Haskell
unc0rr
parents:
diff changeset
    32
82ac0596aa3c Start work on standalone server in Haskell
unc0rr
parents:
diff changeset
    33
sendAll :: [Handle] -> String -> IO[()]
82ac0596aa3c Start work on standalone server in Haskell
unc0rr
parents:
diff changeset
    34
sendAll clientsList str = mapM (\x -> sendMsg x str) clientsList
82ac0596aa3c Start work on standalone server in Haskell
unc0rr
parents:
diff changeset
    35
82ac0596aa3c Start work on standalone server in Haskell
unc0rr
parents:
diff changeset
    36
sendOthers :: [Handle] -> Handle -> String -> IO[()]
82ac0596aa3c Start work on standalone server in Haskell
unc0rr
parents:
diff changeset
    37
sendOthers clientsList clientHandle str = sendAll (filter (/= clientHandle) clientsList) str
82ac0596aa3c Start work on standalone server in Haskell
unc0rr
parents:
diff changeset
    38
82ac0596aa3c Start work on standalone server in Haskell
unc0rr
parents:
diff changeset
    39
extractCmd :: String -> (String, [String])
82ac0596aa3c Start work on standalone server in Haskell
unc0rr
parents:
diff changeset
    40
extractCmd str = if ws == [] then ("", []) else (head ws, tail ws)
82ac0596aa3c Start work on standalone server in Haskell
unc0rr
parents:
diff changeset
    41
		where ws = words str
82ac0596aa3c Start work on standalone server in Haskell
unc0rr
parents:
diff changeset
    42
82ac0596aa3c Start work on standalone server in Haskell
unc0rr
parents:
diff changeset
    43
manipState :: TVar[a] -> ([a] -> [a]) -> IO()
82ac0596aa3c Start work on standalone server in Haskell
unc0rr
parents:
diff changeset
    44
manipState state op =
82ac0596aa3c Start work on standalone server in Haskell
unc0rr
parents:
diff changeset
    45
	atomically $ do
82ac0596aa3c Start work on standalone server in Haskell
unc0rr
parents:
diff changeset
    46
			ls <- readTVar state
82ac0596aa3c Start work on standalone server in Haskell
unc0rr
parents:
diff changeset
    47
			writeTVar state $ op ls
82ac0596aa3c Start work on standalone server in Haskell
unc0rr
parents:
diff changeset
    48
852
f756a1d3324c Handle the case when the room is already created by someone else
unc0rr
parents: 851
diff changeset
    49
manipState2 :: TVar[ClientInfo] -> TVar[RoomInfo] -> ([ClientInfo] -> [RoomInfo] -> ([ClientInfo], [RoomInfo], Bool)) -> IO Bool
851
8ffa4ad0d8ea Introduce function to atomically change both lists
unc0rr
parents: 849
diff changeset
    50
manipState2 state1 state2 op =
8ffa4ad0d8ea Introduce function to atomically change both lists
unc0rr
parents: 849
diff changeset
    51
	atomically $ do
8ffa4ad0d8ea Introduce function to atomically change both lists
unc0rr
parents: 849
diff changeset
    52
			ls1 <- readTVar state1
8ffa4ad0d8ea Introduce function to atomically change both lists
unc0rr
parents: 849
diff changeset
    53
			ls2 <- readTVar state2
852
f756a1d3324c Handle the case when the room is already created by someone else
unc0rr
parents: 851
diff changeset
    54
			let (ol1, ol2, res) = op ls1 ls2
851
8ffa4ad0d8ea Introduce function to atomically change both lists
unc0rr
parents: 849
diff changeset
    55
			writeTVar state1 ol1
8ffa4ad0d8ea Introduce function to atomically change both lists
unc0rr
parents: 849
diff changeset
    56
			writeTVar state2 ol2
852
f756a1d3324c Handle the case when the room is already created by someone else
unc0rr
parents: 851
diff changeset
    57
			return res
889
3bf9dc791f45 Some work on newhwserv
unc0rr
parents: 852
diff changeset
    58
890
1d8c4a5ec622 - Improve server core
unc0rr
parents: 889
diff changeset
    59
tselect :: [ClientInfo] -> STM (String, ClientInfo)
1d8c4a5ec622 - Improve server core
unc0rr
parents: 889
diff changeset
    60
tselect = foldl orElse retry . map (\ci -> (flip (,) ci) `fmap` readTChan (chan ci))
889
3bf9dc791f45 Some work on newhwserv
unc0rr
parents: 852
diff changeset
    61
894
2ca76a7f3121 - Fixed some bugs
unc0rr
parents: 890
diff changeset
    62
maybeRead :: Read a => String -> Maybe a
2ca76a7f3121 - Fixed some bugs
unc0rr
parents: 890
diff changeset
    63
maybeRead s = case reads s of
2ca76a7f3121 - Fixed some bugs
unc0rr
parents: 890
diff changeset
    64
	[(x, rest)] | all isSpace rest -> Just x
2ca76a7f3121 - Fixed some bugs
unc0rr
parents: 890
diff changeset
    65
	_         -> Nothing
2ca76a7f3121 - Fixed some bugs
unc0rr
parents: 890
diff changeset
    66