diff --git a/src/IRCD/Clients.hs b/src/IRCD/Clients.hs index 6b9647b..2372cd5 100644 --- a/src/IRCD/Clients.hs +++ b/src/IRCD/Clients.hs @@ -13,13 +13,24 @@ - limitations under the License. -} -module IRCD.Clients (insertClient) where +module IRCD.Clients +(firstAvailableID, insertClient, deleteClient, deleteClientByUid) +where -import qualified Data.Map as M (insert) -import qualified Data.IntMap as IM (insert) +import Data.List (sort) +import qualified Data.Map as M (insert, delete) +import qualified Data.IntMap as IM (keys, insert, delete) import IRCD.Types.Client import IRCD.Types.Clients +firstAvailableID :: Clients -> Int +firstAvailableID = f 1 . sort . IM.keys . byUid + where + f n (x:xs) + | n == x = f (succ n) xs + | otherwise = n + f n _ = n + insertClient :: Client -> Clients -> Clients insertClient client clients = clients { byUid = byUid' @@ -32,3 +43,19 @@ insertClient client clients = clients byNick' = case nick client of Nothing -> byNick clients Just nick' -> M.insert nick' client (byNick clients) + +deleteClient :: Client -> Clients -> Clients +deleteClient client clients = clients + { byUid = byUid' + , byNick = byNick' + } + where + byUid' = case uid client of + Nothing -> byUid clients + Just uid' -> IM.delete uid' (byUid clients) + byNick' = case nick client of + Nothing -> byNick clients + Just nick' -> M.delete nick' (byNick clients) + +deleteClientByUid :: Int -> Clients -> Clients +deleteClientByUid uid' clients = clients {byUid = IM.delete uid' (byUid clients)} diff --git a/src/IRCD/Server.hs b/src/IRCD/Server.hs index 7603178..af79f69 100644 --- a/src/IRCD/Server.hs +++ b/src/IRCD/Server.hs @@ -13,7 +13,9 @@ - limitations under the License. -} -module IRCD.Server where +{-# LANGUAGE LambdaCase #-} + +module IRCD.Server (serveIRC) where import Control.Monad.State import Control.Concurrent (forkIO) @@ -22,13 +24,14 @@ import Network.Socket import System.IO import System.IO.Error (tryIOError) import qualified IRCD.TS6 as TS6 -import IRCD.Types.Env (Env, defaultEnv) +import IRCD.Types.Env (Env, clients, defaultEnv) import IRCD.Types.Client (uid, defaultClient) -import IRCD.Clients (insertClient) +import IRCD.Clients (firstAvailableID, insertClient, deleteClientByUid) import IRCD.Env (mapClients) data Notification = Accept Handle | Recv Int String + | Disconnect Int deriving Show serveIRC :: IO () @@ -37,7 +40,7 @@ serveIRC = do setSocketOption sock NoDelay 1 setSocketOption sock ReuseAddr 1 {- 6 = TCP option, 9 = defer accept - - only supported on GNU systems + - only supported on Linux systems -} tryIOError $ setSocketOption sock (CustomSockOpt (6, 9)) 30 >> putStrLn "Using deferred accept for connections" @@ -60,16 +63,19 @@ acceptLoop chan sock = do acceptLoop chan sock inputLoop :: Chan Notification -> Socket -> Handle -> Int -> IO () -inputLoop chan sock handle uid = do - hGetLine handle >>= writeChan chan . Recv uid - inputLoop chan sock handle uid +inputLoop chan sock handle uid' = do + tryIOError (hGetLine handle >>= writeChan chan . Recv uid') >>= \case + Left _ -> tryIOError (hClose handle) >> writeChan chan (Disconnect uid') + _ -> inputLoop chan sock handle uid' mainLoop :: Chan Notification -> Socket -> StateT Env IO () mainLoop chan sock = do note <- liftIO (readChan chan) case note of Accept handle -> do - modify $ mapClients (insertClient defaultClient {uid=Just 5000}) - void $ liftIO $ forkIO (inputLoop chan sock handle 5000) - Recv uid line -> liftIO $ putStrLn ("[::" ++ TS6.intToID uid ++ "] " ++ line) + uid' <- gets clients >>= return . firstAvailableID + modify $ mapClients (insertClient defaultClient {uid=Just uid'}) + void $ liftIO $ forkIO (inputLoop chan sock handle uid') + Recv uid' line -> liftIO $ putStrLn ("[::" ++ TS6.intToID uid' ++ "] " ++ line) + Disconnect uid' -> modify $ mapClients (deleteClientByUid uid') mainLoop chan sock