kevin 0.7 → 0.7.1
raw patch · 15 files changed
+283/−109 lines, 15 files
Files
- Kevin/Base.hs +2/−1
- Kevin/Chatrooms.hs +4/−2
- Kevin/Damn/Packet.hs +4/−3
- Kevin/Damn/Protocol.hs +25/−14
- Kevin/Damn/Protocol/Send.hs +14/−11
- Kevin/IRC/Packet.hs +9/−5
- Kevin/IRC/Protocol.hs +41/−23
- Kevin/IRC/Protocol/Send.hs +45/−22
- Kevin/Util/Entity.hs +79/−3
- Kevin/Util/Logger.hs +5/−2
- Kevin/Util/Tablump.hs +18/−9
- Kevin/Util/Token.hs +16/−8
- Kevin/Version.hs +10/−0
- Main.hs +7/−2
- kevin.cabal +4/−4
Kevin/Base.hs view
@@ -37,7 +37,8 @@ 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
Kevin/Chatrooms.hs view
@@ -37,7 +37,8 @@ numUsers ch us = do st <- gets_ $ view users case st^.at ch of- Just usrs -> return . length $ findIndices (\u -> us == username u) usrs+ Just usrs -> return . length+ $ findIndices (\u -> us == username u) usrs Nothing -> return 0 removeUser :: Chatroom -> T.Text -> KevinIO ()@@ -56,7 +57,8 @@ getPrivclass room user = do st <- gets_ $ view users case st^.at room of- Just qs -> return $ privclass <$> listToMaybe (filter ((== user) . username) qs)+ Just qs -> return $ privclass+ <$> listToMaybe (filter ((== user) . username) qs) Nothing -> return Nothing getPrivclassLevel :: Chatroom -> T.Text -> KevinIO Int
Kevin/Damn/Packet.hs view
@@ -88,7 +88,8 @@ 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 . head) . T.splitOn ":") +parsePrivclasses = map (liftM2 (,) (!! 1) (read . T.unpack . head)+ . T.splitOn ":") . filter (not . T.null) . T.splitOn "\n" @@ -96,9 +97,9 @@ readable (Packet cmd param arg bod) = cmd <> maybe "" (' ' `T.cons`) param <> formattedArgs (M.toList arg)- <> maybe "" ("\n\n" `T.append`) bod+ <> maybe "" ("\n\n" <>) bod <> "\n\0" where formattedArgs [] = ""- formattedArgs q = T.append "\n" . T.intercalate "\n"+ formattedArgs q = ("\n" <>) . T.intercalate "\n" . map (uncurry (\x y -> x <> "=" <> y)) $ q
Kevin/Damn/Protocol.hs view
@@ -55,7 +55,8 @@ kevin $ joining %= (roomname:) uname <- use_ name I.sendJoin uname roomname- else I.sendNotice $ T.concat ["Couldn't join ", roomname, ": ", pkt^.args.ix "e"]+ else I.sendNotice $ T.concat+ ["Couldn't join ", roomname, ": ", pkt^.args.ix "e"] respond pkt "part" = do roomname <- deformatRoom $ pkt^.parameter._Just@@ -64,12 +65,14 @@ uname <- use_ name removeRoom roomname I.sendPart uname roomname Nothing- else I.sendNotice $ T.concat ["Couldn't part ", roomname, ": ", pkt^.args.ix "e"]+ else I.sendNotice $ T.concat+ ["Couldn't part ", roomname, ": ", pkt^.args.ix "e"] respond pkt "property" = do roomname <- deformatRoom (pkt^.parameter._Just) case pkt^.args.ix "p" of- "privclasses" -> setPrivclasses roomname . parsePrivclasses $ pkt^.body._Just+ "privclasses" -> setPrivclasses roomname . parsePrivclasses+ $ pkt^.body._Just "topic" -> do uname <- use_ name@@ -87,7 +90,8 @@ 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+ pc = privclass . head . filter (\x -> username x == k^.name)+ $ members n = nub members setUsers roomname members when (roomname `elem` k^.joining) $ do@@ -99,12 +103,13 @@ "info" -> do us <- use_ name curtime <- io $ floor <$> getPOSIXTime- let fixedPacket = parsePacket . T.init . T.replace "\n\nusericon" "\nusericon"+ 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+ let x = parsePacket $ "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)@@ -130,7 +135,8 @@ if countUser == 0 then do I.sendJoin usname roomname- pclevel <- getPrivclassLevel roomname (modifiedPkt^.args.ix "pc")+ pclevel <- getPrivclassLevel roomname+ $ modifiedPkt^.args.ix "pc" I.sendSetUserMode usname roomname pclevel else I.sendNoticeClone (username us) (succ countUser) roomname @@ -146,13 +152,15 @@ let uname = arg "from" msg = pkt^.body._Just un <- use_ name- unless (un == uname) $ I.sendChanMsg uname roomname (entityDecode $ tablumpDecode msg)+ unless (un == uname) $ I.sendChanMsg uname roomname+ (entityDecode $ tablumpDecode msg) "action" -> do let uname = arg "from" msg = pkt^.body._Just un <- use_ name- unless (un == uname) $ I.sendChanAction uname roomname (entityDecode $ tablumpDecode msg)+ unless (un == uname) $ I.sendChanAction uname roomname+ (entityDecode $ tablumpDecode msg) "privchg" -> do let user = pkt^.parameter._Just@@ -164,7 +172,7 @@ setUserPrivclass roomname user newPc I.sendRoomNotice roomname $ T.concat [user, " has been moved"- , maybe "" (T.append " from ") oldPc+ , maybe "" (" from " <>) oldPc , " to ", newPc, " by ", by ] I.sendChangeUserMode user roomname oldPcLevel newPcLevel@@ -193,8 +201,9 @@ , 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"+ "show" -> mapM_ (I.sendRoomNotice roomname) . T.splitOn "\n"+ $ pkt^.body._Just+ "privclass" -> I.sendRoomNotice roomname $ "Admin error: " <> arg "e" q -> klogError $ "Unknown admin packet type " ++ show q x -> klogError $ "Unknown packet type " ++ show x@@ -208,7 +217,8 @@ roomname <- deformatRoom $ pkt^.parameter._Just uname <- use_ name removeRoom roomname- I.sendKick uname (pkt^.args.ix "by") roomname $ pkt^.body.traverse ^? notNull_+ I.sendKick uname (pkt^.args.ix "by") roomname+ $ pkt^.body.traverse ^? notNull_ respond pkt "send" = I.sendNotice $ "Send error: " <> pkt^.args.ix "e" @@ -229,5 +239,6 @@ g s = p^.args.ix s errHandlers :: [Handler KevinIO ()]-errHandlers = [ handler_ _KevinException $ klogError "Malformed communication from server"+errHandlers = [ handler_ _KevinException+ $ klogError "Malformed communication from server" , handler _IOException (\e -> klogError $ "server: " ++ show e) ]
Kevin/Damn/Protocol/Send.hs view
@@ -27,9 +27,10 @@ import Data.Monoid import qualified Data.Text as T import Kevin.Base+import Kevin.Version maybeBody :: Maybe T.Text -> T.Text-maybeBody = maybe "" (T.append "\n\n")+maybeBody = maybe "" ("\n\n" <>) sendPacket :: T.Text -> KevinIO () sendPacket p = get_ >>= \k -> io . writeServer k . T.snoc p $ '\0'@@ -40,16 +41,17 @@ ("#",s) -> return $ "chat:" <> s ("&",s) -> do uname <- use_ name- return . T.append "pchat:" . T.intercalate ":"+ return . ("pchat:" <>) . T.intercalate ":" . sort . map (T.map toLower) $ [uname, s]- r -> return $ "chat" <> uncurry T.append r+ r -> return $ "chat" <> uncurry (<>) r deformatRoom :: T.Text -> KevinIO T.Text deformatRoom room = if "chat:" `T.isPrefixOf` room then return $ '#' `T.cons` T.drop 5 room else do uname <- use_ name- return $ '&' `T.cons` head (filter (/= uname) . T.splitOn ":" . T.drop 6 $ room)+ return $ T.cons '&' (head (filter (/= uname) . T.splitOn ":"+ . T.drop 6 $ room)) type Str = T.Text -- just make it shorter type Room = Str@@ -70,7 +72,8 @@ sendAdmin :: Room -> Str -> KevinIO () sendKill :: Username -> Str -> KevinIO () -sendHandshake = sendPacket $ printf "dAmnClient 0.3\nagent=kevin%s\n" [VERSION]+sendHandshake = sendPacket $ printf "dAmnClient 0.3\nagent=kevin%s\n"+ [versionStr] sendLogin u token = sendPacket $ printf "login %s\npk=%s\n" [u, token] @@ -113,16 +116,16 @@ sendPacket $ printf "kick %s\nu=%s%s\n" [roomname, us, maybeBody reason] sendGet room prop = do- guard $ prop `elem` ["title", "topic", "privclasses", "members"]- roomname <- formatRoom room- sendPacket $ printf "get %s\np=%s\n" [roomname, prop]+ guard $ prop `elem` ["title", "topic", "privclasses", "members"]+ roomname <- formatRoom room+ sendPacket $ printf "get %s\np=%s\n" [roomname, prop] sendWhois us = sendPacket $ printf "get login:%s\np=info\n" [us] sendSet room prop val = do- guard (prop == "topic" || prop == "title")- roomname <- formatRoom room- sendPacket $ printf "set %s\np=%s\n\n%s\n" [roomname, prop, val]+ guard (prop == "topic" || prop == "title")+ roomname <- formatRoom room+ sendPacket $ printf "set %s\np=%s\n\n%s\n" [roomname, prop, val] sendAdmin room cmd = do roomname <- formatRoom room
Kevin/IRC/Packet.hs view
@@ -8,8 +8,10 @@ import Control.Applicative ((<|>), (<$>), (<*>), (*>), (<*)) import Control.Lens+import Control.Monad import Data.Attoparsec.Text import Data.Char+import Data.Monoid import qualified Data.Text as T import Prelude hiding (takeWhile) @@ -17,7 +19,7 @@ , _command :: T.Text , _params :: [T.Text] }- | BadPacket deriving (Show)+ | BadPacket deriving (Show) makeLenses ''Packet @@ -47,8 +49,9 @@ parsePrefix = username <|> servername parseCommand :: Parser T.Text-parseCommand = takeWhile1 isAlpha <|>- (do { a <- digit; b <- digit; c <- digit; return $ T.pack [a,b,c]})+parseCommand = takeWhile1 isAlpha+ <|> liftM3 (\a b c -> T.pack [a,b,c])+ digit digit digit parseParams :: Parser [T.Text] parseParams = (colonParam <|> nonColonParam) `sepBy` spaces@@ -85,6 +88,7 @@ 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]-readable (Packet Nothing c p) = flip T.append "\r\n" $ T.unwords [c, showParams p]+readable (Packet (Just str) cmd pms) = (<> "\r\n")+ $ T.unwords [T.cons ':' str, cmd, showParams pms]+readable (Packet Nothing c p) = (<> "\r\n") $ T.unwords [c, showParams p] readable _ = ""
Kevin/IRC/Protocol.hs view
@@ -11,7 +11,6 @@ import Control.Monad.State 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@@ -23,6 +22,7 @@ import Kevin.Util.Entity import Kevin.Util.Logger import Kevin.Util.Token+import Kevin.Version type KevinState = StateT Settings IO @@ -68,22 +68,24 @@ (pkt^.params._head) (pkt^.params._last) Nothing- _ -> sendRoomNotice (pkt^.params._head) $ "Unsupported mode " <> mode+ _ -> sendRoomNotice (pkt^.params._head)+ $ "Unsupported mode " <> mode else do uname <- use_ name sendChanMode uname (pkt^.params._head) respond pkt "TOPIC" = case pkt^.params of- [] -> sendNotice "Malformed packet"- [room] -> D.sendGet room "topic"- (room:topic:_) -> D.sendSet room "topic" topic+ [] -> sendNotice "Malformed packet"+ [room] -> D.sendGet room "topic"+ (room:topic:_) -> D.sendSet room "topic" topic 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+ [] -> sendNotice "Malformed packet"+ [room] -> do+ title <- gets_ . view $ titles.ix room+ let p = T.concat ["Title for ", room, ": "]+ mapM_ (sendRoomNotice room . (p <>)) (T.splitOn "\n" title)+ (room:title) -> D.sendSet room "title" $ T.unwords title respond pkt "PING" = sendPong $ pkt^.params._head @@ -97,11 +99,14 @@ respond pkt "KICK" = let p = pkt^.params in D.sendKick (head p) (p !! 1)- (if length p > 2 then Just $ last p else Nothing)+ (if length p > 2+ then Just $ last p+ else Nothing) respond _ "QUIT" = klogError "client quit" >> undefined -respond pkt "ADMIN" = let (p:ps) = pkt^.params in D.sendAdmin p $ T.intercalate " " ps+respond pkt "ADMIN" = D.sendAdmin p $ T.intercalate " " ps+ where (p:ps) = pkt^.params respond pkt "PROMOTE" = case pkt^.params of (room:user:group:_) -> D.sendPromote room user $ Just group@@ -117,12 +122,15 @@ xs -> listToMaybe $ filter (not . T.isInfixOf "*") xs errHandlers :: [Handler KevinIO ()]-errHandlers = [ handler_ _KevinException $ klogError "Bad communication from client"+errHandlers = [ handler_ _KevinException+ $ klogError "Bad communication from client" , handler _IOException (\e -> klogError $ "client: " ++ show e)] -- * Authentication-getting function notice :: Handle -> T.Text -> IO ()-notice h str = klogNow Blue ("client -> " ++ T.unpack asStr) >> T.hPutStr h (asStr `T.append` "\r\n")+notice h str = do+ klogNow Blue ("client -> " ++ T.unpack asStr)+ T.hPutStr h (asStr <> "\r\n") where asStr = printf "NOTICE AUTH :%s" [str] @@ -153,15 +161,24 @@ welcome :: Handle -> KevinState () welcome handle = do nick <- use name- mapM_ (\x -> io $ klogNow Blue ("client -> " ++ T.unpack x) >> T.hPutStr handle (x `T.append` "\r\n")) [- printf ":%s 001 %s :Welcome to dAmnServer %s!%s@chat.deviantart.com" [hostname, nick, nick, nick],- printf ":%s 002 %s :Your host is chat.deviantart.com, running dAmnServer 0.3" [hostname, nick],- printf ":%s 003 %s :This server was created Thu Apr 28 1994 at 05:30:00 EDT" [hostname, nick],- printf ":%s 004 %s chat.deviantart.com dAmnServer0.3 qov i" [hostname, nick],+ mapM_ (\x -> io $ do+ klogNow Blue ("client -> " ++ T.unpack x)+ T.hPutStr handle (x <> "\r\n")) [+ printf ":%s 001 %s :Welcome to dAmnServer %s!%s@chat.deviantart.com"+ [hostname, nick, nick, nick],+ printf ":%s 002 %s :Your host is chat.deviantart.com\+ \, running dAmnServer 0.3" [hostname, nick],+ printf ":%s 003 %s :This server was created Thu Apr 28 1994\+ \ at 05:30:00 EDT" [hostname, nick],+ printf ":%s 004 %s chat.deviantart.com dAmnServer0.3 qov i"+ [hostname, nick], printf ":%s 005 %s PREFIX=(qov)~@+" [hostname, nick],- printf ":%s 375 %s :- chat.deviantart.com Message of the day -" [hostname, nick],- printf ":%s 372 %s :- deviantART chat on IRC brought to by kevin %s, created" [hostname, nick, VERSION],- printf ":%s 372 %s :- and maintained by Joel Taylor <http://otter.github.com>" [hostname, nick],+ printf ":%s 375 %s :- chat.deviantart.com Message of the day -" + [hostname, nick],+ printf ":%s 372 %s :- deviantART chat on IRC brought to you\+ \ by kevin %s, created" [hostname, nick, versionStr],+ printf ":%s 372 %s :- and maintained by Joel Taylor <http://otte.rs>"+ [hostname, nick], printf ":%s 376 %s :End of MOTD command" [hostname, nick]] checkToken handle where@@ -177,5 +194,6 @@ authtoken .= t io $ notice handle "Successfully authenticated." Nothing -> do- io $ notice handle "Bad password, try again. (/quote pass yourpassword)"+ io $ notice handle "Bad password, try again.\+ \ (/quote pass yourpassword)" getAuthInfo handle True
Kevin/IRC/Protocol/Send.hs view
@@ -4,7 +4,7 @@ sendSetUserMode, sendChangeUserMode, sendNotice,- sendRoomNotice,+ sendRoomNotice, sendChanMsg, sendChanAction, sendKick,@@ -17,6 +17,7 @@ sendWhoisReply ) where +import Data.Monoid import qualified Data.Text as T import Kevin.Base @@ -27,10 +28,10 @@ getHost u = T.concat [":", u, "!", u, "@chat.deviantart.com"] sendPacket :: T.Text -> KevinIO ()-sendPacket p = get_ >>= \k -> io . writeClient k $ T.append p "\r\n"+sendPacket p = get_ >>= \k -> io . writeClient k $ p <> "\r\n" maybeBody :: Maybe T.Text -> T.Text-maybeBody = maybe "" (T.append " :")+maybeBody = maybe "" (" :" <>) type Str = T.Text type Room = Str@@ -50,7 +51,13 @@ sendPong :: T.Text -> KevinIO () sendNoticeClone :: Username -> Int -> Room -> KevinIO () sendNoticeUnclone :: Username -> Int -> Room -> KevinIO ()-sendWhoisReply :: Username -> Username -> Username -> [Room] -> Int -> Int -> KevinIO ()+sendWhoisReply :: Username+ -> Username+ -> Username+ -> [Room]+ -> Int+ -> Int+ -> KevinIO () sendJoin us rm = sendPacket $ printf "%s JOIN :%s" [getHost us, rm]@@ -78,22 +85,25 @@ sendPacket . printf "NOTICE AUTH :%s" . return sendRoomNotice room n =- sendPacket $ printf "%s NOTICE %s :%s" [hostname, room, n]+ sendPacket $ printf "%s NOTICE %s :%s" [hostname, room, n] sendChanMsg sender room msg = mapM_ (\x -> sendPacket $ printf "%s PRIVMSG %s :%s" [getHost sender, room, x] ) . T.splitOn "\n" $ msg sendChanAction sender room msg = mapM_ (\x ->- sendPacket $ printf "%s PRIVMSG %s :\1ACTION %s\1" [getHost sender, room, x]+ sendPacket $ printf "%s PRIVMSG %s :\1ACTION %s\1"+ [getHost sender, room, x] ) . T.splitOn "\n" $ msg sendKick kickee kicker room msg =- sendPacket $ printf "%s KICK %s %s%s" [getHost kicker, room, kickee, maybeBody msg]+ sendPacket $ printf "%s KICK %s %s%s"+ [getHost kicker, room, kickee, maybeBody msg] sendTopic us rm maker top startdate = do sendPacket $ printf "%s 332 %s %s :%s" [hostname, us, rm, top]- sendPacket $ printf "%s 333 %s %s %s %s" [hostname, us, rm, maker, startdate]+ sendPacket $ printf "%s 333 %s %s %s %s"+ [hostname, us, rm, maker, startdate] sendChanMode us rm = do sendPacket $ printf "%s 324 %s %s +t" [hostname, us, rm]@@ -101,35 +111,48 @@ sendUserList us uss rm = do mapM_ (\nms ->- sendPacket $ printf "%s 353 %s = %s :%s" [hostname, us, rm, T.unwords nms]) chunkedNames+ sendPacket $ printf "%s 353 %s = %s :%s"+ [hostname, us, rm, T.unwords nms]) chunkedNames sendPacket $ printf "%s 366 %s %s :End of /NAMES list." [hostname, us, rm] where- names = map (\u -> T.concat [levelToSym $ privclassLevel u, username u]) uss+ names = map (\u ->+ T.concat [levelToSym $ privclassLevel u, username u]) uss chunkedNames = reverse . map reverse . subchunk' 432 names $ [[]]- subchunk' n = fix (\f x y -> let hy = head y; hx = head x; ty = tail y; tx = tail x in if null x- then y- else f tx $ if sum (map T.length hy) + T.length hx <= n- then (hx:hy):ty- else [hx]:y)+ subchunk' n = fix (\f x y ->+ let hy = head y+ hx = head x+ ty = tail y+ tx = tail x+ in if null x+ then y+ else f tx $ if sum (map T.length hy) + T.length hx <= n+ then (hx:hy):ty+ else [hx]:y) sendPong p = sendPacket $ printf "%s PONG chat.deviantart.com :%s" [hostname, p] sendNoticeClone uname i rm =- sendPacket $ printf "%s NOTICE %s :%s has joined again (now joined %s times)" [hostname, rm, uname, T.pack $ show i]+ sendPacket $ printf "%s NOTICE %s :%s has joined again\+ \ (now joined %s times)" [hostname, rm, uname, T.pack $ show i] sendNoticeUnclone uname i rm =- sendPacket $ printf "%s NOTICE %s :%s has parted (now joined %s)" [hostname, rm, uname, times]+ sendPacket $ printf "%s NOTICE %s :%s has parted (now joined %s)"+ [hostname, rm, uname, times] where times | i == 1 = "once"- | otherwise = T.pack (show i) `T.append` " times"+ | otherwise = T.pack (show i) <> " times" sendWhoisReply me us rn rooms idle signon = do- sendPacket $ printf "%s 311 %s %s %s chat.deviantart.com * :%s" [hostname, me, us, us, rn]+ sendPacket $ printf "%s 311 %s %s %s chat.deviantart.com * :%s"+ [hostname, me, us, us, rn] sendPacket $ printf "%s 307 %s %s :is a registered nick" [hostname, me, us]- sendPacket $ printf "%s 319 %s %s :%s" [hostname, me, us, T.intercalate " " . map (T.cons '#') $ rooms]- sendPacket $ printf "%s 312 %s %s chat.deviantart.com :dAmn" [hostname, me, us]- sendPacket $ printf "%s 317 %s %s %s %s :seconds idle, signon time" [hostname, me, us, T.pack $ show idle, T.pack $ show signon]+ sendPacket $ printf "%s 319 %s %s :%s"+ [hostname, me, us, T.intercalate " " . map (T.cons '#') $ rooms]+ sendPacket $ printf "%s 312 %s %s chat.deviantart.com :dAmn"+ [hostname, me, us]+ sendPacket $ printf "%s 317 %s %s %s %s :seconds idle, signon time"+ [hostname, me, us, T.pack $ show idle, T.pack $ show signon] sendPacket $ printf "%s 318 %s %s :End of /WHOIS list." [hostname, me, us] levelToSym :: Int -> T.Text
Kevin/Util/Entity.hs view
@@ -9,6 +9,7 @@ import Data.Attoparsec.Text import Data.Char import Data.Maybe+import Data.Monoid import qualified Data.Text as T import qualified Data.Text.Read as R import Prelude hiding (take)@@ -19,7 +20,7 @@ entityNumeric :: Parser T.Text entityNumeric = do string "&#"- entity <- T.append <$> option "" (string "x") <*> takeWhile1 isHexDigit+ entity <- (<>) <$> option "" (string "x") <*> takeWhile1 isHexDigit char ';' return . fromMaybe (T.concat ["&#", entity, ";"]) $ (if "x" `T.isPrefixOf` entity @@ -31,7 +32,8 @@ char '&' entity <- T.cons <$> letter <*> takeWhile1 isAlphaNum char ';'- return . fromMaybe (T.concat ["&", entity, ";"]) . lookupNamedEntity $ entity+ return . fromMaybe (T.concat ["&", entity, ";"])+ . lookupNamedEntity $ entity decodeParser :: Parser T.Text decodeParser = T.concat <$> many1 decodeCharacter@@ -69,4 +71,78 @@ Left _ -> Nothing namedEntities :: [(T.Text, Int)]-namedEntities = [("quot", 34), ("amp", 38), ("apos", 39), ("lt", 60), ("gt", 62), ("nbsp", 160), ("iexcl", 161), ("cent", 162), ("pound", 163), ("curren", 164), ("yen", 165), ("brvbar", 166), ("sect", 167), ("uml", 168), ("copy", 169), ("ordf", 170), ("laquo", 171), ("not", 172), ("shy", 173), ("reg", 174), ("macr", 175), ("deg", 176), ("plusmn", 177), ("sup2", 178), ("sup3", 179), ("acute", 180), ("micro", 181), ("para", 182), ("middot", 183), ("cedil", 184), ("sup1", 185), ("ordm", 186), ("raquo", 187), ("frac14", 188), ("frac12", 189), ("frac34", 190), ("iquest", 191), ("Agrave", 192), ("Aacute", 193), ("Acirc", 194), ("Atilde", 195), ("Auml", 196), ("Aring", 197), ("AElig", 198), ("Ccedil", 199), ("Egrave", 200), ("Eacute", 201), ("Ecirc", 202), ("Euml", 203), ("Igrave", 204), ("Iacute", 205), ("Icirc", 206), ("Iuml", 207), ("ETH", 208), ("Ntilde", 209), ("Ograve", 210), ("Oacute", 211), ("Ocirc", 212), ("Otilde", 213), ("Ouml", 214), ("times", 215), ("Oslash", 216), ("Ugrave", 217), ("Uacute", 218), ("Ucirc", 219), ("Uuml", 220), ("Yacute", 221), ("THORN", 222), ("szlig", 223), ("agrave", 224), ("aacute", 225), ("acirc", 226), ("atilde", 227), ("auml", 228), ("aring", 229), ("aelig", 230), ("ccedil", 231), ("egrave", 232), ("eacute", 233), ("ecirc", 234), ("euml", 235), ("igrave", 236), ("iacute", 237), ("icirc", 238), ("iuml", 239), ("eth", 240), ("ntilde", 241), ("ograve", 242), ("oacute", 243), ("ocirc", 244), ("otilde", 245), ("ouml", 246), ("divide", 247), ("oslash", 248), ("ugrave", 249), ("uacute", 250), ("ucirc", 251), ("uuml", 252), ("yacute", 253), ("thorn", 254), ("yuml", 255), ("OElig", 338), ("oelig", 339), ("Scaron", 352), ("scaron", 353), ("Yuml", 376), ("fnof", 402), ("circ", 710), ("tilde", 732), ("Alpha", 913), ("Beta", 914), ("Gamma", 915), ("Delta", 916), ("Epsilon", 917), ("Zeta", 918), ("Eta", 919), ("Theta", 920), ("Iota", 921), ("Kappa", 922), ("Lambda", 923), ("Mu", 924), ("Nu", 925), ("Xi", 926), ("Omicron", 927), ("Pi", 928), ("Rho", 929), ("Sigma", 931), ("Tau", 932), ("Upsilon", 933), ("Phi", 934), ("Chi", 935), ("Psi", 936), ("Omega", 937), ("alpha", 945), ("beta", 946), ("gamma", 947), ("delta", 948), ("epsilon", 949), ("zeta", 950), ("eta", 951), ("theta", 952), ("iota", 953), ("kappa", 954), ("lambda", 955), ("mu", 956), ("nu", 957), ("xi", 958), ("omicron", 959), ("pi", 960), ("rho", 961), ("sigmaf", 962), ("sigma", 963), ("tau", 964), ("upsilon", 965), ("phi", 966), ("chi", 967), ("psi", 968), ("omega", 969), ("thetasym", 977), ("upsih", 978), ("piv", 982), ("ensp", 8194), ("emsp", 8195), ("thinsp", 8201), ("zwnj", 8204), ("zwj", 8205), ("lrm", 8206), ("rlm", 8207), ("ndash", 8211), ("mdash", 8212), ("lsquo", 8216), ("rsquo", 8217), ("sbquo", 8218), ("ldquo", 8220), ("rdquo", 8221), ("bdquo", 8222), ("dagger", 8224), ("Dagger", 8225), ("bull", 8226), ("hellip", 8230), ("permil", 8240), ("prime", 8242), ("Prime", 8243), ("lsaquo", 8249), ("rsaquo", 8250), ("oline", 8254), ("frasl", 8260), ("euro", 8364), ("image", 8465), ("weierp", 8472), ("real", 8476), ("trade", 8482), ("alefsym", 8501), ("larr", 8592), ("uarr", 8593), ("rarr", 8594), ("darr", 8595), ("harr", 8596), ("crarr", 8629), ("lArr", 8656), ("uArr", 8657), ("rArr", 8658), ("dArr", 8659), ("hArr", 8660), ("forall", 8704), ("part", 8706), ("exist", 8707), ("empty", 8709), ("nabla", 8711), ("isin", 8712), ("notin", 8713), ("ni", 8715), ("prod", 8719), ("sum", 8721), ("minus", 8722), ("lowast", 8727), ("radic", 8730), ("prop", 8733), ("infin", 8734), ("ang", 8736), ("and", 8743), ("or", 8744), ("cap", 8745), ("cup", 8746), ("int", 8747), ("there4", 8756), ("sim", 8764), ("cong", 8773), ("asymp", 8776), ("ne", 8800), ("equiv", 8801), ("le", 8804), ("ge", 8805), ("sub", 8834), ("sup", 8835), ("nsub", 8836), ("sube", 8838), ("supe", 8839), ("oplus", 8853), ("otimes", 8855), ("perp", 8869), ("sdot", 8901), ("lceil", 8968), ("rceil", 8969), ("lfloor", 8970), ("rfloor", 8971), ("lang", 9001), ("rang", 9002), ("loz", 9674), ("spades", 9824), ("clubs", 9827), ("hearts", 9829), ("diams", 9830)]+namedEntities = [ ("quot", 34), ("amp", 38), ("apos", 39), ("lt", 60)+ , ("gt", 62), ("nbsp", 160), ("iexcl", 161), ("cent", 162)+ , ("pound", 163), ("curren", 164), ("yen", 165)+ , ("brvbar", 166), ("sect", 167), ("uml", 168), ("copy", 169)+ , ("ordf", 170), ("laquo", 171), ("not", 172), ("shy", 173)+ , ("reg", 174), ("macr", 175), ("deg", 176), ("plusmn", 177)+ , ("sup2", 178), ("sup3", 179), ("acute", 180), ("micro", 181)+ , ("para", 182), ("middot", 183), ("cedil", 184), ("sup1", 185)+ , ("ordm", 186), ("raquo", 187), ("frac14", 188)+ , ("frac12", 189), ("frac34", 190), ("iquest", 191)+ , ("Agrave", 192), ("Aacute", 193), ("Acirc", 194)+ , ("Atilde", 195), ("Auml", 196), ("Aring", 197)+ , ("AElig", 198), ("Ccedil", 199), ("Egrave", 200)+ , ("Eacute", 201), ("Ecirc", 202), ("Euml", 203)+ , ("Igrave", 204), ("Iacute", 205), ("Icirc", 206)+ , ("Iuml", 207), ("ETH", 208), ("Ntilde", 209), ("Ograve", 210)+ , ("Oacute", 211), ("Ocirc", 212), ("Otilde", 213)+ , ("Ouml", 214), ("times", 215), ("Oslash", 216)+ , ("Ugrave", 217), ("Uacute", 218), ("Ucirc", 219)+ , ("Uuml", 220), ("Yacute", 221), ("THORN", 222)+ , ("szlig", 223), ("agrave", 224), ("aacute", 225)+ , ("acirc", 226), ("atilde", 227), ("auml", 228)+ , ("aring", 229), ("aelig", 230), ("ccedil", 231)+ , ("egrave", 232), ("eacute", 233), ("ecirc", 234)+ , ("euml", 235), ("igrave", 236), ("iacute", 237)+ , ("icirc", 238), ("iuml", 239), ("eth", 240), ("ntilde", 241)+ , ("ograve", 242), ("oacute", 243), ("ocirc", 244)+ , ("otilde", 245), ("ouml", 246), ("divide", 247)+ , ("oslash", 248), ("ugrave", 249), ("uacute", 250)+ , ("ucirc", 251), ("uuml", 252), ("yacute", 253)+ , ("thorn", 254), ("yuml", 255), ("OElig", 338), ("oelig", 339)+ , ("Scaron", 352), ("scaron", 353), ("Yuml", 376)+ , ("fnof", 402), ("circ", 710), ("tilde", 732), ("Alpha", 913)+ , ("Beta", 914), ("Gamma", 915), ("Delta", 916)+ , ("Epsilon", 917), ("Zeta", 918), ("Eta", 919), ("Theta", 920)+ , ("Iota", 921), ("Kappa", 922), ("Lambda", 923), ("Mu", 924)+ , ("Nu", 925), ("Xi", 926), ("Omicron", 927), ("Pi", 928)+ , ("Rho", 929), ("Sigma", 931), ("Tau", 932), ("Upsilon", 933)+ , ("Phi", 934), ("Chi", 935), ("Psi", 936), ("Omega", 937)+ , ("alpha", 945), ("beta", 946), ("gamma", 947), ("delta", 948)+ , ("epsilon", 949), ("zeta", 950), ("eta", 951), ("theta", 952)+ , ("iota", 953), ("kappa", 954), ("lambda", 955), ("mu", 956)+ , ("nu", 957), ("xi", 958), ("omicron", 959), ("pi", 960)+ , ("rho", 961), ("sigmaf", 962), ("sigma", 963), ("tau", 964)+ , ("upsilon", 965), ("phi", 966), ("chi", 967), ("psi", 968)+ , ("omega", 969), ("thetasym", 977), ("upsih", 978)+ , ("piv", 982), ("ensp", 8194), ("emsp", 8195)+ , ("thinsp", 8201), ("zwnj", 8204), ("zwj", 8205)+ , ("lrm", 8206), ("rlm", 8207), ("ndash", 8211)+ , ("mdash", 8212), ("lsquo", 8216), ("rsquo", 8217)+ , ("sbquo", 8218), ("ldquo", 8220), ("rdquo", 8221)+ , ("bdquo", 8222), ("dagger", 8224), ("Dagger", 8225)+ , ("bull", 8226), ("hellip", 8230), ("permil", 8240)+ , ("prime", 8242), ("Prime", 8243), ("lsaquo", 8249)+ , ("rsaquo", 8250), ("oline", 8254), ("frasl", 8260)+ , ("euro", 8364), ("image", 8465), ("weierp", 8472)+ , ("real", 8476), ("trade", 8482), ("alefsym", 8501)+ , ("larr", 8592), ("uarr", 8593), ("rarr", 8594)+ , ("darr", 8595), ("harr", 8596), ("crarr", 8629)+ , ("lArr", 8656), ("uArr", 8657), ("rArr", 8658)+ , ("dArr", 8659), ("hArr", 8660), ("forall", 8704)+ , ("part", 8706), ("exist", 8707), ("empty", 8709)+ , ("nabla", 8711), ("isin", 8712), ("notin", 8713)+ , ("ni", 8715), ("prod", 8719), ("sum", 8721), ("minus", 8722)+ , ("lowast", 8727), ("radic", 8730), ("prop", 8733)+ , ("infin", 8734), ("ang", 8736), ("and", 8743), ("or", 8744)+ , ("cap", 8745), ("cup", 8746), ("int", 8747), ("there4", 8756)+ , ("sim", 8764), ("cong", 8773), ("asymp", 8776), ("ne", 8800)+ , ("equiv", 8801), ("le", 8804), ("ge", 8805), ("sub", 8834)+ , ("sup", 8835), ("nsub", 8836), ("sube", 8838), ("supe", 8839)+ , ("oplus", 8853), ("otimes", 8855), ("perp", 8869)+ , ("sdot", 8901), ("lceil", 8968), ("rceil", 8969)+ , ("lfloor", 8970), ("rfloor", 8971), ("lang", 9001)+ , ("rang", 9002), ("loz", 9674), ("spades", 9824)+ , ("clubs", 9827), ("hearts", 9829), ("diams", 9830)]
Kevin/Util/Logger.hs view
@@ -38,9 +38,12 @@ printf str reps = T.concat $ interleave (T.splitOn "%s" str) reps render :: Color -> String -> String-render col str = "\027[" ++ show (colorAsNum col) ++ "m" ++ rtrimmed ++ "\027[0m"+render col str = "\027[" ++ show (colorAsNum col)+ ++ "m" ++ rtrimmed+ ++ "\027[0m" where- rtrimmed = reverse . dropWhile (\x -> isSpace x || x == '\x0') . reverse $ str+ rtrimmed = reverse . dropWhile (\x -> isSpace x || x == '\x0')+ . reverse $ str klog_ :: Chan String -> Color -> String -> IO () klog_ ch col str = writeChan ch $ render col str
Kevin/Util/Tablump.hs view
@@ -18,13 +18,17 @@ {-# NOINLINE regexReplace #-} regexReplace :: Regex -> ([String] -> String) -> String -> String-regexReplace find replace = fix (\f str -> case fromRight . unsafePerformIO $ regexec find str of- Just (bef, _, af, matches) -> concat [bef, replace matches, f af]- Nothing -> str)+regexReplace find replace = fix (\f str -> case fromRight . unsafePerformIO+ $ regexec find str of+ Just (bef, _, af, matches) -> concat [bef, replace matches, f af]+ Nothing -> str) {-# NOINLINE regexen #-} regexen :: [(Regex, [String] -> String)]-regexen = let ($$) = (,) in map (first (fromRight . unsafePerformIO . compile defaultCompOpt defaultExecOpt)) . reverse $ [+regexen = let ($$) = (,) in map (+ first (fromRight . unsafePerformIO+ . compile defaultCompOpt defaultExecOpt)+ ) . reverse $ [ "&b\t" $$ const "\2", "&/b\t" $$ const "\15", "&i\t" $$ const "\22",@@ -59,14 +63,19 @@ "&link\t(.+?)\t(.+?)\t&\t" $$ \(x:y:_) -> printf "%s (%s)" x y, "&dev\t.+?\t(.+?)\t" $$ head, "&avatar\t(.+?)\t.+?\t" $$ \(x:_) -> printf ":icon%s:" x,- "&thumb\t(.+?)\t.+?\t.+?\t.+?\t.+?\t.+?\t.+?\t" $$ \(x:_) -> printf ":thumb%s:" x,- "&img\t(.+?)\t(.*?)\t(.*?)\t" $$ \(x:y:z:_) -> printf "<img src='%s' alt='%s' title='%s' />" x y z,- "&iframe\t(.+?)\t(.*?)\t(.*?)\t" $$ \(x:y:z:_) -> printf "<iframe src='%s' width='%s' height='%s' />" x y z,+ "&thumb\t(.+?)\t.+?\t.+?\t.+?\t.+?\t.+?\t.+?\t" $$ \(x:_) ->+ printf ":thumb%s:" x,+ "&img\t(.+?)\t(.*?)\t(.*?)\t" $$ \(x:y:z:_) ->+ printf "<img src='%s' alt='%s' title='%s' />" x y z,+ "&iframe\t(.+?)\t(.*?)\t(.*?)\t" $$ \(x:y:z:_) ->+ printf "<iframe src='%s' width='%s' height='%s' />" x y z, "&acro\t(.+?)\t" $$ \(x:_) -> printf "<acronym title='%s'>" x, "&abbr\t(.+?)\t" $$ \(x:_) -> printf "<abbr title='%s'>" x,- " ?<abbr title='colors:[0-9A-Fa-f]{6}:[0-9A-Fa-f]{6}'></abbr>" $$ const "",+ " ?<abbr title='colors:[0-9A-Fa-f]{6}:[0-9A-Fa-f]{6}'></abbr>"+ $$ const "", "^<abbr title='(.+?)'>.+?</abbr>:" $$ \(x:_) -> printf "%s:" x,- "^[a-zA-Z0-9\\-_]+<abbr title='(.+?)'></abbr>:" $$ \(x:_) -> printf "%s:" x+ "^[a-zA-Z0-9\\-_]+<abbr title='(.+?)'></abbr>:" $$ \(x:_) ->+ printf "%s:" x ] tablumpDecode :: T.Text -> T.Text
Kevin/Util/Token.hs view
@@ -7,6 +7,7 @@ import qualified Data.ByteString.Char8 as B import qualified Data.ByteString.Lazy.Char8 as LB import Data.List+import Data.Monoid import qualified Data.Text as T import Data.Text.Encoding (decodeUtf8) import Network.HTTP.Base@@ -19,7 +20,7 @@ line <- recvData ctx if str `B.isInfixOf` line then return line- else fmap (line `B.append`) $ recvUntil ctx str+ else fmap (line <>) $ recvUntil ctx str concatHeaders :: [(String,String)] -> String concatHeaders = intercalate "\r\n" . map (\(x,y) -> x ++ ": " ++ y)@@ -27,11 +28,14 @@ getToken :: T.Text -> T.Text -> IO (Maybe T.Text) getToken uname pass = do let params = defaultParams { pCiphers = ciphersuite_all- , onCertificatesRecv = certificateChecks- [return . certificateVerifyDomain "chat.deviantart.com"]+ , onCertificatesRecv =+ certificateChecks [return+ . certificateVerifyDomain+ "chat.deviantart.com"] }+ headers :: [(String, String)] headers = [("Connection", "closed"),- ("Content-Type", "application/x-www-form-urlencoded")] :: [(String,String)]+ ("Content-Type", "application/x-www-form-urlencoded")] gen <- makeSystem ctx <- connectionClient "www.deviantart.com" "443" params gen let payload = urlEncodeVars [ ("username", T.unpack uname)@@ -40,7 +44,8 @@ ] 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"+ $ printf "POST /users/login HTTP/1.1\r\n%s\r\n\+ \Content-Length: %d\r\n\r\n%s" (concatHeaders $ ("Host", "www.deviantart.com"):headers) (length payload) payload@@ -48,10 +53,13 @@ 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 ": ")+ 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"+ s = printf "GET /chat/Botdom HTTP/1.1\r\n%s\r\n\+ \cookie: %s\r\n\r\n" (concatHeaders [("Host", "chat.deviantart.com")]) (B.unpack cookie) sendData ctx $ LB.pack s
+ Kevin/Version.hs view
@@ -0,0 +1,10 @@+module Kevin.Version (showVersion, version, versionStr) where++import Data.Text (Text, pack)+import Data.Version++version :: Version+version = Version [0,7,1] []++versionStr :: Text+versionStr = pack $ showVersion version
Main.hs view
@@ -1,4 +1,5 @@ import Kevin+import Kevin.Version import System.Console.GetOpt import System.Environment @@ -9,7 +10,10 @@ opts :: [OptDescr Flag] opts = [- Option "p" ["port"] (ReqArg (Port . read) "number") $ "local port to run the server on (defaults to " ++ show defaultPort ++ ")",+ Option "p" ["port"] (ReqArg (Port . read) "number")+ $ "local port to run the server on (defaults to "+ ++ show defaultPort+ ++ ")", Option "h" ["help"] (NoArg Help) "print this message", Option "v" ["version"] (NoArg Version) "show kevin's version number" ]@@ -28,6 +32,7 @@ case getOpt Permute opts args of (flags, _, []) -> case flags of f | Help `elem` f -> putStrLn $ usageInfo header opts- | Version `elem` f -> putStrLn $ "kevin version " ++ VERSION+ | Version `elem` f -> putStrLn + $ "kevin version " ++ showVersion version | otherwise -> kevinServer $ getPort flags (_, _, msgs@(_:_)) -> putStrLn $ concat msgs ++ usageInfo header opts
kevin.cabal view
@@ -1,5 +1,5 @@ Name: kevin-Version: 0.7+Version: 0.7.1 Synopsis: a dAmn ↔ IRC proxy Description: a dAmn ↔ IRC proxy License: GPL@@ -52,8 +52,8 @@ Kevin.Util.Entity, Kevin.Util.Logger, Kevin.Util.Tablump,- Kevin.Util.Token+ Kevin.Util.Token,+ Kevin.Version - default-extensions: CPP, DeriveDataTypeable, ExistentialQuantification, FlexibleContexts, OverloadedStrings, ScopedTypeVariables, TemplateHaskell+ default-extensions: DeriveDataTypeable, ExistentialQuantification, FlexibleContexts, OverloadedStrings, ScopedTypeVariables, TemplateHaskell ghc-options: -Wall -fno-warn-unused-do-bind -threaded- cpp-options: -DVERSION="0.7"