diff --git a/kevin.cabal b/kevin.cabal --- a/kevin.cabal +++ b/kevin.cabal @@ -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, diff --git a/src/Kevin/Base.hs b/src/Kevin/Base.hs --- a/src/Kevin/Base.hs +++ b/src/Kevin/Base.hs @@ -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) diff --git a/src/Kevin/Chatrooms.hs b/src/Kevin/Chatrooms.hs --- a/src/Kevin/Chatrooms.hs +++ b/src/Kevin/Chatrooms.hs @@ -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 diff --git a/src/Kevin/Damn/Packet.hs b/src/Kevin/Damn/Packet.hs deleted file mode 100644 --- a/src/Kevin/Damn/Packet.hs +++ /dev/null @@ -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 diff --git a/src/Kevin/Damn/Protocol.hs b/src/Kevin/Damn/Protocol.hs --- a/src/Kevin/Damn/Protocol.hs +++ b/src/Kevin/Damn/Protocol.hs @@ -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) ] diff --git a/src/Kevin/Damn/Protocol/Send.hs b/src/Kevin/Damn/Protocol/Send.hs --- a/src/Kevin/Damn/Protocol/Send.hs +++ b/src/Kevin/Damn/Protocol/Send.hs @@ -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 diff --git a/src/Kevin/IRC/Packet.hs b/src/Kevin/IRC/Packet.hs --- a/src/Kevin/IRC/Packet.hs +++ b/src/Kevin/IRC/Packet.hs @@ -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 _ = "" diff --git a/src/Kevin/IRC/Protocol.hs b/src/Kevin/IRC/Protocol.hs --- a/src/Kevin/IRC/Protocol.hs +++ b/src/Kevin/IRC/Protocol.hs @@ -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 " [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 " [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 diff --git a/src/Kevin/IRC/Protocol/Send.hs b/src/Kevin/IRC/Protocol/Send.hs --- a/src/Kevin/IRC/Protocol/Send.hs +++ b/src/Kevin/IRC/Protocol/Send.hs @@ -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" diff --git a/src/Kevin/Protocol.hs b/src/Kevin/Protocol.hs --- a/src/Kevin/Protocol.hs +++ b/src/Kevin/Protocol.hs @@ -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 () diff --git a/src/Kevin/Settings.hs b/src/Kevin/Settings.hs --- a/src/Kevin/Settings.hs +++ b/src/Kevin/Settings.hs @@ -13,7 +13,7 @@ , _passed :: Bool , _nicked :: Bool , _usered :: Bool - } deriving (Show) + } deriving Show makeClassy ''Settings diff --git a/src/Kevin/Types.hs b/src/Kevin/Types.hs --- a/src/Kevin/Types.hs +++ b/src/Kevin/Types.hs @@ -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 diff --git a/src/Kevin/Util/Entity.hs b/src/Kevin/Util/Entity.hs --- a/src/Kevin/Util/Entity.hs +++ b/src/Kevin/Util/Entity.hs @@ -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) diff --git a/src/Kevin/Util/Logger.hs b/src/Kevin/Util/Logger.hs --- a/src/Kevin/Util/Logger.hs +++ b/src/Kevin/Util/Logger.hs @@ -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 diff --git a/src/Kevin/Util/Tablump.hs b/src/Kevin/Util/Tablump.hs --- a/src/Kevin/Util/Tablump.hs +++ b/src/Kevin/Util/Tablump.hs @@ -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)] diff --git a/src/Kevin/Util/Token.hs b/src/Kevin/Util/Token.hs --- a/src/Kevin/Util/Token.hs +++ b/src/Kevin/Util/Token.hs @@ -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 diff --git a/src/Main.hs b/src/Main.hs --- a/src/Main.hs +++ b/src/Main.hs @@ -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