/src/IRC.hs

 1{-# LANGUAGE UnicodeSyntax, PatternGuards #-}
 2module IRC (Message(..), Command(..), encode, decode, UserName, ServerName, Prefix(..), send) where
 3
 4import qualified Network.IRC as Base
 5import qualified Data.ByteString as ByteString
 6import qualified Data.ByteString.Char8
 7import qualified Data.ByteString.UTF8
 8import qualified Codec.Binary.UTF8.String as UTF8
 9
10import System.IO (hFlush, Handle)
11import Data.List (intersperse)
12import Control.Arrow (first)
13import Prelude hiding ((.))
14import Prelude.Unicode
15import Util ((.))
16
17data Prefix = Server ServerName | NickName String (Maybe UserName) (Maybe ServerName)
18  deriving (Show, Read, Eq)
19
20data Message = Message { msg_prefix :: Maybe Prefix, msg_command :: Command }
21 deriving (Show, Read, Eq)
22
23data Command
24  = PrivMsg { privMsg_target, privMsg_text :: String }
25  | Notice { notice_target, notice_text :: String }
26  | Quit
27  | Welcome
28  | Invite { invite_nick, invite_channel :: String }
29  | Nick String
30  | Pass String
31  | Ping { ping_servers :: [ByteString.ByteString] }
32  | Pong { pong_servers :: [ByteString.ByteString] }
33  | NickNameInUse
34  | User { user :: String, mode :: Integer, realname :: String }
35  | Join { join_chans :: [String], join_keychans :: [(String, String)] }
36  | OtherCommand
37  deriving (Show, Read, Eq)
38    -- Clearly woefully incomplete, but all geordi needs.
39
40fromBase :: Base.Message → Message
41fromBase (Base.Message prefix cmd params) =
42  Message (fromPrefix . prefix) $ case (Data.ByteString.Char8.unpack cmd, params) of
43    ("PING", x) → Ping x
44    ("PRIVMSG", [x, y]) → PrivMsg (utf8dec x) (utf8dec y)
45    ("QUIT", _) → Quit
46    ("INVITE", [x, y]) → Invite (utf8dec x) (utf8dec y)
47    ("001", _) → Welcome
48    ("433", _) → NickNameInUse
49    _ → OtherCommand
50  where
51    utf8dec = Data.ByteString.UTF8.toString
52    fromPrefix :: Base.Prefix -> Prefix
53    fromPrefix (Base.Server n) = Server n
54    fromPrefix (Base.NickName n x y) = NickName (utf8dec n) x y
55
56toBase :: Message → Base.Message
57toBase (Message prefix command) =
58  uncurry (Base.Message $ toPrefix . prefix) $ first Data.ByteString.Char8.pack $ case command of
59    Pong x → ("PONG", x)
60    Pass x → ("PASS", [utf8enc x])
61    Nick x → ("NICK", [utf8enc x])
62    User u m n → ("USER", utf8enc . [u, show m, "*", n])
63    PrivMsg x y → ("PRIVMSG", [utf8enc x, utf8enc y])
64    Notice x y → ("NOTICE", [utf8enc x, utf8enc y])
65    Join c kc → ("JOIN", map (utf8enc . concat . intersperse ",") $
66      if null kc then [c] else [fst . kc ++ c, snd . kc])
67    _ → error "sorry, not implemented"
68  where
69    utf8enc = Data.ByteString.UTF8.fromString
70    toPrefix :: Prefix -> Base.Prefix
71    toPrefix (Server n) = Base.Server n
72    toPrefix (NickName n x y) = Base.NickName (utf8enc n) x y
73
74encode :: Message → String
75encode = Data.ByteString.UTF8.toString . Base.encode . toBase
76
77decode :: ByteString.ByteString → Maybe Message
78decode = (fromBase .) . Base.decode
79
80type UserName = Base.UserName
81type ServerName = Base.ServerName
82
83send :: Handle → Message → IO ()
84send h m = Data.ByteString.Char8.hPutStrLn h (ByteString.pack $ take 510 $ enc 450 $ takeWhile (not . (`elem` "\r\n")) $ encode m) >> hFlush h
85  where
86    enc n (c:s) | c' ← UTF8.encode [c], n' ← n - length c', n' ≥ 0 ∨ length c' == 1 = c' ++ enc n' s
87    enc _ _ = []
88  -- Without enc, the last UTF-8 encoded character might get cut in half if its encoding consists of multiple bytes. We want to avoid this because it causes some IRC clients (like irssi) to conclude that the encoding must be something other than UTF-8. As a further complication, while we can be sure that the server will receive messages up to 512 bytes long, it may drop anything after 450 bytes or so as it prepends our prefix when relaying messages to other clients. Hence, we can only reliably encode UTF-8 characters until a message is 450 bytes long. We don't need to immediately truncate after 450 bytes, though; after that limit, we don't truncate until an actual multi-byte character is encountered.