packages feed

hulk 0.1 → 0.1.1

raw patch · 14 files changed

+1185/−1 lines, 14 files

Files

hulk.cabal view
@@ -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
+ src/Control/Concurrent/Delay.hs view
@@ -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)
+ src/Control/Monad/IO.hs view
@@ -0,0 +1,6 @@+module Control.Monad.IO (io) where++import Control.Monad.Trans++io :: MonadIO m => IO a -> m a+io = liftIO
+ src/Data/String.hs view
@@ -0,0 +1,8 @@+module Data.String where++import Data.List+import Data.Char++downcase = map toLower++digilet c = isDigit c || isLetter c
+ src/Hulk/Auth.hs view
@@ -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
+ src/Hulk/Client.hs view
@@ -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
+ src/Hulk/Concurrent.hs view
@@ -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
+ src/Hulk/Config.hs view
@@ -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
+ src/Hulk/Event.hs view
@@ -0,0 +1,9 @@+module Hulk.Event where++import Hulk.Types++readEventType :: String -> Event+readEventType str = +  case reads str of+    [(a,"")] -> a+    _        -> NOTHING
+ src/Hulk/Log.hs view
@@ -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
+ src/Hulk/Options.hs view
@@ -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
+ src/Hulk/Providers.hs view
@@ -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
+ src/Hulk/Server.hs view
@@ -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
+ src/Hulk/Types.hs view
@@ -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)