kevin 0.10.0 → 0.11.0
raw patch · 17 files changed
+659/−602 lines, 17 filesdep +damnpacket
Dependencies added: damnpacket
Files
- kevin.cabal +2/−2
- src/Kevin/Base.hs +49/−35
- src/Kevin/Chatrooms.hs +23/−17
- src/Kevin/Damn/Packet.hs +0/−99
- src/Kevin/Damn/Protocol.hs +200/−146
- src/Kevin/Damn/Protocol/Send.hs +52/−37
- src/Kevin/IRC/Packet.hs +31/−25
- src/Kevin/IRC/Protocol.hs +129/−109
- src/Kevin/IRC/Protocol/Send.hs +52/−38
- src/Kevin/Protocol.hs +30/−20
- src/Kevin/Settings.hs +1/−1
- src/Kevin/Types.hs +17/−14
- src/Kevin/Util/Entity.hs +39/−30
- src/Kevin/Util/Logger.hs +8/−7
- src/Kevin/Util/Tablump.hs +9/−8
- src/Kevin/Util/Token.hs +9/−9
- src/Main.hs +8/−5
kevin.cabal view
@@ -1,5 +1,5 @@ Name: kevin-Version: 0.10.0+Version: 0.11.0 Synopsis: a dAmn ↔ IRC proxy Description: a dAmn ↔ IRC proxy License: GPL@@ -25,6 +25,7 @@ bytestring, containers, cprng-aes,+ damnpacket, data-default, HTTP >= 4000.2, lens >= 3.9,@@ -47,7 +48,6 @@ Other-Modules: Kevin, Kevin.Base, Kevin.Chatrooms,- Kevin.Damn.Packet, Kevin.Damn.Protocol, Kevin.Damn.Protocol.Send, Kevin.IRC.Packet,
src/Kevin/Base.hs view
@@ -16,31 +16,32 @@ 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.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+import Control.Monad.Catch as K #else-import Control.Monad.CatchIO as K+import Control.Monad.CatchIO as K #endif-import Control.Monad.Reader as K-import qualified Data.ByteString.Char8 as T (hGetLine, hPutStr)+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+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+import qualified Text.Printf as P runPrinter :: Chan T.Text -> Handle -> IO () runPrinter ch h = void . forkIO . forever $ readChan ch >>= T.hPutStr h . T.encodeUtf8@@ -50,13 +51,23 @@ class KevinServer a where readClient, readServer :: a -> IO T.Text- writeServer :: a -> T.Text -> IO ()- writeClient :: a -> T.Text -> IO ()+ writeClient, writeServer :: a -> T.Text -> IO () closeClient, closeServer :: a -> IO () -data KevinException = ParseFailure- deriving (Show, Typeable)+data KevinException = ServerParseFailure String T.Text+ | ClientParseFailure String T.Text+ | ServerClosed+ | ClientClosed+ deriving Typeable +instance Show KevinException where+ show (ServerParseFailure reason input) =+ P.printf "Parse failure (%s) on packet from server:\n%s" reason (show input)+ show (ClientParseFailure reason input) =+ P.printf "Parse failure (%s) on packet from client:\n%s" reason (show input)+ show ServerClosed = "Server closed connection"+ show ClientClosed = "Client closed connection"+ instance Exception KevinException _KevinException :: Prism' SomeException KevinException@@ -65,21 +76,24 @@ -- 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+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)+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+ 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)
src/Kevin/Chatrooms.hs view
@@ -1,27 +1,27 @@ 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 Control.Applicative+import Control.Lens+import Data.List import qualified Data.Map as M-import Data.Maybe+import Data.Maybe import qualified Data.Text as T-import Kevin.Types+import Kevin.Types deleteBy' :: (a -> Bool) -> [a] -> [a] deleteBy' f (x:xs) = if f x then xs else x:deleteBy' f xs@@ -34,9 +34,11 @@ 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+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)@@ -51,17 +53,21 @@ 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- +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})+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
@@ -1,99 +0,0 @@-{-# 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
@@ -7,177 +7,229 @@ 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 Control.Applicative ((<$>), (<$))+import Control.Concurrent+import Control.Exception as E (throw)+import Control.Exception.Lens+import Data.List (delete, nub, minimumBy)+import Data.Maybe (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 Data.Time.Clock.POSIX (getPOSIXTime)+import Kevin.Base+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+import Kevin.Util.Entity+import Kevin.Util.Logger+import Kevin.Util.Tablump+import Text.Damn.Packet hiding (parse)+import qualified Text.Damn.Packet as D (parse) +okay :: Packet -> Bool+okay p = let e = pktArgs p ^. at "e" in e == Nothing || e == Just "ok"++notNull_ :: Prism' T.Text T.Text+notNull_ = prism' id $ toMaybe (not . T.null)+ where toMaybe f x = x <$ guard (f x)++parsePrivclasses :: T.Text -> [Privclass]+parsePrivclasses = map (liftM2 (,) (!! 1) (read . T.unpack . head) . T.splitOn ":")+ . filter (not . T.null)+ . T.splitOn "\n"++parse :: T.Text -> Packet+parse m = case D.parse (fromMaybe m $ T.stripSuffix "\n" m) of+ Left err -> E.throw $ ServerParseFailure err m+ Right x -> x+ initialize :: KevinIO () initialize = sendHandshake cleanup :: KevinIO ()-cleanup = klog Blue "cleanup server"+cleanup = do+ klog Blue "cleanup server"+ k <- gets_ clientMv+ tid <- liftIO $ readMVar k+ liftIO $ killThread tid listen :: KevinIO () listen = fix (\f -> flip catches errHandlers $ do k <- get_- pkt <- io $ parsePacket <$> readServer k- respond pkt (view command pkt)+ pkt <- io $ parse <$> readServer k+ respond pkt (pktCommand pkt) f) -- main responder respond :: Packet -> T.Text -> KevinIO ()-respond _ "dAmnServer" = do s <- use_ settings- sendLogin (s^.name) (s^.authtoken)+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 "login" =+ if okay pkt+ then do+ j <- kevin $ do+ loggedIn .= True+ use joining+ mapM_ sendJoin j+ else I.sendNotice $ "Login failed: " <> pktArgs pkt ^. 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 "join" = do+ roomname <- deformatRoom $ pktParameter pkt ^. _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, ": ", pktArgs pkt ^. 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 "part" = do+ roomname <- deformatRoom $ pktParameter pkt ^. _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, ": ", pktArgs pkt ^. ix "e"] -respond pkt "property" = do roomname <- deformatRoom (pkt^.parameter._Just)- case pkt^.args.ix "p" of "privclasses" -> setPrivclasses roomname . parsePrivclasses $ pkt^.body._Just+respond pkt "property" = do+ roomname <- deformatRoom $ pktParameter pkt ^. _Just+ case pktArgs pkt ^. ix "p" of+ "privclasses" -> setPrivclasses roomname . parsePrivclasses $ pktBody pkt ^. _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")+ "topic" -> do+ uname <- use_ name+ let setter = fromMaybe uname $ pktArgs pkt ^. at "by"+ topic = T.replace "\n" " - " . entityDecode . tablumpDecode $ pktBody pkt ^. _Just+ time = pktArgs pkt ^. ix "ts"+ I.sendTopic uname roomname setter topic time - "title" -> setTitle roomname (T.replace "\n" " - " . entityDecode . tablumpDecode $ pkt^.body._Just)+ "title" -> setTitle roomname (T.replace "\n" " - " . entityDecode . tablumpDecode $ pktBody pkt ^. _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+ "members" -> do+ k <- get_+ let members =map (mkUser roomname (k^.privclasses) . parse)+ . init . T.splitOn "\n\n"+ $ pktBody pkt ^. _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+ "info" -> do+ us <- use_ name+ curtime <- io $ floor <$> getPOSIXTime+ let fixedPacket = parse . T.init+ . T.replace "\n\nusericon" "\nusericon"+ . render $ pkt+ uname = T.drop 6 $ pktParameter pkt ^. _Just+ rn = pktArgs fixedPacket ^. ix "realname"+ conns :: [(Int, Int, [T.Text])]+ conns = map (\pk ->+ let x = parse $ "conn" <> pk+ in ( read (T.unpack $ pktArgs x ^. ix "online") :: Int+ , read (T.unpack $ pktArgs x ^. ix "idle" ) :: Int+ , map (T.drop 8) . filter (not . T.null) . T.splitOn "\n\n" $ pktBody x ^. _Just+ )) . tail . T.splitOn "conn" $ pktBody fixedPacket ^. _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+ 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+respond spk "recv" = deformatRoom (pktParameter spk ^. _Just) >>= \roomname ->+ case pktCommand pkt of+ "join" -> do+ let usname = pktParameter pkt ^. _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 $ pktArgs modifiedPkt ^. 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+ "part" -> do+ let uname = pktParameter pkt ^. _Just+ removeUser roomname uname+ countUser <- numUsers roomname uname+ if countUser < 1+ then I.sendPart uname roomname $ pktArgs pkt ^. 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)+ "msg" -> do+ let uname = arg "from"+ msg = pktBody pkt ^. _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)+ "action" -> do+ let uname = arg "from"+ msg = pktBody pkt ^. _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+ "privchg" -> do+ let user = pktParameter pkt ^. _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_+ "kicked" -> do+ let uname = pktParameter pkt ^. _Just+ removeUserAll roomname uname+ I.sendKick uname (arg "by") roomname $ pktBody pkt ^. 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+ "admin" -> case pktParameter pkt ^. _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" $ pktBody pkt ^. _Just+ "privclass" -> I.sendRoomNotice roomname $ "Admin error: " <> arg "e"+ q -> klogError $ "Unknown admin packet type " ++ show q - x -> klogError $ "Unknown packet type " ++ show x+ 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+ where pkt = pktSubpacket' spk ^?! _Just+ modifiedPkt = parse (T.replace "\n\npc" "\npc" $ render pkt)+ arg s = pktArgs pkt ^. 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 "kicked" = do+ roomname <- deformatRoom $ pktParameter pkt ^. _Just+ uname <- use_ name+ removeRoom roomname+ I.sendKick uname (pktArgs pkt ^. ix "by") roomname $ pktBody pkt ^. traverse ^? notNull_ -respond pkt "send" = I.sendNotice $ "Send error: " <> pkt^.args.ix "e"+respond pkt "send" = I.sendNotice $ "Send error: " <> pkt ^. pktArgsL . ix "e" respond _ "ping" = get_ >>= \k -> io . writeServer k $ ("pong\n\0" :: T.Text) @@ -185,15 +237,17 @@ 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+mkUser room st p = User {+ username = p ^?! pktParameterL . _Just+ , privclass = g "pc"+ , privclassLevel = fromMaybe 0 $ st ^. at room >>= (view (at $ g "pc"))+ , symbol = g "symbol"+ , realname = entityDecode $ g "realname"+ , typename = g "typename"+ , gpc = g "gpc"+ }+ where g s = p ^. pktArgsL . ix s errHandlers :: [ Handler KevinIO () ]-errHandlers = [ handler_ _KevinException $ klogError "Malformed communication from server"- , handler _IOException (\e -> klogError $ "server: " ++ show e) ]+errHandlers = [ handler _KevinException $ klogError . show+ , handler _IOException (\e -> klogError ("server: " ++ show e) >> E.throw e) ]
src/Kevin/Damn/Protocol/Send.hs view
@@ -24,12 +24,12 @@ sendKill ) where -import Data.Char (toLower)-import Data.List (sort)-import Data.Monoid+import Data.Char (toLower)+import Data.List (sort)+import Data.Monoid import qualified Data.Text as T-import Kevin.Base-import Kevin.Version+import Kevin.Base+import Kevin.Version maybeBody :: Maybe T.Text -> T.Text maybeBody = maybe "" ("\n\n" <>)@@ -38,16 +38,19 @@ 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+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))+ 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@@ -72,46 +75,58 @@ sendLogin u token = sendPacket $ printf "login %s\npk=%s\n" [u, token] -sendJoin room = do roomname <- formatRoom room- sendPacket $ printf "join %s\n" [roomname]+sendJoin room = do+ roomname <- formatRoom room+ sendPacket $ printf "join %s\n" [roomname] -sendPart room = do roomname <- formatRoom room- sendPacket $ printf "part %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]+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]+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]+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]+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]+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]+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]+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]+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]+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]+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
@@ -1,4 +1,5 @@ {-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE OverloadedStrings #-} module Kevin.IRC.Packet (@@ -9,21 +10,23 @@ readable ) where -import Control.Applicative ((<|>), (<$>), (<*>), (*>), (<*))-import Control.Lens-import Control.Monad-import Data.Attoparsec.Text-import Data.Char-import Data.Monoid+import Control.Applicative ((<|>), (<$>), (<*>), (*>), (<*))+import Control.Exception (throw)+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)+import Kevin.Base (KevinException(..))+import Prelude hiding (takeWhile) data Packet = Packet { _prefix :: Maybe T.Text , _command :: T.Text , _params :: [T.Text]- }- | BadPacket deriving (Show)+ } deriving (Show) + makeLenses ''Packet badChars :: String@@ -36,10 +39,11 @@ 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]+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[]\\`^{}-")@@ -69,23 +73,25 @@ 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+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+parsePacket str = case parseOnly packetParser str of+ Left err -> throw $ ClientParseFailure err str+ Right p -> p showParams :: [T.Text] -> T.Text-showParams = T.unwords . map (\str -> if " " `T.isInfixOf` str- then T.cons ':' str- else str)+showParams = T.unwords . map (\str ->+ if " " `T.isInfixOf` str+ then T.cons ':' str+ else str) readable :: Packet -> T.Text readable (Packet (Just str) cmd pms) = (<> "\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
@@ -7,160 +7,180 @@ 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 Control.Applicative ((<$>))+import Control.Arrow+import Control.Concurrent+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 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+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"+cleanup = do+ klog Green "cleanup client"+ sm <- gets_ serverMv+ tid <- liftIO $ readMVar sm+ liftIO $ killThread tid listen :: KevinIO ()-listen = fix (\f -> flip catches errHandlers $ do k <- get_- pkt <- io $ parsePacket <$> readClient k- respond pkt (view command pkt)- f)+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 ++)+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 "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)+ 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 "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 "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 "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 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 _ "QUIT" = throw ClientClosed 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 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+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) ]+errHandlers = [ handler _KevinException $ klogError . show+ , 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")+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)+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+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+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
@@ -65,11 +65,11 @@ 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]-+ 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 @@ -81,25 +81,29 @@ 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]+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]+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+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 [T.pack . show . levelToSym $ privclassLevel u, username u]) uss chunkedNames = reverse . map reverse . subchunk' 432 names $ [[]]- subchunk' n = fix (\f x y -> let hy = head y- hx = head x- ty = tail y- tx = tail x- in if null x- then y- else f tx $ if sum (map T.length hy) + T.length hx <= n- then (hx:hy):ty- else [hx]:y)+ subchunk' n = fix (\f x y ->+ let hy = head y+ hx = head x+ ty = tail y+ tx = tail x+ in if null x+ then y+ else f tx $ if sum (map T.length hy) + T.length hx <= n+ then (hx:hy):ty+ else [hx]:y) sendPong p = sendPacket $ printf "%s PONG chat.deviantart.com :%s" [hostname, p] @@ -109,23 +113,33 @@ 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]+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 = ""+data Mode = None | Voice | Operator | Founder +instance Show Mode where+ show None = ""+ show Voice = "+"+ show Operator = "@"+ show Founder = "~"++levelToSym :: Int -> Mode+levelToSym x | x > 0 && x <= 35 = None+ | x > 35 && x <= 70 = Voice+ | x > 70 && x < 99 = Operator+ | x == 99 = Founder+ | otherwise = None+ levelToMode :: Int -> T.Text-levelToMode x = case levelToSym x of "" -> ""- "+" -> "v"- "@" -> "o"- "~" -> "q"- _ -> error "levelToSym, what are you doing"+levelToMode x = case levelToSym x of+ None -> ""+ Voice -> "v"+ Operator -> "o"+ Founder -> "q"
src/Kevin/Protocol.hs view
@@ -2,16 +2,17 @@ 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 Control.Concurrent+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+import Kevin.Util.Logger+import Prelude watchInterrupt :: [Handler IO (Maybe Kevin)] watchInterrupt = [ handler _AsyncException throwIO@@ -28,10 +29,14 @@ logChan <- newChan damnChan <- newChan ircChan <- newChan+ smv <- newEmptyMVar+ cmv <- newEmptyMVar return . Just $ Kevin damnSock client damnChan ircChan+ smv+ cmv s mempty mempty@@ -44,17 +49,22 @@ 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 ()+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 ()+listen k = do+ mvar <- newTVarIO k+ runLogger (logger k)+ runPrinter (dChan k) (damn k)+ runPrinter (iChan k) (irc k)+ sId <- forkIO . void $ runReaderT (bracket_ S.initialize (S.cleanup >> io (closeServer k)) S.listen) mvar+ cId <- forkIO . void $ runReaderT (bracket_ (return ()) (C.cleanup >> io (closeClient k)) C.listen) mvar+ putMVar (serverMv k) sId+ putMVar (clientMv k) cId+ return ()
src/Kevin/Settings.hs view
@@ -13,7 +13,7 @@ , _passed :: Bool , _nicked :: Bool , _usered :: Bool- } deriving (Show)+ } deriving Show makeClassy ''Settings
src/Kevin/Types.hs view
@@ -8,7 +8,7 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} module Kevin.Types (- Kevin(Kevin, damn, irc, dChan, iChan, logger),+ Kevin(Kevin, damn, irc, dChan, iChan, logger, clientMv, serverMv), KevinIO, KevinS, Privclass,@@ -32,17 +32,17 @@ 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 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+import Data.Typeable+import Kevin.Settings+import System.IO if' :: Bool -> a -> a -> a if' x y z = if x then y else z@@ -71,6 +71,8 @@ , irc :: Handle , dChan :: Chan T.Text , iChan :: Chan T.Text+ , serverMv :: MVar ThreadId+ , clientMv :: MVar ThreadId , _kevinSettings :: Settings , _users :: UserStore , _privclasses :: PrivclassStore@@ -88,10 +90,11 @@ 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+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
src/Kevin/Util/Entity.hs view
@@ -5,63 +5,72 @@ 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 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)+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+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+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+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)+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+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+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)
src/Kevin/Util/Logger.hs view
@@ -11,11 +11,11 @@ printf ) where -import Control.Concurrent-import Control.Monad.State-import Data.Char (isSpace)+import Control.Concurrent+import Control.Monad.State+import Data.Char (isSpace) import qualified Data.Text as T-import Kevin.Types+import Kevin.Types data Color = Red | Blue | Green | Cyan | Magenta | Yellow | Gray @@ -40,9 +40,10 @@ printf str reps = T.concat $ interleave (T.splitOn "%s" str) reps render :: Color -> String -> String-render col str = "\027[" ++ show (colorAsNum col)- ++ "m" ++ rtrimmed- ++ "\027[0m"+render col str = "\027["+ ++ show (colorAsNum col)+ ++ "m" ++ rtrimmed+ ++ "\027[0m" where rtrimmed = reverse . dropWhile (\x -> isSpace x || x == '\x0') . reverse $ str
src/Kevin/Util/Tablump.hs view
@@ -4,13 +4,13 @@ tablumpDecode ) where -import Control.Arrow-import Control.Monad.Fix+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+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@@ -19,8 +19,9 @@ {-# 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)+ 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)]
src/Kevin/Util/Token.hs view
@@ -4,18 +4,18 @@ getToken ) where -import Control.Arrow-import Crypto.Random.AESCtr (makeSystem)+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 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+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
src/Main.hs view
@@ -22,8 +22,11 @@ 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+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