diff --git a/Makefile b/Makefile index f123ec6..fcc1699 100644 --- a/Makefile +++ b/Makefile @@ -1,21 +1,23 @@ EXECUTABLE=lambdircd -FLAGS=-W -O2 -threaded +FLAGS=-W -O2 CFLAGS= all: build-plugins build build-plugins: - ghc $(FLAGS) $(CFLAGS) -isrc plugins/*.hs + find plugins -name '*.hs' -print0 | xargs -0 ghc $(FLAGS) $(CFLAGS) -isrc build: - ghc $(FLAGS) $(CFLAGS) -isrc src/Main -o $(EXECUTABLE) + ghc $(FLAGS) $(CFLAGS) -package ghc -package ghc-paths -isrc src/Main -o $(EXECUTABLE) -rts: - ghc $(FLAGS) $(CFLAGS) -isrc src/Main -o $(EXECUTABLE) -rtsopts +clean-all: clean-plugins clean + +clean-plugins: + find plugins -name '*.o' -print0 | xargs -0 rm -fv + find plugins -name '*.hi' -print0 | xargs -0 rm -fv clean: rm -fv $(EXECUTABLE) - rm -fv plugins/*.o plugins/*.hi find src -name '*.o' -print0 | xargs -0 rm -fv find src -name '*.hi' -print0 | xargs -0 rm -fv diff --git a/plugins/CModeNoExternal.hs b/plugins.old/CModeNoExternal.hs similarity index 100% rename from plugins/CModeNoExternal.hs rename to plugins.old/CModeNoExternal.hs diff --git a/plugins/Join.hs b/plugins.old/Join.hs similarity index 100% rename from plugins/Join.hs rename to plugins.old/Join.hs diff --git a/plugins/MaxChannels.hs b/plugins.old/MaxChannels.hs similarity index 100% rename from plugins/MaxChannels.hs rename to plugins.old/MaxChannels.hs diff --git a/plugins.old/Mode.hs b/plugins.old/Mode.hs new file mode 100644 index 0000000..4aa0047 --- /dev/null +++ b/plugins.old/Mode.hs @@ -0,0 +1,52 @@ +{- Copyright 2014 David Farrell + + - Licensed under the Apache License, Version 2.0 (the "License"); + - you may not use this file except in compliance with the License. + - You may obtain a copy of the License at + + - http://www.apache.org/licenses/LICENSE-2.0 + + - Unless required by applicable law or agreed to in writing, software + - distributed under the License is distributed on an "AS IS" BASIS, + - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + - See the License for the specific language governing permissions and + - limitations under the License. + -} + +module Mode where + +import Data.List (nub) +import Data.Maybe (fromMaybe) +import qualified Data.Map as M +import qualified Data.IntMap as IM +import IRC.Message +import IRC.Numeric +import IRC.Action +import qualified IRC.Server.Client as Client +import qualified IRC.Server.Channel as Chan +import IRC.Server.Client.Helper +import IRC.Server.Channel.Helper +import IRC.Server.Environment (whenRegistered) +import qualified IRC.Server.Environment as Env +import Config +import Plugin + +plugin = defaultPlugin {handlers=[CommandHandler "MODE" mode]} + +mode :: CommandHSpec +mode env (Message _ _ (chan@('#':_):xs)) = whenRegistered env $ env {Env.actions=a:Env.actions env} + where + locChans = Env.channels (Env.local env) + aMsg e = do + sendChannelOthersFromClient (Env.client e) e (Env.channels l M.! chan) $ "PRIVMSG " ++ chan ++ " :" ++ text + return e + where l = Env.local e + aNoSuch e = sendNumeric e numERR_NOSUCHCHANNEL [chan, "No such channel"] >> return e + a = if M.member chan locChans + then ChanAction "Mode" chan aMsg + else GenericAction aNoSuch +mode env (Message _ _ (chan:_)) = whenRegistered env $ env {Env.actions=a:Env.actions env} + where a = GenericAction $ \e -> sendNumeric e numERR_BADCHANNAME [chan, "Illegal channel name (no umodes yet)"] + >> return e +mode env _ = whenRegistered env $ env {Env.actions=a:Env.actions env} + where a = GenericAction $ \e -> sendNumeric e numERR_NEEDMOREPARAMS ["MODE", "Not enough parameters"] >> return e diff --git a/plugins/Nick.hs b/plugins.old/Nick.hs similarity index 100% rename from plugins/Nick.hs rename to plugins.old/Nick.hs diff --git a/plugins/Num.hs b/plugins.old/Num.hs similarity index 100% rename from plugins/Num.hs rename to plugins.old/Num.hs diff --git a/plugins/Part.hs b/plugins.old/Part.hs similarity index 100% rename from plugins/Part.hs rename to plugins.old/Part.hs diff --git a/plugins/Ping.hs b/plugins.old/Ping.hs similarity index 100% rename from plugins/Ping.hs rename to plugins.old/Ping.hs diff --git a/plugins/Pong.hs b/plugins.old/Pong.hs similarity index 100% rename from plugins/Pong.hs rename to plugins.old/Pong.hs diff --git a/plugins/Privmsg.hs b/plugins.old/Privmsg.hs similarity index 100% rename from plugins/Privmsg.hs rename to plugins.old/Privmsg.hs diff --git a/plugins/User.hs b/plugins.old/User.hs similarity index 100% rename from plugins/User.hs rename to plugins.old/User.hs diff --git a/plugins/Who.hs b/plugins.old/Who.hs similarity index 100% rename from plugins/Who.hs rename to plugins.old/Who.hs diff --git a/plugins/Whois.hs b/plugins.old/Whois.hs similarity index 100% rename from plugins/Whois.hs rename to plugins.old/Whois.hs diff --git a/plugins/Core/Nick.hs b/plugins/Core/Nick.hs new file mode 100644 index 0000000..617abcc --- /dev/null +++ b/plugins/Core/Nick.hs @@ -0,0 +1,42 @@ +{- Copyright 2014 David Farrell + + - Licensed under the Apache License, Version 2.0 (the "License"); + - you may not use this file except in compliance with the License. + - You may obtain a copy of the License at + + - http://www.apache.org/licenses/LICENSE-2.0 + + - Unless required by applicable law or agreed to in writing, software + - distributed under the License is distributed on an "AS IS" BASIS, + - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + - See the License for the specific language governing permissions and + - limitations under the License. + -} + +module Core.Nick (plugin) where + +import Data.Maybe (fromMaybe) +import Data.Char (toUpper) +import qualified Data.Map as M +import Control.Monad.State +import IRCD.Types +import IRCD.Env +import IRCD.Clients +import IRCD.Helper +import Hoist + +plugin :: Plugin +plugin = defaultPlugin {handlers=[CommandHandler "NICK" nickHandler]} + +nickHandler :: HandlerSpec +nickHandler src@(ClientSrc client) (Message _ _ _ (nick':_)) = do + nicks <- gets (byNick . envClients) + if upperNick `M.notMember` nicks || (upperNick == map toUpper clientNick && nick' /= clientNick) + then return [NickChangeAction src (nick client) nick' ioChange] + else return [GenericAction $ reply_ src "Nickname is already in use"] + where upperNick = map toUpper nick' + clientNick = fromMaybe "" (nick client) + ioChange = do + hoistState $ modify $ mapEnvClients (replaceClient client client {nick=Just nick'}) + when (registered client) $ reply_ src ("NICK " ++ nick') +nickHandler src _ = return [GenericAction $ reply_ src "No nickname given"] diff --git a/plugins/Core/NoExternal.hs b/plugins/Core/NoExternal.hs new file mode 100644 index 0000000..343a12c --- /dev/null +++ b/plugins/Core/NoExternal.hs @@ -0,0 +1,28 @@ +{- Copyright 2014 David Farrell + + - Licensed under the Apache License, Version 2.0 (the "License"); + - you may not use this file except in compliance with the License. + - You may obtain a copy of the License at + + - http://www.apache.org/licenses/LICENSE-2.0 + + - Unless required by applicable law or agreed to in writing, software + - distributed under the License is distributed on an "AS IS" BASIS, + - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + - See the License for the specific language governing permissions and + - limitations under the License. + -} + +module Core.NoExternal (plugin) where + +import IRCD.Types +import IRCD.Plugin + +plugin :: Plugin +plugin = defaultPlugin {startup=registerCMode 'n', transformers=[Transformer noExt 50]} + +noExt :: TransformerSpec +noExt action@(PrivmsgAction (ClientSrc client) (ChannelDst channel) msg io) + | 'n' `elem` modes channel && channel `notElem` channels client = return (False, []) + | otherwise = return (True, []) +noExt _ = return (True, []) diff --git a/plugins/Core/Ping.hs b/plugins/Core/Ping.hs new file mode 100644 index 0000000..8c4011b --- /dev/null +++ b/plugins/Core/Ping.hs @@ -0,0 +1,28 @@ +{- Copyright 2014 David Farrell + + - Licensed under the Apache License, Version 2.0 (the "License"); + - you may not use this file except in compliance with the License. + - You may obtain a copy of the License at + + - http://www.apache.org/licenses/LICENSE-2.0 + + - Unless required by applicable law or agreed to in writing, software + - distributed under the License is distributed on an "AS IS" BASIS, + - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + - See the License for the specific language governing permissions and + - limitations under the License. + -} + +module Core.Ping (plugin) where + +import Control.Monad.State (liftIO) +import IRCD.Types + +plugin :: Plugin +plugin = defaultPlugin {handlers=[CommandHandler "PING" ping]} + +ping :: HandlerSpec +ping src (Message tags prefix cmd (server1:_)) = return [GenericAction io] + where io = liftIO $ putStrLn "received PING" +ping src _ = return [GenericAction io] + where io = liftIO $ putStrLn "not enough parameters for PING" diff --git a/plugins/Core/Register.hs b/plugins/Core/Register.hs new file mode 100644 index 0000000..9469546 --- /dev/null +++ b/plugins/Core/Register.hs @@ -0,0 +1,45 @@ +{- Copyright 2014 David Farrell + + - Licensed under the Apache License, Version 2.0 (the "License"); + - you may not use this file except in compliance with the License. + - You may obtain a copy of the License at + + - http://www.apache.org/licenses/LICENSE-2.0 + + - Unless required by applicable law or agreed to in writing, software + - distributed under the License is distributed on an "AS IS" BASIS, + - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + - See the License for the specific language governing permissions and + - limitations under the License. + -} + +module Core.Register (plugin) where + +import Data.Maybe (isJust) +import IRCD.Types +import IRCD.Helper +import Hoist + +plugin :: Plugin +plugin = defaultPlugin {transformers=[Transformer register 200]} + +register :: TransformerSpec +register action@(NickChangeAction src@(ClientSrc client) _ new _) + | canRegister client {nick=Just new} = return (True, [RegisterAction src io]) + | otherwise = return (True, []) + where io = hoistState $ updateClientRegistered True (uid client) +register action@(UserChangeAction src@(ClientSrc client) _ new _) + | canRegister client {user=Just new} = return (True, [RegisterAction src io]) + | otherwise = return (True, []) + where io = hoistState $ updateClientRegistered True (uid client) +register action@(RealNameChangeAction src@(ClientSrc client) _ new _) + | canRegister client {realName=Just new} = return (True, [RegisterAction src io]) + | otherwise = return (True, []) + where io = hoistState $ updateClientRegistered True (uid client) +register _ = return (True, []) + +canRegister :: Client -> Bool +canRegister client + | registered client = False + | isJust (nick client) && isJust (user client) && isJust (realName client) = True + | otherwise = False diff --git a/plugins/Core/User.hs b/plugins/Core/User.hs new file mode 100644 index 0000000..a2675b7 --- /dev/null +++ b/plugins/Core/User.hs @@ -0,0 +1,33 @@ +{- Copyright 2014 David Farrell + + - Licensed under the Apache License, Version 2.0 (the "License"); + - you may not use this file except in compliance with the License. + - You may obtain a copy of the License at + + - http://www.apache.org/licenses/LICENSE-2.0 + + - Unless required by applicable law or agreed to in writing, software + - distributed under the License is distributed on an "AS IS" BASIS, + - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + - See the License for the specific language governing permissions and + - limitations under the License. + -} + +module Core.User (plugin) where + +import IRCD.Types +import IRCD.Helper +import Hoist + +plugin :: Plugin +plugin = defaultPlugin {handlers=[CommandHandler "USER" userHandler]} + +userHandler :: HandlerSpec +userHandler src@(ClientSrc client) (Message _ _ _ (user':_:_:realname:_)) + | registered client = return [GenericAction $ reply_ src "You may not reregister"] + | otherwise = return [ UserChangeAction src (user client) user' ioUser + , RealNameChangeAction src (realName client) realname ioRealName + ] + where ioUser = hoistState $ updateClientUser user' (uid client) + ioRealName = hoistState $ updateClientRealName realname (uid client) +userHandler src _ = return [GenericAction $ reply_ src "Not enough parameters"] diff --git a/plugins/Core/Welcome.hs b/plugins/Core/Welcome.hs new file mode 100644 index 0000000..c51ecc2 --- /dev/null +++ b/plugins/Core/Welcome.hs @@ -0,0 +1,27 @@ +{- Copyright 2014 David Farrell + + - Licensed under the Apache License, Version 2.0 (the "License"); + - you may not use this file except in compliance with the License. + - You may obtain a copy of the License at + + - http://www.apache.org/licenses/LICENSE-2.0 + + - Unless required by applicable law or agreed to in writing, software + - distributed under the License is distributed on an "AS IS" BASIS, + - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + - See the License for the specific language governing permissions and + - limitations under the License. + -} + +module Core.Welcome (plugin) where + +import IRCD.Types +import IRCD.Helper + +plugin :: Plugin +plugin = defaultPlugin {transformers=[Transformer welcome 80]} + +welcome :: TransformerSpec +welcome action@(RegisterAction src@(ClientSrc client) _) = return (True, [GenericAction io]) + where io = reply_ src "Welcome!" +welcome _ = return (True, []) diff --git a/src/Config.hs b/src.old/Config.hs similarity index 100% rename from src/Config.hs rename to src.old/Config.hs diff --git a/src/IRC/Action.hs b/src.old/IRC/Action.hs similarity index 100% rename from src/IRC/Action.hs rename to src.old/IRC/Action.hs diff --git a/src/IRC/Hostmask.hs b/src.old/IRC/Hostmask.hs similarity index 100% rename from src/IRC/Hostmask.hs rename to src.old/IRC/Hostmask.hs diff --git a/src/IRC/Message.hs b/src.old/IRC/Message.hs similarity index 100% rename from src/IRC/Message.hs rename to src.old/IRC/Message.hs diff --git a/src/IRC/Numeric.hs b/src.old/IRC/Numeric.hs similarity index 100% rename from src/IRC/Numeric.hs rename to src.old/IRC/Numeric.hs diff --git a/src/IRC/Prefix.hs b/src.old/IRC/Prefix.hs similarity index 100% rename from src/IRC/Prefix.hs rename to src.old/IRC/Prefix.hs diff --git a/src/IRC/Server.hs b/src.old/IRC/Server.hs similarity index 100% rename from src/IRC/Server.hs rename to src.old/IRC/Server.hs diff --git a/src/IRC/Server/Channel.hs b/src.old/IRC/Server/Channel.hs similarity index 100% rename from src/IRC/Server/Channel.hs rename to src.old/IRC/Server/Channel.hs diff --git a/src/IRC/Server/Channel/Helper.hs b/src.old/IRC/Server/Channel/Helper.hs similarity index 100% rename from src/IRC/Server/Channel/Helper.hs rename to src.old/IRC/Server/Channel/Helper.hs diff --git a/src/IRC/Server/Client.hs b/src.old/IRC/Server/Client.hs similarity index 100% rename from src/IRC/Server/Client.hs rename to src.old/IRC/Server/Client.hs diff --git a/src/IRC/Server/Client/Helper.hs b/src.old/IRC/Server/Client/Helper.hs similarity index 100% rename from src/IRC/Server/Client/Helper.hs rename to src.old/IRC/Server/Client/Helper.hs diff --git a/src/IRC/Server/Environment.hs b/src.old/IRC/Server/Environment.hs similarity index 100% rename from src/IRC/Server/Environment.hs rename to src.old/IRC/Server/Environment.hs diff --git a/src.old/Main.hs b/src.old/Main.hs new file mode 100644 index 0000000..3fb92b0 --- /dev/null +++ b/src.old/Main.hs @@ -0,0 +1,23 @@ +{- Copyright 2014 David Farrell + + - Licensed under the Apache License, Version 2.0 (the "License"); + - you may not use this file except in compliance with the License. + - You may obtain a copy of the License at + + - http://www.apache.org/licenses/LICENSE-2.0 + + - Unless required by applicable law or agreed to in writing, software + - distributed under the License is distributed on an "AS IS" BASIS, + - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + - See the License for the specific language governing permissions and + - limitations under the License. + -} + +import IRC.Server as IRCD +import IRC.Server.Environment +import Config + +main :: IO () +main = do + cp <- loadConfig "ircd.conf" + serveIRC defaultEnv {config=cp} diff --git a/src/Plugin.hs b/src.old/Plugin.hs similarity index 100% rename from src/Plugin.hs rename to src.old/Plugin.hs diff --git a/src/Plugin/Load.hs b/src.old/Plugin/Load.hs similarity index 100% rename from src/Plugin/Load.hs rename to src.old/Plugin/Load.hs diff --git a/src/Hoist.hs b/src/Hoist.hs new file mode 100644 index 0000000..efd5de3 --- /dev/null +++ b/src/Hoist.hs @@ -0,0 +1,21 @@ +{- Copyright 2014 David Farrell + + - Licensed under the Apache License, Version 2.0 (the "License"); + - you may not use this file except in compliance with the License. + - You may obtain a copy of the License at + + - http://www.apache.org/licenses/LICENSE-2.0 + + - Unless required by applicable law or agreed to in writing, software + - distributed under the License is distributed on an "AS IS" BASIS, + - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + - See the License for the specific language governing permissions and + - limitations under the License. + -} + +module Hoist where + +import Control.Monad.State + +hoistState :: Monad m => State s a -> StateT s m a +hoistState = StateT . (return .) . runState diff --git a/src/IRCD/Clients.hs b/src/IRCD/Clients.hs new file mode 100644 index 0000000..13e5b46 --- /dev/null +++ b/src/IRCD/Clients.hs @@ -0,0 +1,58 @@ +{- Copyright 2014 David Farrell + + - Licensed under the Apache License, Version 2.0 (the "License"); + - you may not use this file except in compliance with the License. + - You may obtain a copy of the License at + + - http://www.apache.org/licenses/LICENSE-2.0 + + - Unless required by applicable law or agreed to in writing, software + - distributed under the License is distributed on an "AS IS" BASIS, + - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + - See the License for the specific language governing permissions and + - limitations under the License. + -} + +module IRCD.Clients where + +import Data.List (sort) +import Data.Char (toUpper) +import qualified Data.Map as M (insert, delete) +import qualified Data.IntMap as IM +import IRCD.Types + +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' + , byNick = byNick' + } + where byUid' = IM.insert (uid client) client (byUid clients) + byNick' = case nick client of + Nothing -> byNick clients + Just nick' -> M.insert (map toUpper nick') client (byNick clients) + +deleteClient :: Client -> Clients -> Clients +deleteClient client clients = clients + { byUid = byUid' + , byNick = byNick' + } + where byUid' = IM.delete (uid client) (byUid clients) + byNick' = case nick client of + Nothing -> byNick clients + Just nick' -> M.delete (map toUpper nick') (byNick clients) + +replaceClient :: Client -> Client -> Clients -> Clients +replaceClient old new = insertClient new . deleteClient old + +deleteClientByUid :: Int -> Clients -> Clients +deleteClientByUid uid' clients = case uid' `IM.lookup` byUid clients of + Nothing -> clients + Just cli -> deleteClient cli clients diff --git a/src/IRCD/Env.hs b/src/IRCD/Env.hs new file mode 100644 index 0000000..faed238 --- /dev/null +++ b/src/IRCD/Env.hs @@ -0,0 +1,27 @@ +{- Copyright 2014 David Farrell + + - Licensed under the Apache License, Version 2.0 (the "License"); + - you may not use this file except in compliance with the License. + - You may obtain a copy of the License at + + - http://www.apache.org/licenses/LICENSE-2.0 + + - Unless required by applicable law or agreed to in writing, software + - distributed under the License is distributed on an "AS IS" BASIS, + - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + - See the License for the specific language governing permissions and + - limitations under the License. + -} + +module IRCD.Env where + +import IRCD.Types + +mapEnvClients :: (Clients -> Clients) -> Env -> Env +mapEnvClients f env = env {envClients = f (envClients env)} + +mapEnvHandlers :: ([Handler] -> [Handler]) -> Env -> Env +mapEnvHandlers f env = env {envHandlers = f (envHandlers env)} + +mapEnvTransformers :: ([Transformer] -> [Transformer]) -> Env -> Env +mapEnvTransformers f env = env {envTransformers = f (envTransformers env)} diff --git a/src/IRCD/Helper.hs b/src/IRCD/Helper.hs new file mode 100644 index 0000000..3574901 --- /dev/null +++ b/src/IRCD/Helper.hs @@ -0,0 +1,58 @@ +{- Copyright 2014 David Farrell + + - Licensed under the Apache License, Version 2.0 (the "License"); + - you may not use this file except in compliance with the License. + - You may obtain a copy of the License at + + - http://www.apache.org/licenses/LICENSE-2.0 + + - Unless required by applicable law or agreed to in writing, software + - distributed under the License is distributed on an "AS IS" BASIS, + - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + - See the License for the specific language governing permissions and + - limitations under the License. + -} + +{-# LANGUAGE LambdaCase #-} + +module IRCD.Helper where + +import qualified Data.IntMap as IM +import Control.Monad.State +import System.IO (hPutStrLn) +import IRCD.Types +import IRCD.Env +import IRCD.Clients + +checkClient :: Int -> State Env (Maybe Client) +checkClient uid' = do + uids <- gets (byUid . envClients) + return (IM.lookup uid' uids) + +checkClientRegistered :: Int -> State Env (Maybe Bool) +checkClientRegistered uid' = checkClient uid' >>= return . \case + Nothing -> Nothing + Just client' -> Just (registered client') + +updateClient :: (Client -> Client) -> Int -> State Env () +updateClient f uid' = do + checkClient uid' >>= modify . mapEnvClients . \case + Nothing -> insertClient (f (defaultClient uid')) + Just client' -> replaceClient client' (f client') + +updateClientNick :: String -> Int -> State Env () +updateClientNick nick' = updateClient (\c -> c {nick=Just nick'}) + +updateClientUser :: String -> Int -> State Env () +updateClientUser user' = updateClient (\c -> c {user=Just user'}) + +updateClientRealName :: String -> Int -> State Env () +updateClientRealName realname = updateClient (\c -> c {realName=Just realname}) + +updateClientRegistered :: Bool -> Int -> State Env () +updateClientRegistered r = updateClient (\c -> c {registered=r}) + +reply_ :: Source -> String -> StateT Env IO () +reply_ (ClientSrc client) msg = case handle client of + Nothing -> return () + Just h -> liftIO (hPutStrLn h msg) diff --git a/src/IRCD/Logic.hs b/src/IRCD/Logic.hs new file mode 100644 index 0000000..c9e2c2a --- /dev/null +++ b/src/IRCD/Logic.hs @@ -0,0 +1,53 @@ +{- Copyright 2014 David Farrell + + - Licensed under the Apache License, Version 2.0 (the "License"); + - you may not use this file except in compliance with the License. + - You may obtain a copy of the License at + + - http://www.apache.org/licenses/LICENSE-2.0 + + - Unless required by applicable law or agreed to in writing, software + - distributed under the License is distributed on an "AS IS" BASIS, + - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + - See the License for the specific language governing permissions and + - limitations under the License. + -} + +{-# LANGUAGE LambdaCase #-} + +module IRCD.Logic (doLogic) where + +import Control.Monad.State +import Hoist +import IRCD.Types +import IRCD.Message + +doLogic :: Client -> String -> StateT Env IO () +doLogic client line = do + actions <- gets envHandlers >>= hoistState . mapM fh >>= return . concat + ts <- gets envTransformers + actions' <- mapM (ft ts ts) actions >>= return . concat + liftIO (print actions') + --mapM_ actionSpec as + --hoistState (mapM (ft ts ts) actions) >>= mapM_ actionSpec . concat + where msg = parseMessage line + fh (GenericHandler spec) = spec (ClientSrc client) msg + fh (CommandHandler cmd spec) + | cmd == command msg = spec (ClientSrc client) msg + | otherwise = return [] + + ft ts [] action = return [action] + ft ts (Transformer spec _ : xs) action = hoistState (spec action) >>= \case + (False, actions) -> mapM (ft ts ts) actions >>= return . concat + (True, actions) -> do + this <- ft ts xs action + mapM_ actionSpec this + rest <- mapM (ft ts ts) actions >>= return . concat + return (concat [this, rest]) + +doLogic :: Client -> String -> StateT Env IO () +doLogic client line = do + actions <- gets envHandlers >>= hoistState . mapM fh >>= return . concat + ts <- gets envTransformers + map (transformAction ts) actions + where transformAction (Transformer spec _ : ts) action = hoistState (spec action)\ diff --git a/src/IRCD/Message.hs b/src/IRCD/Message.hs new file mode 100644 index 0000000..c472079 --- /dev/null +++ b/src/IRCD/Message.hs @@ -0,0 +1,38 @@ +{- Copyright 2014 David Farrell + + - Licensed under the Apache License, Version 2.0 (the "License"); + - you may not use this file except in compliance with the License. + - You may obtain a copy of the License at + + - http://www.apache.org/licenses/LICENSE-2.0 + + - Unless required by applicable law or agreed to in writing, software + - distributed under the License is distributed on an "AS IS" BASIS, + - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + - See the License for the specific language governing permissions and + - limitations under the License. + -} + +module IRCD.Message (parseMessage) where + +import Data.Char (isSpace, toUpper) +import IRCD.Types + +parseMessage :: String -> Message +parseMessage "" = Message () Nothing "" [] +parseMessage (':':xs) + | null prefix' = msg {prefix=Nothing} + | otherwise = msg {prefix=Just (StringPrefix prefix')} + where (prefix', rest) = break isSpace xs + msg = parseMessage rest +parseMessage (' ':':':xs) = parseMessage xs +parseMessage (' ':xs) = parseMessage xs +parseMessage line = Message () Nothing (map toUpper cmd) (parseParams rest) + where (cmd, rest) = break isSpace line + +parseParams :: String -> [String] +parseParams "" = [] +parseParams (' ':xs) = parseParams xs +parseParams (':':xs) = [xs] +parseParams str = x : parseParams (drop 1 xs) + where (x, xs) = break isSpace str diff --git a/src/IRCD/Numeric.hs b/src/IRCD/Numeric.hs new file mode 100644 index 0000000..3d3a2f8 --- /dev/null +++ b/src/IRCD/Numeric.hs @@ -0,0 +1,52 @@ +{- Copyright 2014 David Farrell + + - Licensed under the Apache License, Version 2.0 (the "License"); + - you may not use this file except in compliance with the License. + - You may obtain a copy of the License at + + - http://www.apache.org/licenses/LICENSE-2.0 + + - Unless required by applicable law or agreed to in writing, software + - distributed under the License is distributed on an "AS IS" BASIS, + - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + - See the License for the specific language governing permissions and + - limitations under the License. + -} + +module IRCD.Numeric where + +newtype Numeric = Numeric Int + +instance Show Numeric where + show (Numeric num) = replicate zeroes '0' ++ numString + where numString = show num + zeroes = maximum [0, 3 - length numString] + +numRPL_WELCOME = Numeric 001 +numRPL_YOURHOST = Numeric 002 +numRPL_CREATED = Numeric 003 +numRPL_WHOISUSER = Numeric 311 +numRPL_WHOISSERVER = Numeric 312 +numRPL_ENDOFWHO = Numeric 315 +numRPL_ENDOFWHOIS = Numeric 318 +numRPL_WHOISCHANNELS = Numeric 319 +numRPL_NAMREPLY = Numeric 353 +numRPL_ENDOFNAMES = Numeric 366 +numRPL_MOTD = Numeric 372 +numRPL_MOTDSTART = Numeric 375 +numRPL_ENDOFMOTD = Numeric 376 +numERR_NOSUCHNICK = Numeric 401 +numERR_NOSUCHCHANNEL = Numeric 403 +numERR_CANNOTSENDTOCHAN = Numeric 404 +numERR_TOOMANYCHANNELS = Numeric 405 +numERR_NORECIPIENT = Numeric 411 +numERR_NOTEXTTOSEND = Numeric 412 +numERR_UNKNOWNCOMMAND = Numeric 421 +numERR_NONICKNAMEGIVEN = Numeric 431 +numERR_NICKNAMEINUSE = Numeric 433 +numERR_NICKCOLLISION = Numeric 436 +numERR_NOTONCHANNEL = Numeric 442 +numERR_USERONCHANNEL = Numeric 443 +numERR_NEEDMOREPARAMS = Numeric 461 +numERR_ALREADYREGISTERED = Numeric 462 +numERR_BADCHANNAME = Numeric 479 diff --git a/src/IRCD/Plugin.hs b/src/IRCD/Plugin.hs new file mode 100644 index 0000000..52f14a8 --- /dev/null +++ b/src/IRCD/Plugin.hs @@ -0,0 +1,22 @@ +{- Copyright 2014 David Farrell + + - Licensed under the Apache License, Version 2.0 (the "License"); + - you may not use this file except in compliance with the License. + - You may obtain a copy of the License at + + - http://www.apache.org/licenses/LICENSE-2.0 + + - Unless required by applicable law or agreed to in writing, software + - distributed under the License is distributed on an "AS IS" BASIS, + - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + - See the License for the specific language governing permissions and + - limitations under the License. + -} + +module IRCD.Plugin (registerCMode) where + +import Control.Monad.State +import IRCD.Types + +registerCMode :: Char -> StateT Env IO () +registerCMode = undefined diff --git a/src/IRCD/Plugin/Load.hs b/src/IRCD/Plugin/Load.hs new file mode 100644 index 0000000..501e756 --- /dev/null +++ b/src/IRCD/Plugin/Load.hs @@ -0,0 +1,39 @@ +{- Copyright 2014 David Farrell + + - Licensed under the Apache License, Version 2.0 (the "License"); + - you may not use this file except in compliance with the License. + - You may obtain a copy of the License at + + - http://www.apache.org/licenses/LICENSE-2.0 + + - Unless required by applicable law or agreed to in writing, software + - distributed under the License is distributed on an "AS IS" BASIS, + - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + - See the License for the specific language governing permissions and + - limitations under the License. + -} + +{-# LANGUAGE LambdaCase #-} + +module IRCD.Plugin.Load where + +import GHC +import GHC.Paths (libdir) +import DynFlags +import Unsafe.Coerce +import IRCD.Types + +loadPlugin :: String -> IO (Maybe Plugin) +loadPlugin name' = do + defaultErrorHandler defaultFatalMessager defaultFlushOut $ do + runGhc (Just libdir) $ do + dflags <- getSessionDynFlags + setSessionDynFlags dflags {importPaths="plugins":"src":includePaths dflags} + target <- guessTarget name' Nothing + setTargets [target] + load LoadAllTargets >>= \case + Failed -> return Nothing + Succeeded -> do + setContext [IIDecl $ simpleImportDecl (mkModuleName name')] + result <- compileExpr "plugin" + return $ Just (unsafeCoerce result :: Plugin) diff --git a/src/IRCD/Server.hs b/src/IRCD/Server.hs new file mode 100644 index 0000000..03062a8 --- /dev/null +++ b/src/IRCD/Server.hs @@ -0,0 +1,91 @@ +{- Copyright 2014 David Farrell + + - Licensed under the Apache License, Version 2.0 (the "License"); + - you may not use this file except in compliance with the License. + - You may obtain a copy of the License at + + - http://www.apache.org/licenses/LICENSE-2.0 + + - Unless required by applicable law or agreed to in writing, software + - distributed under the License is distributed on an "AS IS" BASIS, + - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + - See the License for the specific language governing permissions and + - limitations under the License. + -} + +{-# LANGUAGE LambdaCase #-} + +module IRCD.Server (serveIRC) where + +import Data.List (sort) +import qualified Data.IntMap as IM ((!)) +import Control.Monad.State +import Control.Concurrent (forkIO) +import Control.Concurrent.Chan +import Network.Socket +import System.IO +import System.IO.Error (tryIOError) +import IRCD.Types +import IRCD.Clients (firstAvailableID, insertClient, deleteClientByUid) +import IRCD.Env +import IRCD.Logic (doLogic) + +data Notification = Accept Handle + | Recv Int String + | Disconnect Int + deriving Show + +serveIRC :: [Plugin] -> IO () +serveIRC plugins = do + sock <- socket AF_INET Stream defaultProtocol + setSocketOption sock NoDelay 1 + setSocketOption sock ReuseAddr 1 + {- 6 = TCP option, 9 = defer accept + - only supported on Linux systems + -} + tryIOError $ setSocketOption sock (CustomSockOpt (6, 9)) 30 + >> putStrLn "Using deferred accept for connections" + inet_addr "0.0.0.0" >>= bind sock . SockAddrInet 6667 + listen sock 5 + putStrLn $ "Listening on 0.0.0.0" ++ ":6667" + chan <- newChan + forkIO (acceptLoop chan sock) + evalStateT (main plugins chan sock) defaultEnv + +acceptLoop :: Chan Notification -> Socket -> IO () +acceptLoop chan sock = do + tryIOError $ do + (clientSock, sockAddr) <- accept sock + handle' <- socketToHandle clientSock ReadWriteMode + hSetNewlineMode handle' universalNewlineMode + hSetBuffering handle' LineBuffering + hSetEncoding handle' utf8 + writeChan chan (Accept handle') + acceptLoop chan sock + +inputLoop :: Chan Notification -> Socket -> Handle -> Int -> IO () +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' + +main :: [Plugin] -> Chan Notification -> Socket -> StateT Env IO () +main plugins chan sock = do + mapM_ startup plugins + modify $ mapEnvHandlers (++ concatMap handlers plugins) + modify $ mapEnvTransformers (++ sort (concatMap transformers plugins)) + mainLoop chan sock + +mainLoop :: Chan Notification -> Socket -> StateT Env IO () +mainLoop chan sock = do + note <- liftIO (readChan chan) + case note of + Accept handle' -> do + uid' <- gets envClients >>= return . firstAvailableID + modify $ mapEnvClients $ insertClient (defaultClient uid') {handle=Just handle'} + void $ liftIO $ forkIO (inputLoop chan sock handle' uid') + Recv uid' line -> do + client <- gets $ (IM.! uid') . byUid . envClients + doLogic client line + Disconnect uid' -> modify $ mapEnvClients (deleteClientByUid uid') + mainLoop chan sock diff --git a/src/IRCD/TS6.hs b/src/IRCD/TS6.hs new file mode 100644 index 0000000..e13ca96 --- /dev/null +++ b/src/IRCD/TS6.hs @@ -0,0 +1,26 @@ +{- Copyright 2014 David Farrell + + - Licensed under the Apache License, Version 2.0 (the "License"); + - you may not use this file except in compliance with the License. + - You may obtain a copy of the License at + + - http://www.apache.org/licenses/LICENSE-2.0 + + - Unless required by applicable law or agreed to in writing, software + - distributed under the License is distributed on an "AS IS" BASIS, + - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + - See the License for the specific language governing permissions and + - limitations under the License. + -} + +module IRCD.TS6 (intToID) where + +import Numeric (showIntAtBase) +import Data.Char (intToDigit) +import Text.Printf (printf) + +intToID :: Int -> String +intToID x = 'A' : printf "%05s" (showIntAtBase 36 toChr x "") + where toChr c + | 0 <= c && c <= 9 = intToDigit c + | otherwise = toEnum (c + (65 - 10)) diff --git a/src/IRCD/Types.hs b/src/IRCD/Types.hs new file mode 100644 index 0000000..35aaba7 --- /dev/null +++ b/src/IRCD/Types.hs @@ -0,0 +1,160 @@ +{- Copyright 2014 David Farrell + + - Licensed under the Apache License, Version 2.0 (the "License"); + - you may not use this file except in compliance with the License. + - You may obtain a copy of the License at + + - http://www.apache.org/licenses/LICENSE-2.0 + + - Unless required by applicable law or agreed to in writing, software + - distributed under the License is distributed on an "AS IS" BASIS, + - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + - See the License for the specific language governing permissions and + - limitations under the License. + -} + +module IRCD.Types where + +import qualified Data.Map as M (Map, empty) +import qualified Data.IntMap as IM (IntMap, empty) +import Control.Monad.State +import System.IO (Handle) + +data Message = Message + { tags :: () -- TODO: support message tags + , prefix :: Maybe Prefix + , command :: String + , params :: [String] + } deriving Show + +data Prefix = StringPrefix String + | MaskPrefix Hostmask + deriving Eq + +instance Show Prefix where + show (StringPrefix p) = p + show (MaskPrefix p) = show p + +data Hostmask = Hostmask + { maskNick :: String + , maskUser :: String + , maskHost :: String + } deriving Eq + +instance Show Hostmask where show (Hostmask n u h) = n ++ '!' : u ++ '@' : h + +data Client = Client + { uid :: Int + , handle :: Maybe Handle + , registered :: Bool + , nick :: Maybe String + , user :: Maybe String + , realName :: Maybe String + , host :: Maybe String + , channels :: [Channel] + } deriving (Show, Eq) + +data Clients = Clients + { byUid :: IM.IntMap Client + , byNick :: M.Map String Client + } deriving Show + +data Channel = Channel + { name :: String + , modes :: [Char] + , clients :: [Client] + } deriving (Show, Eq) + +data Source = ClientSrc Client deriving Show +data Destination = ChannelDst Channel deriving Show + +data Env = Env + { envClients :: Clients + , envHandlers :: [Handler] + , envTransformers :: [Transformer] + } + +data Plugin = Plugin + { pluginName :: String + , startup :: StateT Env IO () + , shutdown :: StateT Env IO () + , handlers :: [Handler] + , transformers :: [Transformer] + } + +type HandlerSpec = Source -> Message -> State Env [Action] +data Handler = GenericHandler HandlerSpec + | CommandHandler String HandlerSpec + +type TransformerSpec = Action -> State Env (Bool, [Action]) +data Transformer = Transformer TransformerSpec Int + +instance Show Transformer where + show (Transformer _ order) = "Transformer " ++ show order + +instance Eq Transformer where + Transformer _ x == Transformer _ y = x == y + +instance Ord Transformer where + Transformer _ x `compare` Transformer _ y = x `compare` y + +type ActionSpec = StateT Env IO () +data Action = GenericAction ActionSpec + | PrivmsgAction Source Destination Message ActionSpec + | NickChangeAction Source (Maybe String) String ActionSpec + | UserChangeAction Source (Maybe String) String ActionSpec + | RealNameChangeAction Source (Maybe String) String ActionSpec + | RegisterAction Source ActionSpec + +instance Show Action where + show (GenericAction _) = "GenericAction " + show (PrivmsgAction src dst msg _) = "PrivmsgAction " ++ show src ++ ' ' : show dst ++ ' ' : show msg ++ " " + show (NickChangeAction src old new _) = "NickChangeAction " ++ show src ++ ' ' : show old ++ ' ' : new ++ " " + show (UserChangeAction src old new _) = "UserChangeAction " ++ show src ++ ' ' : show old ++ ' ' : new ++ " " + show (RealNameChangeAction src old new _) = "RealNameChangeAction " ++ show src ++ ' ' : show old ++ ' ' : new ++ " " + show (RegisterAction src _) = "RegisterAction " ++ show src ++ " " + +actionSpec :: Action -> ActionSpec +actionSpec (GenericAction spec) = spec +actionSpec (PrivmsgAction _ _ _ spec) = spec +actionSpec (NickChangeAction _ _ _ spec) = spec +actionSpec (UserChangeAction _ _ _ spec) = spec +actionSpec (RealNameChangeAction _ _ _ spec) = spec +actionSpec (RegisterAction _ spec) = spec + +defaultClient :: Int -> Client +defaultClient uid' = Client + { uid = uid' + , handle = Nothing + , registered = False + , nick = Nothing + , user = Nothing + , realName = Nothing + , host = Nothing + , channels = [] + } + +defaultClients :: Clients +defaultClients = Clients + { byUid = IM.empty + , byNick = M.empty + } + +defaultEnv :: Env +defaultEnv = Env + { envClients = defaultClients + , envHandlers = [] + , envTransformers = [] + } + +defaultPlugin :: Plugin +defaultPlugin = Plugin + { pluginName = "" + , startup = return () + , shutdown = return () + , handlers = [] + , transformers = [] + } + +defaultTransformer :: TransformerSpec -> Transformer +defaultTransformer f = Transformer f 100 diff --git a/src/LeftApplication.hs b/src/LeftApplication.hs deleted file mode 100644 index d4c9cba..0000000 --- a/src/LeftApplication.hs +++ /dev/null @@ -1,7 +0,0 @@ -module LeftApplication -( ($>) -) where - -($>) :: (a -> b) -> a -> b -f $> x = f x -infixl 0 $> diff --git a/src/Main.hs b/src/Main.hs index 3fb92b0..bc25730 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -13,11 +13,23 @@ - limitations under the License. -} -import IRC.Server as IRCD -import IRC.Server.Environment -import Config +import Data.Maybe (catMaybes) +import IRCD.Types +import IRCD.Server +import IRCD.Plugin.Load main :: IO () -main = do - cp <- loadConfig "ircd.conf" - serveIRC defaultEnv {config=cp} +main = loadPlugins plugins >>= serveIRC + +plugins :: [String] +plugins = [ "Core.Ping" + , "Core.Nick" + , "Core.User" + , "Core.Register" + , "Core.Welcome" + ] + +loadPlugins :: [String] -> IO [Plugin] +loadPlugins names = do + pluginMaybes <- mapM (\name -> putStrLn ("Loading plugin `" ++ name ++ "`") >> loadPlugin name) names + return (catMaybes pluginMaybes)