kevin 0.1.2 → 0.1.3
raw patch · 3 files changed
+38/−37 lines, 3 filesdep +data-lens
Dependencies added: data-lens
Files
- Kevin/Base.hs +15/−14
- Kevin/Damn/Protocol.hs +20/−20
- kevin.cabal +3/−3
Kevin/Base.hs view
@@ -16,12 +16,12 @@ removeUser, removeUserAll, setUsers,- onUsers,+ usersL, numUsers, addPrivclass, setPrivclasses,- onPrivclasses,+ privclassL, getPcLevel, getPc, setUserPrivclass,@@ -30,11 +30,11 @@ logIn, addToJoin,- onJoining,+ joiningL, removeRoom, setTitle,- onTitles,+ titlesL, -- * Exports module K,@@ -71,6 +71,7 @@ import Kevin.Settings as K import qualified Data.Map as M import Data.Typeable+import Data.Lens.Common as K import Kevin.Types if' :: Bool -> a -> a -> a@@ -132,7 +133,7 @@ addToJoin rooms k = k { toJoin = nub $ rooms ++ toJoin k } removeRoom :: Chatroom -> Kevin -> Kevin-removeRoom c = onPrivclasses (M.delete c) . onUsers (M.delete c)+removeRoom c = (privclassL ^%= M.delete c) . (usersL ^%= M.delete c) addUser :: Chatroom -> User -> UserStore -> UserStore addUser = (. return) . M.insertWith (++)@@ -155,8 +156,8 @@ setUsers :: Chatroom -> [User] -> UserStore -> UserStore setUsers = M.insert -onUsers :: (UserStore -> UserStore) -> Kevin -> Kevin-onUsers f k = k { users = f (users k) }+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)@@ -164,8 +165,8 @@ setPrivclasses :: Chatroom -> [Privclass] -> PrivclassStore -> PrivclassStore setPrivclasses room ps = M.insert room (M.fromList ps) -onPrivclasses :: (PrivclassStore -> PrivclassStore) -> Kevin -> Kevin-onPrivclasses f k = k { privclasses = f (privclasses k) }+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@@ -176,7 +177,7 @@ 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 = onUsers (M.adjust (mapWhen ((user ==) . username) (\u -> u {privclass = pc, privclassLevel = pclevel})) room) k+setUserPrivclass room user pc k = (usersL ^%= M.adjust (mapWhen ((user ==) . username) (\u -> u {privclass = pc, privclassLevel = pclevel})) room) k where pclevel = getPcLevel room pc $ privclasses k @@ -186,8 +187,8 @@ setTitle :: Chatroom -> Title -> TitleStore -> TitleStore setTitle = M.insert -onTitles :: (TitleStore -> TitleStore) -> Kevin -> Kevin-onTitles f k = k { titles = f (titles k) }+titlesL :: Lens Kevin TitleStore+titlesL = lens titles (\t k -> k { titles = t }) -onJoining :: ([T.Text] -> [T.Text]) -> Kevin -> Kevin-onJoining f k = k { joining = f (joining k) }+joiningL :: Lens Kevin [T.Text]+joiningL = lens joining (\t k -> k { joining = t })
Kevin/Damn/Protocol.hs view
@@ -51,8 +51,8 @@ roomname <- deformatRoom . fromJust . parameter $ pkt if okay pkt then do- modifyK (onJoining (roomname:))- uname <- getsK (getUsername . settings)+ modifyK $ joiningL ^%= (roomname:)+ uname <- getsK $ 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 <- getsK $ getUsername . settings+ modifyK $ 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 (onPrivclasses (setPrivclasses roomname pcs))+ modifyK $ privclassL ^%= setPrivclasses roomname pcs "topic" -> do- uname <- getsK (getUsername . settings)+ uname <- getsK $ getUsername . settings I.sendTopic uname roomname (getArg "by" pkt) (T.replace "\n" " - " . entityDecode . tablumpDecode . fromJust . body $ pkt) (getArg "ts" pkt) - "title" -> modifyK (onTitles (setTitle roomname (T.replace "\n" " - " . entityDecode . tablumpDecode . fromJust . body $ pkt)))+ "title" -> modifyK $ titlesL ^%= setTitle roomname (T.replace "\n" " - " . entityDecode . tablumpDecode . fromJust . body $ pkt) "members" -> do- (pcs,(uname,j)) <- getsK (privclasses &&& getUsername . settings &&& joining)+ (pcs,(uname,j)) <- getsK $ privclasses &&& getUsername . settings &&& 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 (onUsers (setUsers roomname members))+ modifyK $ usersL ^%= 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 (onJoining (delete roomname))+ modifyK $ joiningL ^%= delete roomname "info" -> do- us <- getsK (getUsername . settings)+ us <- getsK $ 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) <- getsK $ privclasses &&& numUsers roomname usname . users let us = mkUser roomname pcs modifiedPkt- modifyK (onUsers (addUser roomname us))+ modifyK $ usersL ^%= addUser roomname us if countUser == 0 then do I.sendJoin usname roomname@@ -118,8 +118,8 @@ "part" -> do let uname = fromJust $ parameter pkt- modifyK (onUsers (removeUser roomname uname))- countUser <- getsK (numUsers roomname uname . users)+ modifyK $ usersL ^%= removeUser roomname uname+ countUser <- getsK $ numUsers roomname uname . 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 <- getsK $ 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 <- getsK $ getUsername . settings unless (un == uname) $ I.sendChanAction uname roomname (entityDecode $ tablumpDecode msg) "privchg" -> do- (pcs,us) <- getsK (privclasses &&& users)+ (pcs,us) <- getsK $ privclasses &&& 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)+ modifyK $ 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 (onUsers (removeUserAll roomname uname))+ modifyK $ usersL ^%= removeUserAll roomname uname I.sendKick uname (arg "by") roomname $ case body pkt of {Just "" -> Nothing; x -> x} "admin" -> case fromJust $ parameter pkt of
kevin.cabal view
@@ -1,5 +1,5 @@ Name: kevin-Version: 0.1.2+Version: 0.1.3 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.*, 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.*, 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 ghc-options: -Wall -fno-warn-unused-do-bind -threaded- cpp-options: -DVERSION="0.1.2"+ cpp-options: -DVERSION="0.1.3"