packages feed

kevin 0.1.3 → 0.1.3.1

raw patch · 9 files changed

+110/−137 lines, 9 filesdep +data-lens-template

Dependencies added: data-lens-template

Files

Kevin/Base.hs view
@@ -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 })
Kevin/Damn/Protocol.hs view
@@ -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
Kevin/Damn/Protocol/Send.hs view
@@ -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
Kevin/IRC/Protocol.hs view
@@ -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)
Kevin/IRC/Protocol/Send.hs view
@@ -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 " :")
Kevin/Protocol.hs view
@@ -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 ()
Kevin/Types.hs view
@@ -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
Kevin/Util/Logger.hs view
@@ -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 ()
kevin.cabal view
@@ -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"