diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -14,12 +14,18 @@ ## Usage +See a complete example in the `example/` directory in the root of the +project. You can go into that directory and run `hulk -chulk.conf` to +have an immediate server running on localhost port 6667. + ### Configuration - $ cp hulk.conf.example hulk.conf - + $ cp example/hulk.conf hulk.conf + You can edit the port, server name and MOTD file in here. - + +Detailed instructions follow. + ### Auth $ mkdir auth @@ -67,9 +73,9 @@ [hulk] connect = 127.0.0.1:6666 accept = 6667 - + Then run it: - + stunnel stunnel.conf (It may be in `/usr/sbin/stunnel` depending on your system.) @@ -105,21 +111,3 @@ $ rss2irc http://myserver/foo.atom announce@127.0.0.1/#dev \ -p 6667 -i 1 -l --pass myannouncepass - -## Utility for 'telling' people things externally - -Sometimes you want automatic scripts to send notices to the IRC. - -Save this script in `tell.sh`: - - (cat /mypath/tell-login; echo "NICK $1"; echo "TELL $2 :$3") | nc serverip 6667 -w 1 > /dev/null - -Run it like this: - - $ tell announce '#dev' 'Stuff happened!' - -And put this in your /mypath/tell-login: - - $ cat /opt/hulk/tell-login - PASS mypassword - USER myuser * * * diff --git a/example/auth/passwd b/example/auth/passwd new file mode 100644 --- /dev/null +++ b/example/auth/passwd @@ -0,0 +1,2 @@ +hulk bac95aac1e4e1a3791b4aa044be19bb11b3b +hulk2 bac95aac1e4e1a3791b4aa044be19bb11b3b diff --git a/example/auth/passwd-key b/example/auth/passwd-key new file mode 100644 --- /dev/null +++ b/example/auth/passwd-key @@ -0,0 +1,1 @@ +:-) diff --git a/example/hulk.conf b/example/hulk.conf new file mode 100644 --- /dev/null +++ b/example/hulk.conf @@ -0,0 +1,18 @@ +[LISTEN] +port = 6667 +hostname = hulk-server + +[STRINGS] +motd_file = txt/MOTD +preface_file = txt/PREFACE + +[AUTH] +passwd_file = auth/passwd +passwd_key = auth/passwd-key + +[USERS] +data_dir=users/ + +[LOGS] +event_log=log/events.log +channels=#hulk diff --git a/example/log/events.log b/example/log/events.log new file mode 100644 --- /dev/null +++ b/example/log/events.log @@ -0,0 +1,32 @@ +["2013-11-02T17:06:35.619Z","hulk","RPL_PRIVMSG",["#hulk","Hello!"]] +["2013-11-03T01:53:58.106Z","hulk2","RPL_PRIVMSG",["#hulk","hrm"]] +["2013-11-03T01:54:02.393Z","hulk","RPL_PRIVMSG",["#hulk","yeah"]] +["2013-11-03T01:57:28.112Z","hulk2","RPL_PRIVMSG",["#hulk","2"]] +["2013-11-03T01:57:30.952Z","hulk","RPL_PRIVMSG",["#hulk","sdf"]] +["2013-11-03T01:57:35.393Z","hulk2","RPL_PRIVMSG",["#hulk","hmer"]] +["2013-11-03T01:57:38.809Z","hulk","RPL_PRIVMSG",["#hulk","heymar"]] +["2013-11-03T01:58:44.009Z","hulk2","RPL_PRIVMSG",["#hulk","sfsdfsdf"]] +["2013-11-03T01:58:44.114Z","hulk","RPL_PRIVMSG",["#hulk","sdf"]] +["2013-11-03T01:59:06.823Z","hulk","RPL_PRIVMSG",["#hulk","hello"]] +["2013-11-03T01:59:09.807Z","hulk2","RPL_PRIVMSG",["#hulk","hai"]] +["2013-11-03T01:59:30.808Z","hulk","RPL_PRIVMSG",["#hulk","apples"]] +["2013-11-03T01:59:33.231Z","hulk2","RPL_PRIVMSG",["#hulk","pears"]] +["2013-11-03T01:59:37.615Z","hulk","RPL_PRIVMSG",["#hulk","bacon"]] +["2013-11-03T01:59:41.175Z","hulk2","RPL_PRIVMSG",["#hulk","chop liver"]] +["2013-11-03T01:59:44.591Z","hulk","RPL_PRIVMSG",["#hulk","eh?"]] +["2013-11-03T01:59:48.471Z","hulk2","RPL_PRIVMSG",["#hulk","hurrr"]] +["2013-11-03T02:00:13.543Z","hulk","RPL_PRIVMSG",["#hulk","zer"]] +["2013-11-03T02:00:16.591Z","hulk2","RPL_PRIVMSG",["#hulk","var"]] +["2013-11-03T02:03:08.485Z","hulk2","RPL_PRIVMSG",["#hulk","hello"]] +["2013-11-03T02:03:10.813Z","hulk","RPL_PRIVMSG",["#hulk","world"]] +["2013-11-03T02:03:12.073Z","hulk","RPL_PRIVMSG",["#hulk","world"]] +["2013-11-03T02:03:13.581Z","hulk2","RPL_PRIVMSG",["#hulk","yup"]] +["2013-11-03T02:21:41.371Z","hulk","RPL_PRIVMSG",["#hulk","test"]] +["2013-11-03T02:32:02.087Z","hulk","RPL_PRIVMSG",["#foo","hey"]] +["2013-11-03T02:32:19.997Z","hulk","RPL_PRIVMSG",["hulk","sup"]] +["2013-11-03T02:41:55.108Z","hulk","RPL_PRIVMSG",["#hulk","huh"]] +["2013-11-03T02:44:26.426Z","hulk","RPL_PRIVMSG",["#hulk","jl"]] +["2013-11-03T02:45:20.923Z","hulk","RPL_PRIVMSG",["#hulk",",."]] +["2013-11-03T03:35:31.801Z","hulk2","RPL_PRIVMSG",["#hulk","dfg"]] +["2013-11-03T03:35:34.505Z","hulk","RPL_PRIVMSG",["#hulk","berk"]] +["2013-11-03T03:35:36.777Z","hulk2","RPL_PRIVMSG",["#hulk","heh"]] diff --git a/example/txt/MOTD b/example/txt/MOTD new file mode 100644 --- /dev/null +++ b/example/txt/MOTD @@ -0,0 +1,7 @@ +Hello and welcome to this IRC server. I am your host, Dr. Bruce Banner +PhD in nuclear physics and HRRRRRNNNNNNNNNNNNGGGGGGGGGGGGGGGGGGGGGGGGG +HRRRRRNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNN +NNRUN FOR YOUR LIFENNNNNNNNNNNNNNNNNNNNNNNNNGGGGGGGGNNNNNNNNNNNNNNNNNN +NNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNN +GGGGGGGGGGGGGGGGGGGGGGGGGGGGGGGGGGGGGGGGGGGGGGGGGGGGGGGGGGGGGGGGGGGGGG +GG.. diff --git a/example/txt/PREFACE b/example/txt/PREFACE new file mode 100644 --- /dev/null +++ b/example/txt/PREFACE @@ -0,0 +1,14 @@ +You must login with a username and password. If you have not already +created one, you should do so by generating one and adding it to the +Hulk passwd file in passwd. To generate a user/password +key/pair, use: + + $ genpass myusername + +It will prompt for a password. Inspect it first to confirm it is +correct. To write it to the passwd file use + + $ genpass myusername >> /path/to/hulk/data/passwd + +And configure your IRC client to use your username and to send a +*server* password. diff --git a/example/users/hulk b/example/users/hulk new file mode 100644 --- /dev/null +++ b/example/users/hulk @@ -0,0 +1,1 @@ +{"userDataUser":"hulk","userDataLastSeen":"2013-11-03T02:51:50.980Z"} diff --git a/example/users/hulk2 b/example/users/hulk2 new file mode 100644 --- /dev/null +++ b/example/users/hulk2 @@ -0,0 +1,1 @@ +{"userDataUser":"hulk2","userDataLastSeen":"2013-11-03T02:30:29.083Z"} diff --git a/hulk.cabal b/hulk.cabal --- a/hulk.cabal +++ b/hulk.cabal @@ -1,55 +1,93 @@ Name: hulk -Version: 0.1.2 -Synopsis: IRC daemon. -Description: An IRC daemon with mandatory authentication. +Version: 0.2.0 +Synopsis: IRC server written in Haskell. +Description: An IRC server with (mandatory) server authentication, log recall, bumping. + Intended for private business use or hobby work. License: BSD3 +Stability: Stable License-file: LICENSE Author: Chris Done Maintainer: chrisdone@gmail.com -Copyright: 2010 Chris Done +Copyright: 2010-2013 Chris Done Category: Network Build-type: Simple Cabal-version: >=1.2 -Extra-source-files: README.md, hulk.conf.example, txt/MOTD, txt/PREFACE +Extra-source-files: + README.md + example/log/events.log + example/auth/passwd + example/auth/passwd-key + example/txt/PREFACE + example/txt/MOTD + example/hulk.conf + example/users/hulk2 + example/users/hulk +Library + Exposed-Modules: + Hulk.Server + Hulk.Options + Hulk.Client + Hulk.Config + Hulk.Types + Hulk.Auth + Ghc-options: -threaded -O2 -Wall + Hs-Source-Dirs: src + Build-depends: base >= 4 && <5, + text, + ConfigFile, + fastirc, + network, + ghc-prim, + time, + containers, + aeson, + mtl, + utf8-string, + Crypto, + cmdargs, + strict, + filepath, + directory, + bytestring, + split, + unix, + case-insensitive, + monad-extras == 0.3.2.0 + 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 + Other-Modules: Hulk.Auth, + Hulk.Client, + Hulk.Config, + Hulk.Server, + Hulk.Types + Ghc-options: -threaded -O2 -Wall Hs-Source-Dirs: src - Build-depends: base >= 4 && <5 - ,cmdargs >= 0.6 && <0.7 - ,network >= 2.2 && < 2.4 - ,ConfigFile >= 1.0 && < 1.1 - ,unix >= 2.4 && < 2.5 - ,mtl >= 1.1 && < 1.2 - ,containers >= 0.3 && < 0.4 - ,irc >= 0.4 && < 0.5 - ,split >= 0.1 && < 0.2 - ,utf8-string >= 0.3 && < 0.4 - ,Crypto>=4.2 && < 4.3 - ,time >= 1.1 && < 1.2 + Build-depends: base >= 4 && <5, + text, + ConfigFile, + fastirc, + network, + ghc-prim, + time, + containers, + aeson, + mtl, + utf8-string, + Crypto, + cmdargs, + strict, + filepath, + directory, + bytestring, + split, + unix, + case-insensitive, + monad-extras == 0.3.2.0 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 - ,network >= 2.2 && < 2.4 - ,ConfigFile >= 1.0 && < 1.1 - ,unix >= 2.4 && < 2.5 - ,mtl >= 1.1 && < 1.2 - ,containers >= 0.3 && < 0.4 - ,irc >= 0.4 && < 0.5 - ,split >= 0.1 && < 0.2 - ,utf8-string >= 0.3 && <0.4 - ,Crypto>=4.2 && <4.3 + Build-depends: base + Ghc-options: -threaded -O2 -Wall diff --git a/hulk.conf.example b/hulk.conf.example deleted file mode 100644 --- a/hulk.conf.example +++ /dev/null @@ -1,11 +0,0 @@ -[LISTEN] -port = 6667 -hostname = myhostname - -[STRINGS] -motd_file = txt/MOTD -preface_file = txt/PREFACE - -[AUTH] -passwd_file = auth/passwd -passwd_key = auth/passwd-key diff --git a/src/Control/Concurrent/Delay.hs b/src/Control/Concurrent/Delay.hs deleted file mode 100644 --- a/src/Control/Concurrent/Delay.hs +++ /dev/null @@ -1,10 +0,0 @@ -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 deleted file mode 100644 --- a/src/Control/Monad/IO.hs +++ /dev/null @@ -1,6 +0,0 @@ -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 deleted file mode 100644 --- a/src/Data/String.hs +++ /dev/null @@ -1,8 +0,0 @@ -module Data.String where - -import Data.List -import Data.Char - -downcase = map toLower - -digilet c = isDigit c || isLetter c diff --git a/src/GeneratePass.hs b/src/GeneratePass.hs --- a/src/GeneratePass.hs +++ b/src/GeneratePass.hs @@ -2,16 +2,16 @@ {-# OPTIONS -Wall -fno-warn-missing-signatures -fno-warn-name-shadowing #-} module Main where -import System.Console.CmdArgs -import Data.HMAC -import Codec.Binary.UTF8.String -import Numeric -import Data.String -import Control.Applicative - import Hulk.Types import Hulk.Config +import Codec.Binary.UTF8.String +import Control.Applicative +import Data.Char +import Data.HMAC +import Numeric +import System.Console.CmdArgs + data Options = Options { conf :: FilePath , user :: String @@ -35,3 +35,6 @@ putStrLn $ ((user options ++ " ") ++) $ concat $ map (\x -> showHex x "") $ hmac_sha1 (encode key) (encode pass) + + where downcase = map toLower + digilet c = isDigit c || isLetter c diff --git a/src/Hulk/Auth.hs b/src/Hulk/Auth.hs --- a/src/Hulk/Auth.hs +++ b/src/Hulk/Auth.hs @@ -1,25 +1,39 @@ -{-# OPTIONS -Wall -fno-warn-name-shadowing #-} -module Hulk.Auth where +-- | Password authorization for the server. +module Hulk.Auth + (authenticate + ,sha1) + where + import Codec.Binary.UTF8.String import Control.Arrow -import Control.Monad + import Data.Char import Data.HMAC +import Data.Text (Text,unpack) import Numeric -import Hulk.Types +-- | Authenticate the user. +authenticate :: String -- ^ Salt. + -> String -- ^ Password file. + -> Text -- ^ User. + -> Text -- ^ Password. + -> Bool -- ^ Authenticated? +authenticate keystr passwords user pass = + any (== (unpack user,sha1 key (unpack pass))) + passwds -sha1 :: String -> String -> String -sha1 key str = - concat $ map (\x -> showHex x "") - $ hmac_sha1 (encode key) (encode str) + where key = filter keyChars keystr + passwds = getPasswds passwords -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 + getPasswds = map readPair . lines where readPair = second (drop 1) . span (/=' ') keyChars c = elem c ['a'..'z'] || isDigit c + +-- | Make a sha1 string with the given salt. +sha1 :: String -- ^ Salt. + -> String -- ^ String. + -> String -- ^ Hashed string. +sha1 key str = + concat $ map (\x -> showHex x "") + $ hmac_sha1 (encode key) (encode str) diff --git a/src/Hulk/Client.hs b/src/Hulk/Client.hs --- a/src/Hulk/Client.hs +++ b/src/Hulk/Client.hs @@ -1,697 +1,871 @@ -{-# 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 +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ViewPatterns #-} + +-- | This module communicates and manages the state of clients +-- connected to the server. + +module Hulk.Client + where + +import Hulk.Auth +import Hulk.Types + +import Control.Applicative +import Control.Monad.RWS hiding (pass) +import Data.CaseInsensitive (mk) +import Data.Char +import Data.List +import Data.List.Split +import Data.Map (Map) +import qualified Data.Map as M +import Data.Maybe +import qualified Data.Set as S +import Data.Text (Text, pack) +import qualified Data.Text as T +import Data.Text.Encoding (decodeUtf8,encodeUtf8) +import Data.Time hiding (readTime) +import Network.FastIRC (Command (..), CommandArg, Message (..), UserSpec(..)) +import qualified Network.FastIRC as IRC +import Prelude hiding (log) + +-------------------------------------------------------------------------------- +-- * Top-level dispatchers + +-- | Run the client monad. +handleCommand + :: Config -- ^ Server configuration. + -> HulkState -- ^ Server state. + -> UTCTime -- ^ Current time. + -> Conn -- ^ Current client connection. + -> (String,String) -- ^ Authorization info. + -> Command -- ^ The command. + -> ((), HulkState, [HulkWriter]) -- ^ The new transformed state and any instructions. +handleCommand config state' now conn auth cmd = do + runRWS (runHulk (handleCmd cmd)) + (HulkReader now conn config Nothing auth) + state' + +-- | Handle an incoming command. +handleCmd :: Command -- ^ A command which shouldn't be logged (e.g. PASS). + -> Hulk () +handleCmd cmd = do + case cmd of + PassCmd (decodeUtf8 -> pass) -> do + incoming cmd + asUnregistered $ handlePass pass + StringCmd "PINGPONG" _ -> do + incoming cmd + handlePingPong + _ -> handleMsgSafeToLog cmd + +-- | Handle commands that are safe to log. +handleMsgSafeToLog :: Command -- ^ A command which is safe to log + -- (PONG, NICK, etc.). + -> Hulk () +handleMsgSafeToLog cmd = do + incoming cmd + updateLastPong + case cmd of + PongCmd{} -> handlePong + NickCmd (decodeUtf8 -> nick) _ -> handleNick nick + PingCmd (decodeUtf8 -> param) _ -> handlePing param + UserCmd (decodeUtf8 -> user) _ _ (decodeUtf8 -> realname) -> + asUnregistered $ handleUser user realname + QuitCmd mmsg -> + handleQuit RequestedQuit + (maybe "Quit (no message given)" + decodeUtf8 + mmsg) + StringCmd "DISCONNECT" _ -> + handleQuit SocketQuit "Connection lost." + _ -> handleMsgReg'd cmd + +-- | Handle commands that can only be used when registered. +handleMsgReg'd :: Command -- ^ A command that users use after + -- registration (e.g. JOIN, PART, etc.). + -> Hulk () +handleMsgReg'd cmd = + asRegistered $ + case cmd of + JoinCmd names -> + mapM_ handleJoin (map decodeUtf8 (M.keys names)) + PartCmd names mmsg -> + mapM_ (flip handlePart (maybe "" decodeUtf8 mmsg)) + (map decodeUtf8 (S.toList names)) + PrivMsgCmd targets msg -> + mapM_ (flip handlePrivmsg (decodeUtf8 msg)) + (map decodeUtf8 (S.toList targets)) + TopicCmd chan (fmap decodeUtf8 -> Just topic) -> handleTopic (decodeUtf8 chan) topic + NoticeCmd targets msg -> + mapM_ (flip handleNotice (decodeUtf8 msg)) + (map decodeUtf8 (S.toList targets)) + StringCmd "WHOIS" [nick] -> handleWhoIs (decodeUtf8 nick) + StringCmd "ISON" people -> handleIsOn (map decodeUtf8 people) + StringCmd "NAMES" [chan] -> handleNames (decodeUtf8 chan) + _ -> invalidCmd cmd + +-- | Log an invalid cmd. +invalidCmd :: Command -- ^ The given command that we don't know how to handle. + -> Hulk () +invalidCmd cmd = do + errorReply $ "Invalid or unknown message type, or not" <> + " enough parameters: " <> decodeUtf8 (IRC.showCommand cmd) + +-------------------------------------------------------------------------------- +-- * Command handlers + +-- | Handle the PONG command. This updates the user's “last seen” +-- value on file. +handlePong :: Hulk () +handlePong = do + now <- asks readTime + withRegistered $ \RegUser{regUserUser=user} -> do + tell [UpdateUserData UserData { userDataUser = user + , userDataLastSeen = now + }] + +-- | Handle the PINGPONG event. Disconnect the client if timedout. +handlePingPong :: Hulk () +handlePingPong = do + lastPong <- clientLastPong <$> getClient + now <- asks readTime + let n = diffUTCTime now lastPong + if n > 60*4 + then handleQuit RequestedQuit $ "Ping timeout: " <> pack (show n) <> " seconds" + else do hostname <- asks (connServerName . readConn) + thisCmdReply RPL_PING [hostname] + +-- | Handle the PASS message. +handlePass :: Text -> Hulk () +handlePass pass = do + modifyUnregistered $ \u -> u { unregUserPass = Just pass } + notice "Received password." + tryRegister + +-- | Handle the USER message. +handleUser :: Text -> Text -> Hulk () +handleUser user realname = do + withSentPass $ + if validUser user + then do modifyUnregistered $ \u -> u { unregUserUser = Just (UserName (mk user)) + , unregUserName = Just realname } + notice "Recieved user details." + tryRegister + else errorReply "Invalid user format." + +-- | Handle the USER message. +handleNick :: Text -> Hulk () +handleNick nick' = + withSentPass $ + withValidNick nick' $ \nick -> + ifNotMyNick nick $ + ifUniqueNick nick (updateNickAndTryRegistration nick) + (Just (tryBumpingSomeoneElseOff nick)) + + where updateNickAndTryRegistration nick = do + ref <- getRef + withRegistered $ \RegUser{regUserNick=rnick} -> + modifyNicks $ M.delete rnick + withUnregistered $ \UnregUser{unregUserNick=rnick} -> + maybe (return ()) (modifyNicks . M.delete) rnick + modifyNicks $ M.insert nick ref + modifyUnregistered $ \u -> u { unregUserNick = Just nick } + tryRegister + asRegistered $ do + thisClientReply RPL_NICK [nickText nick] + (myChannels >>=) $ mapM_ $ \Channel{..} -> do + channelReply channelName RPL_NICK [nickText nick] ExcludeMe + modifyRegistered $ \u -> u { regUserNick = nick } + + tryBumpingSomeoneElseOff nick = \error_reply -> do + registered <- isRegistered <$> getUser + if registered + then bumpAndRegister nick error_reply + else do + withUnregistered $ \unreg -> do + (authentic,_) <- isAuthentic unreg { unregUserNick = Just nick } + if not authentic + then error_reply " (Registration not valid, can't bump off this user.)" + else bumpAndRegister nick error_reply + + bumpAndRegister nick error_reply = do + username <- getUsername + if fmap (mk.userText) username == Just (mk (nickText nick)) + then do bumpOff nick + updateNickAndTryRegistration nick + else error_reply $ + let x = "username=" <> pack (show username) <> ", nick=" <> nickText nick + in " (Can only bump the nick that matches your username. Debug: " <> x <> ")" + +-- | Handle the PING message. +handlePing :: Text -> Hulk () +handlePing p = do + hostname <- asks (connServerName . readConn) + thisServerReply RPL_PONG [hostname,p] + +-- | Handle the QUIT message. +handleQuit :: QuitType -> Text -> Hulk () +handleQuit quitType msg = do + clearQuittedUser msg + when (quitType == RequestedQuit) $ + tell [Close] + +-- | Handle the TELL message. +handleTell :: Text -> Text -> Hulk () +handleTell name msg = sendMsgTo RPL_NOTICE name msg + +-- | Handle the NAMES list request. +handleNames :: Text -> Hulk () +handleNames chan = do + withValidChanName chan sendNamesList + +-- | Handle the JOIN message. +handleJoin :: Text -> Hulk () +handleJoin chans = do + let names = T.split (==',') chans + forM_ names $ flip withValidChanName $ \name -> do + exists <- M.member name <$> gets stateChannels + unless exists $ insertChannel name + joined <- inChannel name + unless joined $ joinChannel name + +-- | Handle the PART message. +handlePart :: Text -> Text -> Hulk () +handlePart name msg = + withValidChanName name $ \vname -> do + removeFromChan vname + channelReply vname RPL_PART [msg] IncludeMe + +-- | Handle the TOPIC message. +handleTopic :: Text -> Text -> Hulk () +handleTopic name' topic = + withValidChanName name' $ \name -> do + let setTopic c = c { channelTopic = Just topic } + modifyChannels $ M.adjust setTopic name + channelReply name RPL_TOPIC [channelNameText name,topic] IncludeMe + +-- | Handle the PRIVMSG message. +handlePrivmsg :: Text -> Text -> Hulk () +handlePrivmsg name msg = do + sendMsgTo RPL_PRIVMSG name msg + historyLog RPL_PRIVMSG [name,msg] + +-- | Handle the NOTICE message. +handleNotice :: Text -> Text -> Hulk () +handleNotice name msg = sendMsgTo RPL_NOTICE name msg + +-- | Handle WHOIS message. +handleWhoIs :: Text -> Hulk () +handleWhoIs nick' = + withValidNick nick' $ \nick -> + withClientByNick nick $ \Client{..} -> + withRegUserByNick nick $ \RegUser{..} -> do + thisNickServerReply RPL_WHOISUSER + [nickText regUserNick + ,userText regUserUser + ,clientHostname + ,"*" + ,regUserName] + thisNickServerReply RPL_ENDOFWHOIS + [nickText regUserNick + ,"End of WHOIS list."] + +-- | Handle the ISON ('is on?') message. +handleIsOn :: [Text] -> Hulk () +handleIsOn (catMaybes . map readNick -> nicks') = + asRegistered $ do + online <- catMaybes <$> mapM regUserByNick nicks' + let nicks = T.unwords $ map (nickText.regUserNick) online + unless (T.null nicks) $ thisNickServerReply RPL_ISON [nicks <> " "] + +-------------------------------------------------------------------------------- +-- * General actions + +-- | Send a message to a user or a channel (it figures it out). +sendMsgTo :: RPL -> Text -> Text -> Hulk () +sendMsgTo typ name' msg = + if validChannel name' + then withValidChanName name' $ \name -> + channelReply name typ [channelNameText name,msg] ExcludeMe + else userReply name' typ [name',msg] + +-------------------------------------------------------------------------------- +-- * Users + +-- | Is a username valid? +validUser :: Text -> Bool +validUser = validNick + +-- | Get the username. +getUsername :: Hulk (Maybe UserName) +getUsername = do + user <- getUser + return $ case user of + Unregistered (UnregUser{unregUserUser=username}) -> username + Registered (RegUser{regUserUser=username}) -> Just username + +-- | Get the current connection ref. +getRef :: Hulk Ref +getRef = connRef <$> asks readConn + +-- | Bump off the given nick. +bumpOff :: Nick -> Hulk () +bumpOff nick = ifNotMyNick nick $ do + notice $ "Bumping off user " <> nickText nick <> "…" + withClientByNick nick $ \Client{clientRef=ref} -> + local (\r -> r { readConn = (readConn r) { connRef = ref } }) $ do + clearQuittedUser msg + tell [Bump ref] + + where msg = "Bumped off." + +-- | Clear a quitted user from channels and nick list, and notify +-- people in channels of their leaving. +clearQuittedUser :: Text -> Hulk () +clearQuittedUser msg = do + (myChannels >>=) $ mapM_ $ \Channel{..} -> do + channelReply channelName RPL_QUIT [msg] ExcludeMe + removeFromChan channelName + withRegistered $ \RegUser{regUserNick=nick} -> do + modifyNicks $ M.delete nick + withUnregistered $ \UnregUser{unregUserNick=nick} -> do + maybe (return ()) (modifyNicks . M.delete) nick + ref <- getRef + modifyClients $ M.delete ref + notice msg + +-- | Update the last pong reply time. +updateLastPong :: Hulk () +updateLastPong = do + ref <- getRef + now <- asks readTime + let adjust client@Client{..} = client { clientLastPong = now } + modifyClients $ M.adjust adjust ref + +-- | Send a client reply to a user. +userReply :: Text -> RPL -> [Text] -> Hulk () +userReply nick' typ ps = + withValidNick nick' $ \nick -> + withClientByNick nick $ \Client{..} -> + clientReply clientRef typ ps + +-- | Perform an action with a registered user by its nickname. +withRegUserByNick :: Nick -> (RegUser -> Hulk ()) -> Hulk () +withRegUserByNick nick m = do + user <- regUserByNick nick + case user of + Just user' -> m user' + Nothing -> sendNoSuchNick nick + +-- | Send the RPL_NOSUCHNICK reply. +sendNoSuchNick :: Nick -> Hulk () +sendNoSuchNick nick = + thisServerReply ERR_NOSUCHNICK [nickText nick,"No such nick."] + +-- | Modify the current user. +modifyUser :: (User -> User) -> Hulk () +modifyUser f = do + ref <- getRef + let modUser c = c { clientUser = f (clientUser c) } + modClient = M.adjust modUser ref + modify $ \env -> env { stateClients = modClient (stateClients env) } + +-- | Get the current client's user. +getUser :: Hulk User +getUser = clientUser <$> getClient + +-------------------------------------------------------------------------------- +-- * Clients + +-- | Get the current client. +getClientByRef :: Ref -> Hulk (Maybe Client) +getClientByRef ref = do + clients <- gets stateClients + return $ M.lookup ref clients + +-- | Get a client by nickname. +clientByNick :: Nick -> Hulk (Maybe Client) +clientByNick nick = do + clients <- gets stateClients + (M.lookup nick >=> (`M.lookup` clients)) <$> gets stateNicks + +-- | Perform an action with a client by nickname. +withClientByNick :: Nick -> (Client -> Hulk ()) -> Hulk () +withClientByNick nick m = do + client' <- clientByNick nick + case client' of + Nothing -> sendNoSuchNick nick + Just client@Client{..} + | isRegistered clientUser -> m client + | otherwise -> sendNoSuchNick nick + +-- | Get the current client. +getClient :: Hulk Client +getClient = do + ref <- getRef + clients <- gets stateClients + case M.lookup ref clients of + Just client -> return $ client + Nothing -> makeNewClient + +-- | Modify the clients table. +modifyClients :: (Map Ref Client -> Map Ref Client) -> Hulk () +modifyClients f = modify $ \env -> env { stateClients = f (stateClients env) } + +-- | Make a current client based on the current connection. +makeNewClient :: Hulk Client +makeNewClient = do + Conn{..} <- asks readConn + let client = Client { clientRef = connRef + , clientHostname = connHostname + , clientUser = newUnregisteredUser + , clientLastPong = connTime } + modifyClients $ M.insert connRef client + return client + + +-------------------------------------------------------------------------------- +-- * Registration + +-- | Get a registered user by nickname. +regUserByNick :: Nick -> Hulk (Maybe RegUser) +regUserByNick nick = do + c <- clientByNick nick + case clientUser <$> c of + Just (Registered u) -> return $ Just u + _ -> return Nothing + +-- | 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 :: (UnregUser -> UnregUser) -> Hulk () +modifyUnregistered f = do + modifyUser $ \user -> + case user of + Unregistered user' -> Unregistered (f user') + u -> u + +-- | Modify the current user if registered. +modifyRegistered :: (RegUser -> RegUser) -> Hulk () +modifyRegistered f = do + modifyUser $ \user -> + case user of + Registered user' -> Registered (f user') + u -> u + +-- | Only perform command if the client is registered. +asRegistered :: Hulk () -> Hulk () +asRegistered m = do + registered <- isRegistered <$> getUser + when registered m + +-- | Perform command with a registered user. +withRegistered :: (RegUser -> Hulk ()) -> Hulk () +withRegistered m = do + user <- getUser + case user of + Registered user' -> m user' + _ -> return () + +-- | With sent pass. +withSentPass :: Hulk () -> Hulk () +withSentPass m = do + asRegistered m + withUnregistered $ \UnregUser{..} -> do + case unregUserPass of + Just{} -> m + Nothing -> return () + +-- | Perform command with a registered user. +withUnregistered :: (UnregUser -> Hulk ()) -> Hulk () +withUnregistered m = do + user <- getUser + case user of + Unregistered user' -> m user' + _ -> return () + +-- | Only perform command if the client is registered. +asUnregistered :: Hulk () -> Hulk () +asUnregistered m = do + registered <- isRegistered <$> getUser + unless registered m + +-- | Is a user registered? +isRegistered :: User -> Bool +isRegistered Registered{} = True +isRegistered _ = False + + +-- | Make a new unregistered user. +newUnregisteredUser :: User +newUnregisteredUser = Unregistered $ UnregUser { + unregUserName = Nothing + ,unregUserNick = Nothing + ,unregUserUser = Nothing + ,unregUserPass = Nothing + } + +-- | Try to register the user with the USER/NICK/PASS that have been given. +tryRegister :: Hulk () +tryRegister = + withUnregistered $ \unreg -> do + check <- isAuthentic unreg + case check of + (True,Just (name,user,nick)) -> do + modifyUser $ \_ -> + Registered $ RegUser name nick user "" + sendWelcome + sendMotd + sendEvents + (False,Just{}) -> errorReply $ "Wrong user/pass." + _ -> return () + +isAuthentic :: UnregUser -> Hulk (Bool,Maybe (Text,UserName,Nick)) +isAuthentic UnregUser{..} = do + let details = (,,,) <$> unregUserName + <*> unregUserNick + <*> unregUserUser + <*> unregUserPass + case details of + Nothing -> return (False,Nothing) + Just (name,nick,user,pass) -> do + (keystr,passwords) <- asks readAuth + let authentic = authenticate keystr passwords (userText user) pass + return (authentic,Just (name,user,nick)) + +-------------------------------------------------------------------------------- +-- * Nicknames + +-- | Read a valid nick. +readNick :: Text -> Maybe Nick +readNick n | validNick n = Just $ NickName (mk n) + | otherwise = Nothing + +-- | Modify the nicks mapping. +modifyNicks :: (Map Nick Ref -> Map Nick Ref) -> Hulk () +modifyNicks f = modify $ \env -> env { stateNicks = f (stateNicks env) } + +-- | With a valid nickname, perform an action. +withValidNick :: Text -> (Nick -> Hulk ()) -> Hulk () +withValidNick nick m + | validNick nick = m (NickName (mk nick)) + | otherwise = errorReply $ "Invalid nick format: " <> nick + +-- | Perform an action if a nickname is unique, otherwise send error. +ifUniqueNick :: Nick -> Hulk () -> Maybe ((Text -> Hulk ()) -> Hulk ()) -> Hulk () +ifUniqueNick nick then_m else_m = do + clients <- gets stateClients + client <- (M.lookup nick >=> (`M.lookup` clients)) <$> gets stateNicks + case client of + Nothing -> then_m + Just{} -> do + case else_m of + Just else_m' -> else_m' error_reply + Nothing -> error_reply "" + + where error_reply x = thisServerReply ERR_NICKNAMEINUSE + [nickText nick,"Nick is already in use." <> x] + + +-- | Is a nickname valid? Digit/letter or one of these: -_/\\;()[]{}?`' +validNick :: Text -> Bool +validNick s = T.all ok s && T.length s > 0 where + ok c = isDigit c || isLetter c || elem c "-_/\\;()[]{}?`'" + +-- | If the given nick is not my nick name, …. +ifNotMyNick :: Nick -> Hulk () -> Hulk () +ifNotMyNick nick m = do + user <- getUser + case user of + Registered RegUser{..} | regUserNick /= nick -> m + Unregistered UnregUser{..} | unregUserNick /= Just nick -> m + _ -> return () + +-------------------------------------------------------------------------------- +-- * Channels + +-- | Valid channel name? +validChannel :: Text -> Bool +validChannel (T.uncons -> Just ('#',cs)) = T.all ok cs && T.length cs > 0 where + ok c = isDigit c || isLetter c || elem c "-_/\\;()[]{}?`'" +validChannel _ = False + +-- | Remove a user from a channel. +removeFromChan :: ChannelName -> Hulk () +removeFromChan name = do + ref <- getRef + let remMe c = c { channelUsers = S.delete ref (channelUsers c) } + modifyChannels $ M.adjust remMe name + +-- | Get channels that the current client is in. +myChannels :: Hulk [Channel] +myChannels = do + ref <- getRef + filter (S.member ref . channelUsers) . map snd . M.toList <$> gets stateChannels + +-- | Join a channel. +joinChannel :: ChannelName -> Hulk () +joinChannel name = do + ref <- getRef + let addMe c = c { channelUsers = S.insert ref (channelUsers c) } + modifyChannels $ M.adjust addMe name + channelReply name RPL_JOIN [channelNameText name] IncludeMe + sendNamesList name + withChannel name $ \Channel{..} -> do + case channelTopic of + Just topic -> thisServerReply RPL_TOPIC [channelNameText name,topic] + Nothing -> return () + +-- | Send the names list of a channel. +sendNamesList :: ChannelName -> Hulk () +sendNamesList name = do + asRegistered $ + withChannel name $ \Channel{..} -> do + clients <- catMaybes <$> mapM getClientByRef (S.toList channelUsers) + let nicks = map regUserNick . catMaybes . map clientRegUser $ clients + forM_ (chunksOf 10 nicks) $ \nicks' -> + thisNickServerReply RPL_NAMEREPLY ["@",channelNameText name + ,T.unwords $ map nickText nicks'] + thisNickServerReply RPL_ENDOFNAMES [channelNameText name + ,"End of /NAMES list."] + +-- | Am I in a channel? +inChannel :: ChannelName -> Hulk Bool +inChannel name = do + chan <- M.lookup name <$> gets stateChannels + case chan of + Nothing -> return False + Just Channel{..} -> (`S.member` channelUsers) <$> getRef + +-- | Insert a new channel. +insertChannel :: ChannelName -> Hulk () +insertChannel name = modifyChannels $ M.insert name newChan where + newChan = Channel { channelName = name + , channelTopic = Nothing + , channelUsers = S.empty + } + +-- | Modify the channel map. +modifyChannels :: (Map ChannelName Channel -> Map ChannelName Channel) + -> Hulk () +modifyChannels f = modify $ \e -> e { stateChannels = f (stateChannels e) } + +withValidChanName :: Text -> (ChannelName -> Hulk ()) + -> Hulk () +withValidChanName name m + | validChannel name = m $ ChannelName (mk name) + | otherwise = errorReply $ "Invalid channel name: " <> name + +-- | Perform an action with an existing channel, sends error if not exists. +withChannel :: ChannelName -> (Channel -> Hulk ()) -> Hulk () +withChannel name m = do + chan <- M.lookup name <$> gets stateChannels + case chan of + Nothing -> thisServerReply ERR_NOSUCHCHANNEL [channelNameText name + ,"No such channel."] + Just chan' -> m chan' + +-- | Send a client reply to everyone in a channel. +channelReply :: ChannelName -> RPL -> [Text] + -> ChannelReplyType + -> Hulk () +channelReply name cmd params typ = do + withChannel name $ \Channel{..} -> do + ref <- getRef + forM_ (S.toList channelUsers) $ \theirRef -> do + unless (typ == ExcludeMe && ref == theirRef) $ + clientReply theirRef cmd params + +-------------------------------------------------------------------------------- +-- * Client replies + +-- | Send a client reply to the current client. +thisClientReply :: RPL -> [Text] -> Hulk () +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 :: Ref -> RPL -> [Text] -> Hulk () +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 :: Client -> RegUser -> RPL -> [Text] + -> Hulk Message +newClientMsg Client{..} RegUser{..} cmd ps = do + return (Message (Just (User (encodeUtf8 (nickText regUserNick)) + (encodeUtf8 (userText regUserUser)) + (encodeUtf8 clientHostname))) + (makeCommand cmd ps)) + +-------------------------------------------------------------------------------- +-- * Server replies + +-- | Send the welcome message. +sendWelcome :: Hulk () +sendWelcome = do + withRegistered $ \RegUser{..} -> do + thisNickServerReply RPL_WELCOME ["Welcome."] + +-- | Send the MOTD. +sendMotd :: Hulk () +sendMotd = do + asRegistered $ do + thisNickServerReply RPL_MOTDSTART ["MOTD"] + motd <- fmap (fmap T.lines) (asks readMotd) + let motdLine line = thisNickServerReply RPL_MOTD [line] + case motd of + Nothing -> motdLine "None." + Just lines' -> mapM_ motdLine lines' + thisNickServerReply RPL_ENDOFMOTD ["/MOTD."] + +-- | Send events that the user missed. +sendEvents :: Hulk () +sendEvents = do + chans <- configLogChans <$> asks readConfig + unless (null chans) $ do + withRegistered $ \RegUser{regUserUser=user} -> do + ref <- getRef + forM_ chans handleJoin + tell [SendEvents ref user] + +-------------------------------------------------------------------------------- +-- * Output functions + +-- | Send a message reply. +notice :: Text -> Hulk () +notice msg = thisServerReply RPL_NOTICE ["*",msg] + +thisNickServerReply :: RPL -> [Text] -> Hulk () +thisNickServerReply typ params = do + withRegistered $ \RegUser{regUserNick=nick} -> + thisServerReply typ (nickText nick : params) + +-- | Send a server reply of the given type with the given params. +thisServerReply :: RPL -> [Text] -> Hulk () +thisServerReply typ params = do + ref <- getRef + serverReply ref typ params + +-- | Send a server reply of the given type with the given params. +serverReply :: Ref -> RPL -> [Text] -> Hulk () +serverReply ref typ params = do + msg <- newServerMsg typ params + reply ref msg + +-- | Make a new IRC message from the server. +newServerMsg :: RPL -> [Text] -> Hulk Message +newServerMsg cmd ps = do + hostname <- asks (connServerName.readConn) + return (Message (Just (Nick (encodeUtf8 hostname))) + (makeCommand cmd ps)) + +-- | Send a cmd reply of the given type with the given params. +thisCmdReply :: RPL -> [Text] -> Hulk () +thisCmdReply typ params = do + ref <- getRef + cmdReply ref typ params + +-- | Send a cmd reply of the given type with the given params. +cmdReply :: Ref -> RPL -> [Text] -> Hulk () +cmdReply ref typ params = do + let msg = newCmdMsg typ params + reply ref msg + +-- | Send an error reply. +errorReply :: Text -> Hulk () +errorReply m = do + notice $ "ERROR: " <> m + log $ "ERROR: " <> m + +-- | Send a message reply. +reply :: Ref -> Message -> Hulk () +reply ref msg = do + outgoing msg + tell . return $ MessageReply ref msg + +-- | Log an incoming line. +incoming :: Command -> Hulk () +incoming = log . ("<- " <>) . decodeUtf8 . IRC.showCommand + +-- | Log an outgoing line. +outgoing :: Message -> Hulk () +outgoing msg = do + ref <- getRef + tell [outgoingWriter ref msg] + +-- | Log a line. +log :: Text -> Hulk () +log line = do + ref <- getRef + tell . return . LogReply $ pack (show (unRef ref)) <> ": " <> line + +-- | Make a writer reply. +outgoingWriter :: Ref -> Message -> HulkWriter +outgoingWriter ref = + LogReply . + (pack (show (unRef ref)) <>) . + (": -> " <>) . + decodeUtf8 . + IRC.showMessage + +historyLog :: RPL -> [Text] -> Hulk () +historyLog rpl params = do + chans <- asks (configLogChans . readConfig) + unless (null chans) $ do + withRegistered $ \RegUser{regUserUser=name} -> do + let send = tell [SaveLog (userText name) rpl params] + case (rpl,params) of + (RPL_PRIVMSG,[chan]) + | chan `elem` chans -> send + | otherwise -> return () + _ -> send + +-------------------------------------------------------------------------------- +-- * Command Construction + +-- | Make a command. +makeCommand :: RPL -> [Text] -> Command +makeCommand rpl xs = fromRPL rpl (map encodeUtf8 xs) + +-- | Convert from a reply to an appropriate protocol format. +fromRPL :: RPL -> ([CommandArg] -> Command) +fromRPL RPL_NICK = StringCmd "NICK" +fromRPL RPL_PONG = StringCmd "PONG" +fromRPL RPL_QUIT = StringCmd "QUIT" +fromRPL RPL_JOIN = StringCmd "JOIN" +fromRPL RPL_NOTICE = StringCmd "NOTICE" +fromRPL RPL_PART = StringCmd "PART" +fromRPL RPL_PRIVMSG = StringCmd "PRIVMSG" +fromRPL RPL_JOINS = StringCmd "JOIN" +fromRPL RPL_TOPIC = StringCmd "TOPIC" +fromRPL RPL_PING = StringCmd "PING" +fromRPL RPL_WHOISUSER = NumericCmd 311 +fromRPL RPL_ISON = NumericCmd 303 +fromRPL RPL_NAMEREPLY = NumericCmd 353 +fromRPL RPL_ENDOFNAMES = NumericCmd 366 +fromRPL RPL_WELCOME = NumericCmd 001 +fromRPL RPL_MOTDSTART = NumericCmd 375 +fromRPL RPL_MOTD = NumericCmd 372 +fromRPL RPL_ENDOFMOTD = NumericCmd 376 +fromRPL RPL_WHOISIDLE = NumericCmd 317 +fromRPL RPL_WHOISCHANNELS = NumericCmd 319 +fromRPL RPL_ENDOFWHOIS = NumericCmd 318 +fromRPL ERR_NICKNAMEINUSE = NumericCmd 433 +fromRPL ERR_NOSUCHNICK = NumericCmd 401 +fromRPL ERR_NOSUCHCHANNEL = NumericCmd 403 + +-- | Make a new IRC message from the cmd. +newCmdMsg :: RPL -> [Text] -> Message +newCmdMsg cmd ps = Message Nothing (makeCommand cmd ps) diff --git a/src/Hulk/Concurrent.hs b/src/Hulk/Concurrent.hs deleted file mode 100644 --- a/src/Hulk/Concurrent.hs +++ /dev/null @@ -1,18 +0,0 @@ -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 --- a/src/Hulk/Config.hs +++ b/src/Hulk/Config.hs @@ -1,13 +1,15 @@ -{-# OPTIONS -Wall -fno-warn-missing-signatures -fno-warn-name-shadowing #-} +-- | Configuration parser for the server. + module Hulk.Config (Config(..) ,getConfig) where +import Hulk.Types + import Data.Word import Data.ConfigFile - -import Hulk.Types +import Data.Text (pack) getConfig :: FilePath -> IO Config getConfig conf = do @@ -20,13 +22,20 @@ 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 - } + users <- get c "USERS" "data_dir" + logs <- get c "LOGS" "event_log" + chans <- fmap words $ get c "LOGS" "channels" + return Config + { configListen = fromIntegral (listen::Word16) + , configMotd = Just motd + , configHostname = pack hostname + , configPasswd = passwd + , configPasswdKey = key + , configPreface = Just preface + , configUserData = users + , configLogFile = logs + , configLogChans = map pack chans + } case config of - Left cperr -> error $ show cperr - Right config -> return config + Left cperr -> error $ show cperr + Right config' -> return config' diff --git a/src/Hulk/Event.hs b/src/Hulk/Event.hs deleted file mode 100644 --- a/src/Hulk/Event.hs +++ /dev/null @@ -1,9 +0,0 @@ -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 deleted file mode 100644 --- a/src/Hulk/Log.hs +++ /dev/null @@ -1,49 +0,0 @@ -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/Providers.hs b/src/Hulk/Providers.hs deleted file mode 100644 --- a/src/Hulk/Providers.hs +++ /dev/null @@ -1,23 +0,0 @@ -{-# 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 --- a/src/Hulk/Server.hs +++ b/src/Hulk/Server.hs @@ -1,92 +1,183 @@ -{-# LANGUAGE RecordWildCards #-} -{-# OPTIONS -Wall -fno-warn-name-shadowing #-} -module Hulk.Server (start) where +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +module Hulk.Server where + +import Hulk.Client (handleCommand, makeCommand, + outgoingWriter) +import Hulk.Types + import Control.Applicative import Control.Concurrent import Control.Concurrent.Delay +import Control.Exception (IOException, try) import Control.Monad import Control.Monad.Fix -import Control.Monad.Reader -import qualified Data.Map as M +import Data.Aeson +import qualified Data.ByteString.Char8 as S8 +import qualified Data.ByteString.Lazy as L +import qualified Data.ByteString.Lazy.Char8 as L8 +import Data.CaseInsensitive +import Data.Char +import qualified Data.Map as M +import Data.Maybe +import Data.Monoid +import Data.Text (Text, pack, unpack) +import qualified Data.Text as T +import Data.Text.Encoding (encodeUtf8) +import qualified Data.Text.IO as T import Data.Time import Network -import Network.IRC +import Network.FastIRC hiding (UserName) +import qualified Network.FastIRC.IO as IRC +import Prelude hiding (catch) +import System.Directory +import System.FilePath 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 } + statevar <- newMVar HulkState { stateClients = M.empty + , stateNicks = M.empty + , stateChannels = M.empty } + lvar <- newMVar () forever $ do (handle,host,_port) <- accept listenSock hSetBuffering handle NoBuffering now <- getCurrentTime - let conn = Conn { connRef = newRef handle - , connHostname = host + let conn = Conn { connRef = mkRef handle + , connHostname = pack host , connServerName = configHostname config , connTime = now } - _ <- forkIO $ handleClient config handle envar conn - return () + auth <- getAuth config + void $ forkIO $ handleClient lvar config handle statevar auth conn -- | 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."] +handleClient :: MVar () -> Config -> Handle -> MVar HulkState -> (String,String) -> Conn -> IO () +handleClient lvar config handle env auth conn = do + messages <- newChan + let writeMsg cmd = + writeChan messages (Message Nothing (StringCmd cmd [])) - where newline c = c=='\n' || c=='\r' + pinger <- forkIO $ forever $ do + delayMinutes 2 + writeMsg "PINGPONG" --- | 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 } + void $ forkIO $ fix $ \loop -> do + eline <- try (S8.hGetLine handle) + case eline of + Left (_::IOException) -> do killThread pinger + writeMsg "DISCONNECT" + Right line -> + case readMessage line of + Just msg -> do writeChan messages msg + loop + Nothing -> loop --- | Handle a received line from the client. -runClientHandler :: Config -> MVar Env -> Handle -> Conn -> String -> IO () -runClientHandler config env handle conn line = do + fix $ \loop -> do + msg <- readChan messages + runClientHandler lvar config env handle conn auth msg + case msg of + Message _ (StringCmd "DISCONNECT" _) -> return () + _ -> loop + +-- | Handle a received message from the client. +runClientHandler :: MVar () -> Config -> MVar HulkState -> Handle -> Conn -> (String,String) -> Message -> IO () +runClientHandler lvar config mstate handle conn auth msg = do now <- getCurrentTime - modifyMVar_ env $ \env -> do - (replies,env) <- runReaderT (runHulkIO $ handleLine env now conn line) - config - mapM_ (handleReplies handle) replies - return env + instructions <- modifyMVar mstate $ \state -> return $ + let ((),newstate,instructions) = handleCommand config state now conn auth (msgCommand msg) + in (newstate,instructions) + forM_ instructions $ handleWriter lvar config handle --- | Act on replies from the client. -handleReplies :: Handle -> Reply -> IO () -handleReplies handle reply = do - case reply of +-- | Act on writer from the client. +handleWriter :: MVar () -> Config -> Handle -> HulkWriter -> IO () +handleWriter lvar config@Config{..} handle writer = do + case writer of + SaveLog name rpl params -> saveToLog lvar config name rpl params MessageReply ref msg -> sendMessage ref msg LogReply line -> logLine line Close -> hClose handle + Bump (Ref h) -> hClose h + UpdateUserData udata -> do + L.writeFile (configUserData normalizeUser (unpack (userText (userDataUser udata)))) + (encode udata) + SendEvents ref user -> do + writers <- sendEvents config ref user + mapM_ (handleWriter lvar config handle) (concat writers) -- | Send a message to a client. sendMessage :: Ref -> Message -> IO () -sendMessage (Ref handle) msg = do - catch (UTF8.hPutStrLn handle (encode msg ++ "\r")) - (\_ -> hClose handle) +sendMessage (Ref handle) msg = + void $ (try $ IRC.hPutMessage handle msg :: IO (Either IOException ())) -- | Add a line to the log file. -logLine :: String -> IO () -logLine = UTF8.putStrLn +logLine :: Text -> IO () +logLine = T.putStrLn + +-- | Normalize the username for a filename. +normalizeUser :: [Char] -> [Char] +normalizeUser = filter (\c -> isDigit c || isLetter c) + +-- | Send events that the user missed. +sendEvents :: Config -> Ref -> UserName -> IO [[HulkWriter]] +sendEvents config ref user = do + events <- getLog config + UserData{userDataLastSeen=lastSeen} <- getUser config (userText user) + let filtered = flip filter events $ \(time,_from,_typ,_params) -> + time >. lastSeen + forM filtered $ \msg -> do + case msg of + (time,from',rpl@RPL_PRIVMSG,[name,msg']) + | name == userText user || "#" `T.isPrefixOf` name -> do + let from = T.filter (\c -> isDigit c || isLetter c) from' + user' = User (encodeUtf8 from) + (encodeUtf8 from) + "offline" + message = Message (Just user') + (makeCommand rpl + [name,"[" <> pack (show time) <> "] " <> msg']) + return [MessageReply ref message + ,outgoing message] + _ -> return [] + + where x >. y = x `diffUTCTime` y > 0 + outgoing msg = outgoingWriter ref msg + +-- | Get the log. +getLog :: FromJSON b => Config -> IO [b] +getLog Config{..} = do + contents <- L.readFile configLogFile + return $ mapMaybe decode $ L8.lines contents + +-- | Get the user data. +getUser :: Config -> Text -> IO UserData +getUser Config{..} name = do + let fname = configUserData normalizeUser (unpack name) + now <- getCurrentTime + exists <- doesFileExist fname + if exists + then do contents <- L.readFile fname + case decode contents of + Just u -> return u + Nothing -> error ("unable to parse user file: " ++ fname) + else return $ UserData (UserName (mk name)) now + +-- | Get authorization info. +getAuth :: Config -> IO (String,String) +getAuth Config{..} = + (,) <$> readFile configPasswdKey + <*> readFile configPasswd + +-- | Save the message to the log. +saveToLog :: MVar () -> Config -> Text -> RPL -> [Text] -> IO () +saveToLog lvar Config{..} name rpl params = do + now <- getCurrentTime + withMVar lvar $ const $ + L.appendFile configLogFile $ + encode ((now,name,rpl,params)) <> "\n" diff --git a/src/Hulk/Types.hs b/src/Hulk/Types.hs --- a/src/Hulk/Types.hs +++ b/src/Hulk/Types.hs @@ -1,186 +1,275 @@ -{-# OPTIONS -Wall -fno-warn-name-shadowing #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} -module Hulk.Types where +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} -import Control.Monad.Identity -import Control.Monad.Reader -import Control.Monad.State -import Control.Monad.Writer -import Data.Char -import Data.Function +module Hulk.Types + (Config (..) + ,Nick (..) -- FIXME: + ,nickText + ,UserName (..) -- FIXME: + ,userText + ,ChannelName (..) -- FIXME: + ,channelNameText + ,Channel (..) + ,Client (..) + ,User (..) + ,UnregUser (..) + ,RegUser (..) + ,Ref (..) + ,mkRef + ,UserData (..) + ,Conn (..) + ,Event (..) + ,RPL (..) + ,QuitType (..) + ,ChannelReplyType (..) + ,Hulk + ,runHulk + ,HulkReader(..) + ,HulkWriter(..) + ,HulkState(..)) + where + +import Control.Applicative +import Control.Monad.RWS +import Data.Aeson +import Data.CaseInsensitive import Data.Map (Map) +import Data.Set (Set) +import Data.Text (Text) import Data.Time +import GHC.Generics import Network -import Network.IRC hiding (Channel) +import Network.FastIRC (Message) import System.IO -data Config = Config { - configListen :: PortNumber - , configHostname :: String - , configMotd :: Maybe FilePath - , configPreface :: Maybe FilePath - , configPasswd :: FilePath - , configPasswdKey :: FilePath - } deriving (Show) +-------------------------------------------------------------------------------- +-- Configuration -newtype Ref = Ref { unRef :: Handle } - deriving (Show,Eq) +-- | Server configuration. +data Config = Config + { configListen :: !PortNumber + , configHostname :: !Text + , configMotd :: !(Maybe FilePath) + , configPreface :: !(Maybe FilePath) + , configPasswd :: !FilePath + , configPasswdKey :: !FilePath + , configUserData :: !FilePath + , configLogFile :: !FilePath + , configLogChans :: ![Text] + } deriving (Show) -instance Ord Ref where - compare = on compare show +-------------------------------------------------------------------------------- +-- Fundamental IRC data types --- | Construct a Ref value. -newRef :: Handle -> Ref -newRef = Ref +-- | A case-insensitive nickname. +newtype Nick = NickName (CI Text) + deriving (Show,Eq,Ord) -data Error = Error String +-- | Extract the text of a nickname for use in output. +nickText :: Nick -> Text +nickText (NickName ci) = original ci -data Env = Env { - envClients :: Map Ref Client - ,envNicks :: Map Nick Ref - ,envChannels :: Map ChannelName Channel -} +-- | A case-insensitive username. +newtype UserName = UserName (CI Text) + deriving (Show,Eq,Ord,Generic) -newtype Nick = Nick { unNick :: String } deriving Show +instance ToJSON UserName where + toJSON (UserName ci) = toJSON (original ci) +instance FromJSON UserName where + parseJSON = fmap (UserName . mk) . parseJSON -instance Ord Nick where - compare = on compare (map toLower . unNick) -instance Eq Nick where - (==) = on (==) (map toLower . unNick) +-- | Extract the text of a username for use in output. +userText :: UserName -> Text +userText (UserName ci) = original ci -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) +-- | A case-insensitive channel name. +newtype ChannelName = ChannelName (CI Text) + deriving (Show,Eq,Ord) -data Channel = Channel { - channelName :: ChannelName - , channelTopic :: Maybe String - , channelUsers :: [Ref] -} deriving Show +-- | Extract the text of a channelname for use in output. +channelNameText :: ChannelName -> Text +channelNameText (ChannelName ci) = original ci -data User = Unregistered UnregUser | Registered RegUser +-------------------------------------------------------------------------------- +-- Server state types + +-- | A channel. +data Channel = Channel + { channelName :: !ChannelName + , channelTopic :: !(Maybe Text) + , channelUsers :: !(Set Ref) + } deriving (Show) + +-------------------------------------------------------------------------------- +-- Client data types + +-- | A connected client. +data Client = Client + { clientRef :: !Ref + , clientUser :: !User + , clientHostname :: !Text + , clientLastPong :: !UTCTime + } deriving (Show) + +-- | Some user, either unregistered or registered. +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 +-- | An unregistered user. +data UnregUser = UnregUser + { unregUserName :: !(Maybe Text) + , unregUserNick :: !(Maybe Nick) + , unregUserUser :: !(Maybe UserName) + , unregUserPass :: !(Maybe Text) + } deriving (Show) -data RegUser = RegUser { - regUserName :: String - ,regUserNick :: Nick - ,regUserUser :: String - ,regUserPass :: String -} deriving Show +-- | A registered user. +data RegUser = RegUser + { regUserName :: !Text + , regUserNick :: !Nick + , regUserUser :: !UserName + , regUserPass :: !Text + } deriving (Show) -data Client = Client { - clientRef :: Ref - , clientUser :: User - , clientHostname :: String - , clientLastPong :: UTCTime - } deriving Show +-- | A reference for a client. +newtype Ref = Ref { unRef :: Handle } + deriving (Show,Eq) -data Conn = Conn { - connRef :: Ref - ,connHostname :: String - ,connServerName :: String - ,connTime :: UTCTime -} deriving Show +-- | Make a ref. +mkRef :: Handle -> Ref +mkRef = Ref -data Reply = MessageReply Ref Message | LogReply String | Close +-- | Use for refs in maps. +instance Ord Ref where + compare x y = if x == y then EQ else LT -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 saved about a user for later actions like log recall. +data UserData = UserData + { userDataUser :: !UserName + , userDataLastSeen :: !UTCTime + } deriving (Show,Generic) -data Event = PASS | USER | NICK | PING | QUIT | TELL | JOIN | PART | PRIVMSG - | NOTICE | ISON | WHOIS | TOPIC | CONNECT | DISCONNECT | PINGPONG - | PONG - | NOTHING - deriving (Read,Show) +instance ToJSON UserData +instance FromJSON UserData +-------------------------------------------------------------------------------- +-- Client handling types -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 +-- | The Hulk client monad. +newtype Hulk a = Hulk { runHulk :: RWS HulkReader [HulkWriter] HulkState a } + deriving (Monad, + Functor, + Applicative, + MonadReader HulkReader, + MonadWriter [HulkWriter], + MonadState HulkState) -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" +-- | Configuration/environment information for running the client +-- handler. +data HulkReader = HulkReader + { readTime :: !UTCTime + , readConn :: !Conn + , readConfig :: !Config + , readMotd :: !(Maybe Text) + , readAuth :: (String,String) + } deriving (Show) -data QuitType = RequestedQuit | SocketQuit deriving Eq +-- | State of the whole server, which the client handles. +data HulkState = HulkState + { stateClients :: !(Map Ref Client) + , stateNicks :: !(Map Nick Ref) + , stateChannels :: !(Map ChannelName Channel) + } deriving (Show) -data ChannelReplyType = IncludeMe | ExcludeMe deriving Eq +-- | Replies are generated by the client after some messages. +data HulkWriter + = MessageReply !Ref !Message + | LogReply !Text + | Close + | Bump !Ref + | UpdateUserData !UserData + | SaveLog !Text !RPL ![Text] + | SendEvents !Ref !UserName + deriving (Show) -class Monad m => MonadProvider m where - providePreface :: m (Maybe String) - provideMotd :: m (Maybe String) - provideKey :: m String - providePasswords :: m String +-- | Used when handling a line from a client. +data Conn = Conn + { connRef :: !Ref + , connHostname :: !Text + , connServerName :: !Text + , connTime :: !UTCTime + } deriving (Show) -newtype HulkIO a = HulkIO { runHulkIO :: ReaderT Config IO a } - deriving (Monad,MonadReader Config,Functor,MonadIO) +-- | An incoming client message. +data Event + = PASS + | USER + | NICK + | PING + | QUIT + | TELL + | JOIN + | PART + | PRIVMSG + | NOTICE + | ISON + | WHOIS + | TOPIC + | CONNECT + | DISCONNECT + | PINGPONG + | PONG + | NAMES + | NOTHING + deriving (Show,Read) -newtype HulkP a = HulkP { runHulkPure :: Identity a } - deriving (Monad) +-- | An outgoing server reply. +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,Generic) -instance MonadTrans IRC where - lift m = do - s <- get - IRC $ ReaderT $ \_ -> WriterT $ StateT $ \_ -> do - a <- m - return ((a,[]),s) +instance ToJSON RPL +instance FromJSON RPL + +-- | When quitting it can either be due to user request, ping timeout, +-- or the socket was closed. +data QuitType + = RequestedQuit + | SocketQuit + deriving (Show,Eq) + +-- | When sending a channel reply, it can either include the current +-- client or exclude them (e.g. when the client sends a message, it's +-- no use echoing it back to that user). +data ChannelReplyType + = IncludeMe + | ExcludeMe + deriving (Show,Eq) diff --git a/txt/MOTD b/txt/MOTD deleted file mode 100644 --- a/txt/MOTD +++ /dev/null @@ -1,7 +0,0 @@ -Hello and welcome to this IRC server. I am your host, Dr. Bruce Banner -PhD in nuclear physics and HRRRRRNNNNNNNNNNNNGGGGGGGGGGGGGGGGGGGGGGGGG -HRRRRRNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNN -NNRUN FOR YOUR LIFENNNNNNNNNNNNNNNNNNNNNNNNNGGGGGGGGNNNNNNNNNNNNNNNNNN -NNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNN -GGGGGGGGGGGGGGGGGGGGGGGGGGGGGGGGGGGGGGGGGGGGGGGGGGGGGGGGGGGGGGGGGGGGGG -GG.. diff --git a/txt/PREFACE b/txt/PREFACE deleted file mode 100644 --- a/txt/PREFACE +++ /dev/null @@ -1,14 +0,0 @@ -You must login with a username and password. If you have not already -created one, you should do so by generating one and adding it to the -Hulk passwd file in passwd. To generate a user/password -key/pair, use: - - $ genpass myusername - -It will prompt for a password. Inspect it first to confirm it is -correct. To write it to the passwd file use - - $ genpass myusername >> /path/to/hulk/data/passwd - -And configure your IRC client to use your username and to send a -*server* password.