diff --git a/hulk.cabal b/hulk.cabal --- a/hulk.cabal +++ b/hulk.cabal @@ -1,5 +1,5 @@ Name: hulk -Version: 0.1 +Version: 0.1.1 Synopsis: IRC daemon. Description: An IRC daemon with mandatory authentication. License: BSD3 @@ -14,6 +14,11 @@ Executable hulk Main-is: Main.hs + Other-Modules: Control.Concurrent.Delay, Control.Monad.IO, + Data.String, + Hulk.Auth, Hulk.Client, Hulk.Concurrent, Hulk.Config, + Hulk.Event, Hulk.Log, Hulk.Options, Hulk.Providers, + Hulk.Server, Hulk.Types Ghc-options: -threaded Hs-Source-Dirs: src Build-depends: base >= 4 && <5 @@ -31,6 +36,11 @@ Executable hulk-generate-pass Main-is: GeneratePass.hs + Other-Modules: Control.Concurrent.Delay, Control.Monad.IO, + Data.String, + Hulk.Auth, Hulk.Client, Hulk.Concurrent, Hulk.Config, + Hulk.Event, Hulk.Log, Hulk.Options, Hulk.Providers, + Hulk.Server, Hulk.Types Hs-Source-Dirs: src Build-depends: base >= 4 && <5 ,cmdargs >= 0.6 && <0.7 diff --git a/src/Control/Concurrent/Delay.hs b/src/Control/Concurrent/Delay.hs new file mode 100644 --- /dev/null +++ b/src/Control/Concurrent/Delay.hs @@ -0,0 +1,10 @@ +module Control.Concurrent.Delay where + +import Control.Concurrent + +delaySeconds :: Integer -> IO () +delaySeconds 0 = return () +delaySeconds n = do threadDelay (1000 * 1000); delaySeconds (n-1) + +delayMinutes :: Integer -> IO () +delayMinutes = delaySeconds . (*60) diff --git a/src/Control/Monad/IO.hs b/src/Control/Monad/IO.hs new file mode 100644 --- /dev/null +++ b/src/Control/Monad/IO.hs @@ -0,0 +1,6 @@ +module Control.Monad.IO (io) where + +import Control.Monad.Trans + +io :: MonadIO m => IO a -> m a +io = liftIO diff --git a/src/Data/String.hs b/src/Data/String.hs new file mode 100644 --- /dev/null +++ b/src/Data/String.hs @@ -0,0 +1,8 @@ +module Data.String where + +import Data.List +import Data.Char + +downcase = map toLower + +digilet c = isDigit c || isLetter c diff --git a/src/Hulk/Auth.hs b/src/Hulk/Auth.hs new file mode 100644 --- /dev/null +++ b/src/Hulk/Auth.hs @@ -0,0 +1,25 @@ +{-# OPTIONS -Wall -fno-warn-name-shadowing #-} +module Hulk.Auth where + +import Codec.Binary.UTF8.String +import Control.Arrow +import Control.Monad +import Data.Char +import Data.HMAC +import Numeric + +import Hulk.Types + +sha1 :: String -> String -> String +sha1 key str = + concat $ map (\x -> showHex x "") + $ hmac_sha1 (encode key) (encode str) + +authenticate :: MonadProvider m => String -> String -> m Bool +authenticate user pass = do + key <- filter keyChars `liftM` provideKey + passwds <- liftM getPasswds $ providePasswords + return $ any (== (user,sha1 key pass)) passwds + where getPasswds = map readPair . lines + where readPair = second (drop 1) . span (/=' ') + keyChars c = elem c ['a'..'z'] || isDigit c diff --git a/src/Hulk/Client.hs b/src/Hulk/Client.hs new file mode 100644 --- /dev/null +++ b/src/Hulk/Client.hs @@ -0,0 +1,697 @@ +{-# LANGUAGE RecordWildCards, ViewPatterns #-} +{-# OPTIONS -Wall -fno-warn-name-shadowing #-} +module Hulk.Client + (handleLine) + where + +import Control.Applicative +import Control.Monad.Reader +import Control.Monad.State +import Control.Monad.Writer +import Data.Char +import Data.List.Split +import Data.Map (Map) +import qualified Data.Map as M +import Data.Maybe +import Data.Time +import Network.IRC hiding (Channel) +import Prelude hiding (log) + +import Hulk.Auth +import Hulk.Event +import Hulk.Types + +-- Entry point handler + +-- | Handle an incoming line, try to parse it and handle the message. +handleLine :: MonadProvider m + => Env -> UTCTime -> Conn -> String + -> m ([Reply],Env) +handleLine env now conn line = runClient env now conn $ + case decode line of + Just Message{..} -> handleMsg line (readEventType msg_command,msg_params) + Nothing -> errorReply $ "Unable to parse " ++ show line + +-- | Run the client monad. +runClient :: MonadProvider m + => Env -> UTCTime -> Conn -> IRC m () + -> m ([Reply],Env) +runClient env now conn m = do + flip runStateT env $ + execWriterT $ + flip runReaderT (now,conn) $ + runIRC m + +-- | Handle an incoming message. +handleMsg :: MonadProvider m => String -> (Event,[String]) -> IRC m () +handleMsg line msg = do + case msg of + (NOTHING,_) -> invalidMessage line + (PASS,[pass]) -> asUnregistered $ handlePass pass + (PINGPONG,_) -> do incoming line; handlePingPong + safeToLog -> handleMsgSafeToLog line safeToLog + +-- | Handle messages that are safe to log. +handleMsgSafeToLog :: MonadProvider m => String -> (Event,[String]) + -> IRC m () +handleMsgSafeToLog line safeToLog = do + incoming line + updateLastPong + case safeToLog of + (PONG,_) -> return () + (USER,[user,_,_,realname]) -> asUnregistered $ handleUser user realname + (NICK,[nick]) -> handleNick nick + (PING,[param]) -> handlePing param + (QUIT,[msg]) -> handleQuit RequestedQuit msg + (TELL,[to,msg]) -> handleTell to msg + (DISCONNECT,[msg]) -> handleQuit SocketQuit msg + (CONNECT,_) -> handleConnect + mustBeReg'd -> handleMsgReg'd line mustBeReg'd + +-- | Handle messages that can only be used when registered. +handleMsgReg'd :: Monad m => String -> (Event,[String]) -> IRC m () +handleMsgReg'd line mustBeReg'd = + asRegistered $ + case mustBeReg'd of + (JOIN,(name:_)) -> handleJoin name + (PART,[chan,msg]) -> handlePart chan msg + (PRIVMSG,[to,msg]) -> handlePrivmsg to msg + (TOPIC,[chan,topic]) -> handleTopic chan topic + (NOTICE,[to,msg]) -> handleNotice to msg + (WHOIS,(nick:_)) -> handleWhoIs nick + (ISON,people) -> handleIsOn people + _ -> invalidMessage line + +-- | Log an invalid message. +invalidMessage :: Monad m => String -> IRC m () +invalidMessage line = do + incoming line + errorReply $ "Invalid or unknown message type, or not" ++ + " enough parameters: " ++ show line + +-- Message handlers + +-- | Handle the PINGPONG event. Disconnect the client if timedout. +handlePingPong :: Monad m => IRC m () +handlePingPong = do + lastPong <- clientLastPong <$> getClient + now <- asks fst + let n = diffUTCTime now lastPong + if n > 60*4 + then handleQuit RequestedQuit $ "Ping timeout: " ++ show n ++ " seconds" + else do hostname <- asks $ connServerName . snd + thisCmdReply RPL_PING [hostname] + +-- | Handle the CONNECT event. +handleConnect :: MonadProvider m => IRC m () +handleConnect = do + motd <- fmap lines <$> lift providePreface + case motd of + Nothing -> return () + Just lines -> mapM_ notice lines + +-- | Handle the PASS message. +handlePass :: MonadProvider m => String -> IRC m () +handlePass pass = do + modifyUnregistered $ \u -> u { unregUserPass = Just pass } + notice "Received password." + tryRegister + +-- | Handle the USER message. +handleUser :: MonadProvider m => String -> String -> IRC m () +handleUser user realname = do + withSentPass $ + if validUser user + then do modifyUnregistered $ \u -> u { unregUserUser = Just user + , unregUserName = Just realname } + notice "Recieved user details." + tryRegister + else errorReply "Invalid user format." + +-- | Handle the USER message. +handleNick :: MonadProvider m => String -> IRC m () +handleNick nick = + withSentPass $ + withValidNick nick $ \nick -> + ifUniqueNick nick $ do + ref <- getRef + withRegistered $ \RegUser{regUserNick=nick} -> + modifyNicks $ M.delete nick + withUnegistered $ \UnregUser{unregUserNick=nick} -> + maybe (return ()) (modifyNicks . M.delete) nick + modifyNicks $ M.insert nick ref + modifyUnregistered $ \u -> u { unregUserNick = Just nick } + tryRegister + asRegistered $ do + thisClientReply RPL_NICK [unNick nick] + (myChannels >>=) $ mapM_ $ \Channel{..} -> do + channelReply channelName RPL_NICK [unNick nick] ExcludeMe + modifyRegistered $ \u -> u { regUserNick = nick } + +-- | Handle the PING message. +handlePing :: Monad m => String -> IRC m () +handlePing p = do + hostname <- asks $ connServerName . snd + thisServerReply RPL_PONG [hostname,p] + +-- | Handle the QUIT message. +handleQuit :: Monad m => QuitType -> String -> IRC m () +handleQuit quitType msg = do + (myChannels >>=) $ mapM_ $ \Channel{..} -> do + channelReply channelName RPL_QUIT [msg] ExcludeMe + removeFromChan channelName + withRegistered $ \RegUser{regUserNick=nick} -> do + modifyNicks $ M.delete nick + withUnegistered $ \UnregUser{unregUserNick=nick} -> do + maybe (return ()) (modifyNicks . M.delete) nick + ref <- getRef + modifyClients $ M.delete ref + notice msg + when (quitType == RequestedQuit) $ tell [Close] + +-- | Handle the TELL message. +handleTell :: Monad m => String -> String -> IRC m () +handleTell name msg = sendMsgTo RPL_NOTICE name msg + +-- | Handle the JOIN message. +handleJoin :: Monad m => String -> IRC m () +handleJoin chans = do + let names = splitWhen (==',') chans + forM_ names $ flip withValidChanName $ \name -> do + exists <- M.member name <$> gets envChannels + unless exists $ insertChannel name + joined <- inChannel name + unless joined $ joinChannel name + +-- | Handle the PART message. +handlePart :: Monad m => String -> String -> IRC m () +handlePart name msg = + withValidChanName name $ \name -> do + removeFromChan name + channelReply name RPL_PART [msg] IncludeMe + +-- | Remove a user from a channel. +removeFromChan :: Monad m => ChannelName -> IRC m () +removeFromChan name = do + ref <- getRef + let remMe c = c { channelUsers = filter (/=ref) (channelUsers c) } + modifyChannels $ M.adjust remMe name + +-- | Handle the TOPIC message. +handleTopic :: Monad m => String -> String -> IRC m () +handleTopic name topic = + withValidChanName name $ \name -> do + let setTopic c = c { channelTopic = Just topic } + modifyChannels $ M.adjust setTopic name + channelReply name RPL_TOPIC [unChanName name,topic] IncludeMe + +-- | Handle the PRIVMSG message. +handlePrivmsg :: Monad m => String -> String -> IRC m () +handlePrivmsg name msg = sendMsgTo RPL_PRIVMSG name msg + +-- | Handle the NOTICE message. +handleNotice :: Monad m => String -> String -> IRC m () +handleNotice name msg = sendMsgTo RPL_NOTICE name msg + +-- | Handle WHOIS message. +handleWhoIs :: Monad m => String -> IRC m () +handleWhoIs nick = + withValidNick nick $ \nick -> + withClientByNick nick $ \Client{..} -> + withRegUserByNick nick $ \RegUser{..} -> do + thisNickServerReply RPL_WHOISUSER + [unNick regUserNick + ,regUserUser + ,clientHostname + ,"*" + ,regUserName] + thisNickServerReply RPL_ENDOFWHOIS + [unNick regUserNick + ,"End of WHOIS list."] + +-- | Handle the ISON ('is on?') message. +handleIsOn :: Monad m => [String] -> IRC m () +handleIsOn (catMaybes . map readNick -> nicks) = + asRegistered $ do + online <- catMaybes <$> mapM regUserByNick nicks + let nicks = unwords $ map (unNick.regUserNick) online + unless (null nicks) $ thisNickServerReply RPL_ISON [nicks ++ " "] + +-- Generic message functions + +-- | Send a message to a user or a channel (it figures it out). +sendMsgTo :: Monad m => RPL -> String -> String -> IRC m () +sendMsgTo typ name msg = + if validChannel name + then withValidChanName name $ \name -> + channelReply name typ [unChanName name,msg] ExcludeMe + else userReply name typ [name,msg] + +-- Channel functions + +-- | Get channels that the current client is in. +myChannels :: Monad m => IRC m [Channel] +myChannels = do + ref <- getRef + filter (elem ref . channelUsers) . map snd . M.toList <$> gets envChannels + +-- | Join a channel. +joinChannel :: Monad m => ChannelName -> IRC m () +joinChannel name = do + ref <- getRef + let addMe c = c { channelUsers = channelUsers c ++ [ref] } + modifyChannels $ M.adjust addMe name + channelReply name RPL_JOIN [unChanName name] IncludeMe + sendNamesList name + withChannel name $ \Channel{..} -> do + case channelTopic of + Just topic -> thisServerReply RPL_TOPIC [unChanName name,topic] + Nothing -> return () + +-- | Send the names list of a channel. +sendNamesList :: Monad m => ChannelName -> IRC m () +sendNamesList name = do + asRegistered $ + withChannel name $ \Channel{..} -> do + clients <- catMaybes <$> mapM getClientByRef channelUsers + let nicks = map regUserNick . catMaybes . map clientRegUser $ clients + forM_ (splitEvery 10 nicks) $ \nicks -> + thisNickServerReply RPL_NAMEREPLY ["@",unChanName name + ,unwords $ map unNick nicks] + thisNickServerReply RPL_ENDOFNAMES [unChanName name + ,"End of /NAMES list."] + +-- | Am I in a channel? +inChannel :: Monad m => ChannelName -> IRC m Bool +inChannel name = do + chan <- M.lookup name <$> gets envChannels + case chan of + Nothing -> return False + Just Channel{..} -> (`elem` channelUsers) <$> getRef + +-- | Insert a new channel. +insertChannel :: Monad m => ChannelName -> IRC m () +insertChannel name = modifyChannels $ M.insert name newChan where + newChan = Channel { channelName = name + , channelTopic = Nothing + , channelUsers = [] + } + +-- | Modify the channel map. +modifyChannels :: Monad m + => (Map ChannelName Channel -> Map ChannelName Channel) + -> IRC m () +modifyChannels f = modify $ \e -> e { envChannels = f (envChannels e) } + +-- | Perform an action with an existing channel, sends error if not exists. +withChannel :: Monad m => ChannelName -> (Channel -> IRC m ()) -> IRC m () +withChannel name m = do + chan <- M.lookup name <$> gets envChannels + case chan of + Nothing -> thisServerReply ERR_NOSUCHCHANNEL [unChanName name + ,"No such channel."] + Just chan -> m chan + +withValidChanName :: Monad m => String -> (ChannelName -> IRC m ()) + -> IRC m () +withValidChanName name m + | validChannel name = m $ ChannelName name + | otherwise = errorReply $ "Invalid channel name: " ++ name + +-- Client/user access functions + +-- | Update the last pong reply time. +updateLastPong :: Monad m => IRC m () +updateLastPong = do + ref <- getRef + now <- asks fst + let adjust client@Client{..} = client { clientLastPong = now } + modifyClients $ M.adjust adjust ref + +-- | Read a valid nick. +readNick :: String -> Maybe Nick +readNick n | validNick n = Just $ Nick n + | otherwise = Nothing + +-- | Modify the nicks mapping. +modifyNicks :: Monad m => (Map Nick Ref -> Map Nick Ref) -> IRC m () +modifyNicks f = modify $ \env -> env { envNicks = f (envNicks env) } + +-- | With a valid nickname, perform an action. +withValidNick :: Monad m => String -> (Nick -> IRC m ()) -> IRC m () +withValidNick nick m + | validNick nick = m (Nick nick) + | otherwise = errorReply $ "Invalid nick format: " ++ nick + +-- | Perform an action if a nickname is unique, otherwise send error. +ifUniqueNick :: Monad m => Nick -> IRC m () -> IRC m () +ifUniqueNick nick m = do + clients <- gets envClients + client <- (M.lookup nick >=> (`M.lookup` clients)) <$> gets envNicks + case client of + Nothing -> m + Just{} -> thisServerReply ERR_NICKNAMEINUSE + [unNick nick,"Nick is already in use."] + +-- | Try to register the user with the USER/NICK/PASS that have been given. +tryRegister :: MonadProvider m => IRC m () +tryRegister = + withUnegistered $ \UnregUser{..} -> do + let details = (,,,) <$> unregUserName + <*> unregUserNick + <*> unregUserUser + <*> unregUserPass + case details of + Nothing -> return () + Just (name,nick,user,pass) -> do + authentic <- lift $ authenticate user pass + if not authentic + then errorReply $ "Wrong user/pass." + else do modifyUser $ \_ -> + Registered $ RegUser name nick user pass + sendWelcome + sendMotd + +-- | Send a client reply to a user. +userReply :: Monad m => String -> RPL -> [String] -> IRC m () +userReply nick typ ps = + withValidNick nick $ \nick -> + withClientByNick nick $ \Client{..} -> + clientReply clientRef typ ps + +-- | Perform an action with a client by nickname. +withClientByNick :: Monad m => Nick -> (Client -> IRC m ()) -> IRC m () +withClientByNick nick m = do + client <- clientByNick nick + case client of + Nothing -> sendNoSuchNick nick + Just client@Client{..} + | isRegistered clientUser -> m client + | otherwise -> sendNoSuchNick nick + +-- | Perform an action with a registered user by its nickname. +withRegUserByNick :: Monad m => Nick -> (RegUser -> IRC m ()) -> IRC m () +withRegUserByNick nick m = do + user <- regUserByNick nick + case user of + Just user -> m user + Nothing -> sendNoSuchNick nick + +-- | Send the RPL_NOSUCHNICK reply. +sendNoSuchNick :: Monad m => Nick -> IRC m () +sendNoSuchNick nick = + thisServerReply ERR_NOSUCHNICK [unNick nick,"No such nick."] + +-- | Get a registered user by nickname. +regUserByNick :: Monad m => Nick -> IRC m (Maybe RegUser) +regUserByNick nick = do + c <- clientByNick nick + case clientUser <$> c of + Just (Registered u) -> return $ Just u + _ -> return Nothing + +-- | Get a client by nickname. +clientByNick :: Monad m => Nick -> IRC m (Maybe Client) +clientByNick nick = do + clients <- gets envClients + (M.lookup nick >=> (`M.lookup` clients)) <$> gets envNicks + +-- | Maybe get a registered user from a client. +clientRegUser :: Client -> Maybe RegUser +clientRegUser Client{..} = + case clientUser of + Registered u -> Just u + _ -> Nothing + +-- | Modify the current user if unregistered. +modifyUnregistered :: Monad m => (UnregUser -> UnregUser) -> IRC m () +modifyUnregistered f = do + modifyUser $ \user -> + case user of + Unregistered user -> Unregistered (f user) + u -> u + +-- | Modify the current user if registered. +modifyRegistered :: Monad m => (RegUser -> RegUser) -> IRC m () +modifyRegistered f = do + modifyUser $ \user -> + case user of + Registered user -> Registered (f user) + u -> u + +-- | Modify the current user. +modifyUser :: Monad m => (User -> User) -> IRC m () +modifyUser f = do + ref <- getRef + let modUser c = c { clientUser = f (clientUser c) } + modClient = M.adjust modUser ref + modify $ \env -> env { envClients = modClient (envClients env) } + +-- | Only perform command if the client is registered. +asRegistered :: Monad m => IRC m () -> IRC m () +asRegistered m = do + registered <- isRegistered <$> getUser + when registered m + +-- | Perform command with a registered user. +withRegistered :: Monad m => (RegUser -> IRC m ()) -> IRC m () +withRegistered m = do + user <- getUser + case user of + Registered user -> m user + _ -> return () + +-- | With sent pass. +withSentPass :: Monad m => IRC m () -> IRC m () +withSentPass m = do + asRegistered m + withUnegistered $ \UnregUser{..} -> do + case unregUserPass of + Just{} -> m + Nothing -> return () + +-- | Perform command with a registered user. +withUnegistered :: Monad m => (UnregUser -> IRC m ()) -> IRC m () +withUnegistered m = do + user <- getUser + case user of + Unregistered user -> m user + _ -> return () + +-- | Only perform command if the client is registered. +asUnregistered :: Monad m => IRC m () -> IRC m () +asUnregistered m = do + registered <- isRegistered <$> getUser + unless registered m + +-- | Is a user registered? +isRegistered :: User -> Bool +isRegistered Registered{} = True +isRegistered _ = False + +-- | Get the current client's user. +getUser :: Monad m => IRC m User +getUser = clientUser <$> getClient + +-- | Get the current client. +getClientByRef :: Monad m => Ref -> IRC m (Maybe Client) +getClientByRef ref = do + clients <- gets envClients + return $ M.lookup ref clients + +-- | Get the current client. +getClient :: Monad m => IRC m Client +getClient = do + ref <- getRef + clients <- gets envClients + case M.lookup ref clients of + Just client -> return $ client + Nothing -> makeNewClient + +-- | Modify the clients table. +modifyClients :: Monad m => (Map Ref Client -> Map Ref Client) -> IRC m () +modifyClients f = modify $ \env -> env { envClients = f (envClients env) } + +-- | Make a current client based on the current connection. +makeNewClient :: Monad m => IRC m Client +makeNewClient = do + Conn{..} <- asks snd + let client = Client { clientRef = connRef + , clientHostname = connHostname + , clientUser = newUnregisteredUser + , clientLastPong = connTime } + modifyClients $ M.insert connRef client + return client + +-- | Make a new unregistered user. +newUnregisteredUser :: User +newUnregisteredUser = Unregistered $ UnregUser { + unregUserName = Nothing + ,unregUserNick = Nothing + ,unregUserUser = Nothing + ,unregUserPass = Nothing + } + +-- Channel replies + +-- | Send a client reply to everyone in a channel. +channelReply :: Monad m => ChannelName -> RPL -> [String] + -> ChannelReplyType + -> IRC m () +channelReply name cmd params typ = do + withChannel name $ \Channel{..} -> do + ref <- getRef + forM_ channelUsers $ \theirRef -> do + unless (typ == ExcludeMe && ref == theirRef) $ + clientReply theirRef cmd params + +-- Client replies + +-- | Send a client reply to the current client. +thisClientReply :: Monad m => RPL -> [String] -> IRC m () +thisClientReply typ params = do + ref <- getRef + clientReply ref typ params + +-- | Send a client reply of the given type with the given params, on +-- the given connection reference. +clientReply :: Monad m => Ref -> RPL -> [String] -> IRC m () +clientReply ref typ params = do + withRegistered $ \user -> do + client <- getClient + msg <- newClientMsg client user typ params + reply ref msg + +-- | Make a new IRC message from the current client. +newClientMsg :: Monad m => Client -> RegUser -> RPL -> [String] + -> IRC m Message +newClientMsg Client{..} RegUser{..} cmd ps = do + let nickName = NickName (unNick regUserNick) + (Just regUserUser) + (Just clientHostname) + return $ Message { + msg_prefix = Just $ nickName + ,msg_command = fromRPL cmd + ,msg_params = ps + } + +-- Server replies + +-- | Send the welcome message. +sendWelcome :: Monad m => IRC m () +sendWelcome = do + withRegistered $ \RegUser{..} -> do + thisNickServerReply RPL_WELCOME ["Welcome."] + +-- | Send the MOTD. +sendMotd :: MonadProvider m => IRC m () +sendMotd = do + asRegistered $ do + thisNickServerReply RPL_MOTDSTART ["MOTD"] + motd <- fmap lines <$> lift provideMotd + let motdLine line = thisNickServerReply RPL_MOTD [line] + case motd of + Nothing -> motdLine "None." + Just lines -> mapM_ motdLine lines + thisNickServerReply RPL_ENDOFMOTD ["/MOTD."] + +-- | Send a message reply. +notice :: Monad m => String -> IRC m () +notice msg = thisServerReply RPL_NOTICE ["*",msg] + +thisNickServerReply :: Monad m => RPL -> [String] -> IRC m () +thisNickServerReply typ params = do + withRegistered $ \RegUser{regUserNick=Nick nick} -> + thisServerReply typ (nick : params) + +-- | Send a server reply of the given type with the given params. +thisServerReply :: Monad m => RPL -> [String] -> IRC m () +thisServerReply typ params = do + ref <- getRef + serverReply ref typ params + +-- | Send a server reply of the given type with the given params. +serverReply :: Monad m => Ref -> RPL -> [String] -> IRC m () +serverReply ref typ params = do + msg <- newServerMsg typ params + reply ref msg + +-- | Make a new IRC message from the server. +newServerMsg :: Monad m => RPL -> [String] -> IRC m Message +newServerMsg cmd ps = do + hostname <- asks $ connServerName . snd + return $ Message { + msg_prefix = Just $ Server hostname + ,msg_command = fromRPL cmd + ,msg_params = ps + } + +-- | Send a cmd reply of the given type with the given params. +thisCmdReply :: Monad m => RPL -> [String] -> IRC m () +thisCmdReply typ params = do + ref <- getRef + cmdReply ref typ params + +-- | Send a cmd reply of the given type with the given params. +cmdReply :: Monad m => Ref -> RPL -> [String] -> IRC m () +cmdReply ref typ params = do + msg <- newCmdMsg typ params + reply ref msg + +-- | Make a new IRC message from the cmd. +newCmdMsg :: Monad m => RPL -> [String] -> IRC m Message +newCmdMsg cmd ps = do + return $ Message { + msg_prefix = Nothing + ,msg_command = fromRPL cmd + ,msg_params = ps + } + +-- | Get the current connection ref. +getRef :: Monad m => IRC m Ref +getRef = asks $ connRef . snd + +-- Output functions + +-- | Send an error reply. +errorReply :: Monad m => String -> IRC m () +errorReply m = do + notice $ "ERROR: " ++ m + log $ "ERROR: " ++ m + +-- | Send a message reply. +reply :: Monad m => Ref -> Message -> IRC m () +reply ref msg = do + outgoing $ encode msg + tell . return $ MessageReply ref msg + +-- | Log an incoming line. +incoming :: Monad m => String -> IRC m () +incoming = log . ("<- " ++) + +-- | Log an outgoing line. +outgoing :: Monad m => String -> IRC m () +outgoing = log . ("-> " ++) + +-- | Log a line. +log :: Monad m => String -> IRC m () +log line = do + ref <- getRef + tell . return . LogReply $ show (unRef ref) ++ ": " ++ line + +-- Validation functions + +-- | Is a username valid? +validUser :: String -> Bool +validUser = validNick + +-- | Is a nickname valid? Digit/letter or one of these: -_/\\;()[]{}?`' +validNick :: String -> Bool +validNick s = all ok s && length s > 0 where + ok c = isDigit c || isLetter c || elem c "-_/\\;()[]{}?`'" + +-- | Valid channel name? +validChannel :: String -> Bool +validChannel ('#':cs) = all ok cs && length cs > 0 where + ok c = isDigit c || isLetter c || elem c "-_/\\;()[]{}?`'" +validChannel _ = False diff --git a/src/Hulk/Concurrent.hs b/src/Hulk/Concurrent.hs new file mode 100644 --- /dev/null +++ b/src/Hulk/Concurrent.hs @@ -0,0 +1,18 @@ +module Hulk.Concurrent where + +import Control.Concurrent +import Control.Monad.Reader +import Control.Monad.IO + +import Hulk.Types + +fork :: Hulk a -> Hulk ThreadId +fork m = do + env <- ask + io $ forkIO $ do _ <- runReaderT (runHulk m) env + return () + +withVar :: MVar a -> (a -> Hulk b) -> Hulk b +withVar var m = do + env <- ask + io $ withMVar var $ \var -> runReaderT (runHulk (m var)) env diff --git a/src/Hulk/Config.hs b/src/Hulk/Config.hs new file mode 100644 --- /dev/null +++ b/src/Hulk/Config.hs @@ -0,0 +1,32 @@ +{-# OPTIONS -Wall -fno-warn-missing-signatures -fno-warn-name-shadowing #-} +module Hulk.Config + (Config(..) + ,getConfig) + where + +import Data.Word +import Data.ConfigFile + +import Hulk.Types + +getConfig :: FilePath -> IO Config +getConfig conf = do + contents <- readFile conf + let config = do + c <- readstring emptyCP contents + hostname <- get c "LISTEN" "hostname" + listen <- get c "LISTEN" "port" + motd <- get c "STRINGS" "motd_file" + preface <- get c "STRINGS" "preface_file" + passwd <- get c "AUTH" "passwd_file" + key <- get c "AUTH" "passwd_key" + return Config { configListen = fromIntegral (listen::Word16) + , configMotd = Just motd + , configHostname = hostname + , configPasswd = passwd + , configPasswdKey = key + , configPreface = Just preface + } + case config of + Left cperr -> error $ show cperr + Right config -> return config diff --git a/src/Hulk/Event.hs b/src/Hulk/Event.hs new file mode 100644 --- /dev/null +++ b/src/Hulk/Event.hs @@ -0,0 +1,9 @@ +module Hulk.Event where + +import Hulk.Types + +readEventType :: String -> Event +readEventType str = + case reads str of + [(a,"")] -> a + _ -> NOTHING diff --git a/src/Hulk/Log.hs b/src/Hulk/Log.hs new file mode 100644 --- /dev/null +++ b/src/Hulk/Log.hs @@ -0,0 +1,49 @@ +module Hulk.Log + (doing + ,tell + ,performing + ,incoming + ,outgoing + ,note) + where + +import Control.Monad.Reader +import Control.Concurrent +import System.IO +import Control.Monad.IO +import qualified System.IO.UTF8 as UTF8 + +import Hulk.Types +import Hulk.Config + +instance Loggable Hulk where + tell str = do + h <- asks envTellHandle + col <- (*2) `fmap` asks envLogColumn + io $ withMVar h $ \h -> hPutStrLn h $ replicate col ' ' ++ str + +instance Loggable IRC where + tell str = liftHulk $ tell str + +performing :: String -> Hulk a -> Hulk a +performing str m = do + doing str + v <- indent m + tell "Done." + return v + +doing :: String -> Hulk () +doing str = tell $ str ++ " ..." + +indent :: Hulk a -> Hulk a +indent = local inc where + inc env = env { envLogColumn = envLogColumn env + 1 } + +incoming :: String -> IRC () +incoming str = tell $ "<- " ++ str + +outgoing :: String -> IRC () +outgoing str = tell $ "-> " ++ str + +note :: String -> IRC () +note str = tell $ "Notice: " ++ str diff --git a/src/Hulk/Options.hs b/src/Hulk/Options.hs new file mode 100644 --- /dev/null +++ b/src/Hulk/Options.hs @@ -0,0 +1,19 @@ +{-# LANGUAGE DeriveDataTypeable, RecordWildCards, ScopedTypeVariables #-} +{-# OPTIONS -Wall -fno-warn-missing-signatures #-} +module Hulk.Options (Options + ,options + ,optionsConf) where + +import System.Console.CmdArgs + +data Options = Options + { conf :: FilePath + } deriving (Show,Data,Typeable) + +options = Options + { conf = def &= opt "hulk.conf" &= help "The config file." + } + &= summary "Hulk IRC Daemon (C) Chris Done 2011" + &= help "Runs an IRC server based on the provided configuration file." + +optionsConf = conf diff --git a/src/Hulk/Providers.hs b/src/Hulk/Providers.hs new file mode 100644 --- /dev/null +++ b/src/Hulk/Providers.hs @@ -0,0 +1,23 @@ +{-# OPTIONS -Wall -fno-warn-name-shadowing -fno-warn-orphans #-} +module Hulk.Providers where + +import Control.Applicative +import Control.Monad.Reader + +import Hulk.Types + +instance MonadProvider HulkIO where + providePreface = maybeReadFile configPreface + provideMotd = maybeReadFile configMotd + provideKey = mustReadFile configPasswdKey + providePasswords = mustReadFile configPasswd + +maybeReadFile :: (Config -> Maybe FilePath) -> HulkIO (Maybe String) +maybeReadFile get = do + path <- asks get + case path of + Nothing -> return Nothing + Just path -> Just <$> liftIO (readFile path) + +mustReadFile :: (Config -> FilePath) -> HulkIO String +mustReadFile get = asks get >>= liftIO . readFile diff --git a/src/Hulk/Server.hs b/src/Hulk/Server.hs new file mode 100644 --- /dev/null +++ b/src/Hulk/Server.hs @@ -0,0 +1,92 @@ +{-# LANGUAGE RecordWildCards #-} +{-# OPTIONS -Wall -fno-warn-name-shadowing #-} +module Hulk.Server (start) where + +import Control.Applicative +import Control.Concurrent +import Control.Concurrent.Delay +import Control.Monad +import Control.Monad.Fix +import Control.Monad.Reader +import qualified Data.Map as M +import Data.Time +import Network +import Network.IRC +import System.IO +import System.IO.UTF8 as UTF8 + +import Hulk.Client +import Hulk.Providers () +import Hulk.Types + +-- | Start an IRC server with the given configuration. +start :: Config -> IO () +start config = withSocketsDo $ do + hSetBuffering stdout LineBuffering + listenSock <- listenOn $ PortNumber (configListen config) + envar <- newMVar Env { envClients = M.empty + , envNicks = M.empty + , envChannels = M.empty } + forever $ do + (handle,host,_port) <- accept listenSock + hSetBuffering handle NoBuffering + now <- getCurrentTime + let conn = Conn { connRef = newRef handle + , connHostname = host + , connServerName = configHostname config + , connTime = now + } + _ <- forkIO $ handleClient config handle envar conn + return () + +-- | Handle a client connection. +handleClient :: Config -> Handle -> MVar Env -> Conn -> IO () +handleClient config handle env conn = do + let runHandle = runClientHandler config env handle conn + runLine x y = runHandle $ makeLine x y + pinger <- forkIO $ forever $ do delayMinutes 2; runLine PINGPONG [] + fix $ \loop -> do + line <- catch (Right <$> UTF8.hGetLine handle) + (\e -> do killThread pinger + return $ Left e) + case filter (not.newline) <$> line of + Right [] -> loop + Right line -> do runHandle (line++"\r"); loop + Left _err -> runLine DISCONNECT ["Connection lost."] + + where newline c = c=='\n' || c=='\r' + +-- | Make an internal IRC event to give to the client handler. +makeLine :: Event -> [String] -> String +makeLine event params = (++"\r") $ encode $ + Message { msg_prefix = Nothing + , msg_command = show event + , msg_params = params } + +-- | Handle a received line from the client. +runClientHandler :: Config -> MVar Env -> Handle -> Conn -> String -> IO () +runClientHandler config env handle conn line = do + now <- getCurrentTime + modifyMVar_ env $ \env -> do + (replies,env) <- runReaderT (runHulkIO $ handleLine env now conn line) + config + mapM_ (handleReplies handle) replies + return env + +-- | Act on replies from the client. +handleReplies :: Handle -> Reply -> IO () +handleReplies handle reply = do + case reply of + MessageReply ref msg -> sendMessage ref msg + LogReply line -> logLine line + Close -> hClose handle + +-- | Send a message to a client. +sendMessage :: Ref -> Message -> IO () +sendMessage (Ref handle) msg = do + catch (UTF8.hPutStrLn handle (encode msg ++ "\r")) + (\_ -> hClose handle) + +-- | Add a line to the log file. +logLine :: String -> IO () +logLine = UTF8.putStrLn diff --git a/src/Hulk/Types.hs b/src/Hulk/Types.hs new file mode 100644 --- /dev/null +++ b/src/Hulk/Types.hs @@ -0,0 +1,186 @@ +{-# OPTIONS -Wall -fno-warn-name-shadowing #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +module Hulk.Types where + +import Control.Monad.Identity +import Control.Monad.Reader +import Control.Monad.State +import Control.Monad.Writer +import Data.Char +import Data.Function +import Data.Map (Map) +import Data.Time +import Network +import Network.IRC hiding (Channel) +import System.IO + +data Config = Config { + configListen :: PortNumber + , configHostname :: String + , configMotd :: Maybe FilePath + , configPreface :: Maybe FilePath + , configPasswd :: FilePath + , configPasswdKey :: FilePath + } deriving (Show) + +newtype Ref = Ref { unRef :: Handle } + deriving (Show,Eq) + +instance Ord Ref where + compare = on compare show + +-- | Construct a Ref value. +newRef :: Handle -> Ref +newRef = Ref + +data Error = Error String + +data Env = Env { + envClients :: Map Ref Client + ,envNicks :: Map Nick Ref + ,envChannels :: Map ChannelName Channel +} + +newtype Nick = Nick { unNick :: String } deriving Show + +instance Ord Nick where + compare = on compare (map toLower . unNick) +instance Eq Nick where + (==) = on (==) (map toLower . unNick) + +newtype ChannelName = ChannelName { unChanName :: String } deriving Show + +instance Ord ChannelName where + compare = on compare (map toLower . unChanName) +instance Eq ChannelName where + (==) = on (==) (map toLower . unChanName) + +data Channel = Channel { + channelName :: ChannelName + , channelTopic :: Maybe String + , channelUsers :: [Ref] +} deriving Show + +data User = Unregistered UnregUser | Registered RegUser + deriving Show + +data UnregUser = UnregUser { + unregUserName :: Maybe String + ,unregUserNick :: Maybe Nick + ,unregUserUser :: Maybe String + ,unregUserPass :: Maybe String +} deriving Show + +data RegUser = RegUser { + regUserName :: String + ,regUserNick :: Nick + ,regUserUser :: String + ,regUserPass :: String +} deriving Show + +data Client = Client { + clientRef :: Ref + , clientUser :: User + , clientHostname :: String + , clientLastPong :: UTCTime + } deriving Show + +data Conn = Conn { + connRef :: Ref + ,connHostname :: String + ,connServerName :: String + ,connTime :: UTCTime +} deriving Show + +data Reply = MessageReply Ref Message | LogReply String | Close + +newtype IRC m a = IRC { + runIRC :: ReaderT (UTCTime,Conn) (WriterT [Reply] (StateT Env m)) a + } + deriving (Monad + ,Functor + ,MonadWriter [Reply] + ,MonadState Env + ,MonadReader (UTCTime,Conn)) + +data Event = PASS | USER | NICK | PING | QUIT | TELL | JOIN | PART | PRIVMSG + | NOTICE | ISON | WHOIS | TOPIC | CONNECT | DISCONNECT | PINGPONG + | PONG + | NOTHING + deriving (Read,Show) + + +data RPL = RPL_WHOISUSER + | RPL_NICK + | RPL_PONG + | RPL_JOIN + | RPL_QUIT + | RPL_NOTICE + | RPL_PART + | RPL_PRIVMSG + | RPL_ISON + | RPL_JOINS + | RPL_TOPIC + | RPL_NAMEREPLY + | RPL_ENDOFNAMES + | ERR_NICKNAMEINUSE + | RPL_WELCOME + | RPL_MOTDSTART + | RPL_MOTD + | RPL_ENDOFMOTD + | RPL_WHOISIDLE + | RPL_ENDOFWHOIS + | RPL_WHOISCHANNELS + | ERR_NOSUCHNICK + | ERR_NOSUCHCHANNEL + | RPL_PING + deriving Show + +fromRPL :: RPL -> String +fromRPL RPL_WHOISUSER = "311" +fromRPL RPL_NICK = "NICK" +fromRPL RPL_PONG = "PONG" +fromRPL RPL_QUIT = "QUIT" +fromRPL RPL_JOIN = "JOIN" +fromRPL RPL_NOTICE = "NOTICE" +fromRPL RPL_PART = "PART" +fromRPL RPL_PRIVMSG = "PRIVMSG" +fromRPL RPL_ISON = "303" +fromRPL RPL_JOINS = "JOIN" +fromRPL RPL_TOPIC = "TOPIC" +fromRPL RPL_NAMEREPLY = "353" +fromRPL RPL_ENDOFNAMES = "366" +fromRPL RPL_WELCOME = "001" +fromRPL RPL_MOTDSTART = "375" +fromRPL RPL_MOTD = "372" +fromRPL RPL_ENDOFMOTD = "376" +fromRPL RPL_WHOISIDLE = "317" +fromRPL RPL_WHOISCHANNELS = "319" +fromRPL RPL_ENDOFWHOIS = "318" +fromRPL ERR_NICKNAMEINUSE = "433" +fromRPL ERR_NOSUCHNICK = "401" +fromRPL ERR_NOSUCHCHANNEL = "403" +fromRPL RPL_PING = "PING" + +data QuitType = RequestedQuit | SocketQuit deriving Eq + +data ChannelReplyType = IncludeMe | ExcludeMe deriving Eq + +class Monad m => MonadProvider m where + providePreface :: m (Maybe String) + provideMotd :: m (Maybe String) + provideKey :: m String + providePasswords :: m String + +newtype HulkIO a = HulkIO { runHulkIO :: ReaderT Config IO a } + deriving (Monad,MonadReader Config,Functor,MonadIO) + +newtype HulkP a = HulkP { runHulkPure :: Identity a } + deriving (Monad) + +instance MonadTrans IRC where + lift m = do + s <- get + IRC $ ReaderT $ \_ -> WriterT $ StateT $ \_ -> do + a <- m + return ((a,[]),s)