-
Notifications
You must be signed in to change notification settings - Fork 0
/
Server.hs
140 lines (108 loc) · 4.59 KB
/
Server.hs
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
{-# LANGUAGE TemplateHaskell, TypeSynonymInstances, FlexibleInstances #-}
module Server where
import Text.Parsec (ParseError)
import Network (listenOn, withSocketsDo, accept, PortID(..), Socket)
import System.IO (hSetBuffering, hSetNewlineMode, NewlineMode(..), Newline(CRLF), hGetLine, hPutStrLn, BufferMode(..)
, Handle)
import Control.Concurrent (forkIO)
import Control.Concurrent.STM
import Control.Monad (void)
import Control.Lens hiding ((<.>), (.>))
import Parser (parse, message)
import Model.Message
import Model.User
import Database
data RespTarget = RTUser User
| RTDirect
| RTHandle Handle
-- | RTChannel Channel
type Reply = (RespTarget, MessageOut)
type Replies = [Reply]
data Resp = Resp { _respTransaction :: Transaction
, _respReplies :: Replies
, _respUserData :: UserData
}
makeLenses ''Resp
ircNewlineMode :: NewlineMode
ircNewlineMode = NewlineMode CRLF CRLF
run :: IO ()
run = withSocketsDo $ do
db <- mkDatabase
sock <- listenOn $ PortNumber 6697
putStrLn "Listening on 6697"
sockHandler sock db
sockHandler :: Socket -> TVar Database -> IO ()
sockHandler sock db = do
(handle, _, _) <- accept sock
hSetBuffering handle NoBuffering
hSetNewlineMode handle ircNewlineMode
void $ forkIO $ commandProcessor (mkUserData handle) db
sockHandler sock db
commandProcessor :: UserData -> TVar Database -> IO ()
commandProcessor ud@(UserData _ handle) db = do
-- TODO: if there are too many users online, just return a response and close the connection
line <- hGetLine handle
let m = parse message line
(dbBefore, ud', ms) <- atomically $ do
dbBefore <- readTVar db
let Resp dbTransaction ms ud' = handleEitherRawMessage m dbBefore ud (Resp id [] ud)
writeTVar db $ dbTransaction dbBefore
return (dbBefore, ud', ms)
mapM_ (writeMessage dbBefore handle) ms
commandProcessor ud' db
handleEitherRawMessage :: Either ParseError RawMessage -> Database -> UserData -> Resp -> Resp
handleEitherRawMessage (Right m) db ud = handleEitherMessage (msgFromRaw m) db ud
handleEitherRawMessage (Left e) _ _ = gen $ ErrParseFailed details
where details = map (\c -> if c == '\n' then ' ' else c) $ show e
handleEitherMessage :: Either MessageOut MessageIn -> Database -> UserData -> Resp -> Resp
handleEitherMessage (Right m) db ud = handleMessage m db ud
handleEitherMessage (Left m) _ _ = gen m
welcome :: User -> [MessageOut]
welcome u = [ RplWelcome u
-- TODO servername, createdat
, RplYourHost "$SERVERNAME" "$VERSION"
, RplCreated 0
-- TODO 004 (RPL_MYINFO)
]
class Gen a where
gen :: a -> Resp -> Resp
(.>) :: (Gen a) => (Resp -> Resp) -> a -> (Resp -> Resp)
l .> x = l . (gen x)
(<.>) :: (Gen a, Gen b) => a -> b -> Resp -> Resp
l <.> r = (gen l) . (gen r)
instance Gen Transaction where
gen t r = r & respTransaction %~ (. t)
instance Gen Reply where
gen (t, m) r = r & respReplies %~ ((t, m):)
instance Gen Replies where
gen rs r = r & respReplies %~ (++ rs)
instance Gen MessageOut where
gen m = gen (RTDirect, m)
instance Gen [MessageOut] where
gen ms = gen [(RTDirect, m) | m <- ms]
instance Gen UserData where
gen ud r = r & respUserData .~ ud
handleMessage :: MessageIn -> Database -> UserData -> (Resp -> Resp)
handleMessage (CmdNick n) db ud@(UserData u h)
| isNicknameInUse db n = gen $ ErrNicknameInUse n
| otherwise = f u .> ud'
where f (UnregisteredUser) = gen $ saveUser u' h
f (NicknameOnlyUser n') = RplNick n <.> saveUser u' h .> freeNickname n'
f (UserOnlyUser _ _ _ _) = welcome u' <.> saveUser u' h
f (FullUser n' _ _ _ _) = RplNick n <.> saveUser u' h .> freeNickname n'
-- TODO send to others who should see it
u' = changeNickname n u
ud' = ud { udUser = u' }
handleMessage (CmdUser username flags realname) _ ud@(UserData u h) = f u
where f (UnregisteredUser) = gen ud'
f (NicknameOnlyUser _) = welcome u' <.> saveUser u' h .> ud'
f _ = gen ErrAlreadyRegistered
u' = addUserData u username flags realname
ud' = ud { udUser = u' }
handleMessage (CmdSet v) _ _ = (\db -> db { dbTest = v }) <.> RplValue v
handleMessage CmdGet db _ = gen $ RplValue $ dbTest db
handleMessage ErrIgnore _ _ = id
writeMessage :: Database -> Handle -> (RespTarget, MessageOut) -> IO ()
writeMessage _ sender (RTDirect, m) = hPutStrLn sender $ msgToWire m
writeMessage _ _ (RTHandle h, m) = hPutStrLn h $ msgToWire m
writeMessage _ _ (RTUser _, _) = undefined