diff --git a/Kevin/Base.hs b/Kevin/Base.hs --- a/Kevin/Base.hs +++ b/Kevin/Base.hs @@ -1,40 +1,26 @@ module Kevin.Base ( - Kevin(..), - KevinIO, + module Kevin.Types, KevinException(..), KevinServer(..), User(..), - Privclass, - Chatroom, - Title, - UserStore, - PrivclassStore, - TitleStore, -- * Modifiers addUser, removeUser, removeUserAll, setUsers, - usersL, numUsers, addPrivclass, setPrivclasses, - privclassL, getPcLevel, getPc, setUserPrivclass, changePrivclassName, - logIn, - - addToJoin, - joiningL, removeRoom, setTitle, - titlesL, -- * Exports module K, @@ -42,10 +28,6 @@ -- * Working with KevinState io, runPrinter, - getK, - putK, - getsK, - modifyK, if', @@ -56,14 +38,13 @@ import qualified Data.Text as T import qualified Data.ByteString.Char8 as T (hGetLine, hPutStr) import qualified Data.Text.Encoding as T -import Data.List (intercalate, nub, findIndices) +import Data.List (intercalate, findIndices) import Data.Maybe import System.IO as K (Handle, hClose, hIsClosed, hGetChar) import Control.Exception as K (IOException) import Network as K import Control.Applicative ((<$>)) -import Control.Monad.Reader -import Control.Monad.State as K +import Control.Monad.Reader as K import Control.Concurrent as K (forkIO) import Control.Concurrent.Chan as K import Control.Concurrent.STM.TVar as K @@ -126,14 +107,8 @@ closeServer = hClose . damn -- Kevin modifiers -logIn :: Kevin -> Kevin -logIn k = k { loggedIn = True } - -addToJoin :: [T.Text] -> Kevin -> Kevin -addToJoin rooms k = k { toJoin = nub $ rooms ++ toJoin k } - removeRoom :: Chatroom -> Kevin -> Kevin -removeRoom c = (privclassL ^%= M.delete c) . (usersL ^%= M.delete c) +removeRoom c = (privclasses ^%= M.delete c) . (users ^%= M.delete c) addUser :: Chatroom -> User -> UserStore -> UserStore addUser = (. return) . M.insertWith (++) @@ -156,18 +131,12 @@ setUsers :: Chatroom -> [User] -> UserStore -> UserStore setUsers = M.insert -usersL :: Lens Kevin UserStore -usersL = lens users (\t k -> k { users = t }) - addPrivclass :: Chatroom -> Privclass -> PrivclassStore -> PrivclassStore addPrivclass room (p,i) = M.insertWith M.union room (M.singleton p i) setPrivclasses :: Chatroom -> [Privclass] -> PrivclassStore -> PrivclassStore setPrivclasses room ps = M.insert room (M.fromList ps) -privclassL :: Lens Kevin PrivclassStore -privclassL = lens privclasses (\t k -> k { privclasses = t }) - getPc :: Chatroom -> T.Text -> UserStore -> Maybe T.Text getPc room user st = case M.lookup room st of Just qs -> privclass <$> listToMaybe (filter (\u -> username u == user) qs) @@ -177,18 +146,12 @@ getPcLevel room pcname store = fromMaybe 0 $ M.lookup room store >>= M.lookup pcname setUserPrivclass :: Chatroom -> T.Text -> T.Text -> Kevin -> Kevin -setUserPrivclass room user pc k = (usersL ^%= M.adjust (mapWhen ((user ==) . username) (\u -> u {privclass = pc, privclassLevel = pclevel})) room) k +setUserPrivclass room user pc k = (users ^%= M.adjust (mapWhen ((user ==) . username) (\u -> u {privclass = pc, privclassLevel = pclevel})) room) k where - pclevel = getPcLevel room pc $ privclasses k + pclevel = getPcLevel room pc $ k ^. privclasses changePrivclassName :: Chatroom -> T.Text -> T.Text -> UserStore -> UserStore changePrivclassName room old new = M.adjust (mapWhen ((old ==) . privclass) (\u -> u {privclass = new})) room setTitle :: Chatroom -> Title -> TitleStore -> TitleStore setTitle = M.insert - -titlesL :: Lens Kevin TitleStore -titlesL = lens titles (\t k -> k { titles = t }) - -joiningL :: Lens Kevin [T.Text] -joiningL = lens joining (\t k -> k { joining = t }) diff --git a/Kevin/Damn/Protocol.hs b/Kevin/Damn/Protocol.hs --- a/Kevin/Damn/Protocol.hs +++ b/Kevin/Damn/Protocol.hs @@ -28,7 +28,7 @@ listen :: KevinIO () listen = fix (\f -> flip catches errHandlers $ do - k <- getK + k <- get_ pkt <- io $ parsePacket <$> readServer k respond pkt (command pkt) f) @@ -36,23 +36,23 @@ -- main responder respond :: Packet -> T.Text -> KevinIO () respond _ "dAmnServer" = do - set <- getsK settings + set <- gets_ settings let uname = getUsername set token = getAuthtoken set sendLogin uname token respond pkt "login" = if okay pkt then do - modifyK logIn - getsK toJoin >>= mapM_ sendJoin + modify_ $ loggedIn ^= True + gets_ (^. toJoin) >>= mapM_ sendJoin else I.sendNotice $ "Login failed: " `T.append` getArg "e" pkt respond pkt "join" = do roomname <- deformatRoom . fromJust . parameter $ pkt if okay pkt then do - modifyK $ joiningL ^%= (roomname:) - uname <- getsK $ getUsername . settings + modify_ $ joining ^%= (roomname:) + uname <- gets_ $ getUsername . settings I.sendJoin uname roomname else I.sendNotice $ T.concat ["Couldn't join ", roomname, ": ", getArg "e" pkt] @@ -60,8 +60,8 @@ roomname <- deformatRoom . fromJust . parameter $ pkt if okay pkt then do - uname <- getsK $ getUsername . settings - modifyK $ removeRoom roomname + uname <- gets_ $ getUsername . settings + modify_ $ removeRoom roomname I.sendPart uname roomname Nothing else I.sendNotice $ T.concat ["Couldn't part ", roomname, ": ", getArg "e" pkt] @@ -69,28 +69,28 @@ case getArg "p" pkt of "privclasses" -> do let pcs = parsePrivclasses . fromJust . body $ pkt - modifyK $ privclassL ^%= setPrivclasses roomname pcs + modify_ $ privclasses ^%= setPrivclasses roomname pcs "topic" -> do - uname <- getsK $ getUsername . settings + uname <- gets_ $ getUsername . settings I.sendTopic uname roomname (getArg "by" pkt) (T.replace "\n" " - " . entityDecode . tablumpDecode . fromJust . body $ pkt) (getArg "ts" pkt) - "title" -> modifyK $ titlesL ^%= setTitle roomname (T.replace "\n" " - " . entityDecode . tablumpDecode . fromJust . body $ pkt) + "title" -> modify_ $ titles ^%= setTitle roomname (T.replace "\n" " - " . entityDecode . tablumpDecode . fromJust . body $ pkt) "members" -> do - (pcs,(uname,j)) <- getsK $ privclasses &&& getUsername . settings &&& joining + (pcs,(uname,j)) <- gets_ $ getL privclasses &&& getUsername . settings &&& getL joining let members = map (mkUser roomname pcs . parsePacket) . init . splitOn "\n\n" . fromJust $ body pkt pc = privclass . head . filter (\x -> username x == uname) $ members n = nub members - modifyK $ usersL ^%= setUsers roomname members + modify_ $ users ^%= setUsers roomname members when (roomname `elem` j) $ do I.sendUserList uname n roomname I.sendWhoList uname n roomname I.sendSetUserMode uname roomname $ getPcLevel roomname pc pcs - modifyK $ joiningL ^%= delete roomname + modify_ $ joining ^%= delete roomname "info" -> do - us <- getsK $ getUsername . settings + us <- gets_ $ getUsername . settings curtime <- io $ floor <$> getPOSIXTime let fixedPacket = parsePacket . T.init . T.replace "\n\nusericon" "\nusericon" . readable $ pkt uname = T.drop 6 . fromJust . parameter $ pkt @@ -107,9 +107,9 @@ case command pkt of "join" -> do let usname = fromJust $ parameter pkt - (pcs,countUser) <- getsK $ privclasses &&& numUsers roomname usname . users + (pcs,countUser) <- gets_ $ getL privclasses &&& numUsers roomname usname . getL users let us = mkUser roomname pcs modifiedPkt - modifyK $ usersL ^%= addUser roomname us + modify_ $ users ^%= addUser roomname us if countUser == 0 then do I.sendJoin usname roomname @@ -118,8 +118,8 @@ "part" -> do let uname = fromJust $ parameter pkt - modifyK $ usersL ^%= removeUser roomname uname - countUser <- getsK $ numUsers roomname uname . users + modify_ $ users ^%= removeUser roomname uname + countUser <- gets_ $ numUsers roomname uname . getL users if countUser < 1 then I.sendPart uname roomname $ case getArg "r" pkt of { "" -> Nothing; x -> Just x } else I.sendNoticeUnclone uname countUser roomname @@ -127,30 +127,30 @@ "msg" -> do let uname = arg "from" msg = fromJust (body pkt) - un <- getsK $ getUsername . settings + un <- gets_ $ getUsername . settings unless (un == uname) $ I.sendChanMsg uname roomname (entityDecode $ tablumpDecode msg) "action" -> do let uname = arg "from" msg = fromJust (body pkt) - un <- getsK $ getUsername . settings + un <- gets_ $ getUsername . settings unless (un == uname) $ I.sendChanAction uname roomname (entityDecode $ tablumpDecode msg) "privchg" -> do - (pcs,us) <- getsK $ privclasses &&& users + (pcs,us) <- gets_ $ getL privclasses &&& getL users let user = fromJust $ parameter pkt by = arg "by" oldPc = getPc roomname user us newPc = arg "pc" oldPcLevel = fmap (\p -> getPcLevel roomname p pcs) oldPc newPcLevel = getPcLevel roomname newPc pcs - modifyK $ setUserPrivclass roomname user newPc + modify_ $ setUserPrivclass roomname user newPc I.sendRoomNotice roomname $ T.concat [user, " has been moved", maybe "" (T.append " from ") oldPc, " to ", newPc, " by ", by] I.sendChangeUserMode user roomname (fromMaybe 0 oldPcLevel) newPcLevel "kicked" -> do let uname = fromJust $ parameter pkt - modifyK $ usersL ^%= removeUserAll roomname uname + modify_ $ users ^%= removeUserAll roomname uname I.sendKick uname (arg "by") roomname $ case body pkt of {Just "" -> Nothing; x -> x} "admin" -> case fromJust $ parameter pkt of @@ -172,7 +172,7 @@ respond pkt "send" = I.sendNotice $ T.concat ["Send error: ", getArg "e" pkt] -respond _ "ping" = getK >>= \k -> io . writeServer k $ ("pong\n\0" :: T.Text) +respond _ "ping" = get_ >>= \k -> io . writeServer k $ ("pong\n\0" :: T.Text) respond _ str = klog Yellow $ "Got the packet called " ++ T.unpack str diff --git a/Kevin/Damn/Protocol/Send.hs b/Kevin/Damn/Protocol/Send.hs --- a/Kevin/Damn/Protocol/Send.hs +++ b/Kevin/Damn/Protocol/Send.hs @@ -31,14 +31,14 @@ maybeBody = maybe "" (T.append "\n\n") sendPacket :: T.Text -> KevinIO () -sendPacket p = getK >>= \k -> io . writeServer k . T.snoc p $ '\0' +sendPacket p = get_ >>= \k -> io . writeServer k . T.snoc p $ '\0' formatRoom :: T.Text -> KevinIO T.Text formatRoom b = case T.splitAt 1 b of ("#",s) -> return $ "chat:" `T.append` s ("&",s) -> do - uname <- getsK (getUsername . settings) + uname <- gets_ (getUsername . settings) return . T.append "pchat:" . T.intercalate ":" . sort . map (T.map toLower) $ [uname, s] r -> return $ "chat" `T.append` uncurry T.append r @@ -46,7 +46,7 @@ deformatRoom room = if "chat:" `T.isPrefixOf` room then return $ '#' `T.cons` T.drop 5 room else do - uname <- getsK (getUsername . settings) + uname <- gets_ (getUsername . settings) return $ '&' `T.cons` head (filter (/= uname) . T.splitOn ":" . T.drop 6 $ room) type Str = T.Text -- just make it shorter diff --git a/Kevin/IRC/Protocol.hs b/Kevin/IRC/Protocol.hs --- a/Kevin/IRC/Protocol.hs +++ b/Kevin/IRC/Protocol.hs @@ -16,6 +16,7 @@ import Kevin.IRC.Protocol.Send import Control.Applicative ((<$>)) import Control.Arrow +import Control.Monad.State import Data.Maybe import Data.List (nubBy) import Data.Function (on) @@ -28,7 +29,7 @@ listen :: KevinIO () listen = fix (\f -> flip catches errHandlers $ do - k <- getK + k <- get_ pkt <- io $ parsePacket <$> readClient k respond pkt (command pkt) f) @@ -36,10 +37,10 @@ respond :: Packet -> T.Text -> KevinIO () respond BadPacket _ = sendNotice "Bad packet, try again." respond pkt "JOIN" = do - l <- getsK loggedIn + l <- gets_ (^. loggedIn) if l then mapM_ D.sendJoin rooms - else modifyK (addToJoin rooms) + else modify_ $ joining ^%= (rooms ++) where rooms = T.splitOn "," . head . params $ pkt @@ -61,7 +62,7 @@ "o" -> if' toggle D.sendPromote D.sendDemote (head $ params pkt) (last $ params pkt) Nothing _ -> sendRoomNotice (head $ params pkt) $ "Unsupported mode " `T.append` mode else do - uname <- getsK (getUsername . settings) + uname <- gets_ (getUsername . settings) sendChanMode uname (head $ params pkt) respond pkt "TOPIC" = case params pkt of @@ -72,7 +73,7 @@ respond pkt "TITLE" = case params pkt of [] -> sendNotice "Malformed packet" [room] -> do - title <- getsK (M.lookup room . titles) + title <- gets_ $ M.lookup room . (^. titles) let pre = T.concat ["Title for ", room, ": "] in mapM_ (sendRoomNotice room . T.append pre) (T.splitOn "\n" $ fromMaybe "" title) (room:title) -> D.sendSet room "title" $ T.unwords title @@ -82,7 +83,7 @@ respond pkt "NAMES" = do let (room:_) = params pkt - (me,uss) <- getsK (getUsername . settings &&& M.lookup room . users) + (me,uss) <- gets_ $ getUsername . settings &&& M.lookup room . getL users sendUserList me (nubBy ((==) `on` username) $ fromMaybe [] uss) room respond pkt "KICK" = let p = params pkt in D.sendKick (head p) (p !! 1) (if length p > 2 then Just $ last p else Nothing) diff --git a/Kevin/IRC/Protocol/Send.hs b/Kevin/IRC/Protocol/Send.hs --- a/Kevin/IRC/Protocol/Send.hs +++ b/Kevin/IRC/Protocol/Send.hs @@ -28,7 +28,7 @@ getHost u = T.concat [":", u, "!", u, "@chat.deviantart.com"] sendPacket :: T.Text -> KevinIO () -sendPacket p = getK >>= \k -> io . writeClient k $ T.append p "\r\n" +sendPacket p = get_ >>= \k -> io . writeClient k $ T.append p "\r\n" maybeBody :: Maybe T.Text -> T.Text maybeBody = maybe "" (T.append " :") diff --git a/Kevin/Protocol.hs b/Kevin/Protocol.hs --- a/Kevin/Protocol.hs +++ b/Kevin/Protocol.hs @@ -7,6 +7,7 @@ import qualified Kevin.IRC.Protocol as C import qualified Kevin.Damn.Protocol as S import System.IO (hSetBuffering, BufferMode(..)) +import Control.Monad.State import Data.Monoid (mempty) watchInterrupt :: [E.Handler (Maybe Kevin)] @@ -24,19 +25,18 @@ logChan <- newChan damnChan <- newChan ircChan <- newChan - return $ Just Kevin { damn = damnSock - , irc = client - , dChan = damnChan - , iChan = ircChan - , settings = set - , users = mempty - , privclasses = mempty - , titles = mempty - , toJoin = mempty - , joining = mempty - , loggedIn = False - , logger = logChan - } + return . Just $ Kevin damnSock + client + damnChan + ircChan + set + mempty + mempty + mempty + mempty + mempty + False + logChan mkListener :: Int -> IO Socket mkListener = listenOn . PortNumber . fromIntegral @@ -57,6 +57,6 @@ runLogger (logger kevin) runPrinter (dChan kevin) (damn kevin) runPrinter (iChan kevin) (irc kevin) - forkIO $ evalStateT (bracket_ S.initialize (S.cleanup >> io (closeClient kevin)) S.listen) mvar - forkIO $ evalStateT (bracket_ (return ()) (C.cleanup >> io (closeServer kevin)) C.listen) mvar + forkIO . void $ runReaderT (bracket_ S.initialize (S.cleanup >> io (closeClient kevin)) S.listen) mvar + forkIO . void $ runReaderT (bracket_ (return ()) (C.cleanup >> io (closeServer kevin)) C.listen) mvar return () diff --git a/Kevin/Types.hs b/Kevin/Types.hs --- a/Kevin/Types.hs +++ b/Kevin/Types.hs @@ -1,5 +1,5 @@ module Kevin.Types ( - Kevin(..), + Kevin(Kevin), KevinIO, Privclass, Chatroom, @@ -8,10 +8,16 @@ PrivclassStore, UserStore, TitleStore, - getK, - getsK, - putK, - modifyK + get_, + gets_, + put_, + modify_, + + -- lenses + users, privclasses, titles, toJoin, joining, loggedIn, + + -- other accessors + damn, irc, dChan, iChan, settings, logger ) where import qualified Data.Text as T @@ -19,42 +25,10 @@ import System.IO import Control.Concurrent import Control.Concurrent.STM.TVar -import Control.Monad.State +import Control.Monad.Reader import Control.Monad.STM (atomically) import Kevin.Settings - -data Kevin = Kevin { damn :: Handle - , irc :: Handle - , dChan :: Chan T.Text - , iChan :: Chan T.Text - , settings :: Settings - , users :: UserStore - , privclasses :: PrivclassStore - , titles :: TitleStore - , toJoin :: [T.Text] - , joining :: [T.Text] - , loggedIn :: Bool - , logger :: Chan String - } - -type KevinIO = StateT (TVar Kevin) IO - -getK :: KevinIO Kevin -getK = get >>= liftIO . readTVarIO - -putK :: Kevin -> KevinIO () -putK k = get >>= io . atomically . flip writeTVar k - -getsK :: (Kevin -> a) -> KevinIO a -getsK = flip liftM getK - -modifyK :: (Kevin -> Kevin) -> KevinIO () -modifyK f = do - var <- get - io . atomically $ modifyTVar var f - -io :: MonadIO m => IO a -> m a -io = liftIO +import Data.Lens.Template type Chatroom = T.Text @@ -75,3 +49,38 @@ type Title = T.Text type TitleStore = M.Map Chatroom Title + +data Kevin = Kevin { damn :: Handle + , irc :: Handle + , dChan :: Chan T.Text + , iChan :: Chan T.Text + , settings :: Settings + , _users :: UserStore + , _privclasses :: PrivclassStore + , _titles :: TitleStore + , _toJoin :: [T.Text] + , _joining :: [T.Text] + , _loggedIn :: Bool + , logger :: Chan String + } + +$( makeLens ''Kevin ) + +type KevinIO = ReaderT (TVar Kevin) IO + +get_ :: KevinIO Kevin +get_ = ask >>= liftIO . readTVarIO + +put_ :: Kevin -> KevinIO () +put_ k = ask >>= io . atomically . flip writeTVar k + +gets_ :: (Kevin -> a) -> KevinIO a +gets_ = flip liftM get_ + +modify_ :: (Kevin -> Kevin) -> KevinIO () +modify_ f = do + var <- ask + io . atomically $ modifyTVar var f + +io :: MonadIO m => IO a -> m a +io = liftIO diff --git a/Kevin/Util/Logger.hs b/Kevin/Util/Logger.hs --- a/Kevin/Util/Logger.hs +++ b/Kevin/Util/Logger.hs @@ -49,7 +49,7 @@ klogNow c s = putStrLn $ render c s klog :: Color -> String -> KevinIO () -klog c str = getsK logger >>= \ch -> liftIO $ klog_ ch c str +klog c str = gets_ logger >>= \ch -> liftIO $ klog_ ch c str klogError, klogWarn :: String -> KevinIO () diff --git a/kevin.cabal b/kevin.cabal --- a/kevin.cabal +++ b/kevin.cabal @@ -1,5 +1,5 @@ Name: kevin -Version: 0.1.3 +Version: 0.1.3.1 Synopsis: a dAmn ↔ IRC proxy Description: a dAmn ↔ IRC proxy License: GPL @@ -16,8 +16,8 @@ Executable kevin Main-is: Main.hs - Build-Depends: attoparsec == 0.10.*, base == 4.*, bytestring == 0.9.*, containers == 0.4.*, cprng-aes == 0.2.*, data-lens == 2.10.*, HTTP == 4000.2.*, MonadCatchIO-mtl == 0.3.*, mtl == 2.1.*, network == 2.3.*, regex-pcre-builtin == 0.94.*, stm == 2.3.*, text == 0.11.*, time == 1.4.*, tls == 0.9.*, tls-extra == 0.4.* + Build-Depends: attoparsec == 0.10.*, base == 4.*, bytestring == 0.9.*, containers == 0.4.*, cprng-aes == 0.2.*, data-lens == 2.10.*, data-lens-template == 2.1.*, HTTP == 4000.2.*, MonadCatchIO-mtl == 0.3.*, mtl == 2.1.*, network == 2.3.*, regex-pcre-builtin == 0.94.*, stm == 2.3.*, text == 0.11.*, time == 1.4.*, tls == 0.9.*, tls-extra == 0.4.* Other-Modules: Kevin, Kevin.Protocol, Kevin.Base, Kevin.Util.Logger, Kevin.IRC.Protocol, Kevin.Damn.Protocol, Kevin.Util.Entity, Kevin.Util.Tablump, Kevin.Damn.Packet, Kevin.Damn.Protocol.Send, Kevin.IRC.Protocol.Send, Kevin.IRC.Packet, Kevin.Settings, Kevin.Types, Kevin.Util.Token - extensions: CPP, DeriveDataTypeable, ExistentialQuantification, OverloadedStrings, ScopedTypeVariables + extensions: CPP, DeriveDataTypeable, ExistentialQuantification, OverloadedStrings, ScopedTypeVariables, TemplateHaskell ghc-options: -Wall -fno-warn-unused-do-bind -threaded - cpp-options: -DVERSION="0.1.3" + cpp-options: -DVERSION="0.1.3.1"