Merge pull request #2 from shockkolate/new

Merge new branch back into master finally

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
 

plugins.old/Mode.hs

@@ -0,0 +1,52 @@
+{- Copyright 2014 David Farrell <[email protected]>
+
+ - 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

plugins/Core/Nick.hs

@@ -0,0 +1,42 @@
+{- Copyright 2014 David Farrell <[email protected]>
+
+ - 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"]

plugins/Core/NoExternal.hs

@@ -0,0 +1,28 @@
+{- Copyright 2014 David Farrell <[email protected]>
+
+ - 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, [])

plugins/Core/Ping.hs

@@ -0,0 +1,28 @@
+{- Copyright 2014 David Farrell <[email protected]>
+
+ - 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"

plugins/Core/Register.hs

@@ -0,0 +1,45 @@
+{- Copyright 2014 David Farrell <[email protected]>
+
+ - 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

plugins/Core/User.hs

@@ -0,0 +1,33 @@
+{- Copyright 2014 David Farrell <[email protected]>
+
+ - 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"]

plugins/Core/Welcome.hs

@@ -0,0 +1,27 @@
+{- Copyright 2014 David Farrell <[email protected]>
+
+ - 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, [])

src.old/Main.hs

@@ -0,0 +1,23 @@
+{- Copyright 2014 David Farrell <[email protected]>
+
+ - 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}

src/Hoist.hs

@@ -0,0 +1,21 @@
+{- Copyright 2014 David Farrell <[email protected]>
+
+ - 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

src/IRCD/Clients.hs

@@ -0,0 +1,58 @@
+{- Copyright 2014 David Farrell <[email protected]>
+
+ - 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