kevin 0.4 → 0.5
raw patch · 16 files changed
+370/−266 lines, 16 filesdep +data-defaultdep ~lens
Dependencies added: data-default
Dependency ranges changed: lens
Files
- Kevin/Base.hs +27/−15
- Kevin/Chatrooms.hs +3/−6
- Kevin/Damn/Packet.hs +50/−33
- Kevin/Damn/Protocol.hs +109/−75
- Kevin/Damn/Protocol/Send.hs +8/−6
- Kevin/IRC/Packet.hs +17/−10
- Kevin/IRC/Protocol.hs +46/−35
- Kevin/IRC/Protocol/Send.hs +1/−1
- Kevin/Protocol.hs +18/−13
- Kevin/Settings.hs +3/−3
- Kevin/Types.hs +4/−4
- Kevin/Util/Entity.hs +10/−7
- Kevin/Util/Logger.hs +3/−3
- Kevin/Util/Tablump.hs +4/−4
- Kevin/Util/Token.hs +25/−12
- kevin.cabal +42/−39
Kevin/Base.hs view
@@ -1,6 +1,7 @@ module Kevin.Base ( module Kevin.Types, KevinException(..),+ _KevinException, KevinServer(..), User(..), @@ -12,30 +13,31 @@ printf ) where -import Kevin.Util.Logger-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)-import System.IO as K-import System.IO.Error-import Control.Exception as K (IOException)-import Network as K import Control.Applicative ((<$>))-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 import Control.Exception+import Control.Exception as K (IOException)+import Control.Exception.Lens import Control.Lens as K import Control.Monad.CatchIO as K-import Kevin.Settings as K-import Kevin.Chatrooms as K+import Control.Monad.Reader as K+import qualified Data.ByteString.Char8 as T (hGetLine, hPutStr)+import Data.List (intercalate)+import qualified Data.Text as T+import qualified Data.Text.Encoding as T import Data.Typeable+import Kevin.Chatrooms as K+import Kevin.Settings as K import Kevin.Types+import Kevin.Util.Logger+import Network as K+import System.IO as K+import System.IO.Error runPrinter :: Chan T.Text -> Handle -> IO ()-runPrinter ch h = void $ forkIO $ forever $ readChan ch >>= T.hPutStr h . T.encodeUtf8+runPrinter ch h = void . forkIO . forever $ readChan ch >>= T.hPutStr h . T.encodeUtf8 io :: MonadIO m => IO a -> m a io = liftIO@@ -51,10 +53,16 @@ instance Exception KevinException +_KevinException :: Prism' SomeException KevinException+_KevinException = exception+ -- actions padLines :: Int -> T.Text -> String-padLines len b = let (first:rest) = lines $ T.unpack b in (++) (first ++ "\n") . intercalate "\n" . map (replicate len ' ' ++) $ rest+padLines len b = let (first:rest) = lines $ T.unpack b+ in (++) (first ++ "\n") . intercalate "\n"+ . map (replicate len ' ' ++)+ $ rest hGetCharTimeout :: Handle -> Int -> IO Char hGetCharTimeout h t = do@@ -67,7 +75,11 @@ else throwIO $ mkIOError eofErrorType "read timeout" (Just h) Nothing hGetSep :: Char -> Handle -> IO String-hGetSep sep h = fix (\f -> hGetCharTimeout h 180000 >>= \ch -> if ch == sep then return "" else (ch:) <$> f)+hGetSep sep h = fix (\f -> do+ ch <- hGetCharTimeout h 180000+ if ch == sep+ then return ""+ else (ch:) <$> f) instance KevinServer Kevin where readClient k = do
Kevin/Chatrooms.hs view
@@ -18,10 +18,9 @@ import Control.Applicative import Control.Lens import Data.List--- import Data.Monoid-import qualified Data.Text as T import qualified Data.Map as M import Data.Maybe+import qualified Data.Text as T import Kevin.Types deleteBy' :: (a -> Bool) -> [a] -> [a]@@ -50,9 +49,6 @@ setUsers :: Chatroom -> [User] -> KevinIO () setUsers ch uss = kevin $ users.at ch .= Just uss --- addPrivclass :: Chatroom -> Privclass -> KevinIO ()--- addPrivclass room (p,i) = kevin $ privclasses.ix room %= (M.singleton p i <>)- setPrivclasses :: Chatroom -> [Privclass] -> KevinIO () setPrivclasses room ps = kevin $ privclasses.at room .= Just (M.fromList ps) @@ -71,7 +67,8 @@ setUserPrivclass :: Chatroom -> T.Text -> T.Text -> KevinIO () setUserPrivclass room user pc = do pclevel <- getPrivclassLevel room pc- kevin $ users.ix room.traverse.filtered ((user ==) . username) %= (\u -> u {privclass = pc, privclassLevel = pclevel})+ kevin $ users.ix room.traverse.filtered ((user ==) . username)+ %= (\u -> u {privclass = pc, privclassLevel = pclevel}) setTitle :: Chatroom -> T.Text -> KevinIO () setTitle ch t = kevin $ titles.at ch .= Just t
Kevin/Damn/Packet.hs view
@@ -1,31 +1,46 @@ module Kevin.Damn.Packet ( Packet(..),+ command, parameter, args, body,+ parsePacket, parsePrivclasses, subPacket, fixLoginPacket, okay,- getArg,- splitOn,- readable+ readable,+ null_,+ notNull_ ) where -import Kevin.Base (KevinException(..), Privclass)+import Control.Applicative (many, (<$>), (<$)) import Control.Exception (throw)-import qualified Data.Text as T+import Control.Lens+import Control.Monad (guard, liftM2) import Data.Attoparsec.Text import Data.Char-import Control.Applicative (many, (<$>))-import Control.Monad (liftM2)-import Control.Monad.Fix+import qualified Data.Map as M import Data.Maybe+import Data.Monoid+import qualified Data.Text as T+import Kevin.Base (KevinException(..), Privclass) -data Packet = Packet { command :: T.Text- , parameter :: Maybe T.Text- , args :: [(T.Text,T.Text)]- , body :: Maybe T.Text- } deriving (Show)+toMaybe :: (a -> Bool) -> a -> Maybe a+toMaybe f x = x <$ guard (f x) +notNull_ :: Prism' T.Text T.Text+notNull_ = prism' id $ toMaybe (not . T.null)++null_ :: Prism' T.Text T.Text+null_ = prism' id $ toMaybe T.null++data Packet = Packet { _command :: T.Text+ , _parameter :: Maybe T.Text+ , _args :: M.Map T.Text T.Text+ , _body :: Maybe T.Text+ } deriving Show++makeLenses ''Packet+ parseCommand :: Parser T.Text parseCommand = takeWhile1 (not . isSpace) @@ -35,8 +50,8 @@ parm <- takeWhile1 (not . isSpace) return $ Just parm -parseArgs :: Parser [(T.Text,T.Text)]-parseArgs = many $ do+parseArgs :: Parser (M.Map T.Text T.Text)+parseArgs = (M.fromList <$>) . many $ do char '\n' c <- takeTill (=='=') char '='@@ -51,37 +66,39 @@ return $ Packet c p a Nothing parsePacket :: T.Text -> Packet-parsePacket pack = let (top,b) = T.breakOn "\n\n" pack in case (\x -> (x { body = if T.null b then Nothing else Just $ T.drop 2 b }) :: Packet) <$> parseOnly parseHead top of+parsePacket pack = case parseOnly parseHead top of Left _ -> throw ParseFailure- Right pkt -> pkt+ Right res -> res & body .~ (T.drop 2 <$> toMaybe T.null b)+ where+ (top, b) = T.breakOn "\n\n" pack getResult :: Either String a -> a-getResult (Right x) = x-getResult (Left _) = error "getResult"+getResult x = let Right e = x in e fixLoginPacket :: Packet -> Packet-fixLoginPacket pkt = if command pkt == "login"- then pkt { args = args pkt ++ getResult (parseOnly parseArgs . T.cons '\n' . fromJust . body $ pkt), body = Nothing }+fixLoginPacket pkt = if pkt^.command == "login"+ then pkt & args %~ (<> getResult+ (parseOnly parseArgs . T.cons '\n' . fromJust $ pkt^.body)) else pkt subPacket :: Packet -> Maybe Packet-subPacket = (parsePacket <$>) . body+subPacket = (parsePacket <$>) . view body okay :: Packet -> Bool-okay (Packet _ _ a _) = let e = lookup "e" a in isNothing e || e == Just "ok"--getArg :: T.Text -> Packet -> T.Text-getArg b p = fromMaybe "" $ lookup b (args p)+okay (Packet _ _ a _) = let e = a ^. at "e" in isNothing e || e == Just "ok" parsePrivclasses :: T.Text -> [Privclass]-parsePrivclasses = map (liftM2 (,) (!! 1) (read . T.unpack . (!! 0)) . T.splitOn ":") . filter (not . T.null) . T.splitOn "\n"--splitOn :: T.Text -> T.Text -> [T.Text]-splitOn delim = fix (\rec s -> let (f,l) = T.breakOn delim s in if T.null l then [f] else f:rec (T.drop (T.length delim) l))+parsePrivclasses = map (liftM2 (,) (!! 1) (read . T.unpack . head) . T.splitOn ":") + . filter (not . T.null)+ . T.splitOn "\n" readable :: Packet -> T.Text-readable (Packet cmd param arg bod) = cmd +++ maybe "" (' ' `T.cons`) param +++ formattedArgs arg +++ maybe "" ("\n\n" `T.append`) bod +++ "\n\0"+readable (Packet cmd param arg bod) = cmd+ <> maybe "" (' ' `T.cons`) param+ <> formattedArgs (M.toList arg)+ <> maybe "" ("\n\n" `T.append`) bod+ <> "\n\0" where- (+++) = T.append formattedArgs [] = ""- formattedArgs q = T.append "\n" . T.intercalate "\n" . map (uncurry (\x y -> x +++ "=" +++ y)) $ q+ formattedArgs q = T.append "\n" . T.intercalate "\n"+ . map (uncurry (\x y -> x <> "=" <> y)) $ q
Kevin/Damn/Protocol.hs view
@@ -5,19 +5,21 @@ errHandlers ) where -import Kevin.Base-import Kevin.Util.Logger-import Kevin.Util.Entity-import Kevin.Util.Tablump-import Kevin.Damn.Packet-import qualified Data.Text as T+import Control.Applicative ((<$>))+import Control.Exception.Lens+import Data.List (delete, nub, sortBy) import Data.Maybe (fromJust, fromMaybe)-import Data.List (nub, delete, sortBy)+import Data.Monoid import Data.Ord (comparing)+import qualified Data.Text as T+import Data.Time.Clock.POSIX (getPOSIXTime)+import Kevin.Base+import Kevin.Damn.Packet import Kevin.Damn.Protocol.Send import qualified Kevin.IRC.Protocol.Send as I-import Control.Applicative ((<$>))-import Data.Time.Clock.POSIX (getPOSIXTime)+import Kevin.Util.Entity+import Kevin.Util.Logger+import Kevin.Util.Tablump initialize :: KevinIO () initialize = sendHandshake@@ -29,7 +31,7 @@ listen = fix (\f -> flip catches errHandlers $ do k <- get_ pkt <- io $ parsePacket <$> readServer k- respond pkt (command pkt)+ respond pkt (view command pkt) f) -- main responder@@ -44,68 +46,83 @@ loggedIn .= True use joining mapM_ sendJoin j- else I.sendNotice $ "Login failed: " `T.append` getArg "e" pkt+ else I.sendNotice $ "Login failed: " <> pkt ^. args.ix "e" respond pkt "join" = do- roomname <- deformatRoom . fromJust . parameter $ pkt+ roomname <- deformatRoom $ pkt^.parameter._Just if okay pkt then do kevin $ joining %= (roomname:) uname <- use_ name I.sendJoin uname roomname- else I.sendNotice $ T.concat ["Couldn't join ", roomname, ": ", getArg "e" pkt]+ else I.sendNotice $ T.concat ["Couldn't join ", roomname, ": ", pkt^.args.ix "e"] respond pkt "part" = do- roomname <- deformatRoom . fromJust . parameter $ pkt+ roomname <- deformatRoom $ pkt^.parameter._Just if okay pkt then do uname <- use_ name removeRoom roomname I.sendPart uname roomname Nothing- else I.sendNotice $ T.concat ["Couldn't part ", roomname, ": ", getArg "e" pkt]+ else I.sendNotice $ T.concat ["Couldn't part ", roomname, ": ", pkt^.args.ix "e"] -respond pkt "property" = deformatRoom (fromJust $ parameter pkt) >>= \roomname ->- case getArg "p" pkt of- "privclasses" -> do- let pcs = parsePrivclasses . fromJust . body $ pkt- setPrivclasses roomname pcs+respond pkt "property" = do+ roomname <- deformatRoom (pkt^.parameter._Just)+ case pkt^.args.ix "p" of+ "privclasses" -> setPrivclasses roomname . parsePrivclasses $ pkt^.body._Just - "topic" -> do- uname <- use_ name- I.sendTopic uname roomname (getArg "by" pkt) (T.replace "\n" " - " . entityDecode . tablumpDecode . fromJust . body $ pkt) (getArg "ts" pkt)+ "topic" -> do+ uname <- use_ name+ I.sendTopic uname roomname+ (fromMaybe uname $ pkt^.args.at "by")+ (T.replace "\n" " - " . entityDecode+ . tablumpDecode $ pkt^.body._Just)+ (pkt^.args.ix "ts") - "title" -> setTitle roomname (T.replace "\n" " - " . entityDecode . tablumpDecode . fromJust . body $ pkt)+ "title" -> setTitle roomname (T.replace "\n" " - " . entityDecode+ . tablumpDecode $ pkt^.body._Just) - "members" -> do- k <- get_- let members = map (mkUser roomname (k^.privclasses) . parsePacket) . init . splitOn "\n\n" . fromJust $ body pkt- pc = privclass . head . filter (\x -> username x == k^.name) $ members- n = nub members- setUsers roomname members- when (roomname `elem` k^.joining) $ do- I.sendUserList (k^.name) n roomname- pclevel <- getPrivclassLevel roomname pc- I.sendSetUserMode (k^.name) roomname pclevel- kevin $ joining %= delete roomname+ "members" -> do+ k <- get_+ let members = map (mkUser roomname (k^.privclasses) . parsePacket)+ . init . T.splitOn "\n\n"+ $ pkt^.body._Just+ pc = privclass . head . filter (\x -> username x == k^.name) $ members+ n = nub members+ setUsers roomname members+ when (roomname `elem` k^.joining) $ do+ I.sendUserList (k^.name) n roomname+ pclevel <- getPrivclassLevel roomname pc+ I.sendSetUserMode (k^.name) roomname pclevel+ kevin $ joining %= delete roomname - "info" -> do- us <- use_ name- curtime <- io $ floor <$> getPOSIXTime- let fixedPacket = parsePacket . T.init . T.replace "\n\nusericon" "\nusericon" . readable $ pkt- uname = T.drop 6 . fromJust . parameter $ pkt- rn = getArg "realname" fixedPacket- conns = map (\x -> (read (T.unpack $ getArg "online" x) :: Int, read (T.unpack $ getArg "idle" x) :: Int, map (T.drop 8) . filter (not . T.null) . T.splitOn "\n\n" . fromJust . body $ x)) . fromJust $ (map (parsePacket . T.append "conn") . tail . T.splitOn "conn") <$> body fixedPacket- allRooms = nub $ conns >>= (\(_,_,c) -> c)- (onlinespan,idle) = head . sortBy (comparing fst) . map (\(a,b,_) -> (a,b)) $ conns- signon = curtime - onlinespan- I.sendWhoisReply us uname (entityDecode rn) allRooms idle signon+ "info" -> do+ us <- use_ name+ curtime <- io $ floor <$> getPOSIXTime+ let fixedPacket = parsePacket . T.init . T.replace "\n\nusericon" "\nusericon"+ . readable $ pkt+ uname = T.drop 6 $ pkt^.parameter._Just+ rn = fixedPacket^.args.ix "realname"+ conns = map (\pk ->+ let x = parsePacket . T.append "conn" $ pk+ in ( read (T.unpack $ x^.args.ix "online") :: Int+ , read (T.unpack $ x^.args.ix "idle") :: Int+ , map (T.drop 8) . filter (not . T.null)+ . T.splitOn "\n\n" $ x^.body._Just+ )+ ) . tail . T.splitOn "conn"+ $ fixedPacket^.body._Just+ allRooms = nub $ conns >>= (\(_,_,c) -> c)+ (onlinespan,idle,_) = head . sortBy (comparing (view _1)) $ conns+ signon = curtime - onlinespan+ I.sendWhoisReply us uname (entityDecode rn) allRooms idle signon - q -> klogError $ "Unrecognized property " ++ T.unpack q+ q -> klogError $ "Unrecognized property " ++ T.unpack q -respond spk "recv" = deformatRoom (fromJust $ parameter spk) >>= \roomname ->- case command pkt of+respond spk "recv" = deformatRoom (spk^.parameter._Just) >>= \roomname ->+ case pkt^.command of "join" -> do- let usname = fromJust $ parameter pkt+ let usname = pkt^.parameter._Just pcs <- gets_ $ view privclasses countUser <- numUsers roomname usname let us = mkUser roomname pcs modifiedPkt@@ -113,53 +130,70 @@ if countUser == 0 then do I.sendJoin usname roomname- pclevel <- getPrivclassLevel roomname (getArg "pc" modifiedPkt)+ pclevel <- getPrivclassLevel roomname (modifiedPkt^.args.ix "pc") I.sendSetUserMode usname roomname pclevel else I.sendNoticeClone (username us) (succ countUser) roomname "part" -> do- let uname = fromJust $ parameter pkt+ let uname = pkt^.parameter._Just removeUser roomname uname countUser <- numUsers roomname uname if countUser < 1- then I.sendPart uname roomname $ case getArg "r" pkt of { "" -> Nothing; x -> Just x }+ then I.sendPart uname roomname $ pkt^.args.at "r" else I.sendNoticeUnclone uname countUser roomname "msg" -> do let uname = arg "from"- msg = fromJust (body pkt)+ msg = pkt^.body._Just un <- use_ name unless (un == uname) $ I.sendChanMsg uname roomname (entityDecode $ tablumpDecode msg) "action" -> do let uname = arg "from"- msg = fromJust (body pkt)+ msg = pkt^.body._Just un <- use_ name unless (un == uname) $ I.sendChanAction uname roomname (entityDecode $ tablumpDecode msg) "privchg" -> do- let user = fromJust $ parameter pkt+ let user = pkt^.parameter._Just by = arg "by" newPc = arg "pc" oldPc <- getPrivclass roomname user oldPcLevel <- getPrivclassLevel roomname (fromMaybe "" oldPc) newPcLevel <- getPrivclassLevel roomname newPc setUserPrivclass roomname user newPc- I.sendRoomNotice roomname $ T.concat [user, " has been moved", maybe "" (T.append " from ") oldPc, " to ", newPc, " by ", by]+ I.sendRoomNotice roomname $ T.concat+ [user, " has been moved"+ , maybe "" (T.append " from ") oldPc+ , " to ", newPc, " by ", by+ ] I.sendChangeUserMode user roomname oldPcLevel newPcLevel "kicked" -> do- let uname = fromJust $ parameter pkt+ let uname = pkt^.parameter._Just removeUserAll roomname uname- I.sendKick uname (arg "by") roomname $ case body pkt of {Just "" -> Nothing; x -> x}+ I.sendKick uname (arg "by") roomname $ pkt^.body.traverse ^? notNull_ - "admin" -> case fromJust $ parameter pkt of- "create" -> I.sendRoomNotice roomname $ T.concat ["Privclass ", arg "name", " created by ", arg "by", " with: ", arg "privs"]- "update" -> I.sendRoomNotice roomname $ T.concat ["Privclass ", arg "name", " updated by ", arg "by", " with: ", arg "privs"]- "rename" -> I.sendRoomNotice roomname $ T.concat ["Privclass ", arg "prev", " renamed to ", arg "name", " by ", arg "by"]- "move" -> I.sendRoomNotice roomname $ T.concat [arg "n", " users in privclass ", arg "prev", " moved to ", arg "name", " by ", arg "by"]- "remove" -> I.sendRoomNotice roomname $ T.concat ["Privclass", arg "name", " removed by ", arg "by"]- "show" -> mapM_ (I.sendRoomNotice roomname) . T.splitOn "\n" . fromJust . body $ pkt+ "admin" -> case pkt^.parameter._Just of+ "create" -> I.sendRoomNotice roomname $+ T.concat ["Privclass ", arg "name"+ , " created by ", arg "by"+ , " with: ", arg "privs"]+ "update" -> I.sendRoomNotice roomname $+ T.concat ["Privclass ", arg "name"+ , " updated by ", arg "by"+ , " with: ", arg "privs"]+ "rename" -> I.sendRoomNotice roomname $+ T.concat ["Privclass ", arg "prev"+ , " renamed to ", arg "name"+ , " by ", arg "by"]+ "move" -> I.sendRoomNotice roomname $+ T.concat [ arg "n", " users in privclass "+ , arg "prev", " moved to "+ , arg "name", " by ", arg "by"]+ "remove" -> I.sendRoomNotice roomname $+ T.concat ["Privclass", arg "name", " removed by ", arg "by"]+ "show" -> mapM_ (I.sendRoomNotice roomname) . T.splitOn "\n" $ pkt^.body._Just "privclass" -> I.sendRoomNotice roomname $ "Admin error: " `T.append` arg "e" q -> klogError $ "Unknown admin packet type " ++ show q @@ -167,16 +201,16 @@ where pkt = fromJust $ subPacket spk- modifiedPkt = parsePacket (T.replace "\n\npc" "\npc" (fromJust $ body spk))- arg = flip getArg pkt+ modifiedPkt = parsePacket (T.replace "\n\npc" "\npc" $ pkt^.body._Just)+ arg s = pkt^.args.ix s respond pkt "kicked" = do- roomname <- deformatRoom (fromJust $ parameter pkt)+ roomname <- deformatRoom $ pkt^.parameter._Just uname <- use_ name removeRoom roomname- I.sendKick uname (getArg "by" pkt) roomname $ case body pkt of {Just "" -> Nothing; x -> x}+ I.sendKick uname (pkt^.args.ix "by") roomname $ pkt^.body.traverse ^? notNull_ -respond pkt "send" = I.sendNotice $ T.concat ["Send error: ", getArg "e" pkt]+respond pkt "send" = I.sendNotice $ "Send error: " <> pkt^.args.ix "e" respond _ "ping" = get_ >>= \k -> io . writeServer k $ ("pong\n\0" :: T.Text) @@ -184,7 +218,7 @@ mkUser :: Chatroom -> PrivclassStore -> Packet -> User-mkUser room st p = User (fromJust $ parameter p)+mkUser room st p = User (p^.parameter._Just) (g "pc") (fromMaybe 0 $ st^.at room >>= (^.at (g "pc"))) (g "symbol")@@ -192,8 +226,8 @@ (g "typename") (g "gpc") where- g = flip getArg p+ g s = p^.args.ix s errHandlers :: [Handler KevinIO ()]-errHandlers = [Handler (\(_ :: KevinException) -> klogError "Malformed communication from server"),- Handler (\(e :: IOException) -> klogError $ "server: " ++ show e)]+errHandlers = [ handler_ _KevinException $ klogError "Malformed communication from server"+ , handler _IOException (\e -> klogError $ "server: " ++ show e) ]
Kevin/Damn/Protocol/Send.hs view
@@ -22,10 +22,11 @@ sendKill ) where -import Kevin.Base-import qualified Data.Text as T-import Data.List (sort) import Data.Char (toLower)+import Data.List (sort)+import Data.Monoid+import qualified Data.Text as T+import Kevin.Base maybeBody :: Maybe T.Text -> T.Text maybeBody = maybe "" (T.append "\n\n")@@ -36,11 +37,12 @@ formatRoom :: T.Text -> KevinIO T.Text formatRoom b = case T.splitAt 1 b of- ("#",s) -> return $ "chat:" `T.append` s+ ("#",s) -> return $ "chat:" <> s ("&",s) -> do uname <- use_ name- return . T.append "pchat:" . T.intercalate ":" . sort . map (T.map toLower) $ [uname, s]- r -> return $ "chat" `T.append` uncurry T.append r+ return . T.append "pchat:" . T.intercalate ":"+ . sort . map (T.map toLower) $ [uname, s]+ r -> return $ "chat" <> uncurry T.append r deformatRoom :: T.Text -> KevinIO T.Text deformatRoom room = if "chat:" `T.isPrefixOf` room
Kevin/IRC/Packet.hs view
@@ -1,21 +1,26 @@ module Kevin.IRC.Packet ( Packet(..),+ prefix, command, params,+ parsePacket, readable ) where -import Prelude hiding (takeWhile)-import qualified Data.Text as T-import Data.Char-import Data.Attoparsec.Text import Control.Applicative ((<|>), (<$>), (<*>), (*>), (<*))+import Control.Lens+import Data.Attoparsec.Text+import Data.Char+import qualified Data.Text as T+import Prelude hiding (takeWhile) -data Packet = Packet { prefix :: Maybe T.Text- , command :: T.Text- , params :: [T.Text]+data Packet = Packet { _prefix :: Maybe T.Text+ , _command :: T.Text+ , _params :: [T.Text] } | BadPacket deriving (Show) +makeLenses ''Packet+ badChars :: String badChars = "\x20\x0\xd\xa" @@ -62,12 +67,12 @@ packetParser :: Parser Packet packetParser = do- pre <- option Nothing messageBegin+ pr <- option Nothing messageBegin cmd <- T.map toUpper <$> parseCommand spaces par <- filter (not . T.null) <$> parseParams option "" crlf- return $ Packet pre cmd par+ return $ Packet pr cmd par parsePacket :: T.Text -> Packet parsePacket str = case parseOnly packetParser str of@@ -75,7 +80,9 @@ Right p -> p showParams :: [T.Text] -> T.Text-showParams = T.unwords . map (\str -> if " " `T.isInfixOf` str then T.cons ':' str else str)+showParams = T.unwords . map (\str -> if " " `T.isInfixOf` str+ then T.cons ':' str+ else str) readable :: Packet -> T.Text readable (Packet (Just str) cmd pms) = flip T.append "\r\n" $ T.unwords [T.cons ':' str, cmd, showParams pms]
Kevin/IRC/Protocol.hs view
@@ -5,22 +5,24 @@ getAuthInfo ) where -import qualified Data.Text as T-import qualified Data.Text.IO as T-import Kevin.Base-import Kevin.Util.Logger-import Kevin.Util.Token-import Kevin.Util.Entity-import Kevin.IRC.Packet-import qualified Kevin.Damn.Protocol.Send as D-import Kevin.IRC.Protocol.Send import Control.Applicative ((<$>)) import Control.Arrow+import Control.Exception.Lens import Control.Monad.State-import Data.Maybe-import Data.List (nubBy) import Data.Function (on)+import Data.List (nubBy) import qualified Data.Map as M+import Data.Maybe+import Data.Monoid+import qualified Data.Text as T+import qualified Data.Text.IO as T+import Kevin.Base+import qualified Kevin.Damn.Protocol.Send as D+import Kevin.IRC.Packet+import Kevin.IRC.Protocol.Send+import Kevin.Util.Entity+import Kevin.Util.Logger+import Kevin.Util.Token type KevinState = StateT Settings IO @@ -31,68 +33,77 @@ listen = fix (\f -> flip catches errHandlers $ do k <- get_ pkt <- io $ parsePacket <$> readClient k- respond pkt (command pkt)+ respond pkt (view command pkt) f) respond :: Packet -> T.Text -> KevinIO () respond BadPacket _ = sendNotice "Bad packet, try again." respond pkt "JOIN" = do- l <- gets_ (^. loggedIn)+ l <- gets_ (view loggedIn) if l then mapM_ D.sendJoin rooms else kevin $ joining %= (rooms ++) where- rooms = T.splitOn "," . head . params $ pkt+ rooms = T.splitOn "," $ pkt^.params._head -respond pkt "PART" = mapM_ D.sendPart . T.splitOn "," . head . params $ pkt+respond pkt "PART" = mapM_ D.sendPart . T.splitOn "," $ pkt^.params._head respond pkt "PRIVMSG" = do- let (room:msg:_) = params pkt+ let (room:msg:_) = pkt^.params if "\1ACTION" `T.isPrefixOf` msg then do let newMsg = T.drop 8 $ T.init msg D.sendAction room $ entityEncode newMsg else D.sendMsg room $ entityEncode msg -respond pkt "MODE" = if length (params pkt) > 1+respond pkt "MODE" = if length (pkt^.params) > 1 then do- let (toggle,mode) = first (=="+") $ T.splitAt 1 (params pkt !! 1)+ let (toggle,mode) = first (=="+") . T.splitAt 1 $ pkt^.params.ix 1 case mode of- "b" -> if' toggle D.sendBan D.sendUnban (head $ params pkt) (fromMaybe "random unparseable garbage" . unmask . last . params $ pkt)- "o" -> if' toggle D.sendPromote D.sendDemote (head $ params pkt) (last $ params pkt) Nothing- _ -> sendRoomNotice (head $ params pkt) $ "Unsupported mode " `T.append` mode+ "b" -> if' toggle D.sendBan D.sendUnban+ (pkt^.params._head)+ (fromMaybe "random unparseable garbage" . unmask+ $ pkt^.params._last)+ "o" -> if' toggle D.sendPromote D.sendDemote+ (pkt^.params._head)+ (pkt^.params._last)+ Nothing+ _ -> sendRoomNotice (pkt^.params._head) $ "Unsupported mode " <> mode else do uname <- use_ name- sendChanMode uname (head $ params pkt)+ sendChanMode uname (pkt^.params._head) -respond pkt "TOPIC" = case params pkt of+respond pkt "TOPIC" = case pkt^.params of [] -> sendNotice "Malformed packet" [room] -> D.sendGet room "topic" (room:topic:_) -> D.sendSet room "topic" topic -respond pkt "TITLE" = case params pkt of+respond pkt "TITLE" = case pkt^.params of [] -> sendNotice "Malformed packet" [room] -> do title <- gets_ $ M.lookup room . (^. titles) let p = T.concat ["Title for ", room, ": "] in mapM_ (sendRoomNotice room . T.append p) (T.splitOn "\n" $ fromMaybe "" title) (room:title) -> D.sendSet room "title" $ T.unwords title -respond pkt "PING" = sendPong (head $ params pkt)+respond pkt "PING" = sendPong $ pkt^.params._head -respond pkt "WHOIS" = D.sendWhois . head . params $ pkt+respond pkt "WHOIS" = D.sendWhois $ pkt^.params._head respond pkt "NAMES" = do- let (room:_) = params pkt+ let room = pkt^.params._head k <- get_ sendUserList (k^.name) (nubBy ((==) `on` username) (k^.users.ix room)) 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)+respond pkt "KICK" = let p = pkt^.params+ in D.sendKick (head p)+ (p !! 1)+ (if length p > 2 then Just $ last p else Nothing) respond _ "QUIT" = klogError "client quit" >> undefined -respond pkt "ADMIN" = let (p:ps) = params pkt in D.sendAdmin p $ T.intercalate " " ps+respond pkt "ADMIN" = let (p:ps) = pkt^.params in D.sendAdmin p $ T.intercalate " " ps -respond pkt "PROMOTE" = case params pkt of+respond pkt "PROMOTE" = case pkt^.params of (room:user:group:_) -> D.sendPromote room user $ Just group (room:_) -> sendRoomNotice room "Usage: /promote #room username group" _ -> sendNotice "Usage: /promote #room username group"@@ -106,8 +117,8 @@ xs -> listToMaybe $ filter (not . T.isInfixOf "*") xs errHandlers :: [Handler KevinIO ()]-errHandlers = [Handler (\(_ :: KevinException) -> klogError "Bad communication from client"),- Handler (\(e :: IOException) -> klogError $ "client: " ++ show e)]+errHandlers = [ handler_ _KevinException $ klogError "Bad communication from client"+ , handler _IOException (\e -> klogError $ "client: " ++ show e)] -- * Authentication-getting function notice :: Handle -> T.Text -> IO ()@@ -119,12 +130,12 @@ getAuthInfo handle = fix (\f authRetry -> do pkt <- io $ parsePacket <$> T.hGetLine handle io $ klogNow Yellow $ "client <- " ++ T.unpack (readable pkt)- case command pkt of+ case pkt^.command of "PASS" -> do- password .= head (params pkt)+ password .= pkt^.params._head passed .= True "NICK" -> do- name .= head (params pkt)+ name .= pkt^.params._head nicked .= True "USER" -> usered .= True _ -> io $ klogNow Red $ "invalid packet: " ++ show pkt
Kevin/IRC/Protocol/Send.hs view
@@ -17,8 +17,8 @@ sendWhoisReply ) where -import Kevin.Base import qualified Data.Text as T+import Kevin.Base hostname :: T.Text hostname = ":chat.deviantart.com"
Kevin/Protocol.hs view
@@ -1,24 +1,25 @@ module Kevin.Protocol (kevinServer) where -import Prelude hiding (catch)-import Kevin.Base-import Kevin.Util.Logger-import qualified Control.Exception as E-import qualified Kevin.IRC.Protocol as C-import qualified Kevin.Damn.Protocol as S+import Control.Exception.Lens import Control.Monad.State+import Data.Default import Data.Monoid (mempty)+import Kevin.Base+import qualified Kevin.Damn.Protocol as S+import qualified Kevin.IRC.Protocol as C+import Kevin.Util.Logger+import Prelude hiding (catch) -watchInterrupt :: [E.Handler (Maybe Kevin)]-watchInterrupt = [E.Handler (\(e :: E.AsyncException) -> throw e),- E.Handler (\(_ :: E.SomeException) -> return Nothing)]+watchInterrupt :: [Handler IO (Maybe Kevin)]+watchInterrupt = [ handler _AsyncException throw+ , handler_ id (return Nothing) ] mkKevin :: Socket -> IO (Maybe Kevin)-mkKevin sock = flip E.catches watchInterrupt . withSocketsDo $ do+mkKevin sock = flip catches watchInterrupt . withSocketsDo $ do (client, _, _) <- accept sock hSetBuffering client NoBuffering klogNow Blue "received a client"- s <- execStateT (C.getAuthInfo client False) emptySettings+ s <- execStateT (C.getAuthInfo client False) def damnSock <- connectTo "chat.deviantart.com" $ PortNumber 3900 hSetBuffering damnSock NoBuffering logChan <- newChan@@ -55,6 +56,10 @@ runLogger (logger k) runPrinter (dChan k) (damn k) runPrinter (iChan k) (irc k)- forkIO . void $ runReaderT (bracket_ S.initialize (S.cleanup >> io (closeClient k)) S.listen) mvar- forkIO . void $ runReaderT (bracket_ (return ()) (C.cleanup >> io (closeServer k)) C.listen) mvar+ forkIO . void $ runReaderT (bracket_ S.initialize+ (S.cleanup >> io (closeClient k))+ S.listen) mvar+ forkIO . void $ runReaderT (bracket_ (return ())+ (C.cleanup >> io (closeServer k))+ C.listen) mvar return ()
Kevin/Settings.hs view
@@ -1,7 +1,7 @@-{-# LANGUAGE TemplateHaskell #-} module Kevin.Settings where import Control.Lens+import Data.Default import Data.Text data Settings = Settings { _name :: Text@@ -14,5 +14,5 @@ makeClassy ''Settings -emptySettings :: Settings-emptySettings = Settings "" "" "" False False False+instance Default Settings where+ def = Settings "" "" "" False False False
Kevin/Types.hs view
@@ -80,10 +80,10 @@ kevin :: KevinS a -> KevinIO a kevin m = ask >>= \v -> liftIO $ atomically $ do- s <- readTVar v- (a, t) <- runStateT m s- writeTVar v t- return a+ s <- readTVar v+ (a, t) <- runStateT m s+ writeTVar v t+ return a type KevinIO = ReaderT (TVar Kevin) IO
Kevin/Util/Entity.hs view
@@ -3,15 +3,15 @@ entityDecode ) where -import Prelude hiding (take)-import qualified Data.Text as T-import Data.Attoparsec.Text-import Data.Char-import qualified Data.Text.Read as R+import Control.Applicative ((<|>), (<$>), (<*>)) import Control.Monad (guard) import Control.Monad.Fix-import Control.Applicative ((<|>), (<$>), (<*>))+import Data.Attoparsec.Text+import Data.Char import Data.Maybe+import qualified Data.Text as T+import qualified Data.Text.Read as R+import Prelude hiding (take) decodeCharacter :: Parser T.Text decodeCharacter = entityNumeric <|> entityNamed <|> take 1@@ -21,7 +21,10 @@ string "&#" entity <- T.append <$> option "" (string "x") <*> takeWhile1 isHexDigit char ';'- return $ fromMaybe (T.concat ["&#", entity, ";"]) $ (if "x" `T.isPrefixOf` entity then lookupHexEntity else lookupNumericEntity) entity+ return . fromMaybe (T.concat ["&#", entity, ";"])+ $ (if "x" `T.isPrefixOf` entity + then lookupHexEntity+ else lookupNumericEntity) entity entityNamed :: Parser T.Text entityNamed = do
Kevin/Util/Logger.hs view
@@ -9,11 +9,11 @@ printf ) where -import Kevin.Types-import Data.Char (isSpace)-import qualified Data.Text as T import Control.Concurrent import Control.Monad.State+import Data.Char (isSpace)+import qualified Data.Text as T+import Kevin.Types data Color = Red | Blue | Green | Cyan | Magenta | Yellow | Gray
Kevin/Util/Tablump.hs view
@@ -4,13 +4,13 @@ tablumpDecode ) where -import Text.Regex.PCRE-import Text.Regex.PCRE.String-import Text.Printf import Control.Arrow import Control.Monad.Fix-import System.IO.Unsafe import qualified Data.Text as T+import System.IO.Unsafe+import Text.Printf+import Text.Regex.PCRE+import Text.Regex.PCRE.String fromRight :: (Show a) => Either a b -> b fromRight (Left x) = error $ "fromRight on Left " ++ show x
Kevin/Util/Token.hs view
@@ -2,17 +2,17 @@ getToken ) where -import Network.TLS-import Network.TLS.Extra-import Network.HTTP.Base-import Crypto.Random.AESCtr (makeSystem) import Control.Arrow-import Data.List-import Text.Printf-import qualified Data.ByteString.Lazy.Char8 as LB+import Crypto.Random.AESCtr (makeSystem) import qualified Data.ByteString.Char8 as B+import qualified Data.ByteString.Lazy.Char8 as LB+import Data.List import qualified Data.Text as T import Data.Text.Encoding (decodeUtf8)+import Network.HTTP.Base+import Network.TLS+import Network.TLS.Extra+import Text.Printf recvUntil :: TLSCtx -> B.ByteString -> IO B.ByteString recvUntil ctx str = do@@ -34,15 +34,28 @@ ("Content-Type", "application/x-www-form-urlencoded")] :: [(String,String)] gen <- makeSystem ctx <- connectionClient "www.deviantart.com" "443" params gen- let payload = urlEncodeVars [("username", T.unpack uname),("password", T.unpack pass),("remember_me","1")]+ let payload = urlEncodeVars [ ("username", T.unpack uname)+ , ("password", T.unpack pass)+ , ("remember_me","1")+ ] handshake ctx- sendData ctx . LB.pack $ printf "POST /users/login HTTP/1.1\r\n%s\r\nContent-Length: %d\r\n\r\n%s" (concatHeaders $ ("Host", "www.deviantart.com"):headers) (length payload) payload+ sendData ctx . LB.pack+ $ printf "POST /users/login HTTP/1.1\r\n%s\r\nContent-Length: %d\r\n\r\n%s"+ (concatHeaders $ ("Host", "www.deviantart.com"):headers)+ (length payload)+ payload bs <- recvData ctx if "wrong-password" `B.isInfixOf` bs then return Nothing else do- let cookie = B.intercalate ";" . map snd . filter ((== "Set-Cookie") . fst) . map (second (B.drop 2 . B.takeWhile (/=';')) . B.breakSubstring ": ") . B.lines $ bs- s = printf "GET /chat/Botdom HTTP/1.1\r\n%s\r\ncookie: %s\r\n\r\n" (concatHeaders [("Host", "chat.deviantart.com")]) (B.unpack cookie)+ let cookie = B.intercalate ";" . map snd . filter ((== "Set-Cookie") . fst)+ . map (second (B.drop 2 . B.takeWhile (/=';')) . B.breakSubstring ": ")+ . B.lines $ bs+ s = printf "GET /chat/Botdom HTTP/1.1\r\n%s\r\ncookie: %s\r\n\r\n"+ (concatHeaders [("Host", "chat.deviantart.com")])+ (B.unpack cookie) sendData ctx $ LB.pack s bq <- recvUntil ctx "dAmnChat_Init"- return . (Just . decodeUtf8 . B.take 32 . B.tail . B.dropWhile (/='"') . B.dropWhile (/=',') . snd) . B.breakSubstring "dAmn_Login" $ bq+ return . (Just . decodeUtf8 . B.take 32 . B.tail+ . B.dropWhile (/='"') . B.dropWhile (/=',') . snd)+ . B.breakSubstring "dAmn_Login" $ bq
kevin.cabal view
@@ -1,5 +1,5 @@ Name: kevin-Version: 0.4+Version: 0.5 Synopsis: a dAmn ↔ IRC proxy Description: a dAmn ↔ IRC proxy License: GPL@@ -7,7 +7,7 @@ Author: Joel Taylor Maintainer: barebonesgraphics@gmail.com Build-Type: Simple-Cabal-Version: >=1.6+Cabal-Version: >=1.10 Category: Utils source-repository head@@ -15,42 +15,45 @@ location: git://github.com/otters/kevin.git Executable kevin- Main-is: Main.hs+ Main-is: Main.hs++ Default-language: Haskell2010 - Build-Depends: attoparsec == 0.10.*,- base == 4.*,- bytestring == 0.9.*,- containers == 0.4.*,- cprng-aes == 0.3.*,- HTTP == 4000.2.*,- lens == 3.8.*,- MonadCatchIO-transformers == 0.3.*,- mtl == 2.1.*,- network == 2.4.*,- regex-pcre-builtin == 0.94.*,- stm == 2.4.*,- text == 0.11.*,- time == 1.4.*,- tls == 1.1.*,- tls-extra == 0.6.*- - Other-Modules: Kevin,- Kevin.Base,- Kevin.Chatrooms,- Kevin.Damn.Packet,- Kevin.Damn.Protocol,- Kevin.Damn.Protocol.Send,- Kevin.IRC.Packet,- Kevin.IRC.Protocol,- Kevin.IRC.Protocol.Send,- Kevin.Protocol,- Kevin.Settings,- Kevin.Types,- Kevin.Util.Entity,- Kevin.Util.Logger,- Kevin.Util.Tablump,- Kevin.Util.Token+ Build-Depends: attoparsec == 0.10.*,+ base == 4.*,+ bytestring == 0.9.*,+ containers == 0.4.*,+ cprng-aes == 0.3.*,+ data-default == 0.5.*,+ HTTP == 4000.2.*,+ lens >= 3.8.2 && < 3.9,+ MonadCatchIO-transformers == 0.3.*,+ mtl == 2.1.*,+ network == 2.4.*,+ regex-pcre-builtin == 0.94.*,+ stm == 2.4.*,+ text == 0.11.*,+ time == 1.4.*,+ tls == 1.1.*,+ tls-extra == 0.6.*+ + Other-Modules: Kevin,+ Kevin.Base,+ Kevin.Chatrooms,+ Kevin.Damn.Packet,+ Kevin.Damn.Protocol,+ Kevin.Damn.Protocol.Send,+ Kevin.IRC.Packet,+ Kevin.IRC.Protocol,+ Kevin.IRC.Protocol.Send,+ Kevin.Protocol,+ Kevin.Settings,+ Kevin.Types,+ Kevin.Util.Entity,+ Kevin.Util.Logger,+ Kevin.Util.Tablump,+ Kevin.Util.Token - extensions: CPP, DeriveDataTypeable, ExistentialQuantification, FlexibleContexts, OverloadedStrings, ScopedTypeVariables, TemplateHaskell- ghc-options: -Wall -fno-warn-unused-do-bind -threaded- cpp-options: -DVERSION="0.4"+ default-extensions: CPP, DeriveDataTypeable, ExistentialQuantification, FlexibleContexts, OverloadedStrings, ScopedTypeVariables, TemplateHaskell+ ghc-options: -Wall -fno-warn-unused-do-bind -threaded+ cpp-options: -DVERSION="0.5"