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