├── .ghci ├── .gitignore ├── LICENSE ├── README.md ├── Setup.hs ├── example ├── auth │ ├── passwd │ └── passwd-key ├── hulk.conf ├── log │ └── events.log ├── txt │ ├── MOTD │ └── PREFACE └── users │ ├── hulk │ └── hulk2 ├── fastirc-0.2.0 ├── LICENSE ├── Network │ ├── FastIRC.hs │ └── FastIRC │ │ ├── IO.hs │ │ ├── Messages.hs │ │ ├── ServerSet.hs │ │ ├── Session.hs │ │ ├── Types.hs │ │ ├── Users.hs │ │ └── Utils.hs ├── Setup.hs └── fastirc.cabal ├── hulk.cabal ├── src ├── Hulk │ ├── Auth.hs │ ├── Client.hs │ ├── Config.hs │ ├── Options.hs │ ├── Server.hs │ └── Types.hs └── main │ ├── GeneratePass.hs │ └── Server.hs └── stack.yaml /.ghci: -------------------------------------------------------------------------------- 1 | :set -hide-package monads-tf 2 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | .stack-work 2 | dist 3 | cabal-dev 4 | .hsenv 5 | 6 | TAGS 7 | 8 | *.o 9 | *.hi 10 | *~ 11 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c)2011, Chris Done 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 Chris Done 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 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # Hulk IRC Server Guide 2 | 3 | ## Installation 4 | 5 | ### From Hackage 6 | 7 | $ cabal install hulk 8 | 9 | ### From Github 10 | 11 | $ git clone git://github.com/chrisdone/hulk.git 12 | $ cd hulk 13 | $ cabal install 14 | 15 | ## Usage 16 | 17 | See a complete example in the `example/` directory in the root of the 18 | project. You can go into that directory and run `hulk -chulk.conf` to 19 | have an immediate server running on localhost port 6667. 20 | 21 | ### Configuration 22 | 23 | $ cp example/hulk.conf hulk.conf 24 | 25 | You can edit the port, server name and MOTD file in here. 26 | 27 | Detailed instructions follow. 28 | 29 | ### Auth 30 | 31 | $ mkdir auth 32 | 33 | Put a salt for your passwords in auth/passwd. For example: 34 | 35 | $ head -c 128 /dev/random | sha1sum > auth/passwd-key 36 | 37 | Then generate a password for your IRC user: 38 | 39 | $ hulk-generate-pass -u demo -c=hulk.conf >> auth/passwd 40 | 41 | (It will wait for a single line containing a pass and output the user 42 | and sha1 sum.) 43 | 44 | ### Start the server 45 | 46 | $ hulk -chulk.conf 47 | 48 | Logs / events will be outputted to stdout. This will be a 49 | configuration option later. (Send me a patch if you already did this!) 50 | 51 | Clients *must* connect with a password and user that matches the users 52 | and passwords in your `auth/passwd` file. 53 | 54 | ## Using with SSL 55 | 56 | You can use it with stunnel. 57 | 58 | Change the port setting in hulk.conf: 59 | 60 | port = 6666 61 | 62 | Generate an SSL certificate: 63 | 64 | $ openssl req -new -out hulk.pem -keyout hulk.pem -nodes -x509 -days 365 65 | 66 | Make a stunnel.conf file: 67 | 68 | pid = /path/to/wherever/stunnel.pid 69 | client = no 70 | foreground = yes 71 | output = /dev/stdout 72 | cert = hulk.pem 73 | [hulk] 74 | connect = 127.0.0.1:6666 75 | accept = 6667 76 | 77 | Then run it: 78 | 79 | stunnel stunnel.conf 80 | 81 | (It may be in `/usr/sbin/stunnel` depending on your system.) 82 | 83 | Then run hulk: 84 | 85 | hulk -chulk.conf 86 | 87 | ## Logging 88 | 89 | Hulk doesn't support specific channel logging yet, but you can use a 90 | logger bot. 91 | 92 | $ cabal install hog 93 | $ hog -h=127.0.0.1 --port=6666 -n=hog -u=hog --pass=mypassword --channels=#dev,#x -l/directory/of/logs -d5 94 | 95 | `-d5` is the timeout before reconnect. 96 | 97 | ## Using an announcer bot 98 | 99 | If you're using a private IRC server you're probably using it at a dev 100 | company, and you probably want to make announcements about commits, 101 | tickets, etc. from a feed. 102 | 103 | You can use rss2irc. But you need a patched version which supports 104 | sending the PASS command: 105 | 106 | $ git clone git://github.com/chrisdone/rss2irc.git 107 | $ cd rss2irc 108 | $ cabal install 109 | 110 | Then run it: 111 | 112 | $ rss2irc http://myserver/foo.atom announce@127.0.0.1/#dev \ 113 | -p 6667 -i 1 -l --pass myannouncepass 114 | -------------------------------------------------------------------------------- /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /example/auth/passwd: -------------------------------------------------------------------------------- 1 | hulk bac95aac1e4e1a3791b4aa044be19bb11b3b 2 | hulk2 bac95aac1e4e1a3791b4aa044be19bb11b3b 3 | -------------------------------------------------------------------------------- /example/auth/passwd-key: -------------------------------------------------------------------------------- 1 | :-) 2 | -------------------------------------------------------------------------------- /example/hulk.conf: -------------------------------------------------------------------------------- 1 | [LISTEN] 2 | port = 6667 3 | hostname = hulk-server 4 | 5 | [STRINGS] 6 | motd_file = txt/MOTD 7 | preface_file = txt/PREFACE 8 | 9 | [AUTH] 10 | passwd_file = auth/passwd 11 | passwd_key = auth/passwd-key 12 | 13 | [USERS] 14 | data_dir=users/ 15 | 16 | [LOGS] 17 | event_log=log/events.log 18 | channels=#hulk -------------------------------------------------------------------------------- /example/log/events.log: -------------------------------------------------------------------------------- 1 | ["2013-11-02T17:06:35.619Z","hulk","RPL_PRIVMSG",["#hulk","Hello!"]] 2 | -------------------------------------------------------------------------------- /example/txt/MOTD: -------------------------------------------------------------------------------- 1 | Hello and welcome to this IRC server. I am your host, Dr. Bruce Banner 2 | PhD in nuclear physics and HRRRRRNNNNNNNNNNNNGGGGGGGGGGGGGGGGGGGGGGGGG 3 | HRRRRRNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNN 4 | NNRUN FOR YOUR LIFENNNNNNNNNNNNNNNNNNNNNNNNNGGGGGGGGNNNNNNNNNNNNNNNNNN 5 | NNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNN 6 | GGGGGGGGGGGGGGGGGGGGGGGGGGGGGGGGGGGGGGGGGGGGGGGGGGGGGGGGGGGGGGGGGGGGGG 7 | GG.. 8 | -------------------------------------------------------------------------------- /example/txt/PREFACE: -------------------------------------------------------------------------------- 1 | You must login with a username and password. If you have not already 2 | created one, you should do so by generating one and adding it to the 3 | Hulk passwd file in passwd. To generate a user/password 4 | key/pair, use: 5 | 6 | $ genpass myusername 7 | 8 | It will prompt for a password. Inspect it first to confirm it is 9 | correct. To write it to the passwd file use 10 | 11 | $ genpass myusername >> /path/to/hulk/data/passwd 12 | 13 | And configure your IRC client to use your username and to send a 14 | *server* password. 15 | -------------------------------------------------------------------------------- /example/users/hulk: -------------------------------------------------------------------------------- 1 | {"userDataUser":"hulk","userDataLastSeen":"2013-11-03T00:59:22.130Z"} -------------------------------------------------------------------------------- /example/users/hulk2: -------------------------------------------------------------------------------- 1 | {"userDataUser":"hulk2","userDataLastSeen":"2013-11-03T00:59:25.723Z"} -------------------------------------------------------------------------------- /fastirc-0.2.0/LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2010, Ertugrul Soeylemez 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 7 | met: 8 | 9 | * Redistributions of source code must retain the above copyright 10 | notice, this list of conditions and the following disclaimer. 11 | 12 | * Redistributions in binary form must reproduce the above copyright 13 | notice, this list of conditions and the following disclaimer in 14 | the documentation and/or other materials provided with the 15 | distribution. 16 | 17 | * Neither the name of the author nor the names of any contributors 18 | may be used to endorse or promote products derived from this 19 | software without specific prior written permission. 20 | 21 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS 22 | IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED 23 | TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A 24 | PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER 25 | OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, 26 | EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, 27 | PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR 28 | PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF 29 | LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING 30 | NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS 31 | SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 32 | -------------------------------------------------------------------------------- /fastirc-0.2.0/Network/FastIRC.hs: -------------------------------------------------------------------------------- 1 | -- | 2 | -- Module: Network.FastIRC 3 | -- Copyright: (c) 2010 Ertugrul Soeylemez 4 | -- License: BSD3 5 | -- Maintainer: Ertugrul Soeylemez 6 | -- Stability: alpha 7 | -- 8 | -- Fast IRC parsing and connection library. 9 | 10 | module Network.FastIRC 11 | ( module Network.FastIRC.IO, 12 | module Network.FastIRC.Messages, 13 | module Network.FastIRC.ServerSet, 14 | module Network.FastIRC.Types, 15 | module Network.FastIRC.Users, 16 | module Network.FastIRC.Utils 17 | ) 18 | where 19 | 20 | import Network.FastIRC.IO 21 | import Network.FastIRC.Messages 22 | import Network.FastIRC.ServerSet 23 | import Network.FastIRC.Types 24 | import Network.FastIRC.Users 25 | import Network.FastIRC.Utils 26 | -------------------------------------------------------------------------------- /fastirc-0.2.0/Network/FastIRC/IO.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | -- | 4 | -- Module: Network.FastIRC.IO 5 | -- Copyright: (c) 2010 Ertugrul Soeylemez 6 | -- License: BSD3 7 | -- Maintainer: Ertugrul Soeylemez 8 | -- Stability: alpha 9 | -- 10 | -- This module helps you with doing input and output on IRC connections 11 | -- or even log files. 12 | 13 | module Network.FastIRC.IO 14 | ( hGetIRCLine, 15 | hGetMessage, 16 | hPutCommand, 17 | hPutMessage 18 | ) 19 | where 20 | 21 | import qualified Data.ByteString.Char8 as B 22 | import Network.FastIRC.Messages 23 | import Network.FastIRC.Types 24 | import Network.FastIRC.Utils 25 | import System.IO 26 | 27 | 28 | -- | Read an IRC message string. 29 | 30 | hGetIRCLine :: Handle -> IO MsgString 31 | hGetIRCLine h = getl B.empty 32 | where 33 | getl :: MsgString -> IO MsgString 34 | getl buf = do 35 | c <- hGetChar h 36 | if isIRCEOLChar c 37 | then return buf 38 | else getl (B.snoc buf c) 39 | 40 | 41 | -- | Read the next valid IRC message. 42 | 43 | hGetMessage :: Handle -> IO Message 44 | hGetMessage h = do 45 | line <- hGetIRCLine h 46 | if B.null line 47 | then hGetMessage h 48 | else 49 | case readMessage line of 50 | Just msg -> return msg 51 | Nothing -> hGetMessage h 52 | 53 | 54 | -- | Write an IRC command with no origin. 55 | 56 | hPutCommand :: Handle -> Command -> IO () 57 | hPutCommand h cmd = 58 | B.hPutStr h $ B.append (showCommand cmd) "\r\n" 59 | 60 | 61 | -- | Write an IRC message. 62 | 63 | hPutMessage :: Handle -> Message -> IO () 64 | hPutMessage h msg = 65 | B.hPutStr h $ B.append (showMessage msg) "\r\n" 66 | -------------------------------------------------------------------------------- /fastirc-0.2.0/Network/FastIRC/Messages.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | -- | 4 | -- Module: Network.FastIRC.Messages 5 | -- Copyright: (c) 2010 Ertugrul Soeylemez 6 | -- License: BSD3 7 | -- Maintainer: Ertugrul Soeylemez 8 | -- Stability: alpha 9 | -- 10 | -- Parser and printer for IRC messages. 11 | 12 | module Network.FastIRC.Messages 13 | ( -- * IRC messages 14 | Message(..), 15 | messageParser, 16 | readMessage, 17 | showMessage, 18 | 19 | -- * IRC commands 20 | Command(..), 21 | commandParser, 22 | showCommand 23 | ) 24 | where 25 | 26 | import qualified Data.ByteString.Char8 as B 27 | import qualified Data.Map as M 28 | import qualified Data.Set as S 29 | import Control.Applicative 30 | import Control.Monad 31 | import Data.Attoparsec.Char8 as P hiding (many) 32 | import Data.Char 33 | import Data.Map (Map) 34 | import Data.Maybe 35 | import Data.Set (Set) 36 | import Network.FastIRC.Types 37 | import Network.FastIRC.Users 38 | import Network.FastIRC.Utils 39 | import Text.Printf 40 | 41 | 42 | -- | Data type for IRC messages. 43 | 44 | data Message = 45 | Message { 46 | msgOrigin :: !(Maybe UserSpec), -- ^ Message origin (user/server). 47 | msgCommand :: !Command -- ^ Message command or numeric. 48 | } 49 | deriving (Eq, Read, Show) 50 | 51 | 52 | -- | Data type for IRC commands. 53 | 54 | data Command 55 | = StringCmd CommandName [CommandArg] -- ^ Arbitrary string command. 56 | | NumericCmd Integer [CommandArg] -- ^ Arbitrary numeric command. 57 | 58 | | JoinCmd (Map ChannelName (Maybe ChannelKey)) 59 | | KickCmd (Set ChannelName) (Set NickName) (Maybe CommandArg) 60 | | ModeCmd (Maybe (TargetName, CommandArg, [CommandArg])) 61 | | NickCmd NickName (Maybe Int) 62 | | NoticeCmd (Set TargetName) CommandArg 63 | | PartCmd (Set ChannelName) (Maybe CommandArg) 64 | | PassCmd CommandArg 65 | | PingCmd ServerName (Maybe ServerName) 66 | | PongCmd ServerName (Maybe ServerName) 67 | | PrivMsgCmd (Set TargetName) CommandArg 68 | | QuitCmd (Maybe CommandArg) 69 | | TopicCmd ChannelName (Maybe CommandArg) 70 | | UserCmd UserName CommandArg CommandArg CommandArg 71 | 72 | deriving (Eq, Read, Show) 73 | 74 | 75 | -- | Parser for IRC commands and their arguments. 76 | 77 | commandParser :: Parser Command 78 | commandParser = 79 | try numCmd <|> 80 | stringCmd 81 | 82 | where 83 | cmdArg :: Parser CommandArg 84 | cmdArg = do 85 | skipMany1 (char ' ') 86 | try lastArg <|> takeWhile1 isIRCTokChar 87 | 88 | where 89 | lastArg :: Parser CommandArg 90 | lastArg = char ':' *> P.takeWhile isMessageChar 91 | 92 | commaArg :: Parser (Set CommandArg) 93 | commaArg = S.filter (not . B.null) . S.fromList . B.split ',' <$> cmdArg 94 | 95 | intArg :: Parser (Maybe Int) 96 | intArg = option Nothing (fmap fst . B.readInt <$> cmdArg) 97 | 98 | joinCmd :: Parser Command 99 | joinCmd = do 100 | channels <- B.split ',' <$> cmdArg 101 | keys <- option [] $ B.split ',' <$> cmdArg 102 | many cmdArg 103 | return . JoinCmd . M.fromList $ 104 | zip channels (map Just keys ++ repeat Nothing) 105 | 106 | numCmd :: Parser Command 107 | numCmd = NumericCmd <$> decimal <*> many cmdArg 108 | 109 | optArg :: Parser (Maybe CommandArg) 110 | optArg = option Nothing (Just <$> cmdArg) 111 | 112 | stringCmd :: Parser Command 113 | stringCmd = do 114 | cmd <- B.map toUpper <$> takeWhile1 isCommandChar 115 | case cmd of 116 | "JOIN" -> joinCmd 117 | "KICK" -> KickCmd <$> commaArg <*> commaArg <*> optArg <* many cmdArg 118 | "MODE" -> 119 | try ((\a b c -> ModeCmd (Just (a,b,c))) 120 | <$> cmdArg 121 | <*> cmdArg 122 | <*> many cmdArg) 123 | <|> (many cmdArg >>= guard . null >> pure (ModeCmd Nothing)) 124 | "NICK" -> NickCmd <$> cmdArg <*> intArg <* many cmdArg 125 | "NOTICE" -> NoticeCmd <$> commaArg <*> cmdArg <* many cmdArg 126 | "PART" -> PartCmd <$> commaArg <*> optArg <* many cmdArg 127 | "PASS" -> PassCmd <$> cmdArg <* many cmdArg 128 | "PING" -> PingCmd <$> cmdArg <*> optArg <* many cmdArg 129 | "PONG" -> PongCmd <$> cmdArg <*> optArg <* many cmdArg 130 | "PRIVMSG" -> PrivMsgCmd <$> commaArg <*> cmdArg <* many cmdArg 131 | "QUIT" -> QuitCmd <$> optArg <* many cmdArg 132 | "TOPIC" -> TopicCmd <$> cmdArg <*> optArg <* many cmdArg 133 | "USER" -> UserCmd <$> cmdArg <*> cmdArg <*> cmdArg <*> cmdArg <* many cmdArg 134 | _ -> StringCmd cmd <$> many cmdArg 135 | 136 | 137 | -- | Parser for IRC messages. 138 | 139 | messageParser :: Parser Message 140 | messageParser = 141 | Message <$> option Nothing (Just <$> try userSpec) 142 | <*> commandParser 143 | 144 | where 145 | userSpec :: Parser UserSpec 146 | userSpec = char ':' *> userParser <* skipMany1 (char ' ') 147 | 148 | 149 | -- | Run the 'messageParser' parser. 150 | 151 | readMessage :: MsgString -> Maybe Message 152 | readMessage = parseComplete messageParser 153 | 154 | 155 | -- | Turn a 'Command' into a 'B.ByteString'. If you need to specify an 156 | -- origin for the command, you should use 'Message' together with 157 | -- 'showMessage'. 158 | 159 | showCommand :: Command -> MsgString 160 | showCommand cmd = 161 | case cmd of 162 | StringCmd cmdStr args -> B.append cmdStr (showArgs args) 163 | NumericCmd cmdNum args -> 164 | B.append (B.pack . printf "%03i" $ cmdNum) 165 | (showArgs args) 166 | 167 | JoinCmd channels -> 168 | case formatJoins channels of 169 | (chanList, "") -> "JOIN" +-+ [chanList] 170 | (chanList, keyList) -> "JOIN" +-+ [chanList, keyList] 171 | KickCmd channels nicks Nothing -> 172 | "KICK" +-+ [commaList channels, commaList nicks] 173 | KickCmd channels nicks (Just reason) -> 174 | "KICK" +-+ [commaList channels, commaList nicks, reason] 175 | ModeCmd Nothing -> "MODE" 176 | ModeCmd (Just (target, mode, args)) -> 177 | "MODE" +-+ [target, mode] ++ args 178 | NickCmd nick (Just hc) -> "NICK" +-+ [nick, B.pack (show hc)] 179 | NickCmd nick Nothing -> "NICK" +-+ [nick] 180 | NoticeCmd targets text -> "NOTICE" +-+ [commaList targets, text] 181 | PartCmd chans Nothing -> "PART" +-+ [commaList chans] 182 | PartCmd chans (Just reason) -> 183 | "PART" +-+ [commaList chans, reason] 184 | PassCmd pwd -> "PASS" +-+ [pwd] 185 | PingCmd srv1 Nothing -> "PING" +-+ [srv1] 186 | PingCmd srv1 (Just srv2) -> "PING" +-+ [srv1, srv2] 187 | PongCmd srv1 Nothing -> "PONG" +-+ [srv1] 188 | PongCmd srv1 (Just srv2) -> "PONG" +-+ [srv1, srv2] 189 | PrivMsgCmd targets text -> "PRIVMSG" +-+ [commaList targets, text] 190 | QuitCmd Nothing -> "QUIT" +-+ [] 191 | QuitCmd (Just reason) -> "QUIT" +-+ [reason] 192 | TopicCmd channel Nothing -> "TOPIC" +-+ [channel] 193 | TopicCmd channel (Just newTopic) -> 194 | "TOPIC" +-+ [channel, newTopic] 195 | UserCmd user vhost vport realName -> 196 | "USER" +-+ [user, vhost, vport, realName] 197 | 198 | where 199 | (+-+) :: B.ByteString -> [B.ByteString] -> B.ByteString 200 | cmd +-+ args = B.append cmd (showArgs args) 201 | infix 4 +-+ 202 | 203 | formatJoins :: Map ChannelName (Maybe ChannelKey) -> 204 | (CommandArg, CommandArg) 205 | formatJoins channels = (chanList, keyList) 206 | where 207 | (withKey, withoutKey) = M.partition isJust channels 208 | chanWithKeyAssocs = M.assocs withKey 209 | chanList = B.intercalate "," $ map fst chanWithKeyAssocs ++ 210 | M.keys withoutKey 211 | keyList = B.intercalate "," $ map (fromJust . snd) chanWithKeyAssocs 212 | 213 | commaList :: Set CommandArg -> CommandArg 214 | commaList = B.intercalate "," . S.toList 215 | 216 | showArgs :: [CommandArg] -> MsgString 217 | showArgs [] = B.empty 218 | showArgs [arg] 219 | | B.null arg = " :" 220 | | B.head arg == ':' = B.append " :" arg 221 | | B.elem ' ' arg = B.append " :" arg 222 | | otherwise = B.cons ' ' arg 223 | showArgs (arg:args) = 224 | B.append (B.cons ' ' arg) (showArgs args) 225 | 226 | 227 | -- | Turn a 'Message' into a 'B.ByteString'. 228 | 229 | showMessage :: Message -> MsgString 230 | showMessage (Message origin cmd) = 231 | case origin of 232 | Nothing -> showCommand cmd 233 | Just o -> 234 | B.append (':' `B.cons` showUserSpec o) 235 | (' ' `B.cons` showCommand cmd) 236 | -------------------------------------------------------------------------------- /fastirc-0.2.0/Network/FastIRC/ServerSet.hs: -------------------------------------------------------------------------------- 1 | -- | 2 | -- Module: Network.FastIRC.ServerSet 3 | -- Copyright: (c) 2010 Ertugrul Soeylemez 4 | -- License: BSD3 5 | -- Maintainer: Ertugrul Soeylemez 6 | -- Stability: alpha 7 | -- 8 | -- Functions for dealing with sets of IRC servers. Note that servers 9 | -- are compared case-insensitively. 10 | 11 | module Network.FastIRC.ServerSet 12 | ( -- * The server set type 13 | ServerSet, 14 | 15 | -- * Manipulation 16 | addServer, 17 | delServer, 18 | emptyServers, 19 | isServer, 20 | 21 | -- * Conversion 22 | serversFromList, 23 | serversToList 24 | ) 25 | where 26 | 27 | import qualified Data.ByteString.Char8 as B 28 | import qualified Data.Set as S 29 | import Data.Char 30 | import Network.FastIRC.Types 31 | 32 | 33 | -- | A set of servers. This data type uses 'S.Set' internally, but 34 | -- the strings are handled case-insensitively. 35 | 36 | newtype ServerSet = ServerSet (S.Set ServerName) 37 | 38 | 39 | -- | Empty set of servers. 40 | 41 | emptyServers :: ServerSet 42 | emptyServers = ServerSet S.empty 43 | 44 | 45 | -- | Add a server to a 'ServerSet'. 46 | 47 | addServer :: ServerName -> ServerSet -> ServerSet 48 | addServer s (ServerSet ss) = ServerSet $ S.insert (B.map toLower s) ss 49 | 50 | 51 | -- | Remove a server from a 'ServerSet'. 52 | 53 | delServer :: ServerName -> ServerSet -> ServerSet 54 | delServer s (ServerSet ss) = ServerSet $ S.delete (B.map toLower s) ss 55 | 56 | 57 | -- | Check whether specified server is in the set. 58 | 59 | isServer :: ServerName -> ServerSet -> Bool 60 | isServer s (ServerSet ss) = S.member (B.map toLower s) ss 61 | 62 | 63 | -- | Build from list. 64 | 65 | serversFromList :: [ServerName] -> ServerSet 66 | serversFromList = ServerSet . S.fromList 67 | 68 | 69 | -- | Convert to list. 70 | 71 | serversToList :: ServerSet -> [ServerName] 72 | serversToList (ServerSet ss) = S.toList ss 73 | -------------------------------------------------------------------------------- /fastirc-0.2.0/Network/FastIRC/Session.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | -- | 4 | -- Module: Network.FastIRC.Session 5 | -- Copyright: (c) 2010 Ertugrul Soeylemez 6 | -- License: BSD3 7 | -- Maintainer: Ertugrul Soeylemez 8 | -- Stability: alpha 9 | -- 10 | -- This module implements a framework for IRC client software. 11 | -- Essentially it consists of a dumb bot, which connects to and stays on 12 | -- an IRC server waiting for commands. 13 | -- 14 | -- Using the 'onEvent' function (or the convenience functions 15 | -- 'onConnect', 'onDisconnect', etc.) you can attach event handlers to 16 | -- certain events. These event handlers are run in the 'Bot' monad, 17 | -- which encapsulates the current state of the bot. 18 | -- 19 | -- Please note that even though unlikely you should expect that parts of 20 | -- this interface will be changed in future revisions. 21 | 22 | module Network.FastIRC.Session 23 | ( -- * Types 24 | Bot, 25 | BotCommand(..), 26 | BotInfo(..), 27 | BotSession, 28 | Event(..), 29 | EventHandler, 30 | Params(..), 31 | 32 | -- * Functions 33 | ircSendCmd, 34 | ircSendMsg, 35 | ircSendString, 36 | onEvent, 37 | sendBotCmd, 38 | startBot, 39 | 40 | -- * Event utility functions 41 | onConnect, 42 | onDisconnect, 43 | onError, 44 | onLoggedIn, 45 | onMessage, 46 | onQuit, 47 | 48 | -- * Bot monad 49 | getBotInfo 50 | ) 51 | where 52 | 53 | import Control.Exception (catch) 54 | import qualified Data.ByteString.Char8 as B 55 | import qualified Data.Map as M 56 | import Control.Applicative 57 | import Control.Concurrent 58 | import Data.Map (Map) 59 | import Data.Unique 60 | import MonadLib 61 | import Network.Fancy 62 | import Network.FastIRC.IO 63 | import Network.FastIRC.Messages 64 | import Network.FastIRC.ServerSet 65 | import Network.FastIRC.Types 66 | import System.IO 67 | 68 | 69 | -- | Bot monad. 70 | 71 | type Bot = ContT () (StateT Config (ReaderT Params IO)) 72 | 73 | 74 | -- | Commands to be sent to the bot. 75 | 76 | data BotCommand 77 | -- | Add an event handler. 78 | = BotAddHandler (EventHandler -> IO ()) (Event -> Bot ()) 79 | | BotDispatch Event -- ^ Dispatch simulated event. 80 | | BotError String -- ^ Simulate an error. 81 | | BotQuit (Maybe CommandArg) -- ^ Send a quit message. 82 | | BotRecv Message -- ^ Simulate receiving of a message. 83 | | BotSendCmd Command -- ^ Send a command to the IRC server. 84 | | BotSendMsg Message -- ^ Send a message to the IRC server. 85 | | BotSendString MsgString -- ^ Send a raw string to the IRC server. 86 | | BotTerminate -- ^ Immediately kill the bot. 87 | 88 | 89 | -- | Runtime bot information. 90 | 91 | data BotInfo = 92 | BotInfo { 93 | botCurrentNick :: Maybe NickName 94 | } 95 | 96 | 97 | -- | Bot session descriptor. 98 | 99 | data BotSession = 100 | BotSession { 101 | botCmdChan :: Chan BotCommand -- ^ Command channel. 102 | } 103 | 104 | 105 | -- | Bot configuration at run-time. 106 | 107 | data Config = 108 | Config { 109 | -- | Event handlers. 110 | botEventHandlers :: Map EventHandler (Event -> Bot ()), 111 | botEventChan :: Chan Event, -- ^ Event channel. 112 | botHandle :: Handle, -- ^ Connection handle. 113 | botInfo :: BotInfo, -- ^ Current information. 114 | botIsQuitting :: Bool, -- ^ Quit command issued? 115 | botKillerThread :: Maybe ThreadId, -- ^ Killer thread. 116 | botServers :: ServerSet, -- ^ Nicknames known to be servers. 117 | botSession :: BotSession -- ^ Session information. 118 | } 119 | 120 | 121 | -- | A bot event. 122 | 123 | data Event 124 | = ConnectedEvent -- ^ Bot connected. 125 | | DisconnectedEvent -- ^ Bot disconnected (either error or on demand). 126 | | ErrorEvent String -- ^ Connection failed or disconnected on error. 127 | | LoggedInEvent -- ^ Bot logged in (received numeric 001). 128 | | MessageEvent Message -- ^ Received message from server. 129 | | QuitEvent -- ^ Bot disconnected on demand. 130 | deriving (Eq, Read, Show) 131 | 132 | 133 | -- | Event handler identifier. 134 | 135 | type EventHandler = Unique 136 | 137 | 138 | -- | Parameters for an IRC client connection. 139 | 140 | data Params = 141 | Params { 142 | botGetNick :: IO NickName, -- ^ IRC nick name generator. 143 | botGetUser :: IO UserName, -- ^ IRC user name generator. 144 | botGetRealName :: IO RealName, -- ^ IRC real name generator. 145 | botPassword :: Maybe CommandArg, -- ^ IRC server password. 146 | botServerAddr :: Address -- ^ IRC server address. 147 | } 148 | 149 | 150 | -- | Core bot management thread. 151 | 152 | botManager :: Params -> Config -> IO () 153 | botManager params cfg = do 154 | -- Initialize bot. 155 | let eventChan = botEventChan $ cfg 156 | cmdChan = botCmdChan . botSession $ cfg 157 | h = botHandle $ cfg 158 | 159 | writeChan eventChan ConnectedEvent 160 | 161 | dispatchThread <- forkIO $ 162 | getChanContents eventChan >>= writeList2Chan cmdChan . map BotDispatch 163 | 164 | netThread <- forkIO $ networkHandler cmdChan (botHandle cfg) 165 | 166 | -- Main loop. 167 | runBot params cfg $ do 168 | sendLogin 169 | forever $ do 170 | bcmd <- inBase $ readChan cmdChan 171 | case bcmd of 172 | BotAddHandler reportId f -> do 173 | hid <- inBase newUnique 174 | handlers <- botEventHandlers <$> get 175 | sets_ (\cfg -> cfg { botEventHandlers = M.insert hid f handlers }) 176 | inBase $ reportId hid 177 | 178 | BotDispatch ev -> do 179 | handlerList <- M.elems . botEventHandlers <$> get 180 | mapM_ ($ ev) handlerList 181 | 182 | BotError err -> do 183 | isQuitting <- botIsQuitting <$> get 184 | unless isQuitting . inBase . writeChan eventChan $ ErrorEvent err 185 | die 186 | 187 | BotQuit reason -> do 188 | inBase $ hPutCommand h (QuitCmd reason) 189 | ktid <- inBase . forkIO $ 190 | threadDelay 1000000 >> 191 | writeChan cmdChan BotTerminate 192 | sets_ $ \cfg -> cfg { botIsQuitting = True, 193 | botKillerThread = Just ktid } 194 | 195 | BotRecv msg -> 196 | inBase (writeChan eventChan $ MessageEvent msg) >> 197 | handleMsg msg 198 | 199 | BotSendCmd cmd -> inBase $ hPutCommand h cmd 200 | BotSendMsg msg -> inBase $ hPutMessage h msg 201 | BotSendString str -> inBase $ B.hPutStr h str 202 | BotTerminate -> die 203 | 204 | -- Clean up. 205 | killThread dispatchThread 206 | killThread netThread 207 | 208 | where 209 | networkHandler :: Chan BotCommand -> Handle -> IO () 210 | networkHandler cmdChan h = do 211 | res <- try $ hGetMessage h 212 | case res of 213 | Left err -> writeChan cmdChan $ BotError (show err) 214 | Right msg -> 215 | writeChan cmdChan (BotRecv msg) >> 216 | networkHandler cmdChan h 217 | 218 | die :: Bot () 219 | die = do 220 | isQuitting <- botIsQuitting <$> get 221 | ktidM <- botKillerThread <$> get 222 | handlerList <- M.elems . botEventHandlers <$> get 223 | when isQuitting $ mapM_ ($ QuitEvent) handlerList 224 | case ktidM of 225 | Just ktid -> inBase $ killThread ktid 226 | Nothing -> return () 227 | mapM_ ($ DisconnectedEvent) handlerList 228 | abort () 229 | 230 | 231 | -- | Default bot information. 232 | 233 | defBotInfo :: BotInfo 234 | defBotInfo = 235 | BotInfo { botCurrentNick = Nothing } 236 | 237 | 238 | -- | Handle an incoming IRC message. 239 | 240 | handleMsg :: Message -> Bot () 241 | handleMsg msg = do 242 | h <- botHandle <$> get 243 | let origin = msgOrigin msg 244 | cmd = msgCommand msg 245 | eventChan <- botEventChan <$> get 246 | 247 | case cmd of 248 | NumericCmd 1 (myNick:_) -> do 249 | inBase $ writeChan eventChan LoggedInEvent 250 | sets_ $ \cfg -> let bi = (botInfo cfg) { botCurrentNick = Just myNick } 251 | in cfg { botInfo = bi } 252 | 253 | PingCmd a b -> inBase $ hPutCommand h (PongCmd a b) 254 | 255 | _ -> return () 256 | 257 | 258 | -- | Send a command to the IRC server. 259 | 260 | ircSendCmd :: BotSession -> Command -> IO () 261 | ircSendCmd bs = sendBotCmd bs . BotSendCmd 262 | 263 | 264 | -- | Send a message (with origin) to the IRC server. Note that IRC 265 | -- servers ignore the origin prefix, so in general you would want to use 266 | -- 'ircSendCmd' instead. 267 | 268 | ircSendMsg :: BotSession -> Message -> IO () 269 | ircSendMsg bs = sendBotCmd bs . BotSendMsg 270 | 271 | 272 | -- | Send a raw message string to the IRC server. This is what most IRC 273 | -- clients call /quote. 274 | 275 | ircSendString :: BotSession -> MsgString -> IO () 276 | ircSendString bs = sendBotCmd bs . BotSendString 277 | 278 | 279 | -- | Add an event handler. 280 | 281 | onEvent :: BotSession -> (Event -> Bot ()) -> IO EventHandler 282 | onEvent bs f = do 283 | let cmdChan = botCmdChan bs 284 | answerVar <- newEmptyMVar 285 | writeChan cmdChan $ BotAddHandler (putMVar answerVar) f 286 | takeMVar answerVar 287 | 288 | 289 | -- | Run a 'Bot' monad computation. 290 | 291 | runBot :: Params -> Config -> Bot () -> IO () 292 | runBot params cfg = 293 | fmap fst . 294 | runReaderT params . 295 | runStateT cfg . 296 | runContT return 297 | 298 | 299 | -- | Send bot command to a bot. 300 | 301 | sendBotCmd :: BotSession -> BotCommand -> IO () 302 | sendBotCmd bs cmd = writeChan (botCmdChan bs) cmd 303 | 304 | 305 | -- | Send login commands. 306 | 307 | sendLogin :: Bot () 308 | sendLogin = do 309 | h <- botHandle <$> get 310 | nick <- asks botGetNick >>= inBase 311 | user <- asks botGetUser >>= inBase 312 | real <- asks botGetRealName >>= inBase 313 | addr <- asks botServerAddr 314 | pass <- asks botPassword 315 | let (host, port) = 316 | case addr of 317 | IP h p -> (B.pack h, B.pack $ show p) 318 | IPv4 h p -> (B.pack h, B.pack $ show p) 319 | IPv6 h p -> (B.pack h, B.pack $ show p) 320 | _ -> ("localhost", "6667") 321 | 322 | inBase $ do 323 | case pass of 324 | Just pwd -> hPutCommand h $ PassCmd pwd 325 | Nothing -> return () 326 | 327 | hPutCommand h $ NickCmd nick Nothing 328 | hPutCommand h $ UserCmd user host port real 329 | 330 | 331 | -- | Launch an IRC bot. 332 | 333 | startBot :: Params -> IO (Either IOError BotSession) 334 | startBot params = do 335 | cmdChan <- newChan 336 | eventChan <- newChan 337 | errorVar <- newEmptyMVar 338 | let session = BotSession { botCmdChan = cmdChan } 339 | 340 | forkIO $ 341 | let comp = 342 | withStream (botServerAddr params) $ \h -> 343 | let cfg = 344 | Config { 345 | botEventHandlers = M.empty, 346 | botEventChan = eventChan, 347 | botHandle = h, 348 | botInfo = defBotInfo, 349 | botIsQuitting = False, 350 | botKillerThread = Nothing, 351 | botServers = emptyServers, 352 | botSession = session 353 | } 354 | in do 355 | hSetBuffering h NoBuffering 356 | putMVar errorVar Nothing 357 | res <- try $ botManager params cfg 358 | case res of 359 | Left err -> do 360 | hPutStrLn stderr "Warning (fastirc): unexpected exception:" 361 | hPrint stderr err 362 | hPutStrLn stderr "Please report this to the author." 363 | Right _ -> return () 364 | in comp `catch` (putMVar errorVar . Just) 365 | 366 | error <- takeMVar errorVar 367 | case error of 368 | Nothing -> return (Right session) 369 | Just err -> return (Left err) 370 | 371 | 372 | -- | Action to run on connect. 373 | onConnect :: BotSession -> Bot () -> IO EventHandler 374 | onConnect bs c = onEvent bs $ \ev -> case ev of ConnectedEvent -> c; _ -> return () 375 | 376 | -- | Action to run on disconnect. 377 | onDisconnect :: BotSession -> Bot () -> IO EventHandler 378 | onDisconnect bs c = onEvent bs $ \ev -> case ev of DisconnectedEvent -> c; _ -> return () 379 | 380 | -- | Action to run on error (connection failed/aborted). 381 | onError :: BotSession -> (String -> Bot ()) -> IO EventHandler 382 | onError bs f = onEvent bs $ \ev -> case ev of ErrorEvent str -> f str; _ -> return () 383 | 384 | -- | Action to run after login (numeric 001 received). 385 | onLoggedIn :: BotSession -> Bot () -> IO EventHandler 386 | onLoggedIn bs c = onEvent bs $ \ev -> case ev of LoggedInEvent -> c; _ -> return () 387 | 388 | -- | Action to run when a message arrives. 389 | onMessage :: BotSession -> (Message -> Bot ()) -> IO EventHandler 390 | onMessage bs f = onEvent bs $ \ev -> case ev of MessageEvent msg -> f msg; _ -> return () 391 | 392 | -- | Action to run on quit. 393 | onQuit :: BotSession -> Bot () -> IO EventHandler 394 | onQuit bs c = onEvent bs $ \ev -> case ev of QuitEvent -> c; _ -> return () 395 | 396 | 397 | -- | Get current bot information. 398 | 399 | getBotInfo :: Bot BotInfo 400 | getBotInfo = botInfo <$> get 401 | -------------------------------------------------------------------------------- /fastirc-0.2.0/Network/FastIRC/Types.hs: -------------------------------------------------------------------------------- 1 | -- | 2 | -- Module: Network.FastIRC.Types 3 | -- Copyright: (c) 2010 Ertugrul Soeylemez 4 | -- License: BSD3 5 | -- Maintainer: Ertugrul Soeylemez 6 | -- Stability: alpha 7 | -- 8 | -- A number of convenient type aliases. 9 | 10 | module Network.FastIRC.Types 11 | ( -- * Types 12 | ChannelKey, 13 | ChannelName, 14 | CommandArg, 15 | CommandName, 16 | HostName, 17 | MsgString, 18 | NickName, 19 | RealName, 20 | ServerName, 21 | TargetName, 22 | UserName 23 | ) 24 | where 25 | 26 | import qualified Data.ByteString.Char8 as B 27 | 28 | 29 | type ChannelKey = B.ByteString 30 | type ChannelName = B.ByteString 31 | type CommandArg = B.ByteString 32 | type CommandName = B.ByteString 33 | type HostName = B.ByteString 34 | type MsgString = B.ByteString 35 | type NickName = B.ByteString 36 | type RealName = B.ByteString 37 | type ServerName = B.ByteString 38 | type TargetName = B.ByteString 39 | type UserName = B.ByteString 40 | -------------------------------------------------------------------------------- /fastirc-0.2.0/Network/FastIRC/Users.hs: -------------------------------------------------------------------------------- 1 | -- | 2 | -- Module: Network.FastIRC.Users 3 | -- Copyright: (c) 2010 Ertugrul Soeylemez 4 | -- License: BSD3 5 | -- Maintainer: Ertugrul Soeylemez 6 | -- Stability: alpha 7 | -- 8 | -- This module includes parsers for IRC users. 9 | 10 | module Network.FastIRC.Users 11 | ( UserSpec(..), 12 | userIsServer, 13 | showUserSpec, 14 | userParser ) 15 | where 16 | 17 | import qualified Data.ByteString.Char8 as B 18 | import Control.Applicative 19 | import Data.Attoparsec.Char8 as P 20 | import Network.FastIRC.ServerSet 21 | import Network.FastIRC.Types 22 | import Network.FastIRC.Utils 23 | 24 | 25 | -- | IRC user or server. 26 | 27 | data UserSpec 28 | -- | Nickname. 29 | = Nick NickName 30 | -- | Nickname, username and hostname. 31 | | User NickName UserName HostName 32 | deriving (Eq, Read, Show) 33 | 34 | 35 | -- | Check whether a given nickname is a server. 36 | 37 | userIsServer :: UserSpec -> ServerSet -> Bool 38 | userIsServer (User _ _ _) _ = False 39 | userIsServer (Nick nick) servers = isServer nick servers 40 | 41 | 42 | -- | Turn a 'UserSpec' into a 'B.ByteString' in a format suitable to be 43 | -- sent to the IRC server. 44 | 45 | showUserSpec :: UserSpec -> MsgString 46 | showUserSpec (Nick n) = n 47 | showUserSpec (User n u h) = B.concat [ n, B.cons '!' u, B.cons '@' h ] 48 | 49 | 50 | -- | A 'Parser' for IRC users and servers. 51 | 52 | userParser :: Parser UserSpec 53 | userParser = 54 | try full <|> nickOnly 55 | 56 | where 57 | full :: Parser UserSpec 58 | full = 59 | User <$> P.takeWhile1 isNickChar <* char '!' 60 | <*> P.takeWhile1 isUserChar <* char '@' 61 | <*> P.takeWhile1 isHostChar 62 | 63 | nickOnly :: Parser UserSpec 64 | nickOnly = Nick <$> P.takeWhile1 isNickChar 65 | -------------------------------------------------------------------------------- /fastirc-0.2.0/Network/FastIRC/Utils.hs: -------------------------------------------------------------------------------- 1 | -- | 2 | -- Module: Network.FastIRC.Utils 3 | -- Copyright: (c) 2010 Ertugrul Soeylemez 4 | -- License: BSD3 5 | -- Maintainer: Ertugrul Soeylemez 6 | -- Stability: alpha 7 | -- 8 | -- Utility functions for parsing IRC messages. 9 | 10 | module Network.FastIRC.Utils 11 | ( -- * Character predicates for IRC 12 | isChannelChar, 13 | isChanPwdChar, 14 | isCommandChar, 15 | isHostChar, 16 | isIRCEOLChar, 17 | isIRCTokChar, 18 | isMessageChar, 19 | isNickChar, 20 | isServerChar, 21 | isUserChar, 22 | isUserSpecChar, 23 | 24 | -- * Other helper functions 25 | parseComplete 26 | ) 27 | where 28 | 29 | import qualified Data.ByteString.Char8 as B 30 | import Data.Attoparsec.Char8 31 | 32 | 33 | -- | Character predicate for channel names. 34 | 35 | isChannelChar :: Char -> Bool 36 | isChannelChar c = isIRCTokChar c && c /= ',' 37 | 38 | 39 | -- | Character predicate for channel passwords. 40 | 41 | isChanPwdChar :: Char -> Bool 42 | isChanPwdChar = isChannelChar 43 | 44 | 45 | -- | Character predicate for IRC commands. 46 | 47 | isCommandChar :: Char -> Bool 48 | isCommandChar = inClass "A-Za-z0-9_" 49 | 50 | 51 | -- | Character predicate for IRC user hostnames. In the string @x!y\@z@ 52 | -- the substring @z@ is the user's hostname. 53 | 54 | isHostChar :: Char -> Bool 55 | isHostChar = isUserSpecChar 56 | 57 | 58 | -- | Character predicate for IRC end of line characters. 59 | 60 | isIRCEOLChar :: Char -> Bool 61 | isIRCEOLChar c = c == '\n' || c == '\r' 62 | 63 | 64 | -- | Character predicate for IRC tokens. 65 | 66 | isIRCTokChar :: Char -> Bool 67 | isIRCTokChar c = c /= ' ' && c /= '\r' && c /= '\n' 68 | 69 | 70 | -- | Character predicate for IRC messages. 71 | 72 | isMessageChar :: Char -> Bool 73 | isMessageChar c = c /= '\n' && c /= '\r' 74 | 75 | 76 | -- | Character predicate for IRC nicknames. This function considers 77 | -- high bytes (0x80 to 0xFF) and most nonstandard ASCII bytes as valid, 78 | -- because most modern IRC daemons allow nonstandard nicknames. 79 | 80 | isNickChar :: Char -> Bool 81 | isNickChar = isUserSpecChar 82 | 83 | 84 | -- | Character predicate for IRC servers. 85 | 86 | isServerChar :: Char -> Bool 87 | isServerChar c = inClass "a-zA-Z0-9.:-" c || c >= '\x80' 88 | 89 | 90 | -- | Character predicate for IRC usernames. In the string @x!y\@z@ the 91 | -- substring @y@ is the user's username. 92 | 93 | isUserChar :: Char -> Bool 94 | isUserChar = isUserSpecChar 95 | 96 | 97 | -- | Character predicate for nicknames, usernames and hostnames. 98 | 99 | isUserSpecChar :: Char -> Bool 100 | isUserSpecChar c = c > '!' && c /= '@' 101 | 102 | 103 | -- | Run a parser completely. 104 | 105 | parseComplete :: Parser a -> B.ByteString -> Maybe a 106 | parseComplete p = complete . parse p 107 | where 108 | complete :: Result a -> Maybe a 109 | complete (Partial f) = complete (f B.empty) 110 | complete (Done _ r) = Just r 111 | complete (Fail _ _ _) = Nothing 112 | -------------------------------------------------------------------------------- /fastirc-0.2.0/Setup.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import Distribution.Simple 4 | 5 | main :: IO () 6 | main = defaultMain 7 | -------------------------------------------------------------------------------- /fastirc-0.2.0/fastirc.cabal: -------------------------------------------------------------------------------- 1 | Name: fastirc 2 | Version: 0.2.0 3 | Category: Network 4 | Synopsis: Fast Internet Relay Chat (IRC) library 5 | Package-URL: http://code.haskell.org/fastirc/ 6 | Maintainer: Ertugrul Söylemez 7 | Author: Ertugrul Söylemez 8 | Copyright: (c) 2010 Ertugrul Söylemez 9 | License: BSD3 10 | License-file: LICENSE 11 | Build-type: Simple 12 | Stability: alpha 13 | Cabal-version: >= 1.6 14 | Description: 15 | Fast Internet Relay Chat (IRC) library. This library implements a 16 | attoparsec-based fast parser for IRC messages as well as a network 17 | manager for IRC clients (user agents and bots). 18 | 19 | Source-repository head 20 | Type: darcs 21 | Location: http://code.haskell.org/fastirc/ 22 | 23 | 24 | Library 25 | Build-depends: 26 | attoparsec >= 0.8, 27 | base >= 4 && < 5, 28 | bytestring >= 0.9.1.4, 29 | bytestring-show >= 0.3.3, 30 | containers >= 0.2.0.1, 31 | monadLib >= 3.6.1, 32 | network-fancy >= 0.1.4 33 | GHC-Options: -W 34 | Extensions: 35 | OverloadedStrings 36 | Exposed-modules: 37 | Network.FastIRC 38 | Network.FastIRC.IO 39 | Network.FastIRC.Messages 40 | Network.FastIRC.ServerSet 41 | Network.FastIRC.Session 42 | Network.FastIRC.Types 43 | Network.FastIRC.Users 44 | Network.FastIRC.Utils 45 | 46 | 47 | -- Executable test 48 | -- Build-depends: base >= 4 && < 5, network 49 | -- Main-is: Test.hs 50 | -- GHC-Options: -W 51 | -- Other-modules: 52 | -- Network.FastIRC 53 | -------------------------------------------------------------------------------- /hulk.cabal: -------------------------------------------------------------------------------- 1 | name: hulk 2 | version: 0.2.0 3 | synopsis: IRC server written in Haskell. 4 | description: An IRC server with (mandatory) server authentication, log recall, bumping. 5 | Intended for private business use or hobby work. See examples/ directory for a demo. 6 | bug-reports: https://github.com/chrisdone/hulk/issues 7 | license: BSD3 8 | stability: Stable 9 | license-file: LICENSE 10 | author: Chris Done 11 | maintainer: chrisdone@gmail.com 12 | copyright: 2010-2013 Chris Done 13 | category: Network 14 | build-type: Simple 15 | cabal-version: >=1.8 16 | extra-source-files: 17 | README.md 18 | example/log/events.log 19 | example/auth/passwd 20 | example/auth/passwd-key 21 | example/txt/PREFACE 22 | example/txt/MOTD 23 | example/hulk.conf 24 | example/users/hulk2 25 | example/users/hulk 26 | 27 | library 28 | exposed-modules: Hulk.Server 29 | Hulk.Options 30 | Hulk.Client 31 | Hulk.Config 32 | Hulk.Types 33 | Hulk.Auth 34 | ghc-options: -O2 -Wall 35 | hs-source-dirs: src 36 | build-depends: utf8-string, 37 | Crypto, 38 | ConfigFile, 39 | mtl, 40 | split, 41 | containers, 42 | cmdargs, 43 | aeson, 44 | bytestring, 45 | case-insensitive, 46 | text, 47 | time, 48 | network, 49 | fastirc, 50 | directory, 51 | filepath, 52 | ghc-prim, 53 | base 54 | 55 | executable hulk 56 | main-is: Server.hs 57 | ghc-options: -threaded -O2 -Wall 58 | hs-source-dirs: src/main 59 | build-depends: cmdargs, 60 | network, 61 | cmdargs, 62 | unix, 63 | hulk, 64 | base 65 | 66 | executable hulk-generate-pass 67 | main-is: GeneratePass.hs 68 | hs-source-dirs: src/main 69 | build-depends: utf8-string, 70 | Crypto, 71 | cmdargs, 72 | hulk, 73 | base 74 | ghc-options: -threaded -O2 -Wall 75 | 76 | source-repository head 77 | type: git 78 | location: https://github.com/chrisdone/hulk.git 79 | -------------------------------------------------------------------------------- /src/Hulk/Auth.hs: -------------------------------------------------------------------------------- 1 | -- | Password authorization for the server. 2 | 3 | module Hulk.Auth 4 | (authenticate 5 | ,sha1) 6 | where 7 | 8 | import Codec.Binary.UTF8.String 9 | import Control.Arrow 10 | 11 | import Data.Char 12 | import Data.HMAC 13 | import Data.Text (Text,unpack) 14 | import Numeric 15 | 16 | -- | Authenticate the user. 17 | authenticate :: String -- ^ Salt. 18 | -> String -- ^ Password file. 19 | -> Text -- ^ User. 20 | -> Text -- ^ Password. 21 | -> Bool -- ^ Authenticated? 22 | authenticate keystr passwords user pass = 23 | any (== (unpack user,sha1 key (unpack pass))) 24 | passwds 25 | 26 | where key = filter keyChars keystr 27 | passwds = getPasswds passwords 28 | 29 | getPasswds = map readPair . lines 30 | where readPair = second (drop 1) . span (/=' ') 31 | keyChars c = elem c ['a'..'z'] || isDigit c 32 | 33 | -- | Make a sha1 string with the given salt. 34 | sha1 :: String -- ^ Salt. 35 | -> String -- ^ String. 36 | -> String -- ^ Hashed string. 37 | sha1 key str = 38 | concat $ map (\x -> showHex x "") 39 | $ hmac_sha1 (encode key) (encode str) 40 | -------------------------------------------------------------------------------- /src/Hulk/Client.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | {-# LANGUAGE RecordWildCards #-} 3 | {-# LANGUAGE ViewPatterns #-} 4 | 5 | -- | This module communicates and manages the state of clients 6 | -- connected to the server. 7 | 8 | module Hulk.Client 9 | where 10 | 11 | import Hulk.Auth 12 | import Hulk.Types 13 | 14 | import Control.Monad.RWS hiding (pass) 15 | import Data.CaseInsensitive (mk) 16 | import Data.Char 17 | import Data.List 18 | import Data.List.Split 19 | import Data.Map (Map) 20 | import qualified Data.Map as M 21 | import Data.Maybe 22 | import qualified Data.Set as S 23 | import Data.Text (Text, pack) 24 | import qualified Data.Text as T 25 | import Data.Text.Encoding (decodeUtf8,encodeUtf8) 26 | import Data.Time hiding (readTime) 27 | import Network.FastIRC (Command (..), CommandArg, Message (..), UserSpec(..)) 28 | import qualified Network.FastIRC as IRC 29 | import Prelude hiding (log) 30 | 31 | -------------------------------------------------------------------------------- 32 | -- * Top-level dispatchers 33 | 34 | -- | Run the client monad. 35 | handleCommand 36 | :: Config -- ^ Server configuration. 37 | -> HulkState -- ^ Server state. 38 | -> UTCTime -- ^ Current time. 39 | -> Conn -- ^ Current client connection. 40 | -> (String,String) -- ^ Authorization info. 41 | -> Command -- ^ The command. 42 | -> ((), HulkState, [HulkWriter]) -- ^ The new transformed state and any instructions. 43 | handleCommand config state' now conn auth cmd = do 44 | runRWS (runHulk (handleCmd cmd)) 45 | (HulkReader now conn config Nothing auth) 46 | state' 47 | 48 | -- | Handle an incoming command. 49 | handleCmd :: Command -- ^ A command which shouldn't be logged (e.g. PASS). 50 | -> Hulk () 51 | handleCmd cmd = do 52 | case cmd of 53 | PassCmd (decodeUtf8 -> pass) -> do 54 | incoming cmd 55 | asUnregistered $ handlePass pass 56 | StringCmd "PINGPONG" _ -> do 57 | incoming cmd 58 | handlePingPong 59 | _ -> handleMsgSafeToLog cmd 60 | 61 | -- | Handle commands that are safe to log. 62 | handleMsgSafeToLog :: Command -- ^ A command which is safe to log 63 | -- (PONG, NICK, etc.). 64 | -> Hulk () 65 | handleMsgSafeToLog cmd = do 66 | incoming cmd 67 | updateLastPong 68 | case cmd of 69 | PongCmd{} -> handlePong 70 | NickCmd (decodeUtf8 -> nick) _ -> handleNick nick 71 | PingCmd (decodeUtf8 -> param) _ -> handlePing param 72 | UserCmd (decodeUtf8 -> user) _ _ (decodeUtf8 -> realname) -> 73 | asUnregistered $ handleUser user realname 74 | QuitCmd mmsg -> 75 | handleQuit RequestedQuit 76 | (maybe "Quit (no message given)" 77 | decodeUtf8 78 | mmsg) 79 | StringCmd "DISCONNECT" _ -> 80 | handleQuit SocketQuit "Connection lost." 81 | _ -> handleMsgReg'd cmd 82 | 83 | -- | Handle commands that can only be used when registered. 84 | handleMsgReg'd :: Command -- ^ A command that users use after 85 | -- registration (e.g. JOIN, PART, etc.). 86 | -> Hulk () 87 | handleMsgReg'd cmd = 88 | asRegistered $ 89 | case cmd of 90 | JoinCmd names -> 91 | mapM_ handleJoin (map decodeUtf8 (M.keys names)) 92 | PartCmd names mmsg -> 93 | mapM_ (flip handlePart (maybe "" decodeUtf8 mmsg)) 94 | (map decodeUtf8 (S.toList names)) 95 | PrivMsgCmd targets msg -> 96 | mapM_ (flip handlePrivmsg (decodeUtf8 msg)) 97 | (map decodeUtf8 (S.toList targets)) 98 | TopicCmd chan (fmap decodeUtf8 -> Just topic) -> handleTopic (decodeUtf8 chan) topic 99 | NoticeCmd targets msg -> 100 | mapM_ (flip handleNotice (decodeUtf8 msg)) 101 | (map decodeUtf8 (S.toList targets)) 102 | -- TODO: Try to get these messages into the fastirc library. 103 | StringCmd "AWAY" (listToMaybe -> mmsg) -> handleAway (fmap decodeUtf8 mmsg) 104 | StringCmd "WHOIS" [nick] -> handleWhoIs (decodeUtf8 nick) 105 | StringCmd "ISON" people -> handleIsOn (map decodeUtf8 people) 106 | StringCmd "NAMES" [chan] -> handleNames (decodeUtf8 chan) 107 | _ -> invalidCmd cmd 108 | 109 | -- | Log an invalid cmd. 110 | invalidCmd :: Command -- ^ The given command that we don't know how to handle. 111 | -> Hulk () 112 | invalidCmd cmd = do 113 | errorReply $ "Invalid or unknown message type, or not" <> 114 | " enough parameters: " <> decodeUtf8 (IRC.showCommand cmd) 115 | 116 | -------------------------------------------------------------------------------- 117 | -- * Command handlers 118 | 119 | -- | Handle the AWAY command. 120 | handleAway :: Maybe Text -> Hulk () 121 | handleAway mmsg = do 122 | ref <- getRef 123 | let adjust client@Client{..} = client { clientAwayMsg = mmsg } 124 | modifyClients $ M.adjust adjust ref 125 | 126 | 127 | -- | Handle the PONG command. This updates the user's “last seen” 128 | -- value on file. 129 | handlePong :: Hulk () 130 | handlePong = do 131 | now <- asks readTime 132 | withRegistered $ \RegUser{regUserUser=user} -> do 133 | tell [UpdateUserData UserData { userDataUser = user 134 | , userDataLastSeen = now 135 | }] 136 | 137 | -- | Handle the PINGPONG event. Disconnect the client if timedout. 138 | handlePingPong :: Hulk () 139 | handlePingPong = do 140 | lastPong <- clientLastPong <$> getClient 141 | now <- asks readTime 142 | let n = diffUTCTime now lastPong 143 | if n > 60*4 144 | then handleQuit RequestedQuit $ "Ping timeout: " <> pack (show n) <> " seconds" 145 | else do hostname <- asks (connServerName . readConn) 146 | thisCmdReply RPL_PING [hostname] 147 | 148 | -- | Handle the PASS message. 149 | handlePass :: Text -> Hulk () 150 | handlePass pass = do 151 | modifyUnregistered $ \u -> u { unregUserPass = Just pass } 152 | notice "Received password." 153 | tryRegister 154 | 155 | -- | Handle the USER message. 156 | handleUser :: Text -> Text -> Hulk () 157 | handleUser user realname = do 158 | withSentPass $ 159 | if validUser user 160 | then do modifyUnregistered $ \u -> u { unregUserUser = Just (UserName (mk user)) 161 | , unregUserName = Just realname } 162 | notice "Recieved user details." 163 | tryRegister 164 | else errorReply "Invalid user format." 165 | 166 | -- | Handle the USER message. 167 | handleNick :: Text -> Hulk () 168 | handleNick nick' = 169 | withSentPass $ 170 | withValidNick nick' $ \nick -> 171 | ifNotMyNick nick $ 172 | ifUniqueNick nick (updateNickAndTryRegistration nick) 173 | Nothing 174 | 175 | where updateNickAndTryRegistration nick = do 176 | ref <- getRef 177 | withRegistered $ \RegUser{regUserNick=rnick} -> 178 | modifyNicks $ M.delete rnick 179 | withUnregistered $ \UnregUser{unregUserNick=rnick} -> 180 | maybe (return ()) (modifyNicks . M.delete) rnick 181 | modifyNicks $ M.insert nick ref 182 | modifyUnregistered $ \u -> u { unregUserNick = Just nick } 183 | tryRegister 184 | asRegistered $ do 185 | thisClientReply RPL_NICK [nickText nick] 186 | (myChannels >>=) $ mapM_ $ \Channel{..} -> do 187 | channelReply channelName RPL_NICK [nickText nick] ExcludeMe 188 | modifyRegistered $ \u -> u { regUserNick = nick } 189 | 190 | -- | Handle the PING message. 191 | handlePing :: Text -> Hulk () 192 | handlePing p = do 193 | hostname <- asks (connServerName . readConn) 194 | thisServerReply RPL_PONG [hostname,p] 195 | 196 | -- | Handle the QUIT message. 197 | handleQuit :: QuitType -> Text -> Hulk () 198 | handleQuit quitType msg = do 199 | clearQuittedUser msg 200 | when (quitType == RequestedQuit) $ 201 | tell [Close] 202 | 203 | -- | Handle the TELL message. 204 | handleTell :: Text -> Text -> Hulk () 205 | handleTell name msg = sendMsgTo RPL_NOTICE name msg 206 | 207 | -- | Handle the NAMES list request. 208 | handleNames :: Text -> Hulk () 209 | handleNames chan = do 210 | withValidChanName chan sendNamesList 211 | 212 | -- | Handle the JOIN message. 213 | handleJoin :: Text -> Hulk () 214 | handleJoin chans = do 215 | let names = T.split (==',') chans 216 | forM_ names $ flip withValidChanName $ \name -> do 217 | exists <- M.member name <$> gets stateChannels 218 | unless exists $ insertChannel name 219 | joined <- inChannel name 220 | unless joined $ joinChannel name 221 | 222 | -- | Handle the PART message. 223 | handlePart :: Text -> Text -> Hulk () 224 | handlePart name msg = 225 | withValidChanName name $ \vname -> do 226 | removeFromChan vname 227 | channelReply vname RPL_PART [msg] IncludeMe 228 | 229 | -- | Handle the TOPIC message. 230 | handleTopic :: Text -> Text -> Hulk () 231 | handleTopic name' topic = 232 | withValidChanName name' $ \name -> do 233 | let setTopic c = c { channelTopic = Just topic } 234 | modifyChannels $ M.adjust setTopic name 235 | channelReply name RPL_TOPIC [channelNameText name,topic] IncludeMe 236 | 237 | -- | Handle the PRIVMSG message. 238 | handlePrivmsg :: Text -> Text -> Hulk () 239 | handlePrivmsg name msg = do 240 | sendMsgTo RPL_PRIVMSG name msg 241 | historyLog RPL_PRIVMSG [name,msg] 242 | 243 | -- | Handle the NOTICE message. 244 | handleNotice :: Text -> Text -> Hulk () 245 | handleNotice name msg = sendMsgTo RPL_NOTICE name msg 246 | 247 | -- | Handle WHOIS message. 248 | handleWhoIs :: Text -> Hulk () 249 | handleWhoIs nick' = 250 | withValidNick nick' $ \nick -> 251 | withClientByNick nick $ \Client{..} -> 252 | withRegUserByNick nick $ \RegUser{..} -> do 253 | thisNickServerReply RPL_WHOISUSER 254 | [nickText regUserNick 255 | ,userText regUserUser 256 | ,clientHostname 257 | ,"*" 258 | ,regUserName] 259 | thisNickServerReply RPL_ENDOFWHOIS 260 | [nickText regUserNick 261 | ,"End of WHOIS list."] 262 | 263 | -- | Handle the ISON ('is on?') message. 264 | handleIsOn :: [Text] -> Hulk () 265 | handleIsOn (catMaybes . map readNick -> nicks') = 266 | asRegistered $ do 267 | online <- catMaybes <$> mapM regUserByNick nicks' 268 | let nicks = T.unwords $ map (nickText.regUserNick) online 269 | unless (T.null nicks) $ thisNickServerReply RPL_ISON [nicks <> " "] 270 | 271 | -------------------------------------------------------------------------------- 272 | -- * General actions 273 | 274 | -- | Send a message to a user or a channel (it figures it out). 275 | sendMsgTo :: RPL -> Text -> Text -> Hulk () 276 | sendMsgTo typ name' msg = 277 | if validChannel name' 278 | then withValidChanName name' $ \name -> 279 | channelReply name typ [channelNameText name,msg] ExcludeMe 280 | else userReply name' typ [name',msg] 281 | 282 | -------------------------------------------------------------------------------- 283 | -- * Users 284 | 285 | -- | Is a username valid? 286 | validUser :: Text -> Bool 287 | validUser = validNick 288 | 289 | -- | Get the username. 290 | getUsername :: Hulk (Maybe UserName) 291 | getUsername = do 292 | user <- getUser 293 | return $ case user of 294 | Unregistered (UnregUser{unregUserUser=username}) -> username 295 | Registered (RegUser{regUserUser=username}) -> Just username 296 | 297 | -- | Get the current connection ref. 298 | getRef :: Hulk Ref 299 | getRef = connRef <$> asks readConn 300 | 301 | -- | Bump off the given nick. 302 | bumpOff :: Nick -> Hulk () 303 | bumpOff nick = ifNotMyNick nick $ do 304 | notice $ "Bumping off user " <> nickText nick <> "…" 305 | withClientByNick nick $ \Client{clientRef=ref} -> 306 | local (\r -> r { readConn = (readConn r) { connRef = ref } }) $ do 307 | clearQuittedUser msg 308 | tell [Bump ref] 309 | 310 | where msg = "Bumped off." 311 | 312 | -- | Clear a quitted user from channels and nick list, and notify 313 | -- people in channels of their leaving. 314 | clearQuittedUser :: Text -> Hulk () 315 | clearQuittedUser msg = do 316 | (myChannels >>=) $ mapM_ $ \Channel{..} -> do 317 | channelReply channelName RPL_QUIT [msg] ExcludeMe 318 | removeFromChan channelName 319 | withRegistered $ \RegUser{regUserNick=nick} -> do 320 | modifyNicks $ M.delete nick 321 | withUnregistered $ \UnregUser{unregUserNick=nick} -> do 322 | maybe (return ()) (modifyNicks . M.delete) nick 323 | ref <- getRef 324 | modifyClients $ M.delete ref 325 | notice msg 326 | 327 | -- | Update the last pong reply time. 328 | updateLastPong :: Hulk () 329 | updateLastPong = do 330 | ref <- getRef 331 | now <- asks readTime 332 | let adjust client@Client{..} = client { clientLastPong = now } 333 | modifyClients $ M.adjust adjust ref 334 | 335 | -- | Send a client reply to a user. 336 | userReply :: Text -> RPL -> [Text] -> Hulk () 337 | userReply nick' typ ps = 338 | withValidNick nick' $ \nick -> 339 | withClientByNick nick $ \Client{..} -> 340 | clientReply clientRef typ ps 341 | 342 | -- | Perform an action with a registered user by its nickname. 343 | withRegUserByNick :: Nick -> (RegUser -> Hulk ()) -> Hulk () 344 | withRegUserByNick nick m = do 345 | user <- regUserByNick nick 346 | case user of 347 | Just user' -> m user' 348 | Nothing -> sendNoSuchNick nick 349 | 350 | -- | Send the RPL_NOSUCHNICK reply. 351 | sendNoSuchNick :: Nick -> Hulk () 352 | sendNoSuchNick nick = 353 | thisServerReply ERR_NOSUCHNICK [nickText nick,"No such nick."] 354 | 355 | -- | Modify the current user. 356 | modifyUser :: (User -> User) -> Hulk () 357 | modifyUser f = do 358 | ref <- getRef 359 | let modUser c = c { clientUser = f (clientUser c) } 360 | modClient = M.adjust modUser ref 361 | modify $ \env -> env { stateClients = modClient (stateClients env) } 362 | 363 | -- | Get the current client's user. 364 | getUser :: Hulk User 365 | getUser = clientUser <$> getClient 366 | 367 | -------------------------------------------------------------------------------- 368 | -- * Clients 369 | 370 | -- | Get the current client. 371 | getClientByRef :: Ref -> Hulk (Maybe Client) 372 | getClientByRef ref = do 373 | clients <- gets stateClients 374 | return $ M.lookup ref clients 375 | 376 | -- | Get a client by nickname. 377 | clientByNick :: Nick -> Hulk (Maybe Client) 378 | clientByNick nick = do 379 | clients <- gets stateClients 380 | (M.lookup nick >=> (`M.lookup` clients)) <$> gets stateNicks 381 | 382 | -- | Perform an action with a client by nickname. 383 | withClientByNick :: Nick -> (Client -> Hulk ()) -> Hulk () 384 | withClientByNick nick m = do 385 | client' <- clientByNick nick 386 | case client' of 387 | Nothing -> sendNoSuchNick nick 388 | Just client@Client{..} 389 | | isRegistered clientUser -> m client 390 | | otherwise -> sendNoSuchNick nick 391 | 392 | -- | Get the current client. 393 | getClient :: Hulk Client 394 | getClient = do 395 | ref <- getRef 396 | clients <- gets stateClients 397 | case M.lookup ref clients of 398 | Just client -> return $ client 399 | Nothing -> makeNewClient 400 | 401 | -- | Modify the clients table. 402 | modifyClients :: (Map Ref Client -> Map Ref Client) -> Hulk () 403 | modifyClients f = modify $ \env -> env { stateClients = f (stateClients env) } 404 | 405 | -- | Make a current client based on the current connection. 406 | makeNewClient :: Hulk Client 407 | makeNewClient = do 408 | Conn{..} <- asks readConn 409 | let client = Client { clientRef = connRef 410 | , clientHostname = connHostname 411 | , clientUser = newUnregisteredUser 412 | , clientLastPong = connTime 413 | , clientAwayMsg = Nothing 414 | } 415 | modifyClients $ M.insert connRef client 416 | return client 417 | 418 | 419 | -------------------------------------------------------------------------------- 420 | -- * Registration 421 | 422 | -- | Get a registered user by nickname. 423 | regUserByNick :: Nick -> Hulk (Maybe RegUser) 424 | regUserByNick nick = do 425 | c <- clientByNick nick 426 | case clientUser <$> c of 427 | Just (Registered u) -> return $ Just u 428 | _ -> return Nothing 429 | 430 | -- | Maybe get a registered user from a client. 431 | clientRegUser :: Client -> Maybe RegUser 432 | clientRegUser Client{..} = 433 | case clientUser of 434 | Registered u -> Just u 435 | _ -> Nothing 436 | 437 | -- | Modify the current user if unregistered. 438 | modifyUnregistered :: (UnregUser -> UnregUser) -> Hulk () 439 | modifyUnregistered f = do 440 | modifyUser $ \user -> 441 | case user of 442 | Unregistered user' -> Unregistered (f user') 443 | u -> u 444 | 445 | -- | Modify the current user if registered. 446 | modifyRegistered :: (RegUser -> RegUser) -> Hulk () 447 | modifyRegistered f = do 448 | modifyUser $ \user -> 449 | case user of 450 | Registered user' -> Registered (f user') 451 | u -> u 452 | 453 | -- | Only perform command if the client is registered. 454 | asRegistered :: Hulk () -> Hulk () 455 | asRegistered m = do 456 | registered <- isRegistered <$> getUser 457 | when registered m 458 | 459 | -- | Perform command with a registered user. 460 | withRegistered :: (RegUser -> Hulk ()) -> Hulk () 461 | withRegistered m = do 462 | user <- getUser 463 | case user of 464 | Registered user' -> m user' 465 | _ -> return () 466 | 467 | -- | With sent pass. 468 | withSentPass :: Hulk () -> Hulk () 469 | withSentPass m = do 470 | asRegistered m 471 | withUnregistered $ \UnregUser{..} -> do 472 | case unregUserPass of 473 | Just{} -> m 474 | Nothing -> return () 475 | 476 | -- | Perform command with a registered user. 477 | withUnregistered :: (UnregUser -> Hulk ()) -> Hulk () 478 | withUnregistered m = do 479 | user <- getUser 480 | case user of 481 | Unregistered user' -> m user' 482 | _ -> return () 483 | 484 | -- | Only perform command if the client is registered. 485 | asUnregistered :: Hulk () -> Hulk () 486 | asUnregistered m = do 487 | registered <- isRegistered <$> getUser 488 | unless registered m 489 | 490 | -- | Is a user registered? 491 | isRegistered :: User -> Bool 492 | isRegistered Registered{} = True 493 | isRegistered _ = False 494 | 495 | 496 | -- | Make a new unregistered user. 497 | newUnregisteredUser :: User 498 | newUnregisteredUser = Unregistered $ UnregUser { 499 | unregUserName = Nothing 500 | ,unregUserNick = Nothing 501 | ,unregUserUser = Nothing 502 | ,unregUserPass = Nothing 503 | } 504 | 505 | -- | Try to register the user with the USER/NICK/PASS that have been given. 506 | tryRegister :: Hulk () 507 | tryRegister = 508 | withUnregistered $ \unreg -> do 509 | check <- isAuthentic unreg 510 | case check of 511 | (True,Just (name,user,nick)) -> do 512 | modifyUser $ \_ -> 513 | Registered $ RegUser name nick user "" 514 | sendWelcome 515 | sendMotd 516 | sendEvents 517 | (False,Just{}) -> errorReply $ "Wrong user/pass." 518 | _ -> return () 519 | 520 | isAuthentic :: UnregUser -> Hulk (Bool,Maybe (Text,UserName,Nick)) 521 | isAuthentic UnregUser{..} = do 522 | let details = (,,,) <$> unregUserName 523 | <*> unregUserNick 524 | <*> unregUserUser 525 | <*> unregUserPass 526 | case details of 527 | Nothing -> return (False,Nothing) 528 | Just (name,nick,user,pass) -> do 529 | (keystr,passwords) <- asks readAuth 530 | let authentic = authenticate keystr passwords (userText user) pass 531 | return (authentic,Just (name,user,nick)) 532 | 533 | -------------------------------------------------------------------------------- 534 | -- * Nicknames 535 | 536 | -- | Read a valid nick. 537 | readNick :: Text -> Maybe Nick 538 | readNick n | validNick n = Just $ NickName (mk n) 539 | | otherwise = Nothing 540 | 541 | -- | Modify the nicks mapping. 542 | modifyNicks :: (Map Nick Ref -> Map Nick Ref) -> Hulk () 543 | modifyNicks f = modify $ \env -> env { stateNicks = f (stateNicks env) } 544 | 545 | -- | With a valid nickname, perform an action. 546 | withValidNick :: Text -> (Nick -> Hulk ()) -> Hulk () 547 | withValidNick nick m 548 | | validNick nick = m (NickName (mk nick)) 549 | | otherwise = errorReply $ "Invalid nick format: " <> nick 550 | 551 | -- | Perform an action if a nickname is unique, otherwise send error. 552 | ifUniqueNick :: Nick -> Hulk () -> Maybe ((Text -> Hulk ()) -> Hulk ()) -> Hulk () 553 | ifUniqueNick nick then_m else_m = do 554 | clients <- gets stateClients 555 | client <- (M.lookup nick >=> (`M.lookup` clients)) <$> gets stateNicks 556 | case client of 557 | Nothing -> then_m 558 | Just{} -> do 559 | case else_m of 560 | Just else_m' -> else_m' error_reply 561 | Nothing -> error_reply "" 562 | 563 | where error_reply x = thisServerReply ERR_NICKNAMEINUSE 564 | [nickText nick,"Nick is already in use." <> x] 565 | 566 | 567 | -- | Is a nickname valid? Digit/letter or one of these: -_/\\;()[]{}?`' 568 | validNick :: Text -> Bool 569 | validNick s = T.all ok s && T.length s > 0 where 570 | ok c = isDigit c || isLetter c || elem c ("-_/\\;()[]{}?`'"::String) 571 | 572 | -- | If the given nick is not my nick name, …. 573 | ifNotMyNick :: Nick -> Hulk () -> Hulk () 574 | ifNotMyNick nick m = do 575 | user <- getUser 576 | case user of 577 | Registered RegUser{..} | regUserNick /= nick -> m 578 | Unregistered UnregUser{..} | unregUserNick /= Just nick -> m 579 | _ -> return () 580 | 581 | -------------------------------------------------------------------------------- 582 | -- * Channels 583 | 584 | -- | Valid channel name? 585 | validChannel :: Text -> Bool 586 | validChannel (T.uncons -> Just ('#',cs)) = T.all ok cs && T.length cs > 0 where 587 | ok c = isDigit c || isLetter c || elem c ("-_/\\;()[]{}?`'"::String) 588 | validChannel _ = False 589 | 590 | -- | Remove a user from a channel. 591 | removeFromChan :: ChannelName -> Hulk () 592 | removeFromChan name = do 593 | ref <- getRef 594 | let remMe c = c { channelUsers = S.delete ref (channelUsers c) } 595 | modifyChannels $ M.adjust remMe name 596 | 597 | -- | Get channels that the current client is in. 598 | myChannels :: Hulk [Channel] 599 | myChannels = do 600 | ref <- getRef 601 | filter (S.member ref . channelUsers) . map snd . M.toList <$> gets stateChannels 602 | 603 | -- | Join a channel. 604 | joinChannel :: ChannelName -> Hulk () 605 | joinChannel name = do 606 | ref <- getRef 607 | let addMe c = c { channelUsers = S.insert ref (channelUsers c) } 608 | modifyChannels $ M.adjust addMe name 609 | channelReply name RPL_JOIN [channelNameText name] IncludeMe 610 | sendNamesList name 611 | withChannel name $ \Channel{..} -> do 612 | case channelTopic of 613 | Just topic -> thisServerReply RPL_TOPIC [channelNameText name,topic] 614 | Nothing -> return () 615 | 616 | -- | Send the names list of a channel. 617 | sendNamesList :: ChannelName -> Hulk () 618 | sendNamesList name = do 619 | asRegistered $ 620 | withChannel name $ \Channel{..} -> do 621 | clients <- catMaybes <$> mapM getClientByRef (S.toList channelUsers) 622 | let nicks = map regUserNick . catMaybes . map clientRegUser $ clients 623 | forM_ (chunksOf 10 nicks) $ \nicks' -> 624 | thisNickServerReply RPL_NAMEREPLY ["@",channelNameText name 625 | ,T.unwords $ map nickText nicks'] 626 | thisNickServerReply RPL_ENDOFNAMES [channelNameText name 627 | ,"End of /NAMES list."] 628 | 629 | -- | Am I in a channel? 630 | inChannel :: ChannelName -> Hulk Bool 631 | inChannel name = do 632 | chan <- M.lookup name <$> gets stateChannels 633 | case chan of 634 | Nothing -> return False 635 | Just Channel{..} -> (`S.member` channelUsers) <$> getRef 636 | 637 | -- | Insert a new channel. 638 | insertChannel :: ChannelName -> Hulk () 639 | insertChannel name = modifyChannels $ M.insert name newChan where 640 | newChan = Channel { channelName = name 641 | , channelTopic = Nothing 642 | , channelUsers = S.empty 643 | } 644 | 645 | -- | Modify the channel map. 646 | modifyChannels :: (Map ChannelName Channel -> Map ChannelName Channel) 647 | -> Hulk () 648 | modifyChannels f = modify $ \e -> e { stateChannels = f (stateChannels e) } 649 | 650 | withValidChanName :: Text -> (ChannelName -> Hulk ()) 651 | -> Hulk () 652 | withValidChanName name m 653 | | validChannel name = m $ ChannelName (mk name) 654 | | otherwise = errorReply $ "Invalid channel name: " <> name 655 | 656 | -- | Perform an action with an existing channel, sends error if not exists. 657 | withChannel :: ChannelName -> (Channel -> Hulk ()) -> Hulk () 658 | withChannel name m = do 659 | chan <- M.lookup name <$> gets stateChannels 660 | case chan of 661 | Nothing -> thisServerReply ERR_NOSUCHCHANNEL [channelNameText name 662 | ,"No such channel."] 663 | Just chan' -> m chan' 664 | 665 | -- | Send a client reply to everyone in a channel. 666 | channelReply :: ChannelName -> RPL -> [Text] 667 | -> ChannelReplyType 668 | -> Hulk () 669 | channelReply name cmd params typ = do 670 | withChannel name $ \Channel{..} -> do 671 | ref <- getRef 672 | forM_ (S.toList channelUsers) $ \theirRef -> do 673 | unless (typ == ExcludeMe && ref == theirRef) $ 674 | clientReply theirRef cmd params 675 | 676 | -------------------------------------------------------------------------------- 677 | -- * Client replies 678 | 679 | -- | Send a client reply to the current client. 680 | thisClientReply :: RPL -> [Text] -> Hulk () 681 | thisClientReply typ params = do 682 | ref <- getRef 683 | clientReply ref typ params 684 | 685 | -- | Send a client reply of the given type with the given params, on 686 | -- the given connection reference. 687 | clientReply :: Ref -> RPL -> [Text] -> Hulk () 688 | clientReply ref typ params = do 689 | withRegistered $ \user -> do 690 | client <- getClient 691 | msg <- newClientMsg client user typ params 692 | reply ref msg 693 | 694 | -- | Make a new IRC message from the current client. 695 | newClientMsg :: Client -> RegUser -> RPL -> [Text] 696 | -> Hulk Message 697 | newClientMsg Client{..} RegUser{..} cmd ps = do 698 | return (Message (Just (User (encodeUtf8 (nickText regUserNick)) 699 | (encodeUtf8 (userText regUserUser)) 700 | (encodeUtf8 clientHostname))) 701 | (makeCommand cmd ps)) 702 | 703 | -------------------------------------------------------------------------------- 704 | -- * Server replies 705 | 706 | -- | Send the welcome message. 707 | sendWelcome :: Hulk () 708 | sendWelcome = do 709 | withRegistered $ \RegUser{..} -> do 710 | thisNickServerReply RPL_WELCOME ["Welcome."] 711 | 712 | -- | Send the MOTD. 713 | sendMotd :: Hulk () 714 | sendMotd = do 715 | asRegistered $ do 716 | thisNickServerReply RPL_MOTDSTART ["MOTD"] 717 | motd <- fmap (fmap T.lines) (asks readMotd) 718 | let motdLine line = thisNickServerReply RPL_MOTD [line] 719 | case motd of 720 | Nothing -> motdLine "None." 721 | Just lines' -> mapM_ motdLine lines' 722 | thisNickServerReply RPL_ENDOFMOTD ["/MOTD."] 723 | 724 | -- | Send events that the user missed. 725 | sendEvents :: Hulk () 726 | sendEvents = do 727 | chans <- configLogChans <$> asks readConfig 728 | unless (null chans) $ do 729 | withRegistered $ \RegUser{regUserUser=user} -> do 730 | ref <- getRef 731 | forM_ chans handleJoin 732 | tell [SendEvents ref user] 733 | 734 | -------------------------------------------------------------------------------- 735 | -- * Output functions 736 | 737 | -- | Send a message reply. 738 | notice :: Text -> Hulk () 739 | notice msg = thisServerReply RPL_NOTICE ["*",msg] 740 | 741 | thisNickServerReply :: RPL -> [Text] -> Hulk () 742 | thisNickServerReply typ params = do 743 | withRegistered $ \RegUser{regUserNick=nick} -> 744 | thisServerReply typ (nickText nick : params) 745 | 746 | -- | Send a server reply of the given type with the given params. 747 | thisServerReply :: RPL -> [Text] -> Hulk () 748 | thisServerReply typ params = do 749 | ref <- getRef 750 | serverReply ref typ params 751 | 752 | -- | Send a server reply of the given type with the given params. 753 | serverReply :: Ref -> RPL -> [Text] -> Hulk () 754 | serverReply ref typ params = do 755 | msg <- newServerMsg typ params 756 | reply ref msg 757 | 758 | -- | Make a new IRC message from the server. 759 | newServerMsg :: RPL -> [Text] -> Hulk Message 760 | newServerMsg cmd ps = do 761 | hostname <- asks (connServerName.readConn) 762 | return (Message (Just (Nick (encodeUtf8 hostname))) 763 | (makeCommand cmd ps)) 764 | 765 | -- | Send a cmd reply of the given type with the given params. 766 | thisCmdReply :: RPL -> [Text] -> Hulk () 767 | thisCmdReply typ params = do 768 | ref <- getRef 769 | cmdReply ref typ params 770 | 771 | -- | Send a cmd reply of the given type with the given params. 772 | cmdReply :: Ref -> RPL -> [Text] -> Hulk () 773 | cmdReply ref typ params = do 774 | let msg = newCmdMsg typ params 775 | reply ref msg 776 | 777 | -- | Send an error reply. 778 | errorReply :: Text -> Hulk () 779 | errorReply m = do 780 | notice $ "ERROR: " <> m 781 | log $ "ERROR: " <> m 782 | 783 | -- | Send a message reply. 784 | reply :: Ref -> Message -> Hulk () 785 | reply ref msg = do 786 | outgoing msg 787 | tell . return $ MessageReply ref msg 788 | 789 | -- | Log an incoming line. 790 | incoming :: Command -> Hulk () 791 | incoming = log . ("<- " <>) . decodeUtf8 . IRC.showCommand 792 | 793 | -- | Log an outgoing line. 794 | outgoing :: Message -> Hulk () 795 | outgoing msg = do 796 | ref <- getRef 797 | tell [outgoingWriter ref msg] 798 | 799 | -- | Log a line. 800 | log :: Text -> Hulk () 801 | log line = do 802 | ref <- getRef 803 | tell . return . LogReply $ pack (show (unRef ref)) <> ": " <> line 804 | 805 | -- | Make a writer reply. 806 | outgoingWriter :: Ref -> Message -> HulkWriter 807 | outgoingWriter ref = 808 | LogReply . 809 | (pack (show (unRef ref)) <>) . 810 | (": -> " <>) . 811 | decodeUtf8 . 812 | IRC.showMessage 813 | 814 | historyLog :: RPL -> [Text] -> Hulk () 815 | historyLog rpl params = do 816 | chans <- asks (configLogChans . readConfig) 817 | unless (null chans) $ do 818 | withRegistered $ \RegUser{regUserUser=name} -> do 819 | let send = tell [SaveLog (userText name) rpl params] 820 | case (rpl,params) of 821 | (RPL_PRIVMSG,[chan]) 822 | | chan `elem` chans -> send 823 | | otherwise -> return () 824 | _ -> send 825 | 826 | -------------------------------------------------------------------------------- 827 | -- * Command Construction 828 | 829 | -- | Make a command. 830 | makeCommand :: RPL -> [Text] -> Command 831 | makeCommand rpl xs = fromRPL rpl (map encodeUtf8 xs) 832 | 833 | -- | Convert from a reply to an appropriate protocol format. 834 | fromRPL :: RPL -> ([CommandArg] -> Command) 835 | fromRPL RPL_NICK = StringCmd "NICK" 836 | fromRPL RPL_PONG = StringCmd "PONG" 837 | fromRPL RPL_QUIT = StringCmd "QUIT" 838 | fromRPL RPL_JOIN = StringCmd "JOIN" 839 | fromRPL RPL_NOTICE = StringCmd "NOTICE" 840 | fromRPL RPL_PART = StringCmd "PART" 841 | fromRPL RPL_PRIVMSG = StringCmd "PRIVMSG" 842 | fromRPL RPL_JOINS = StringCmd "JOIN" 843 | fromRPL RPL_TOPIC = StringCmd "TOPIC" 844 | fromRPL RPL_PING = StringCmd "PING" 845 | fromRPL RPL_WHOISUSER = NumericCmd 311 846 | fromRPL RPL_ISON = NumericCmd 303 847 | fromRPL RPL_NAMEREPLY = NumericCmd 353 848 | fromRPL RPL_ENDOFNAMES = NumericCmd 366 849 | fromRPL RPL_WELCOME = NumericCmd 001 850 | fromRPL RPL_MOTDSTART = NumericCmd 375 851 | fromRPL RPL_MOTD = NumericCmd 372 852 | fromRPL RPL_ENDOFMOTD = NumericCmd 376 853 | fromRPL RPL_WHOISIDLE = NumericCmd 317 854 | fromRPL RPL_WHOISCHANNELS = NumericCmd 319 855 | fromRPL RPL_ENDOFWHOIS = NumericCmd 318 856 | fromRPL ERR_NICKNAMEINUSE = NumericCmd 433 857 | fromRPL ERR_NOSUCHNICK = NumericCmd 401 858 | fromRPL ERR_NOSUCHCHANNEL = NumericCmd 403 859 | 860 | -- | Make a new IRC message from the cmd. 861 | newCmdMsg :: RPL -> [Text] -> Message 862 | newCmdMsg cmd ps = Message Nothing (makeCommand cmd ps) 863 | -------------------------------------------------------------------------------- /src/Hulk/Config.hs: -------------------------------------------------------------------------------- 1 | -- | Configuration parser for the server. 2 | 3 | module Hulk.Config 4 | (Config(..) 5 | ,getConfig) 6 | where 7 | 8 | import Hulk.Types 9 | 10 | import Data.Word 11 | import Data.ConfigFile 12 | import Data.Text (pack) 13 | 14 | getConfig :: FilePath -> IO Config 15 | getConfig conf = do 16 | contents <- readFile conf 17 | let config = do 18 | c <- readstring emptyCP contents 19 | hostname <- get c "LISTEN" "hostname" 20 | listen <- get c "LISTEN" "port" 21 | motd <- get c "STRINGS" "motd_file" 22 | preface <- get c "STRINGS" "preface_file" 23 | passwd <- get c "AUTH" "passwd_file" 24 | key <- get c "AUTH" "passwd_key" 25 | users <- get c "USERS" "data_dir" 26 | logs <- get c "LOGS" "event_log" 27 | chans <- fmap words $ get c "LOGS" "channels" 28 | return Config 29 | { configListen = fromIntegral (listen::Word16) 30 | , configMotd = Just motd 31 | , configHostname = pack hostname 32 | , configPasswd = passwd 33 | , configPasswdKey = key 34 | , configPreface = Just preface 35 | , configUserData = users 36 | , configLogFile = logs 37 | , configLogChans = map pack chans 38 | } 39 | case config of 40 | Left cperr -> error $ show cperr 41 | Right config' -> return config' 42 | -------------------------------------------------------------------------------- /src/Hulk/Options.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveDataTypeable, RecordWildCards, ScopedTypeVariables #-} 2 | {-# OPTIONS -Wall -fno-warn-missing-signatures #-} 3 | module Hulk.Options (Options 4 | ,options 5 | ,optionsConf) where 6 | 7 | import System.Console.CmdArgs 8 | 9 | data Options = Options 10 | { conf :: FilePath 11 | } deriving (Show,Data,Typeable) 12 | 13 | options = Options 14 | { conf = def &= opt "hulk.conf" &= help "The config file." 15 | } 16 | &= summary "Hulk IRC Daemon (C) Chris Done 2011" 17 | &= help "Runs an IRC server based on the provided configuration file." 18 | 19 | optionsConf = conf -------------------------------------------------------------------------------- /src/Hulk/Server.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | {-# LANGUAGE RecordWildCards #-} 3 | {-# LANGUAGE ScopedTypeVariables #-} 4 | 5 | module Hulk.Server where 6 | 7 | import Hulk.Client (handleCommand, makeCommand, 8 | outgoingWriter) 9 | import Hulk.Types 10 | 11 | import Control.Applicative 12 | import Control.Concurrent 13 | import Control.Exception 14 | import Control.Exception (IOException, try) 15 | import Control.Monad 16 | import Control.Monad.Fix 17 | import Data.Aeson 18 | import qualified Data.ByteString.Char8 as S8 19 | import qualified Data.ByteString.Lazy as L 20 | import qualified Data.ByteString.Lazy.Char8 as L8 21 | import Data.CaseInsensitive 22 | import Data.Char 23 | import Data.Maybe 24 | import Data.Monoid 25 | import Data.Text (Text, pack, unpack) 26 | import qualified Data.Text as T 27 | import Data.Text.Encoding (encodeUtf8) 28 | import qualified Data.Text.IO as T 29 | import Data.Time 30 | import Network 31 | import Network.FastIRC hiding (UserName) 32 | import qualified Network.FastIRC.IO as IRC 33 | import System.Directory 34 | import System.FilePath 35 | import System.IO 36 | 37 | -- | Start an IRC server with the given configuration. 38 | start :: Config -> IO () 39 | start config = withSocketsDo $ do 40 | hSetBuffering stdout LineBuffering 41 | listenSock <- listenOn $ PortNumber (configListen config) 42 | statevar <- newMVar HulkState { stateClients = mempty 43 | , stateNicks = mempty 44 | , stateChannels = mempty } 45 | lvar <- newMVar () 46 | forever $ do 47 | (handle,host,_port) <- accept listenSock 48 | hSetBuffering handle NoBuffering 49 | now <- getCurrentTime 50 | let conn = Conn { connRef = mkRef handle 51 | , connHostname = pack host 52 | , connServerName = configHostname config 53 | , connTime = now 54 | } 55 | auth <- getAuth config 56 | void $ forkIO $ handleClient lvar config handle statevar auth conn 57 | 58 | -- | Handle a client connection. 59 | handleClient :: MVar () -> Config -> Handle -> MVar HulkState -> (String,String) -> Conn -> IO () 60 | handleClient lvar config handle env auth conn = do 61 | messages <- newChan 62 | let writeMsg cmd = 63 | writeChan messages (Message Nothing (StringCmd cmd [])) 64 | 65 | pinger <- forkIO $ forever $ do 66 | threadDelay (1000 * 1000 * 60 * 2) 67 | writeMsg "PINGPONG" 68 | 69 | void $ forkIO $ fix $ \loop -> do 70 | eline <- try (S8.hGetLine handle) 71 | case eline of 72 | Left (_::IOException) -> do killThread pinger 73 | writeMsg "DISCONNECT" 74 | Right line -> 75 | case readMessage line of 76 | Just msg -> do writeChan messages msg 77 | loop 78 | Nothing -> loop 79 | 80 | fix $ \loop -> do 81 | msg <- readChan messages 82 | runClientHandler lvar config env handle conn auth msg 83 | case msg of 84 | Message _ (StringCmd "DISCONNECT" _) -> return () 85 | _ -> loop 86 | 87 | -- | Handle a received message from the client. 88 | runClientHandler :: MVar () -> Config -> MVar HulkState -> Handle -> Conn -> (String,String) -> Message -> IO () 89 | runClientHandler lvar config mstate handle conn auth msg = do 90 | now <- getCurrentTime 91 | instructions <- modifyMVar mstate $ \state -> return $ 92 | let ((),newstate,instructions) = handleCommand config state now conn auth (msgCommand msg) 93 | in (newstate,instructions) 94 | forM_ instructions $ \i -> 95 | do result <- try (handleWriter lvar config handle i) 96 | case result of 97 | Left e -> putStrLn ("handleWriter exception: " ++ show (e :: SomeException) ++ " for " ++ show i) 98 | Right () -> return () 99 | 100 | -- | Act on writer from the client. 101 | handleWriter :: MVar () -> Config -> Handle -> HulkWriter -> IO () 102 | handleWriter lvar config@Config{..} handle writer = do 103 | case writer of 104 | SaveLog name rpl params -> saveToLog lvar config name rpl params 105 | MessageReply ref msg -> sendMessage ref msg 106 | LogReply line -> logLine line 107 | Close -> hClose handle 108 | Bump (Ref h) -> hClose h 109 | UpdateUserData udata -> do 110 | L.writeFile (configUserData normalizeUser (unpack (userText (userDataUser udata)))) 111 | (encode udata) 112 | SendEvents ref user -> do 113 | writers <- sendEvents config ref user 114 | mapM_ (handleWriter lvar config handle) (concat writers) 115 | 116 | -- | Send a message to a client. 117 | sendMessage :: Ref -> Message -> IO () 118 | sendMessage (Ref handle) msg = 119 | void $ (try $ IRC.hPutMessage handle msg :: IO (Either IOException ())) 120 | 121 | -- | Add a line to the log file. 122 | logLine :: Text -> IO () 123 | logLine = T.putStrLn 124 | 125 | -- | Normalize the username for a filename. 126 | normalizeUser :: [Char] -> [Char] 127 | normalizeUser = filter (\c -> isDigit c || isLetter c) 128 | 129 | -- | Send events that the user missed. 130 | sendEvents :: Config -> Ref -> UserName -> IO [[HulkWriter]] 131 | sendEvents config ref user = do 132 | events <- getLog config 133 | UserData{userDataLastSeen=lastSeen} <- getUser config (userText user) 134 | let filtered = flip filter events $ \(time,_from,_typ,_params) -> 135 | time >. lastSeen 136 | forM filtered $ \msg -> do 137 | case msg of 138 | (time,from',rpl@RPL_PRIVMSG,[name,msg']) 139 | | name == userText user || "#" `T.isPrefixOf` name -> do 140 | let from = T.filter (\c -> isDigit c || isLetter c) from' 141 | user' = User (encodeUtf8 from) 142 | (encodeUtf8 from) 143 | "offline" 144 | message = Message (Just user') 145 | (makeCommand rpl 146 | [name,"[" <> pack (show time) <> "] " <> msg']) 147 | return [MessageReply ref message 148 | ,outgoing message] 149 | _ -> return [] 150 | 151 | where x >. y = x `diffUTCTime` y > 0 152 | outgoing msg = outgoingWriter ref msg 153 | 154 | -- | Get the log. 155 | getLog :: FromJSON b => Config -> IO [b] 156 | getLog Config{..} = do 157 | contents <- L.readFile configLogFile 158 | return $ mapMaybe decode $ L8.lines contents 159 | 160 | -- | Get the user data. 161 | getUser :: Config -> Text -> IO UserData 162 | getUser Config{..} name = do 163 | let fname = configUserData normalizeUser (unpack name) 164 | now <- getCurrentTime 165 | exists <- doesFileExist fname 166 | if exists 167 | then do contents <- L.readFile fname 168 | case decode contents of 169 | Just u -> return u 170 | Nothing -> error ("unable to parse user file: " ++ fname) 171 | else return $ UserData (UserName (mk name)) now 172 | 173 | -- | Get authorization info. 174 | getAuth :: Config -> IO (String,String) 175 | getAuth Config{..} = 176 | (,) <$> readFile configPasswdKey 177 | <*> readFile configPasswd 178 | 179 | -- | Save the message to the log. 180 | saveToLog :: MVar () -> Config -> Text -> RPL -> [Text] -> IO () 181 | saveToLog lvar Config{..} name rpl params = do 182 | now <- getCurrentTime 183 | withMVar lvar $ const $ 184 | L.appendFile configLogFile $ 185 | encode ((now,name,rpl,params)) <> "\n" 186 | -------------------------------------------------------------------------------- /src/Hulk/Types.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveFunctor #-} 2 | {-# LANGUAGE DeriveGeneric #-} 3 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 4 | {-# LANGUAGE OverloadedStrings #-} 5 | {-# LANGUAGE RecordWildCards #-} 6 | 7 | module Hulk.Types 8 | (Config (..) 9 | ,Nick (..) -- FIXME: 10 | ,nickText 11 | ,UserName (..) -- FIXME: 12 | ,userText 13 | ,ChannelName (..) -- FIXME: 14 | ,nickToUserName 15 | ,channelNameText 16 | ,Channel (..) 17 | ,Client (..) 18 | ,User (..) 19 | ,UnregUser (..) 20 | ,RegUser (..) 21 | ,Ref (..) 22 | ,mkRef 23 | ,UserData (..) 24 | ,Conn (..) 25 | ,Event (..) 26 | ,RPL (..) 27 | ,QuitType (..) 28 | ,ChannelReplyType (..) 29 | ,Hulk 30 | ,HulkT 31 | ,runHulk 32 | ,HulkReader(..) 33 | ,HulkWriter(..) 34 | ,HulkState(..)) 35 | where 36 | 37 | import Control.Monad.Identity 38 | import Control.Monad.RWS 39 | import Data.Aeson 40 | import Data.CaseInsensitive 41 | import Data.Map (Map) 42 | import Data.Ord 43 | import Data.Set (Set) 44 | import Data.Text (Text) 45 | import Data.Time 46 | import GHC.Generics 47 | import Network 48 | import Network.FastIRC (Message) 49 | import System.IO 50 | 51 | -------------------------------------------------------------------------------- 52 | -- Configuration 53 | 54 | -- | Server configuration. 55 | data Config = Config 56 | { configListen :: !PortNumber 57 | , configHostname :: !Text 58 | , configMotd :: !(Maybe FilePath) 59 | , configPreface :: !(Maybe FilePath) 60 | , configPasswd :: !FilePath 61 | , configPasswdKey :: !FilePath 62 | , configUserData :: !FilePath 63 | , configLogFile :: !FilePath 64 | , configLogChans :: ![Text] 65 | } deriving (Show) 66 | 67 | -------------------------------------------------------------------------------- 68 | -- Fundamental IRC data types 69 | 70 | -- | A case-insensitive nickname. 71 | newtype Nick = NickName (CI Text) 72 | deriving (Show,Eq,Ord) 73 | 74 | -- | Extract the text of a nickname for use in output. 75 | nickText :: Nick -> Text 76 | nickText (NickName ci) = original ci 77 | 78 | -- | A case-insensitive username. 79 | newtype UserName = UserName (CI Text) 80 | deriving (Show,Eq,Ord,Generic) 81 | 82 | instance ToJSON UserName where 83 | toJSON (UserName ci) = toJSON (original ci) 84 | instance FromJSON UserName where 85 | parseJSON = fmap (UserName . mk) . parseJSON 86 | 87 | -- | Extract the text of a username for use in output. 88 | userText :: UserName -> Text 89 | userText (UserName ci) = original ci 90 | 91 | -- | Convert a nick to a username. 92 | nickToUserName :: Nick -> UserName 93 | nickToUserName = UserName . mk . nickText 94 | 95 | -- | A case-insensitive channel name. 96 | newtype ChannelName = ChannelName (CI Text) 97 | deriving (Show,Eq,Ord) 98 | 99 | -- | Extract the text of a channelname for use in output. 100 | channelNameText :: ChannelName -> Text 101 | channelNameText (ChannelName ci) = original ci 102 | 103 | -------------------------------------------------------------------------------- 104 | -- Server state types 105 | 106 | -- | A channel. 107 | data Channel = Channel 108 | { channelName :: !ChannelName 109 | , channelTopic :: !(Maybe Text) 110 | , channelUsers :: !(Set Ref) 111 | } deriving (Show) 112 | 113 | -------------------------------------------------------------------------------- 114 | -- Client data types 115 | 116 | -- | A connected client. 117 | data Client = Client 118 | { clientRef :: !Ref 119 | , clientUser :: !User 120 | , clientHostname :: !Text 121 | , clientLastPong :: !UTCTime 122 | , clientAwayMsg :: !(Maybe Text) 123 | } deriving (Show) 124 | 125 | -- | Some user, either unregistered or registered. 126 | data User 127 | = Unregistered UnregUser 128 | | Registered RegUser 129 | deriving Show 130 | 131 | -- | An unregistered user. 132 | data UnregUser = UnregUser 133 | { unregUserName :: !(Maybe Text) 134 | , unregUserNick :: !(Maybe Nick) 135 | , unregUserUser :: !(Maybe UserName) 136 | , unregUserPass :: !(Maybe Text) 137 | } deriving (Show) 138 | 139 | -- | A registered user. 140 | data RegUser = RegUser 141 | { regUserName :: !Text 142 | , regUserNick :: !Nick 143 | , regUserUser :: !UserName 144 | , regUserPass :: !Text 145 | } deriving (Show) 146 | 147 | -- | A reference for a client. 148 | newtype Ref = Ref { unRef :: Handle } 149 | deriving (Show,Eq) 150 | 151 | -- | Make a ref. 152 | mkRef :: Handle -> Ref 153 | mkRef = Ref 154 | 155 | -- | Use for refs in maps. 156 | instance Ord Ref where 157 | compare = comparing show 158 | 159 | -- | Data saved about a user for later actions like log recall. 160 | data UserData = UserData 161 | { userDataUser :: !UserName 162 | , userDataLastSeen :: !UTCTime 163 | } deriving (Show,Generic) 164 | 165 | instance ToJSON UserData 166 | instance FromJSON UserData 167 | 168 | -------------------------------------------------------------------------------- 169 | -- Client handling types 170 | 171 | -- | The Hulk client monad. 172 | newtype HulkT m a = Hulk { runHulk :: RWST HulkReader [HulkWriter] HulkState m a } 173 | deriving (Monad, 174 | Functor, 175 | Applicative, 176 | MonadReader HulkReader, 177 | MonadWriter [HulkWriter], 178 | MonadState HulkState) 179 | 180 | type Hulk = HulkT Identity 181 | 182 | -- | Configuration/environment information for running the client 183 | -- handler. 184 | data HulkReader = HulkReader 185 | { readTime :: !UTCTime 186 | , readConn :: !Conn 187 | , readConfig :: !Config 188 | , readMotd :: !(Maybe Text) 189 | , readAuth :: !(String,String) 190 | } deriving (Show) 191 | 192 | -- | State of the whole server, which the client handles. 193 | data HulkState = HulkState 194 | { stateClients :: !(Map Ref Client) 195 | , stateNicks :: !(Map Nick Ref) 196 | , stateChannels :: !(Map ChannelName Channel) 197 | } deriving (Show) 198 | 199 | -- | Replies are generated by the client after some messages. 200 | data HulkWriter 201 | = MessageReply !Ref !Message 202 | | LogReply !Text 203 | | Close 204 | | Bump !Ref 205 | | UpdateUserData !UserData 206 | | SaveLog !Text !RPL ![Text] 207 | | SendEvents !Ref !UserName 208 | deriving (Show) 209 | 210 | -- | Used when handling a line from a client. 211 | data Conn = Conn 212 | { connRef :: !Ref 213 | , connHostname :: !Text 214 | , connServerName :: !Text 215 | , connTime :: !UTCTime 216 | } deriving (Show) 217 | 218 | -- | An incoming client message. 219 | data Event 220 | = PASS 221 | | USER 222 | | NICK 223 | | PING 224 | | QUIT 225 | | TELL 226 | | JOIN 227 | | PART 228 | | PRIVMSG 229 | | NOTICE 230 | | ISON 231 | | WHOIS 232 | | TOPIC 233 | | CONNECT 234 | | DISCONNECT 235 | | PINGPONG 236 | | PONG 237 | | NAMES 238 | | NOTHING 239 | deriving (Show,Read) 240 | 241 | -- | An outgoing server reply. 242 | data RPL 243 | = RPL_WHOISUSER 244 | | RPL_NICK 245 | | RPL_PONG 246 | | RPL_JOIN 247 | | RPL_QUIT 248 | | RPL_NOTICE 249 | | RPL_PART 250 | | RPL_PRIVMSG 251 | | RPL_ISON 252 | | RPL_JOINS 253 | | RPL_TOPIC 254 | | RPL_NAMEREPLY 255 | | RPL_ENDOFNAMES 256 | | ERR_NICKNAMEINUSE 257 | | RPL_WELCOME 258 | | RPL_MOTDSTART 259 | | RPL_MOTD 260 | | RPL_ENDOFMOTD 261 | | RPL_WHOISIDLE 262 | | RPL_ENDOFWHOIS 263 | | RPL_WHOISCHANNELS 264 | | ERR_NOSUCHNICK 265 | | ERR_NOSUCHCHANNEL 266 | | RPL_PING 267 | deriving (Show,Generic) 268 | 269 | instance ToJSON RPL 270 | instance FromJSON RPL 271 | 272 | -- | When quitting it can either be due to user request, ping timeout, 273 | -- or the socket was closed. 274 | data QuitType 275 | = RequestedQuit 276 | | SocketQuit 277 | deriving (Show,Eq) 278 | 279 | -- | When sending a channel reply, it can either include the current 280 | -- client or exclude them (e.g. when the client sends a message, it's 281 | -- no use echoing it back to that user). 282 | data ChannelReplyType 283 | = IncludeMe 284 | | ExcludeMe 285 | deriving (Show,Eq) 286 | -------------------------------------------------------------------------------- /src/main/GeneratePass.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveDataTypeable, RecordWildCards, ScopedTypeVariables #-} 2 | {-# OPTIONS -Wall -fno-warn-missing-signatures -fno-warn-name-shadowing #-} 3 | module Main where 4 | 5 | import Hulk.Types 6 | import Hulk.Config 7 | 8 | import Codec.Binary.UTF8.String 9 | import Control.Applicative 10 | import Data.Char 11 | import Data.HMAC 12 | import Numeric 13 | import System.Console.CmdArgs 14 | 15 | data Options = Options 16 | { conf :: FilePath 17 | , user :: String 18 | } deriving (Show,Data,Typeable) 19 | 20 | options = Options 21 | { conf = def &= opt "hulk.conf" &= help "The config file." 22 | , user = "demo" 23 | } 24 | &= summary "Hulk IRC Daemon Password Generator (C) Chris Done 2011" 25 | &= help "Generates a password entry line for the Hulk passwd file." 26 | 27 | optionsConf = conf 28 | 29 | main = do 30 | options <- cmdArgs options 31 | config <- getConfig $ optionsConf options 32 | let keyFile = configPasswdKey config 33 | key <- takeWhile digilet <$> readFile keyFile 34 | pass <- filter (/='\n') <$> getLine 35 | putStrLn $ ((user options ++ " ") ++) 36 | $ concat $ map (\x -> showHex x "") 37 | $ hmac_sha1 (encode key) (encode pass) 38 | 39 | where digilet c = isDigit c || isLetter c 40 | -------------------------------------------------------------------------------- /src/main/Server.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS -Wall -fno-warn-missing-signatures #-} 2 | module Main where 3 | 4 | import Network 5 | import System.Console.CmdArgs 6 | import System.Posix 7 | 8 | import Hulk.Config (getConfig) 9 | import Hulk.Options (options,optionsConf) 10 | import Hulk.Server (start) 11 | import Hulk.Types () 12 | 13 | main :: IO () 14 | main = withSocketsDo $ do 15 | _ <- installHandler sigPIPE Ignore Nothing 16 | cmdArgs options >>= getConfig . optionsConf >>= start 17 | -------------------------------------------------------------------------------- /stack.yaml: -------------------------------------------------------------------------------- 1 | packages: 2 | - . 3 | - fastirc-0.2.0 4 | resolver: lts-6.27 5 | extra-deps: 6 | - Crypto-4.2.5.1 7 | - fastirc-0.2.0 8 | - bytestring-show-0.3.5.6 9 | - network-fancy-0.2.4 10 | 11 | --------------------------------------------------------------------------------