kevin 0.9.0 → 0.10.0
raw patch · 37 files changed
+1567/−1504 lines, 37 filesdep +exceptionsdep ~HTTPdep ~lens
Dependencies added: exceptions
Dependency ranges changed: HTTP, lens
Files
- Kevin.hs +0/−2
- Kevin/Base.hs +0/−82
- Kevin/Chatrooms.hs +0/−67
- Kevin/Damn/Packet.hs +0/−96
- Kevin/Damn/Protocol.hs +0/−196
- Kevin/Damn/Protocol/Send.hs +0/−115
- Kevin/IRC/Packet.hs +0/−88
- Kevin/IRC/Protocol.hs +0/−164
- Kevin/IRC/Protocol/Send.hs +0/−129
- Kevin/Protocol.hs +0/−57
- Kevin/Settings.hs +0/−18
- Kevin/Types.hs +0/−95
- Kevin/Util/Entity.hs +0/−139
- Kevin/Util/Logger.hs +0/−59
- Kevin/Util/Tablump.hs +0/−76
- Kevin/Util/Token.hs +0/−76
- Kevin/Version.hs +0/−10
- Main.hs +0/−29
- kevin.cabal +14/−6
- src/Kevin.hs +2/−0
- src/Kevin/Base.hs +89/−0
- src/Kevin/Chatrooms.hs +67/−0
- src/Kevin/Damn/Packet.hs +99/−0
- src/Kevin/Damn/Protocol.hs +199/−0
- src/Kevin/Damn/Protocol/Send.hs +117/−0
- src/Kevin/IRC/Packet.hs +91/−0
- src/Kevin/IRC/Protocol.hs +166/−0
- src/Kevin/IRC/Protocol/Send.hs +131/−0
- src/Kevin/Protocol.hs +60/−0
- src/Kevin/Settings.hs +21/−0
- src/Kevin/Types.hs +112/−0
- src/Kevin/Util/Entity.hs +141/−0
- src/Kevin/Util/Logger.hs +61/−0
- src/Kevin/Util/Tablump.hs +76/−0
- src/Kevin/Util/Token.hs +82/−0
- src/Kevin/Version.hs +10/−0
- src/Main.hs +29/−0
− Kevin.hs
@@ -1,2 +0,0 @@-module Kevin (module Kevin.Protocol) where-import Kevin.Protocol
− Kevin/Base.hs
@@ -1,82 +0,0 @@-module Kevin.Base (- module Kevin.Types,- KevinException(..),- _KevinException,- KevinServer(..),- User(..),-- module K,-- io,- runPrinter,-- printf-) where--import Control.Applicative ((<$>))-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 Control.Monad.Reader as K-import qualified Data.ByteString.Char8 as T (hGetLine, hPutStr)-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--io :: MonadIO m => IO a -> m a-io = liftIO--class KevinServer a where- readClient, readServer :: a -> IO T.Text- writeServer :: a -> T.Text -> IO ()- writeClient :: a -> T.Text -> IO ()- closeClient, closeServer :: a -> IO ()--data KevinException = ParseFailure- deriving (Show, Typeable)--instance Exception KevinException--_KevinException :: Prism' SomeException KevinException-_KevinException = exception---- actions--hGetCharTimeout :: Handle -> Int -> IO Char-hGetCharTimeout h t = do hSetBuffering h NoBuffering- ready <- hWaitForInput h t- if ready- then hGetChar h- else throwIO $ mkIOError eofErrorType "read timeout" (Just h) Nothing--hGetSep :: Char -> Handle -> IO String-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 line <- T.decodeUtf8 <$> T.hGetLine (irc k)- return $ T.init line- readServer k = T.pack <$> hGetSep '\NUL' (damn k)-- writeClient k = writeChan (iChan k)- writeServer k = writeChan (dChan k)-- closeClient = hClose . irc- closeServer = hClose . damn
− Kevin/Chatrooms.hs
@@ -1,67 +0,0 @@-module Kevin.Chatrooms (- removeRoom,- - addUser,- setUsers,- removeUser,- removeUserAll,- numUsers,- - setPrivclasses,- getPrivclass,- getPrivclassLevel,- setUserPrivclass,- - setTitle-) where--import Control.Applicative-import Control.Lens-import Data.List-import qualified Data.Map as M-import Data.Maybe-import qualified Data.Text as T-import Kevin.Types--deleteBy' :: (a -> Bool) -> [a] -> [a]-deleteBy' f (x:xs) = if f x then xs else x:deleteBy' f xs-deleteBy' _ [] = []--removeRoom :: Chatroom -> KevinIO ()-removeRoom c = kevin $ privclasses.at c .= Nothing >> users.at c .= Nothing--addUser :: Chatroom -> User -> KevinIO ()-addUser ch us = kevin $ users.ix ch %= (us:)--numUsers :: Chatroom -> T.Text -> KevinIO Int-numUsers ch us = do st <- gets_ $ view users- case st^.at ch of Just usrs -> return . length $ findIndices (\u -> us == username u) usrs- Nothing -> return 0--removeUser :: Chatroom -> T.Text -> KevinIO ()-removeUser ch us = kevin $ users.ix ch %= deleteBy' ((== us) . username)--removeUserAll :: Chatroom -> T.Text -> KevinIO ()-removeUserAll ch us = kevin $ users.ix ch %= filter ((/= us) . username)--setUsers :: Chatroom -> [User] -> KevinIO ()-setUsers ch uss = kevin $ users.at ch ?= uss--setPrivclasses :: Chatroom -> [Privclass] -> KevinIO ()-setPrivclasses room ps = kevin $ privclasses.at room ?= M.fromList ps--getPrivclass :: Chatroom -> T.Text -> KevinIO (Maybe T.Text)-getPrivclass room user = do st <- gets_ $ view users- case st^.at room of Just qs -> return $ privclass <$> listToMaybe (filter ((== user) . username) qs)- Nothing -> return Nothing- -getPrivclassLevel :: Chatroom -> T.Text -> KevinIO Int-getPrivclassLevel room pc = do st <- gets_ $ view privclasses- return . fromMaybe 0 $ st^.at room >>= (^.at pc)--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})--setTitle :: Chatroom -> T.Text -> KevinIO ()-setTitle ch t = kevin $ titles.at ch ?= t
− Kevin/Damn/Packet.hs
@@ -1,96 +0,0 @@-module Kevin.Damn.Packet (- Packet(..),- command, parameter, args, body,- - parsePacket,- parsePrivclasses,- subPacket,- fixLoginPacket,- okay,- readable,- null_,- notNull_-) where--import Control.Applicative (many, (<$>), (<$))-import Control.Exception (throw)-import Control.Lens-import Control.Monad (guard, liftM2)-import Data.Attoparsec.Text-import Data.Char-import qualified Data.Map as M-import Data.Maybe-import Data.Monoid-import qualified Data.Text as T-import Kevin.Base (KevinException(..), Privclass)--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)--parseParam :: Parser (Maybe T.Text)-parseParam = do char ' '- parm <- takeWhile1 (not . isSpace)- return $ Just parm--parseArgs :: Parser (M.Map T.Text T.Text)-parseArgs = (M.fromList <$>) . many $ do char '\n'- c <- takeTill (=='=')- char '='- r <- takeTill (=='\n')- return (c,r)--parseHead :: Parser Packet-parseHead = do c <- parseCommand- p <- option Nothing parseParam- a <- parseArgs- return $ Packet c p a Nothing--parsePacket :: T.Text -> Packet-parsePacket pack = case parseOnly parseHead top of Left _ -> throw ParseFailure- Right res -> res & body .~ (T.drop 2 <$> toMaybe (not . T.null) b)- where (top, b) = T.breakOn "\n\n" pack--getResult :: Either String a -> a-getResult x = let Right e = x in e--fixLoginPacket :: Packet -> Packet-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 <$>) . view body--okay :: Packet -> Bool-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 ":") - . filter (not . T.null)- . T.splitOn "\n"--readable :: Packet -> T.Text-readable (Packet cmd param arg bod) = cmd <> maybe "" (' ' `T.cons`) param- <> formattedArgs (M.toList arg)- <> maybe "" ("\n\n" <>) bod- <> "\n\0"- where- formattedArgs [] = ""- formattedArgs q = ("\n" <>) . T.intercalate "\n" . map (uncurry (\x y -> x <> "=" <> y)) $ q
− Kevin/Damn/Protocol.hs
@@ -1,196 +0,0 @@-module Kevin.Damn.Protocol (- initialize,- cleanup,- listen,- errHandlers-) where--import Control.Applicative ((<$>))-import Control.Exception.Lens-import Data.List (delete, nub, minimumBy)-import Data.Maybe (fromJust, fromMaybe)-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 Kevin.Util.Entity-import Kevin.Util.Logger-import Kevin.Util.Tablump--initialize :: KevinIO ()-initialize = sendHandshake--cleanup :: KevinIO ()-cleanup = klog Blue "cleanup server"--listen :: KevinIO ()-listen = fix (\f -> flip catches errHandlers $ do k <- get_- pkt <- io $ parsePacket <$> readServer k- respond pkt (view command pkt)- f)---- main responder-respond :: Packet -> T.Text -> KevinIO ()-respond _ "dAmnServer" = do s <- use_ settings- sendLogin (s^.name) (s^.authtoken)--respond pkt "login" = if okay pkt- then do j <- kevin $ do loggedIn .= True- use joining- mapM_ sendJoin j- else I.sendNotice $ "Login failed: " <> pkt ^. args.ix "e"--respond pkt "join" = do 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, ": ", pkt^.args.ix "e"]--respond pkt "part" = do 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, ": ", 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-- "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 $ pkt^.body._Just)-- "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 $ pkt^.parameter._Just- rn = fixedPacket^.args.ix "realname"- conns = map (\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) . T.splitOn "\n\n" $ x^.body._Just- )) . tail . T.splitOn "conn" $ fixedPacket^.body._Just- allRooms = nub $ conns >>= (\(_,_,c) -> c)- (onlinespan,idle,_) = minimumBy (comparing (view _1)) conns- signon = curtime - onlinespan- I.sendWhoisReply us uname (entityDecode rn) allRooms idle signon-- q -> klogError $ "Unrecognized property " ++ T.unpack q--respond spk "recv" = deformatRoom (spk^.parameter._Just) >>=- \roomname -> case pkt^.command of "join" -> do let usname = pkt^.parameter._Just- pcs <- gets_ $ view privclasses- countUser <- numUsers roomname usname- let us = mkUser roomname pcs modifiedPkt- addUser roomname us- if countUser == 0- then do I.sendJoin usname roomname- pclevel <- getPrivclassLevel roomname $ modifiedPkt^.args.ix "pc"- I.sendSetUserMode usname roomname pclevel- else I.sendNoticeClone (username us) (succ countUser) roomname-- "part" -> do let uname = pkt^.parameter._Just- removeUser roomname uname- countUser <- numUsers roomname uname- if countUser < 1- then I.sendPart uname roomname $ pkt^.args.at "r"- else I.sendNoticeUnclone uname countUser roomname-- "msg" -> do let uname = arg "from"- msg = pkt^.body._Just- un <- use_ name- 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)-- "privchg" -> do 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 "" (" from " <>) oldPc- , " to ", newPc, " by ", by- ]- I.sendChangeUserMode user roomname oldPcLevel newPcLevel-- "kicked" -> do let uname = pkt^.parameter._Just- removeUserAll roomname uname- I.sendKick uname (arg "by") roomname $ pkt^.body.traverse ^? notNull_-- "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: " <> arg "e"- q -> klogError $ "Unknown admin packet type " ++ show q-- x -> klogError $ "Unknown packet type " ++ show x-- where pkt = fromJust $ subPacket spk- modifiedPkt = parsePacket (T.replace "\n\npc" "\npc" $ readable pkt)- arg s = pkt^.args.ix s--respond pkt "kicked" = do roomname <- deformatRoom $ pkt^.parameter._Just- uname <- use_ name- removeRoom roomname- I.sendKick uname (pkt^.args.ix "by") roomname $ pkt^.body.traverse ^? notNull_--respond pkt "send" = I.sendNotice $ "Send error: " <> pkt^.args.ix "e"--respond _ "ping" = get_ >>= \k -> io . writeServer k $ ("pong\n\0" :: T.Text)--respond _ str = klog Yellow $ "Got the packet called " ++ T.unpack str---mkUser :: Chatroom -> PrivclassStore -> Packet -> User-mkUser room st p = User (p^.parameter._Just)- (g "pc")- (fromMaybe 0 $ st^.at room >>= (^.at (g "pc")))- (g "symbol")- (entityDecode $ g "realname")- (g "typename")- (g "gpc")- where g s = p^.args.ix s--errHandlers :: [Handler KevinIO ()]-errHandlers = [ handler_ _KevinException $ klogError "Malformed communication from server"- , handler _IOException (\e -> klogError $ "server: " ++ show e) ]
− Kevin/Damn/Protocol/Send.hs
@@ -1,115 +0,0 @@-module Kevin.Damn.Protocol.Send (- sendPacket,- formatRoom,- deformatRoom,-- sendHandshake,- sendLogin,- sendJoin,- sendPart,- sendMsg,- sendAction,- sendNpMsg,- sendPromote,- sendDemote,- sendBan,- sendUnban,- sendKick,- sendGet,- sendWhois,- sendSet,- sendAdmin,- sendKill-) where--import Data.Char (toLower)-import Data.List (sort)-import Data.Monoid-import qualified Data.Text as T-import Kevin.Base-import Kevin.Version--maybeBody :: Maybe T.Text -> T.Text-maybeBody = maybe "" ("\n\n" <>)--sendPacket :: T.Text -> KevinIO ()-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:" <> s- ("&",s) -> do uname <- use_ name- return . ("pchat:" <>) . T.intercalate ":" . sort . map (T.map toLower) $ [uname, s]- 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))--type Str = T.Text -- just make it shorter-type Room = Str-type Username = Str-type Pc = Str---- * Communication to the server-sendHandshake :: KevinIO ()-sendLogin :: Username -> Str -> KevinIO ()-sendJoin, sendPart :: Room -> KevinIO ()-sendMsg, sendAction, sendNpMsg :: Room -> Str -> KevinIO ()-sendPromote, sendDemote :: Room -> Username -> Maybe Pc -> KevinIO ()-sendBan, sendUnban :: Room -> Username -> KevinIO ()-sendKick :: Room -> Username -> Maybe Str -> KevinIO ()-sendGet :: Room -> Str -> KevinIO ()-sendWhois :: Username -> KevinIO ()-sendSet :: Room -> Str -> Str -> KevinIO ()-sendAdmin :: Room -> Str -> KevinIO ()-sendKill :: Username -> Str -> KevinIO ()--sendHandshake = sendPacket $ printf "dAmnClient 0.3\nagent=kevin%s\n" [versionStr]--sendLogin u token = sendPacket $ printf "login %s\npk=%s\n" [u, token]--sendJoin room = do roomname <- formatRoom room- sendPacket $ printf "join %s\n" [roomname]--sendPart room = do roomname <- formatRoom room- sendPacket $ printf "part %s\n" [roomname]--sendMsg = sendNpMsg--sendAction room msg = do roomname <- formatRoom room- sendPacket $ printf "send %s\n\naction main\n\n%s" [roomname, msg]--sendNpMsg room msg = do roomname <- formatRoom room- sendPacket $ printf "send %s\n\nnpmsg main\n\n%s" [roomname, msg]--sendPromote room us pc = do roomname <- formatRoom room- sendPacket $ printf "send %s\n\npromote %s%s" [roomname, us, maybeBody pc]--sendDemote room us pc = do roomname <- formatRoom room- sendPacket $ printf "send %s\n\ndemote %s%s" [roomname, us, maybeBody pc]--sendBan room us = do roomname <- formatRoom room- sendPacket $ printf "send %s\n\nban %s\n\n" [roomname, us]--sendUnban room us = do roomname <- formatRoom room- sendPacket $ printf "send %s\n\nunban %s\n\n" [roomname, us]--sendKick room us reason = do roomname <- formatRoom room- 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]--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]--sendAdmin room cmd = do roomname <- formatRoom room- sendPacket $ printf "send %s\n\nadmin\n\n%s" [roomname, cmd]--sendKill = undefined
− Kevin/IRC/Packet.hs
@@ -1,88 +0,0 @@-module Kevin.IRC.Packet (- Packet(..),- prefix, command, params,- - parsePacket,- readable-) where--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)--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"--spaces :: Parser T.Text-spaces = takeWhile1 isSpace--servername :: Parser T.Text-servername = takeWhile1 (inClass "a-z0-9.-")--username :: Parser T.Text-username = do n <- nick- u <- option "" (T.cons <$> char '!' <*> user)- h <- option "" (T.cons <$> char '@' <*> servername)- return $ T.concat [n, u, h]--nick :: Parser T.Text-nick = T.cons <$> letter <*> takeWhile (inClass "a-zA-Z0-9[]\\`^{}-")--user :: Parser T.Text-user = takeWhile1 (notInClass badChars)--parsePrefix :: Parser T.Text-parsePrefix = username <|> servername--parseCommand :: Parser T.Text-parseCommand = takeWhile1 isAlpha <|> liftM3 (\a b c -> T.pack [a,b,c]) digit digit digit--parseParams :: Parser [T.Text]-parseParams = (colonParam <|> nonColonParam) `sepBy` spaces--colonParam :: Parser T.Text-colonParam = char ':' *> takeWhile (notInClass "\x0\xd\xa")--nonColonParam :: Parser T.Text-nonColonParam = takeWhile (notInClass badChars)--crlf :: Parser T.Text-crlf = string "\r\n"--messageBegin :: Parser (Maybe T.Text)-messageBegin = Just <$> (char ':' *> parsePrefix <* spaces)--packetParser :: Parser Packet-packetParser = do pr <- option Nothing messageBegin- cmd <- T.map toUpper <$> parseCommand- spaces- par <- filter (not . T.null) <$> parseParams- option "" crlf- return $ Packet pr cmd par--parsePacket :: T.Text -> Packet-parsePacket str = case parseOnly packetParser str of Left _ -> BadPacket- Right p -> p--showParams :: [T.Text] -> T.Text-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) = (<> "\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
@@ -1,164 +0,0 @@-module Kevin.IRC.Protocol (- cleanup,- listen,- errHandlers,- getAuthInfo-) where--import Control.Applicative ((<$>))-import Control.Arrow-import Control.Exception.Lens-import Control.Monad.State-import Data.Function (on)-import Data.List (nubBy)-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-import Kevin.Version--type KevinState = StateT Settings IO--cleanup :: KevinIO ()-cleanup = klog Green "cleanup client"--listen :: KevinIO ()-listen = fix (\f -> flip catches errHandlers $ do k <- get_- pkt <- io $ parsePacket <$> readClient k- respond pkt (view command pkt)- f)--respond :: Packet -> T.Text -> KevinIO ()-respond BadPacket _ = sendNotice "Bad packet, try again."-respond pkt "JOIN" = do l <- gets_ (view loggedIn)- if l- then mapM_ D.sendJoin rooms- else kevin $ joining %= (rooms ++)- where rooms = T.splitOn "," $ pkt^.params._head--respond pkt "PART" = mapM_ D.sendPart . T.splitOn "," $ pkt^.params._head--respond pkt "PRIVMSG" = do 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 (pkt^.params) > 1- then do let (toggle,mode) = first (=="+") . T.splitAt 1 $ pkt^.params.ix 1- case mode of "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 (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--respond pkt "TITLE" = case pkt^.params of [] -> 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--respond pkt "WHOIS" = D.sendWhois $ pkt^.params._head--respond pkt "NAMES" = do let room = pkt^.params._head- k <- get_- sendUserList (k^.name) (nubBy ((==) `on` username) (k^.users.ix room)) room--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" = 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- (room:_) -> sendRoomNotice room "Usage: /promote #room username group"- _ -> sendNotice "Usage: /promote #room username group"--respond _ str = klogError $ T.unpack str---unmask :: T.Text -> Maybe T.Text-unmask y = case T.split (`elem` "@!") y of [s] -> Just s- xs -> listToMaybe $ filter (not . T.isInfixOf "*") xs--errHandlers :: [Handler KevinIO ()]-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 = do klogNow Blue ("client -> " ++ T.unpack asStr)- T.hPutStr h (asStr <> "\r\n")- where asStr = printf "NOTICE AUTH :%s" [str]--getAuthInfo :: Handle -> Bool -> KevinState ()-getAuthInfo handle = fix (\f authRetry -> do pkt <- io $ parsePacket <$> T.hGetLine handle- io $ klogNow Yellow $ "client <- " ++ T.unpack (readable pkt)- case pkt^.command of "PASS" -> do password .= pkt^.params._head- passed .= True- "NICK" -> do name .= pkt^.params._head- nicked .= True- "USER" -> usered .= True- _ -> io $ klogNow Red $ "invalid packet: " ++ show pkt- if authRetry- then checkToken handle- else do p <- use passed- n <- use nicked- u <- use usered- if p && n && u- then welcome handle- else f False)--welcome :: Handle -> KevinState ()-welcome handle = do nick <- use name- 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 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 hostname = "chat.deviantart.com"--checkToken :: Handle -> KevinState ()-checkToken handle = do s <- get- io $ notice handle "Fetching token..."- tok <- io $ getToken (s^.name) (s^.password)- case tok of Just t -> do authtoken .= t- io $ notice handle "Successfully authenticated."- Nothing -> do io $ notice handle "Bad password, try again. (/quote pass yourpassword)"- getAuthInfo handle True
− Kevin/IRC/Protocol/Send.hs
@@ -1,129 +0,0 @@-module Kevin.IRC.Protocol.Send (- sendJoin,- sendPart,- sendSetUserMode,- sendChangeUserMode,- sendNotice,- sendRoomNotice,- sendChanMsg,- sendChanAction,- sendKick,- sendTopic,- sendChanMode,- sendUserList,- sendPong,- sendNoticeClone,- sendNoticeUnclone,- sendWhoisReply-) where--import Data.Monoid-import qualified Data.Text as T-import Kevin.Base--hostname :: T.Text-hostname = ":chat.deviantart.com"--getHost :: T.Text -> T.Text-getHost u = T.concat [":", u, "!", u, "@chat.deviantart.com"]--sendPacket :: T.Text -> KevinIO ()-sendPacket p = get_ >>= \k -> io . writeClient k $ p <> "\r\n"--maybeBody :: Maybe T.Text -> T.Text-maybeBody = maybe "" (" :" <>)--type Str = T.Text-type Room = Str-type Username = Str--sendJoin :: Username -> Room -> KevinIO ()-sendPart :: Username -> Room -> Maybe Str -> KevinIO ()-sendSetUserMode :: Username -> Room -> Int -> KevinIO ()-sendChangeUserMode :: Username -> Room -> Int -> Int -> KevinIO ()-sendNotice :: Str -> KevinIO ()-sendRoomNotice :: Room -> Str -> KevinIO ()-sendChanMsg, sendChanAction :: Username -> Room -> Str -> KevinIO ()-sendKick :: Username -> Username -> Room -> Maybe Str -> KevinIO ()-sendTopic :: Username -> Room -> Username -> Str -> Str -> KevinIO ()-sendChanMode :: Username -> Room -> KevinIO ()-sendUserList :: Username -> [User] -> Room -> KevinIO ()-sendPong :: T.Text -> KevinIO ()-sendNoticeClone :: Username -> Int -> Room -> KevinIO ()-sendNoticeUnclone :: Username -> Int -> Room -> KevinIO ()-sendWhoisReply :: Username -> Username -> Username -> [Room] -> Int -> Int -> KevinIO ()--sendJoin us rm = sendPacket $ printf "%s JOIN :%s" [getHost us, rm]--sendPart us rm msg = sendPacket $ printf "%s PART %s%s" [getHost us, rm, maybeBody msg]--sendSetUserMode us rm m = unless (T.null mode) $ sendPacket $ printf "%s MODE %s +%s %s" [hostname, rm, mode, us]- where mode = levelToMode m--sendChangeUserMode us rm old new = unless (oldMode == newMode) $ sendPacket $ printf "%s MODE %s %s" [hostname, rm, modesAndUser]- where oldMode = levelToMode old- newMode = levelToMode new- modesAndUser = case (oldMode, newMode) of ("", "") -> T.concat ["-v ", us]- ("", _) -> T.concat ["+", newMode, " ", us]- (_, "") -> T.concat ["-", oldMode, " ", us]- (a, b) -> T.concat ["-", a, "+", b, " ", us, " ", us]---sendNotice = sendPacket . printf "NOTICE AUTH :%s" . return--sendRoomNotice 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]) . T.splitOn "\n" $ msg--sendKick kickee kicker room 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]--sendChanMode us rm = do sendPacket $ printf "%s 324 %s %s +t" [hostname, us, rm]- sendPacket $ printf "%s 329 %s %s 767529000" [hostname, us, rm]--sendUserList us uss rm = do mapM_ (\nms -> 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- 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)--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]--sendNoticeUnclone uname i rm = 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) <> " 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 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 318 %s %s :End of /WHOIS list." [hostname, me, us]--levelToSym :: Int -> T.Text-levelToSym x | x > 0 && x <= 35 = ""- | x > 35 && x <= 70 = "+"- | x > 70 && x < 99 = "@"- | x == 99 = "~"- | otherwise = ""--levelToMode :: Int -> T.Text-levelToMode x = case levelToSym x of "" -> ""- "+" -> "v"- "@" -> "o"- "~" -> "q"- _ -> error "levelToSym, what are you doing"
− Kevin/Protocol.hs
@@ -1,57 +0,0 @@-module Kevin.Protocol (kevinServer) where--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--watchInterrupt :: [Handler IO (Maybe Kevin)]-watchInterrupt = [ handler _AsyncException throw- , handler_ id (return Nothing) ]--mkKevin :: Socket -> IO (Maybe Kevin)-mkKevin sock = flip catches watchInterrupt . withSocketsDo- $ do (client, _, _) <- accept sock- hSetBuffering client NoBuffering- klogNow Blue "received a client"- s <- execStateT (C.getAuthInfo client False) def- damnSock <- connectTo "chat.deviantart.com" $ PortNumber 3900- hSetBuffering damnSock NoBuffering- logChan <- newChan- damnChan <- newChan- ircChan <- newChan- return . Just $ Kevin damnSock- client- damnChan- ircChan- s- mempty- mempty- mempty- mempty- False- logChan--mkListener :: Int -> IO Socket-mkListener = listenOn . PortNumber . fromIntegral--kevinServer :: Int -> IO ()-kevinServer n = do sock <- mkListener n- putStrLn $ "Listening on port " ++ show n- forever $ do kev <- mkKevin sock- case kev of Just k -> listen k- Nothing -> return ()--listen :: Kevin -> IO ()-listen k = do mvar <- newTVarIO k- 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- return ()
− Kevin/Settings.hs
@@ -1,18 +0,0 @@-module Kevin.Settings where--import Control.Lens-import Data.Default-import Data.Text--data Settings = Settings { _name :: Text- , _password :: Text- , _authtoken :: Text- , _passed :: Bool- , _nicked :: Bool- , _usered :: Bool- } deriving (Show)--makeClassy ''Settings--instance Default Settings where- def = Settings "" "" "" False False False
− Kevin/Types.hs
@@ -1,95 +0,0 @@-module Kevin.Types (- Kevin(Kevin, damn, irc, dChan, iChan, logger),- KevinIO,- KevinS,- Privclass,- Chatroom,- User(..),- Title,- PrivclassStore,- UserStore,- TitleStore,- kevin,- use_,- get_,- gets_,-- -- lenses- users, privclasses, titles, joining, loggedIn,-- -- other accessors- settings,- - if'-) where--import Control.Concurrent-import Control.Concurrent.STM.TVar-import Control.Lens-import Control.Monad.Reader-import Control.Monad.STM (STM, atomically)-import Control.Monad.State-import qualified Data.Map as M-import qualified Data.Text as T-import Kevin.Settings-import System.IO--if' :: Bool -> a -> a -> a-if' x y z = if x then y else z--type Chatroom = T.Text--data User = User { username :: T.Text- , privclass :: T.Text- , privclassLevel :: Int- , symbol :: T.Text- , realname :: T.Text- , typename :: T.Text- , gpc :: T.Text- } deriving (Eq, Show)--type UserStore = M.Map Chatroom [User]--type Privclasses = M.Map T.Text Int-type PrivclassStore = M.Map Chatroom Privclasses-type Privclass = (T.Text, Int)--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- , _kevinSettings :: Settings- , _users :: UserStore- , _privclasses :: PrivclassStore- , _titles :: TitleStore- , _joining :: [T.Text]- , _loggedIn :: Bool- , logger :: Chan String- }--makeLenses ''Kevin--instance HasSettings Kevin where- settings = kevinSettings--type KevinS = StateT Kevin STM--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--type KevinIO = ReaderT (TVar Kevin) IO--use_ :: Getting a Kevin a -> KevinIO a-use_ = gets_ . view--get_ :: KevinIO Kevin-get_ = ask >>= liftIO . readTVarIO--gets_ :: (Kevin -> a) -> KevinIO a-gets_ = flip liftM get_
− Kevin/Util/Entity.hs
@@ -1,139 +0,0 @@-module Kevin.Util.Entity (- entityEncode,- entityDecode-) where--import Control.Applicative ((<|>), (<$>), (<*>))-import Control.Monad (guard)-import Control.Monad.Fix-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)--decodeCharacter :: Parser T.Text-decodeCharacter = entityNumeric <|> entityNamed <|> take 1--entityNumeric :: Parser T.Text-entityNumeric = do string "&#"- entity <- (<>) <$> option "" (string "x") <*> takeWhile1 isHexDigit- char ';'- return . fromMaybe (T.concat ["&#", entity, ";"]) $ (if "x" `T.isPrefixOf` entity - then lookupHexEntity- else lookupNumericEntity) entity--entityNamed :: Parser T.Text-entityNamed = do char '&'- entity <- T.cons <$> letter <*> takeWhile1 isAlphaNum- char ';'- return . fromMaybe (T.concat ["&", entity, ";"]) . lookupNamedEntity $ entity--decodeParser :: Parser T.Text-decodeParser = T.concat <$> many1 decodeCharacter--entityDecode :: T.Text -> T.Text-entityDecode "" = ""-entityDecode str = case parseOnly decodeParser str of Left err -> error $ "entityDecode: " ++ err- Right s -> s--entityEncode :: T.Text -> T.Text-entityEncode = T.pack . concat . entityEncodeS . T.unpack--entityEncodeS :: String -> [String]-entityEncodeS = fix (\f str -> case str of [] -> []- (x:xs) -> if x < '\127'- then [x]:f xs- else ("&#" ++ show (ord x) ++ ";"):f xs)--lookupNamedEntity :: T.Text -> Maybe T.Text-lookupNamedEntity ent = (T.singleton . chr) <$> lookup ent namedEntities--lookupHexEntity :: T.Text -> Maybe T.Text-lookupHexEntity e = case R.hexadecimal $ T.cons '0' e of Right (n,_) -> do guard $ n < ord maxBound- return . T.singleton . chr $ n- Left _ -> Nothing--lookupNumericEntity :: T.Text -> Maybe T.Text-lookupNumericEntity e = case R.decimal e of Right (n,_) -> do guard $ n < ord maxBound- return . T.singleton . chr $ n- 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)]
− Kevin/Util/Logger.hs
@@ -1,59 +0,0 @@-module Kevin.Util.Logger (- klog,- klog_,- klogNow,- klogError,- klogWarn,- Color(..),- runLogger,- printf-) where--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--colorAsNum :: Color -> Int-colorAsNum Red = 31-colorAsNum Green = 32-colorAsNum Yellow = 33-colorAsNum Blue = 34-colorAsNum Magenta = 35-colorAsNum Cyan = 36-colorAsNum Gray = 37--runLogger :: Chan String -> IO ()-runLogger ch = void . forkIO . forever $ readChan ch >>= putStrLn--interleave :: [a] -> [a] -> [a]-interleave xs [] = xs-interleave [] ys = ys-interleave (x:xs) (y:ys) = x:y:interleave xs ys--printf :: T.Text -> [T.Text] -> T.Text-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"- where- 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--klogNow :: Color -> String -> IO ()-klogNow c s = putStrLn $ render c s--klog :: Color -> String -> KevinIO ()-klog c str = gets_ logger >>= \ch -> liftIO $ klog_ ch c str--klogError, klogWarn :: String -> KevinIO ()--klogError = klog Red . ("ERROR :: " ++)-klogWarn = klog Yellow . ("WARNING :: " ++)
− Kevin/Util/Tablump.hs
@@ -1,76 +0,0 @@-{-# OPTIONS_GHC -fno-warn-incomplete-patterns #-}--module Kevin.Util.Tablump (- tablumpDecode-) where--import Control.Arrow-import Control.Monad.Fix-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-fromRight (Right a) = a--{-# 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)--{-# NOINLINE regexen #-}-regexen :: [(Regex, [String] -> String)]-regexen = let ($$) = (,) in map (- first (fromRight . unsafePerformIO- . compile defaultCompOpt defaultExecOpt)- ) . reverse $ [- "&b\t" $$ const "\2",- "&/b\t" $$ const "\15",- "&i\t" $$ const "\22",- "&/i\t" $$ const "\15",- "&u\t" $$ const "\31",- "&/u\t" $$ const "\15",- "&s\t" $$ const "<s>",- "&/s\t" $$ const "</s>",- "&sup\t" $$ const "",- "&/sup\t" $$ const "",- "&sub\t" $$ const "",- "&/sub\t" $$ const "",- "&code\t" $$ const "",- "&/code\t" $$ const "",- "&br\t" $$ const "\n",- "&ul\t" $$ const "",- "&/ul\t" $$ const "",- "&ol\t" $$ const "",- "&/ol\t" $$ const "",- "&li\t" $$ const "- ",- "&/li\t" $$ const "\n",- "&bcode\t" $$ const "",- "&/bcode\t" $$ const "",- "&/a\t" $$ const ")",- "&/acro\t" $$ const "</acronym>",- "&/abbr\t" $$ const "</abbr>",- "&p\t" $$ const "",- "&/p\t" $$ const "\n",- "&emote\t(.+?)\t.+?\t.+?\t.+?\t.+?\t" $$ head,- "&a\t(.+?)\t.*?\t" $$ \(x:_) -> printf "%s (" x,- "&link\t(.+?)\t&\t" $$ head,- "&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" $$ \(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='(.+?)'>.+?</abbr>:" $$ \(x:_) -> printf "%s:" x,- "^[a-zA-Z0-9\\-_]+<abbr title='(.+?)'></abbr>:" $$ \(x:_) -> printf "%s:" x- ]--tablumpDecode :: T.Text -> T.Text-tablumpDecode = T.pack . flip (foldr (uncurry regexReplace)) regexen . T.unpack
− Kevin/Util/Token.hs
@@ -1,76 +0,0 @@-module Kevin.Util.Token (- getToken-) where--import Control.Arrow-import Crypto.Random.AESCtr (makeSystem)-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-import Network.TLS-import Network.TLS.Extra-import Text.Printf--recvUntil :: TLSCtx -> B.ByteString -> IO B.ByteString-recvUntil ctx str = do line <- recvData ctx- if str `B.isInfixOf` line- then return line- else fmap (line <>) $ recvUntil ctx str--concatHeaders :: [(String,String)] -> String-concatHeaders = intercalate "\r\n" . map (\(x,y) -> x ++ ": " ++ y)--scrapeFormValue :: String -> B.ByteString -> B.ByteString-scrapeFormValue key bs = B.takeWhile (/='"') . B.drop 7 . head- . filter (\l -> "value=" `B.isPrefixOf` l) . B.words . head- . filter (\l -> B.pack key `B.isInfixOf` l) . B.lines $ bs--scrapeCookies :: B.ByteString -> B.ByteString-scrapeCookies bs = B.intercalate ";" . map snd- . filter ((== "Set-Cookie") . fst)- . map (second (B.drop 2 . B.takeWhile (/=';'))- . B.breakSubstring ": ")- . B.lines $ bs--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"] }- headers :: [(String, String)]- headers = [("Connection", "closed"), ("Content-Type", "application/x-www-form-urlencoded")]- gen <- makeSystem- ctv <- connectionClient "www.deviantart.com" "443" params gen- handshake ctv- sendData ctv . LB.pack $ "GET /users/login HTTP/1.1\r\nHost: www.deviantart.com\r\n\r\n"- bl <- recvUntil ctv "validate_key"- bye ctv-- let payload = urlEncodeVars [ ("username", T.unpack uname)- , ("password", T.unpack pass)- , ("validate_token", B.unpack (scrapeFormValue "validate_token" bl))- , ("validate_key", B.unpack (scrapeFormValue "validate_key" bl))- , ("remember_me","1")- ]- ctx <- connectionClient "www.deviantart.com" "443" params gen- handshake ctx- sendData ctx . LB.pack $ printf "POST /users/login HTTP/1.1\r\n%s\r\n\- \cookie: %s\r\nContent-Length: %d\r\n\r\n%s"- (concatHeaders $ ("Host", "www.deviantart.com"):headers)- (B.unpack (scrapeCookies bl))- (length payload)- payload- bs <- recvData ctx- if "wrong-password" `B.isInfixOf` bs- then return Nothing- else do let 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 (scrapeCookies bs))- 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
− Kevin/Version.hs
@@ -1,10 +0,0 @@-module Kevin.Version (showVersion, version, versionStr) where--import Data.Text (Text, pack)-import Data.Version--version :: Version-version = Version [0,8] []--versionStr :: Text-versionStr = pack $ showVersion version
− Main.hs
@@ -1,29 +0,0 @@-import Kevin-import Kevin.Version-import System.Console.GetOpt-import System.Environment--defaultPort :: Int-defaultPort = 6669--data Flag = Port Int | Version | Help deriving (Eq)--opts :: [OptDescr Flag]-opts = [ 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" ]--header :: String-header = "Usage: kevin [options...]"--getPort :: [Flag] -> Int-getPort (Port x:_) = x-getPort (_:xs) = getPort xs-getPort [] = defaultPort--main :: IO ()-main = do args <- getArgs- case getOpt Permute opts args of (flags, _, []) -> case flags of f | Help `elem` f -> putStrLn $ usageInfo header opts- | Version `elem` f -> putStrLn $ "kevin version " ++ showVersion version- | otherwise -> kevinServer $ getPort flags- (_, _, msgs@(_:_)) -> putStrLn $ concat msgs ++ usageInfo header opts
kevin.cabal view
@@ -1,14 +1,15 @@ Name: kevin-Version: 0.9.0+Version: 0.10.0 Synopsis: a dAmn ↔ IRC proxy Description: a dAmn ↔ IRC proxy License: GPL License-file: LICENSE Author: Joel Taylor-Maintainer: joel@otte.rs+Maintainer: me@joelt.io Build-Type: Simple Cabal-Version: >=1.10 Category: Utils+Tested-With: GHC == 7.4.2, GHC == 7.6.3, GHC == 7.7.20130828 source-repository head type: git@@ -25,9 +26,8 @@ containers, cprng-aes, data-default,- HTTP,- lens,- MonadCatchIO-transformers,+ HTTP >= 4000.2,+ lens >= 3.9, mtl, network, regex-pcre-builtin,@@ -37,6 +37,13 @@ tls, tls-extra + if impl(ghc>=7.7)+ Build-Depends: exceptions,+ lens >= 3.10++ if impl(ghc<7.7)+ Build-Depends: MonadCatchIO-transformers+ Other-Modules: Kevin, Kevin.Base, Kevin.Chatrooms,@@ -55,5 +62,6 @@ Kevin.Util.Token, Kevin.Version - default-extensions: DeriveDataTypeable, ExistentialQuantification, FlexibleContexts, OverloadedStrings, ScopedTypeVariables, TemplateHaskell ghc-options: -Wall -fno-warn-unused-do-bind -threaded++ hs-source-dirs: src
+ src/Kevin.hs view
@@ -0,0 +1,2 @@+module Kevin (module Kevin.Protocol) where+import Kevin.Protocol
+ src/Kevin/Base.hs view
@@ -0,0 +1,89 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveDataTypeable #-}++module Kevin.Base (+ module Kevin.Types,+ KevinException(..),+ _KevinException,+ KevinServer(..),+ User(..),++ module K,++ io,+ runPrinter,++ printf+) where++import Control.Applicative ((<$>))+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+#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 707+import Control.Monad.Catch as K+#else+import Control.Monad.CatchIO as K+#endif+import Control.Monad.Reader as K+import qualified Data.ByteString.Char8 as T (hGetLine, hPutStr)+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++io :: MonadIO m => IO a -> m a+io = liftIO++class KevinServer a where+ readClient, readServer :: a -> IO T.Text+ writeServer :: a -> T.Text -> IO ()+ writeClient :: a -> T.Text -> IO ()+ closeClient, closeServer :: a -> IO ()++data KevinException = ParseFailure+ deriving (Show, Typeable)++instance Exception KevinException++_KevinException :: Prism' SomeException KevinException+_KevinException = exception++-- actions++hGetCharTimeout :: Handle -> Int -> IO Char+hGetCharTimeout h t = do hSetBuffering h NoBuffering+ ready <- hWaitForInput h t+ if ready+ then hGetChar h+ else throwIO $ mkIOError eofErrorType "read timeout" (Just h) Nothing++hGetSep :: Char -> Handle -> IO String+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 line <- T.decodeUtf8 <$> T.hGetLine (irc k)+ return $ T.init line+ readServer k = T.pack <$> hGetSep '\NUL' (damn k)++ writeClient k = writeChan (iChan k)+ writeServer k = writeChan (dChan k)++ closeClient = hClose . irc+ closeServer = hClose . damn
+ src/Kevin/Chatrooms.hs view
@@ -0,0 +1,67 @@+module Kevin.Chatrooms (+ removeRoom,+ + addUser,+ setUsers,+ removeUser,+ removeUserAll,+ numUsers,+ + setPrivclasses,+ getPrivclass,+ getPrivclassLevel,+ setUserPrivclass,+ + setTitle+) where++import Control.Applicative+import Control.Lens+import Data.List+import qualified Data.Map as M+import Data.Maybe+import qualified Data.Text as T+import Kevin.Types++deleteBy' :: (a -> Bool) -> [a] -> [a]+deleteBy' f (x:xs) = if f x then xs else x:deleteBy' f xs+deleteBy' _ [] = []++removeRoom :: Chatroom -> KevinIO ()+removeRoom c = kevin $ privclasses.at c .= Nothing >> users.at c .= Nothing++addUser :: Chatroom -> User -> KevinIO ()+addUser ch us = kevin $ users.ix ch %= (us:)++numUsers :: Chatroom -> T.Text -> KevinIO Int+numUsers ch us = do st <- gets_ $ view users+ case st^.at ch of Just usrs -> return . length $ findIndices (\u -> us == username u) usrs+ Nothing -> return 0++removeUser :: Chatroom -> T.Text -> KevinIO ()+removeUser ch us = kevin $ users.ix ch %= deleteBy' ((== us) . username)++removeUserAll :: Chatroom -> T.Text -> KevinIO ()+removeUserAll ch us = kevin $ users.ix ch %= filter ((/= us) . username)++setUsers :: Chatroom -> [User] -> KevinIO ()+setUsers ch uss = kevin $ users.at ch ?= uss++setPrivclasses :: Chatroom -> [Privclass] -> KevinIO ()+setPrivclasses room ps = kevin $ privclasses.at room ?= M.fromList ps++getPrivclass :: Chatroom -> T.Text -> KevinIO (Maybe T.Text)+getPrivclass room user = do st <- gets_ $ view users+ case st^.at room of Just qs -> return $ privclass <$> listToMaybe (filter ((== user) . username) qs)+ Nothing -> return Nothing+ +getPrivclassLevel :: Chatroom -> T.Text -> KevinIO Int+getPrivclassLevel room pc = do st <- gets_ $ view privclasses+ return . fromMaybe 0 $ st^.at room >>= (^.at pc)++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})++setTitle :: Chatroom -> T.Text -> KevinIO ()+setTitle ch t = kevin $ titles.at ch ?= t
+ src/Kevin/Damn/Packet.hs view
@@ -0,0 +1,99 @@+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE OverloadedStrings #-}++module Kevin.Damn.Packet (+ Packet(..),+ command, parameter, args, body,++ parsePacket,+ parsePrivclasses,+ subPacket,+ fixLoginPacket,+ okay,+ readable,+ null_,+ notNull_+) where++import Control.Applicative (many, (<$>), (<$))+import Control.Exception (throw)+import Control.Lens+import Control.Monad (guard, liftM2)+import Data.Attoparsec.Text+import Data.Char+import qualified Data.Map as M+import Data.Maybe+import Data.Monoid+import qualified Data.Text as T+import Kevin.Base (KevinException(..), Privclass)++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)++parseParam :: Parser (Maybe T.Text)+parseParam = do char ' '+ parm <- takeWhile1 (not . isSpace)+ return $ Just parm++parseArgs :: Parser (M.Map T.Text T.Text)+parseArgs = (M.fromList <$>) . many $ do char '\n'+ c <- takeTill (=='=')+ char '='+ r <- takeTill (=='\n')+ return (c,r)++parseHead :: Parser Packet+parseHead = do c <- parseCommand+ p <- option Nothing parseParam+ a <- parseArgs+ return $ Packet c p a Nothing++parsePacket :: T.Text -> Packet+parsePacket pack = case parseOnly parseHead top of Left _ -> throw ParseFailure+ Right res -> res & body .~ (T.drop 2 <$> toMaybe (not . T.null) b)+ where (top, b) = T.breakOn "\n\n" pack++getResult :: Either String a -> a+getResult x = let Right e = x in e++fixLoginPacket :: Packet -> Packet+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 <$>) . view body++okay :: Packet -> Bool+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 ":")+ . filter (not . T.null)+ . T.splitOn "\n"++readable :: Packet -> T.Text+readable (Packet cmd param arg bod) = cmd <> maybe "" (' ' `T.cons`) param+ <> formattedArgs (M.toList arg)+ <> maybe "" ("\n\n" <>) bod+ <> "\n\0"+ where+ formattedArgs [] = ""+ formattedArgs q = ("\n" <>) . T.intercalate "\n" . map (uncurry (\x y -> x <> "=" <> y)) $ q
+ src/Kevin/Damn/Protocol.hs view
@@ -0,0 +1,199 @@+{-# LANGUAGE OverloadedStrings #-}++module Kevin.Damn.Protocol (+ initialize,+ cleanup,+ listen,+ errHandlers+) where++import Control.Applicative ((<$>))+import Control.Exception.Lens+import Data.List (delete, nub, minimumBy)+import Data.Maybe (fromJust, fromMaybe)+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 Kevin.Util.Entity+import Kevin.Util.Logger+import Kevin.Util.Tablump++initialize :: KevinIO ()+initialize = sendHandshake++cleanup :: KevinIO ()+cleanup = klog Blue "cleanup server"++listen :: KevinIO ()+listen = fix (\f -> flip catches errHandlers $ do+ k <- get_+ pkt <- io $ parsePacket <$> readServer k+ respond pkt (view command pkt)+ f)++-- main responder+respond :: Packet -> T.Text -> KevinIO ()+respond _ "dAmnServer" = do s <- use_ settings+ sendLogin (s^.name) (s^.authtoken)++respond pkt "login" = if okay pkt+ then do j <- kevin $ do loggedIn .= True+ use joining+ mapM_ sendJoin j+ else I.sendNotice $ "Login failed: " <> pkt ^. args.ix "e"++respond pkt "join" = do 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, ": ", pkt^.args.ix "e"]++respond pkt "part" = do 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, ": ", 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++ "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 $ pkt^.body._Just)++ "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 $ pkt^.parameter._Just+ rn = fixedPacket^.args.ix "realname"+ conns = map (\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) . T.splitOn "\n\n" $ x^.body._Just+ )) . tail . T.splitOn "conn" $ fixedPacket^.body._Just+ allRooms = nub $ conns >>= (\(_,_,c) -> c)+ (onlinespan,idle,_) = minimumBy (comparing (view _1)) conns+ signon = curtime - onlinespan+ I.sendWhoisReply us uname (entityDecode rn) allRooms idle signon++ q -> klogError $ "Unrecognized property " ++ T.unpack q++respond spk "recv" = deformatRoom (spk^.parameter._Just) >>=+ \roomname -> case pkt^.command of "join" -> do let usname = pkt^.parameter._Just+ pcs <- gets_ $ view privclasses+ countUser <- numUsers roomname usname+ let us = mkUser roomname pcs modifiedPkt+ addUser roomname us+ if countUser == 0+ then do I.sendJoin usname roomname+ pclevel <- getPrivclassLevel roomname $ modifiedPkt^.args.ix "pc"+ I.sendSetUserMode usname roomname pclevel+ else I.sendNoticeClone (username us) (succ countUser) roomname++ "part" -> do let uname = pkt^.parameter._Just+ removeUser roomname uname+ countUser <- numUsers roomname uname+ if countUser < 1+ then I.sendPart uname roomname $ pkt^.args.at "r"+ else I.sendNoticeUnclone uname countUser roomname++ "msg" -> do let uname = arg "from"+ msg = pkt^.body._Just+ un <- use_ name+ 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)++ "privchg" -> do 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 "" (" from " <>) oldPc+ , " to ", newPc, " by ", by+ ]+ I.sendChangeUserMode user roomname oldPcLevel newPcLevel++ "kicked" -> do let uname = pkt^.parameter._Just+ removeUserAll roomname uname+ I.sendKick uname (arg "by") roomname $ pkt^.body.traverse ^? notNull_++ "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: " <> arg "e"+ q -> klogError $ "Unknown admin packet type " ++ show q++ x -> klogError $ "Unknown packet type " ++ show x++ where pkt = fromJust $ subPacket spk+ modifiedPkt = parsePacket (T.replace "\n\npc" "\npc" $ readable pkt)+ arg s = pkt^.args.ix s++respond pkt "kicked" = do roomname <- deformatRoom $ pkt^.parameter._Just+ uname <- use_ name+ removeRoom roomname+ I.sendKick uname (pkt^.args.ix "by") roomname $ pkt^.body.traverse ^? notNull_++respond pkt "send" = I.sendNotice $ "Send error: " <> pkt^.args.ix "e"++respond _ "ping" = get_ >>= \k -> io . writeServer k $ ("pong\n\0" :: T.Text)++respond _ str = klog Yellow $ "Got the packet called " ++ T.unpack str+++mkUser :: Chatroom -> PrivclassStore -> Packet -> User+mkUser room st p = User (p^.parameter._Just)+ (g "pc")+ (fromMaybe 0 $ st^.at room >>= (^.at (g "pc")))+ (g "symbol")+ (entityDecode $ g "realname")+ (g "typename")+ (g "gpc")+ where g s = p^.args.ix s++errHandlers :: [ Handler KevinIO () ]+errHandlers = [ handler_ _KevinException $ klogError "Malformed communication from server"+ , handler _IOException (\e -> klogError $ "server: " ++ show e) ]
+ src/Kevin/Damn/Protocol/Send.hs view
@@ -0,0 +1,117 @@+{-# LANGUAGE OverloadedStrings #-}++module Kevin.Damn.Protocol.Send (+ sendPacket,+ formatRoom,+ deformatRoom,++ sendHandshake,+ sendLogin,+ sendJoin,+ sendPart,+ sendMsg,+ sendAction,+ sendNpMsg,+ sendPromote,+ sendDemote,+ sendBan,+ sendUnban,+ sendKick,+ sendGet,+ sendWhois,+ sendSet,+ sendAdmin,+ sendKill+) where++import Data.Char (toLower)+import Data.List (sort)+import Data.Monoid+import qualified Data.Text as T+import Kevin.Base+import Kevin.Version++maybeBody :: Maybe T.Text -> T.Text+maybeBody = maybe "" ("\n\n" <>)++sendPacket :: T.Text -> KevinIO ()+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:" <> s+ ("&",s) -> do uname <- use_ name+ return . ("pchat:" <>) . T.intercalate ":" . sort . map (T.map toLower) $ [uname, s]+ 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))++type Str = T.Text -- just make it shorter+type Room = Str+type Username = Str+type Pc = Str++-- * Communication to the server+sendHandshake :: KevinIO ()+sendLogin :: Username -> Str -> KevinIO ()+sendJoin, sendPart :: Room -> KevinIO ()+sendMsg, sendAction, sendNpMsg :: Room -> Str -> KevinIO ()+sendPromote, sendDemote :: Room -> Username -> Maybe Pc -> KevinIO ()+sendBan, sendUnban :: Room -> Username -> KevinIO ()+sendKick :: Room -> Username -> Maybe Str -> KevinIO ()+sendGet :: Room -> Str -> KevinIO ()+sendWhois :: Username -> KevinIO ()+sendSet :: Room -> Str -> Str -> KevinIO ()+sendAdmin :: Room -> Str -> KevinIO ()+sendKill :: Username -> Str -> KevinIO ()++sendHandshake = sendPacket $ printf "dAmnClient 0.3\nagent=kevin%s\n" [versionStr]++sendLogin u token = sendPacket $ printf "login %s\npk=%s\n" [u, token]++sendJoin room = do roomname <- formatRoom room+ sendPacket $ printf "join %s\n" [roomname]++sendPart room = do roomname <- formatRoom room+ sendPacket $ printf "part %s\n" [roomname]++sendMsg = sendNpMsg++sendAction room msg = do roomname <- formatRoom room+ sendPacket $ printf "send %s\n\naction main\n\n%s" [roomname, msg]++sendNpMsg room msg = do roomname <- formatRoom room+ sendPacket $ printf "send %s\n\nnpmsg main\n\n%s" [roomname, msg]++sendPromote room us pc = do roomname <- formatRoom room+ sendPacket $ printf "send %s\n\npromote %s%s" [roomname, us, maybeBody pc]++sendDemote room us pc = do roomname <- formatRoom room+ sendPacket $ printf "send %s\n\ndemote %s%s" [roomname, us, maybeBody pc]++sendBan room us = do roomname <- formatRoom room+ sendPacket $ printf "send %s\n\nban %s\n\n" [roomname, us]++sendUnban room us = do roomname <- formatRoom room+ sendPacket $ printf "send %s\n\nunban %s\n\n" [roomname, us]++sendKick room us reason = do roomname <- formatRoom room+ 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]++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]++sendAdmin room cmd = do roomname <- formatRoom room+ sendPacket $ printf "send %s\n\nadmin\n\n%s" [roomname, cmd]++sendKill = undefined
+ src/Kevin/IRC/Packet.hs view
@@ -0,0 +1,91 @@+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE OverloadedStrings #-}++module Kevin.IRC.Packet (+ Packet(..),+ prefix, command, params,++ parsePacket,+ readable+) where++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)++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"++spaces :: Parser T.Text+spaces = takeWhile1 isSpace++servername :: Parser T.Text+servername = takeWhile1 (inClass "a-z0-9.-")++username :: Parser T.Text+username = do n <- nick+ u <- option "" (T.cons <$> char '!' <*> user)+ h <- option "" (T.cons <$> char '@' <*> servername)+ return $ T.concat [n, u, h]++nick :: Parser T.Text+nick = T.cons <$> letter <*> takeWhile (inClass "a-zA-Z0-9[]\\`^{}-")++user :: Parser T.Text+user = takeWhile1 (notInClass badChars)++parsePrefix :: Parser T.Text+parsePrefix = username <|> servername++parseCommand :: Parser T.Text+parseCommand = takeWhile1 isAlpha <|> liftM3 (\a b c -> T.pack [a,b,c]) digit digit digit++parseParams :: Parser [T.Text]+parseParams = (colonParam <|> nonColonParam) `sepBy` spaces++colonParam :: Parser T.Text+colonParam = char ':' *> takeWhile (notInClass "\x0\xd\xa")++nonColonParam :: Parser T.Text+nonColonParam = takeWhile (notInClass badChars)++crlf :: Parser T.Text+crlf = string "\r\n"++messageBegin :: Parser (Maybe T.Text)+messageBegin = Just <$> (char ':' *> parsePrefix <* spaces)++packetParser :: Parser Packet+packetParser = do pr <- option Nothing messageBegin+ cmd <- T.map toUpper <$> parseCommand+ spaces+ par <- filter (not . T.null) <$> parseParams+ option "" crlf+ return $ Packet pr cmd par++parsePacket :: T.Text -> Packet+parsePacket str = case parseOnly packetParser str of Left _ -> BadPacket+ Right p -> p++showParams :: [T.Text] -> T.Text+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) = (<> "\r\n") $ T.unwords [T.cons ':' str, cmd, showParams pms]+readable (Packet Nothing c p) = (<> "\r\n") $ T.unwords [c, showParams p]+readable _ = ""
+ src/Kevin/IRC/Protocol.hs view
@@ -0,0 +1,166 @@+{-# LANGUAGE OverloadedStrings #-}++module Kevin.IRC.Protocol (+ cleanup,+ listen,+ errHandlers,+ getAuthInfo+) where++import Control.Applicative ((<$>))+import Control.Arrow+import Control.Exception.Lens+import Control.Monad.State+import Data.Function (on)+import Data.List (nubBy)+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+import Kevin.Version++type KevinState = StateT Settings IO++cleanup :: KevinIO ()+cleanup = klog Green "cleanup client"++listen :: KevinIO ()+listen = fix (\f -> flip catches errHandlers $ do k <- get_+ pkt <- io $ parsePacket <$> readClient k+ respond pkt (view command pkt)+ f)++respond :: Packet -> T.Text -> KevinIO ()+respond BadPacket _ = sendNotice "Bad packet, try again."+respond pkt "JOIN" = do l <- gets_ (view loggedIn)+ if l+ then mapM_ D.sendJoin rooms+ else kevin $ joining %= (rooms ++)+ where rooms = T.splitOn "," $ pkt^.params._head++respond pkt "PART" = mapM_ D.sendPart . T.splitOn "," $ pkt^.params._head++respond pkt "PRIVMSG" = do 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 (pkt^.params) > 1+ then do let (toggle,mode) = first (=="+") . T.splitAt 1 $ pkt^.params.ix 1+ case mode of "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 (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++respond pkt "TITLE" = case pkt^.params of [] -> 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++respond pkt "WHOIS" = D.sendWhois $ pkt^.params._head++respond pkt "NAMES" = do let room = pkt^.params._head+ k <- get_+ sendUserList (k^.name) (nubBy ((==) `on` username) (k^.users.ix room)) room++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" = 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+ (room:_) -> sendRoomNotice room "Usage: /promote #room username group"+ _ -> sendNotice "Usage: /promote #room username group"++respond _ str = klogError $ T.unpack str+++unmask :: T.Text -> Maybe T.Text+unmask y = case T.split (`elem` "@!") y of [s] -> Just s+ xs -> listToMaybe $ filter (not . T.isInfixOf "*") xs++errHandlers :: [Handler KevinIO ()]+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 = do klogNow Blue ("client -> " ++ T.unpack asStr)+ T.hPutStr h (asStr <> "\r\n")+ where asStr = printf "NOTICE AUTH :%s" [str]++getAuthInfo :: Handle -> Bool -> KevinState ()+getAuthInfo h = fix (\f authRetry -> do pkt <- io $ parsePacket <$> T.hGetLine h+ io $ klogNow Yellow $ "client <- " ++ T.unpack (readable pkt)+ case pkt^.command of "PASS" -> do password .= pkt^.params._head+ passed .= True+ "NICK" -> do name .= pkt^.params._head+ nicked .= True+ "USER" -> usered .= True+ _ -> io $ klogNow Red $ "invalid packet: " ++ show pkt+ if authRetry+ then checkToken h+ else do p <- use passed+ n <- use nicked+ u <- use usered+ if p && n && u+ then welcome h+ else f False)++welcome :: Handle -> KevinState ()+welcome h = do nick <- use name+ mapM_ (\x -> io $ do+ klogNow Blue ("client -> " ++ T.unpack x)+ T.hPutStr h (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 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 h+ where hostname = "chat.deviantart.com"++checkToken :: Handle -> KevinState ()+checkToken h = do s <- get+ io $ notice h "Fetching token..."+ tok <- io $ getToken (s^.name) (s^.password)+ case tok of Just t -> do authtoken .= t+ io $ notice h "Successfully authenticated."+ Nothing -> do io $ notice h "Bad password, try again. (/quote pass yourpassword)"+ getAuthInfo h True
+ src/Kevin/IRC/Protocol/Send.hs view
@@ -0,0 +1,131 @@+{-# LANGUAGE OverloadedStrings #-}++module Kevin.IRC.Protocol.Send (+ sendJoin,+ sendPart,+ sendSetUserMode,+ sendChangeUserMode,+ sendNotice,+ sendRoomNotice,+ sendChanMsg,+ sendChanAction,+ sendKick,+ sendTopic,+ sendChanMode,+ sendUserList,+ sendPong,+ sendNoticeClone,+ sendNoticeUnclone,+ sendWhoisReply+) where++import Data.Monoid+import qualified Data.Text as T+import Kevin.Base++hostname :: T.Text+hostname = ":chat.deviantart.com"++getHost :: T.Text -> T.Text+getHost u = T.concat [":", u, "!", u, "@chat.deviantart.com"]++sendPacket :: T.Text -> KevinIO ()+sendPacket p = get_ >>= \k -> io . writeClient k $ p <> "\r\n"++maybeBody :: Maybe T.Text -> T.Text+maybeBody = maybe "" (" :" <>)++type Str = T.Text+type Room = Str+type Username = Str++sendJoin :: Username -> Room -> KevinIO ()+sendPart :: Username -> Room -> Maybe Str -> KevinIO ()+sendSetUserMode :: Username -> Room -> Int -> KevinIO ()+sendChangeUserMode :: Username -> Room -> Int -> Int -> KevinIO ()+sendNotice :: Str -> KevinIO ()+sendRoomNotice :: Room -> Str -> KevinIO ()+sendChanMsg, sendChanAction :: Username -> Room -> Str -> KevinIO ()+sendKick :: Username -> Username -> Room -> Maybe Str -> KevinIO ()+sendTopic :: Username -> Room -> Username -> Str -> Str -> KevinIO ()+sendChanMode :: Username -> Room -> KevinIO ()+sendUserList :: Username -> [User] -> Room -> KevinIO ()+sendPong :: T.Text -> KevinIO ()+sendNoticeClone :: Username -> Int -> Room -> KevinIO ()+sendNoticeUnclone :: Username -> Int -> Room -> KevinIO ()+sendWhoisReply :: Username -> Username -> Username -> [Room] -> Int -> Int -> KevinIO ()++sendJoin us rm = sendPacket $ printf "%s JOIN :%s" [getHost us, rm]++sendPart us rm msg = sendPacket $ printf "%s PART %s%s" [getHost us, rm, maybeBody msg]++sendSetUserMode us rm m = unless (T.null mode) $ sendPacket $ printf "%s MODE %s +%s %s" [hostname, rm, mode, us]+ where mode = levelToMode m++sendChangeUserMode us rm old new = unless (oldMode == newMode) $ sendPacket $ printf "%s MODE %s %s" [hostname, rm, modesAndUser]+ where oldMode = levelToMode old+ newMode = levelToMode new+ modesAndUser = case (oldMode, newMode) of ("", "") -> T.concat ["-v ", us]+ ("", _) -> T.concat ["+", newMode, " ", us]+ (_, "") -> T.concat ["-", oldMode, " ", us]+ (a, b) -> T.concat ["-", a, "+", b, " ", us, " ", us]+++sendNotice = sendPacket . printf "NOTICE AUTH :%s" . return++sendRoomNotice 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]) . T.splitOn "\n" $ msg++sendKick kickee kicker room 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]++sendChanMode us rm = do sendPacket $ printf "%s 324 %s %s +t" [hostname, us, rm]+ sendPacket $ printf "%s 329 %s %s 767529000" [hostname, us, rm]++sendUserList us uss rm = do mapM_ (\nms -> 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+ 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)++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]++sendNoticeUnclone uname i rm = 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) <> " 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 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 318 %s %s :End of /WHOIS list." [hostname, me, us]++levelToSym :: Int -> T.Text+levelToSym x | x > 0 && x <= 35 = ""+ | x > 35 && x <= 70 = "+"+ | x > 70 && x < 99 = "@"+ | x == 99 = "~"+ | otherwise = ""++levelToMode :: Int -> T.Text+levelToMode x = case levelToSym x of "" -> ""+ "+" -> "v"+ "@" -> "o"+ "~" -> "q"+ _ -> error "levelToSym, what are you doing"
+ src/Kevin/Protocol.hs view
@@ -0,0 +1,60 @@+{-# LANGUAGE FlexibleContexts #-}++module Kevin.Protocol (kevinServer) where++import Control.Exception (throwIO)+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++watchInterrupt :: [Handler IO (Maybe Kevin)]+watchInterrupt = [ handler _AsyncException throwIO+ , handler_ id (return Nothing) ]++mkKevin :: Socket -> IO (Maybe Kevin)+mkKevin sock = flip catches watchInterrupt . withSocketsDo+ $ do (client, _, _) <- accept sock+ hSetBuffering client NoBuffering+ klogNow Blue "received a client"+ s <- execStateT (C.getAuthInfo client False) def+ damnSock <- connectTo "chat.deviantart.com" $ PortNumber 3900+ hSetBuffering damnSock NoBuffering+ logChan <- newChan+ damnChan <- newChan+ ircChan <- newChan+ return . Just $ Kevin damnSock+ client+ damnChan+ ircChan+ s+ mempty+ mempty+ mempty+ mempty+ False+ logChan++mkListener :: Int -> IO Socket+mkListener = listenOn . PortNumber . fromIntegral++kevinServer :: Int -> IO ()+kevinServer n = do sock <- mkListener n+ putStrLn $ "Listening on port " ++ show n+ forever $ do kev <- mkKevin sock+ case kev of Just k -> listen k+ Nothing -> return ()++listen :: Kevin -> IO ()+listen k = do mvar <- newTVarIO k+ 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+ return ()
+ src/Kevin/Settings.hs view
@@ -0,0 +1,21 @@+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE OverloadedStrings #-}++module Kevin.Settings where++import Control.Lens+import Data.Default+import Data.Text++data Settings = Settings { _name :: Text+ , _password :: Text+ , _authtoken :: Text+ , _passed :: Bool+ , _nicked :: Bool+ , _usered :: Bool+ } deriving (Show)++makeClassy ''Settings++instance Default Settings where+ def = Settings "" "" "" False False False
+ src/Kevin/Types.hs view
@@ -0,0 +1,112 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeSynonymInstances #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}++module Kevin.Types (+ Kevin(Kevin, damn, irc, dChan, iChan, logger),+ KevinIO,+ KevinS,+ Privclass,+ Chatroom,+ User(..),+ Title,+ PrivclassStore,+ UserStore,+ TitleStore,+ kevin,+ use_,+ get_,+ gets_,++ -- lenses+ users, privclasses, titles, joining, loggedIn,++ -- other accessors+ settings,++ if'+) where++import Control.Concurrent+import Control.Concurrent.STM.TVar+import Control.Lens+import Control.Monad.Reader+import Control.Monad.STM (STM, atomically)+import Control.Monad.State+import qualified Data.Map as M+import qualified Data.Text as T+import Data.Typeable+import Kevin.Settings+import System.IO++if' :: Bool -> a -> a -> a+if' x y z = if x then y else z++type Chatroom = T.Text++data User = User { username :: T.Text+ , privclass :: T.Text+ , privclassLevel :: Int+ , symbol :: T.Text+ , realname :: T.Text+ , typename :: T.Text+ , gpc :: T.Text+ } deriving (Eq, Show)++type UserStore = M.Map Chatroom [User]++type Privclasses = M.Map T.Text Int+type PrivclassStore = M.Map Chatroom Privclasses+type Privclass = (T.Text, Int)++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+ , _kevinSettings :: Settings+ , _users :: UserStore+ , _privclasses :: PrivclassStore+ , _titles :: TitleStore+ , _joining :: [T.Text]+ , _loggedIn :: Bool+ , logger :: Chan String+ } deriving Typeable++makeLenses ''Kevin++instance HasSettings Kevin where+ settings = kevinSettings++type KevinS = StateT Kevin STM++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++type KevinIO = ReaderT (TVar Kevin) IO++#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 707+deriving instance Typeable ReaderT+#else+instance Typeable1 (ReaderT (TVar Kevin) IO) where+ typeOf1 _ = mkTyConApp (mkTyCon3 "kevin" "Kevin.Types" "KevinIO") []+#endif++use_ :: Getting a Kevin a -> KevinIO a+use_ = gets_ . view++get_ :: KevinIO Kevin+get_ = ask >>= liftIO . readTVarIO++gets_ :: (Kevin -> a) -> KevinIO a+gets_ = flip liftM get_
+ src/Kevin/Util/Entity.hs view
@@ -0,0 +1,141 @@+{-# LANGUAGE OverloadedStrings #-}++module Kevin.Util.Entity (+ entityEncode,+ entityDecode+) where++import Control.Applicative ((<|>), (<$>), (<*>))+import Control.Monad (guard)+import Control.Monad.Fix+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)++decodeCharacter :: Parser T.Text+decodeCharacter = entityNumeric <|> entityNamed <|> take 1++entityNumeric :: Parser T.Text+entityNumeric = do string "&#"+ entity <- (<>) <$> option "" (string "x") <*> takeWhile1 isHexDigit+ char ';'+ return . fromMaybe (T.concat ["&#", entity, ";"]) $ (if "x" `T.isPrefixOf` entity + then lookupHexEntity+ else lookupNumericEntity) entity++entityNamed :: Parser T.Text+entityNamed = do char '&'+ entity <- T.cons <$> letter <*> takeWhile1 isAlphaNum+ char ';'+ return . fromMaybe (T.concat ["&", entity, ";"]) . lookupNamedEntity $ entity++decodeParser :: Parser T.Text+decodeParser = T.concat <$> many1 decodeCharacter++entityDecode :: T.Text -> T.Text+entityDecode "" = ""+entityDecode str = case parseOnly decodeParser str of Left err -> error $ "entityDecode: " ++ err+ Right s -> s++entityEncode :: T.Text -> T.Text+entityEncode = T.pack . concat . entityEncodeS . T.unpack++entityEncodeS :: String -> [String]+entityEncodeS = fix (\f str -> case str of [] -> []+ (x:xs) -> if x < '\127'+ then [x]:f xs+ else ("&#" ++ show (ord x) ++ ";"):f xs)++lookupNamedEntity :: T.Text -> Maybe T.Text+lookupNamedEntity ent = (T.singleton . chr) <$> lookup ent namedEntities++lookupHexEntity :: T.Text -> Maybe T.Text+lookupHexEntity e = case R.hexadecimal $ T.cons '0' e of Right (n,_) -> do guard $ n < ord maxBound+ return . T.singleton . chr $ n+ Left _ -> Nothing++lookupNumericEntity :: T.Text -> Maybe T.Text+lookupNumericEntity e = case R.decimal e of Right (n,_) -> do guard $ n < ord maxBound+ return . T.singleton . chr $ n+ 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)]
+ src/Kevin/Util/Logger.hs view
@@ -0,0 +1,61 @@+{-# LANGUAGE OverloadedStrings #-}++module Kevin.Util.Logger (+ klog,+ klog_,+ klogNow,+ klogError,+ klogWarn,+ Color(..),+ runLogger,+ printf+) where++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++colorAsNum :: Color -> Int+colorAsNum Red = 31+colorAsNum Green = 32+colorAsNum Yellow = 33+colorAsNum Blue = 34+colorAsNum Magenta = 35+colorAsNum Cyan = 36+colorAsNum Gray = 37++runLogger :: Chan String -> IO ()+runLogger ch = void . forkIO . forever $ readChan ch >>= putStrLn++interleave :: [a] -> [a] -> [a]+interleave xs [] = xs+interleave [] ys = ys+interleave (x:xs) (y:ys) = x:y:interleave xs ys++printf :: T.Text -> [T.Text] -> T.Text+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"+ where+ 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++klogNow :: Color -> String -> IO ()+klogNow c s = putStrLn $ render c s++klog :: Color -> String -> KevinIO ()+klog c str = gets_ logger >>= \ch -> liftIO $ klog_ ch c str++klogError, klogWarn :: String -> KevinIO ()++klogError = klog Red . ("ERROR :: " ++)+klogWarn = klog Yellow . ("WARNING :: " ++)
+ src/Kevin/Util/Tablump.hs view
@@ -0,0 +1,76 @@+{-# OPTIONS_GHC -fno-warn-incomplete-patterns #-}++module Kevin.Util.Tablump (+ tablumpDecode+) where++import Control.Arrow+import Control.Monad.Fix+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+fromRight (Right a) = a++{-# 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)++{-# NOINLINE regexen #-}+regexen :: [(Regex, [String] -> String)]+regexen = let ($$) = (,) in map (+ first (fromRight . unsafePerformIO+ . compile defaultCompOpt defaultExecOpt)+ ) . reverse $ [+ "&b\t" $$ const "\2",+ "&/b\t" $$ const "\15",+ "&i\t" $$ const "\22",+ "&/i\t" $$ const "\15",+ "&u\t" $$ const "\31",+ "&/u\t" $$ const "\15",+ "&s\t" $$ const "<s>",+ "&/s\t" $$ const "</s>",+ "&sup\t" $$ const "",+ "&/sup\t" $$ const "",+ "&sub\t" $$ const "",+ "&/sub\t" $$ const "",+ "&code\t" $$ const "",+ "&/code\t" $$ const "",+ "&br\t" $$ const "\n",+ "&ul\t" $$ const "",+ "&/ul\t" $$ const "",+ "&ol\t" $$ const "",+ "&/ol\t" $$ const "",+ "&li\t" $$ const "- ",+ "&/li\t" $$ const "\n",+ "&bcode\t" $$ const "",+ "&/bcode\t" $$ const "",+ "&/a\t" $$ const ")",+ "&/acro\t" $$ const "</acronym>",+ "&/abbr\t" $$ const "</abbr>",+ "&p\t" $$ const "",+ "&/p\t" $$ const "\n",+ "&emote\t(.+?)\t.+?\t.+?\t.+?\t.+?\t" $$ head,+ "&a\t(.+?)\t.*?\t" $$ \(x:_) -> printf "%s (" x,+ "&link\t(.+?)\t&\t" $$ head,+ "&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" $$ \(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='(.+?)'>.+?</abbr>:" $$ \(x:_) -> printf "%s:" x,+ "^[a-zA-Z0-9\\-_]+<abbr title='(.+?)'></abbr>:" $$ \(x:_) -> printf "%s:" x+ ]++tablumpDecode :: T.Text -> T.Text+tablumpDecode = T.pack . flip (foldr (uncurry regexReplace)) regexen . T.unpack
+ src/Kevin/Util/Token.hs view
@@ -0,0 +1,82 @@+{-# LANGUAGE OverloadedStrings #-}++module Kevin.Util.Token (+ getToken+) where++import Control.Arrow+import Crypto.Random.AESCtr (makeSystem)+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+import Network.TLS+import Network.TLS.Extra+import Text.Printf++recvUntil :: TLSCtx -> B.ByteString -> IO B.ByteString+recvUntil ctx str = do+ line <- recvData ctx+ if str `B.isInfixOf` line+ then return line+ else fmap (line <>) $ recvUntil ctx str++concatHeaders :: [(String,String)] -> String+concatHeaders = intercalate "\r\n" . map (\(x,y) -> x ++ ": " ++ y)++scrapeFormValue :: String -> B.ByteString -> B.ByteString+scrapeFormValue key bs = B.takeWhile (/='"') . B.drop 7 . head+ . filter (\l -> "value=" `B.isPrefixOf` l) . B.words . head+ . filter (\l -> B.pack key `B.isInfixOf` l) . B.lines $ bs++scrapeCookies :: B.ByteString -> B.ByteString+scrapeCookies bs = B.intercalate ";" . map snd+ . filter ((== "Set-Cookie") . fst)+ . map (second (B.drop 2 . B.takeWhile (/=';'))+ . B.breakSubstring ": ")+ . B.lines $ bs++getToken :: T.Text -> T.Text -> IO (Maybe T.Text)+getToken uname pass = do+ let params = defaultParamsClient {+ pCiphers = ciphersuite_all+ , onCertificatesRecv = certificateChecks+ [return . certificateVerifyDomain "chat.deviantart.com"]+ }+ headers :: [(String, String)]+ headers = [("Connection", "closed"), ("Content-Type", "application/x-www-form-urlencoded")]+ gen <- makeSystem+ ctv <- connectionClient "www.deviantart.com" "443" params gen+ handshake ctv+ sendData ctv . LB.pack $ "GET /users/login HTTP/1.1\r\nHost: www.deviantart.com\r\n\r\n"+ bl <- recvUntil ctv "validate_key"+ bye ctv+ let payload = urlEncodeVars [ ("username", T.unpack uname)+ , ("password", T.unpack pass)+ , ("validate_token", B.unpack (scrapeFormValue "validate_token" bl))+ , ("validate_key", B.unpack (scrapeFormValue "validate_key" bl))+ , ("remember_me","1")+ ]+ ctx <- connectionClient "www.deviantart.com" "443" params gen+ handshake ctx+ sendData ctx . LB.pack $ printf+ "POST /users/login HTTP/1.1\r\n%s\r\ncookie: %s\r\nContent-Length: %d\r\n\r\n%s"+ (concatHeaders $ ("Host", "www.deviantart.com"):headers)+ (B.unpack (scrapeCookies bl))+ (length payload)+ payload+ bs <- recvData ctx+ if "wrong-password" `B.isInfixOf` bs+ then return Nothing+ else do+ let 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 (scrapeCookies bs))+ 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
+ src/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,8] []++versionStr :: Text+versionStr = pack $ showVersion version
+ src/Main.hs view
@@ -0,0 +1,29 @@+import Kevin+import Kevin.Version+import System.Console.GetOpt+import System.Environment++defaultPort :: Int+defaultPort = 6669++data Flag = Port Int | Version | Help deriving (Eq)++opts :: [OptDescr Flag]+opts = [ 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" ]++header :: String+header = "Usage: kevin [options...]"++getPort :: [Flag] -> Int+getPort (Port x:_) = x+getPort (_:xs) = getPort xs+getPort [] = defaultPort++main :: IO ()+main = do args <- getArgs+ case getOpt Permute opts args of (flags, _, []) -> case flags of f | Help `elem` f -> putStrLn $ usageInfo header opts+ | Version `elem` f -> putStrLn $ "kevin version " ++ showVersion version+ | otherwise -> kevinServer $ getPort flags+ (_, _, msgs@(_:_)) -> putStrLn $ concat msgs ++ usageInfo header opts