diff --git a/Kevin.hs b/Kevin.hs deleted file mode 100644 --- a/Kevin.hs +++ /dev/null @@ -1,2 +0,0 @@ -module Kevin (module Kevin.Protocol) where -import Kevin.Protocol diff --git a/Kevin/Base.hs b/Kevin/Base.hs deleted file mode 100644 --- a/Kevin/Base.hs +++ /dev/null @@ -1,82 +0,0 @@ -module Kevin.Base ( - module Kevin.Types, - KevinException(..), - _KevinException, - KevinServer(..), - User(..), - - module K, - - io, - runPrinter, - - printf -) where - -import Control.Applicative ((<$>)) -import Control.Concurrent as K (forkIO) -import Control.Concurrent.Chan as K -import Control.Concurrent.STM.TVar as K -import Control.Exception -import Control.Exception as K (IOException) -import Control.Exception.Lens -import Control.Lens as K -import Control.Monad.CatchIO as K -import Control.Monad.Reader as K -import qualified Data.ByteString.Char8 as T (hGetLine, hPutStr) -import qualified Data.Text as T -import qualified Data.Text.Encoding as T -import Data.Typeable -import Kevin.Chatrooms as K -import Kevin.Settings as K -import Kevin.Types -import Kevin.Util.Logger -import Network as K -import System.IO as K -import System.IO.Error - -runPrinter :: Chan T.Text -> Handle -> IO () -runPrinter ch h = void . forkIO . forever $ readChan ch >>= T.hPutStr h . T.encodeUtf8 - -io :: MonadIO m => IO a -> m a -io = liftIO - -class KevinServer a where - readClient, readServer :: a -> IO T.Text - writeServer :: a -> T.Text -> IO () - writeClient :: a -> T.Text -> IO () - closeClient, closeServer :: a -> IO () - -data KevinException = ParseFailure - deriving (Show, Typeable) - -instance Exception KevinException - -_KevinException :: Prism' SomeException KevinException -_KevinException = exception - --- actions - -hGetCharTimeout :: Handle -> Int -> IO Char -hGetCharTimeout h t = do hSetBuffering h NoBuffering - ready <- hWaitForInput h t - if ready - then hGetChar h - else throwIO $ mkIOError eofErrorType "read timeout" (Just h) Nothing - -hGetSep :: Char -> Handle -> IO String -hGetSep sep h = fix (\f -> do ch <- hGetCharTimeout h 180000 - if ch == sep - then return "" - else (ch:) <$> f) - -instance KevinServer Kevin where - readClient k = do line <- T.decodeUtf8 <$> T.hGetLine (irc k) - return $ T.init line - readServer k = T.pack <$> hGetSep '\NUL' (damn k) - - writeClient k = writeChan (iChan k) - writeServer k = writeChan (dChan k) - - closeClient = hClose . irc - closeServer = hClose . damn diff --git a/Kevin/Chatrooms.hs b/Kevin/Chatrooms.hs deleted file mode 100644 --- a/Kevin/Chatrooms.hs +++ /dev/null @@ -1,67 +0,0 @@ -module Kevin.Chatrooms ( - removeRoom, - - addUser, - setUsers, - removeUser, - removeUserAll, - numUsers, - - setPrivclasses, - getPrivclass, - getPrivclassLevel, - setUserPrivclass, - - setTitle -) where - -import Control.Applicative -import Control.Lens -import Data.List -import qualified Data.Map as M -import Data.Maybe -import qualified Data.Text as T -import Kevin.Types - -deleteBy' :: (a -> Bool) -> [a] -> [a] -deleteBy' f (x:xs) = if f x then xs else x:deleteBy' f xs -deleteBy' _ [] = [] - -removeRoom :: Chatroom -> KevinIO () -removeRoom c = kevin $ privclasses.at c .= Nothing >> users.at c .= Nothing - -addUser :: Chatroom -> User -> KevinIO () -addUser ch us = kevin $ users.ix ch %= (us:) - -numUsers :: Chatroom -> T.Text -> KevinIO Int -numUsers ch us = do st <- gets_ $ view users - case st^.at ch of Just usrs -> return . length $ findIndices (\u -> us == username u) usrs - Nothing -> return 0 - -removeUser :: Chatroom -> T.Text -> KevinIO () -removeUser ch us = kevin $ users.ix ch %= deleteBy' ((== us) . username) - -removeUserAll :: Chatroom -> T.Text -> KevinIO () -removeUserAll ch us = kevin $ users.ix ch %= filter ((/= us) . username) - -setUsers :: Chatroom -> [User] -> KevinIO () -setUsers ch uss = kevin $ users.at ch ?= uss - -setPrivclasses :: Chatroom -> [Privclass] -> KevinIO () -setPrivclasses room ps = kevin $ privclasses.at room ?= M.fromList ps - -getPrivclass :: Chatroom -> T.Text -> KevinIO (Maybe T.Text) -getPrivclass room user = do st <- gets_ $ view users - case st^.at room of Just qs -> return $ privclass <$> listToMaybe (filter ((== user) . username) qs) - Nothing -> return Nothing - -getPrivclassLevel :: Chatroom -> T.Text -> KevinIO Int -getPrivclassLevel room pc = do st <- gets_ $ view privclasses - return . fromMaybe 0 $ st^.at room >>= (^.at pc) - -setUserPrivclass :: Chatroom -> T.Text -> T.Text -> KevinIO () -setUserPrivclass room user pc = do pclevel <- getPrivclassLevel room pc - kevin $ users.ix room.traverse.filtered ((user ==) . username) %= (\u -> u {privclass = pc, privclassLevel = pclevel}) - -setTitle :: Chatroom -> T.Text -> KevinIO () -setTitle ch t = kevin $ titles.at ch ?= t diff --git a/Kevin/Damn/Packet.hs b/Kevin/Damn/Packet.hs deleted file mode 100644 --- a/Kevin/Damn/Packet.hs +++ /dev/null @@ -1,96 +0,0 @@ -module Kevin.Damn.Packet ( - Packet(..), - command, parameter, args, body, - - parsePacket, - parsePrivclasses, - subPacket, - fixLoginPacket, - okay, - readable, - null_, - notNull_ -) where - -import Control.Applicative (many, (<$>), (<$)) -import Control.Exception (throw) -import Control.Lens -import Control.Monad (guard, liftM2) -import Data.Attoparsec.Text -import Data.Char -import qualified Data.Map as M -import Data.Maybe -import Data.Monoid -import qualified Data.Text as T -import Kevin.Base (KevinException(..), Privclass) - -toMaybe :: (a -> Bool) -> a -> Maybe a -toMaybe f x = x <$ guard (f x) - -notNull_ :: Prism' T.Text T.Text -notNull_ = prism' id $ toMaybe (not . T.null) - -null_ :: Prism' T.Text T.Text -null_ = prism' id $ toMaybe T.null - -data Packet = Packet { _command :: T.Text - , _parameter :: Maybe T.Text - , _args :: M.Map T.Text T.Text - , _body :: Maybe T.Text - } deriving Show - -makeLenses ''Packet - -parseCommand :: Parser T.Text -parseCommand = takeWhile1 (not . isSpace) - -parseParam :: Parser (Maybe T.Text) -parseParam = do char ' ' - parm <- takeWhile1 (not . isSpace) - return $ Just parm - -parseArgs :: Parser (M.Map T.Text T.Text) -parseArgs = (M.fromList <$>) . many $ do char '\n' - c <- takeTill (=='=') - char '=' - r <- takeTill (=='\n') - return (c,r) - -parseHead :: Parser Packet -parseHead = do c <- parseCommand - p <- option Nothing parseParam - a <- parseArgs - return $ Packet c p a Nothing - -parsePacket :: T.Text -> Packet -parsePacket pack = case parseOnly parseHead top of Left _ -> throw ParseFailure - Right res -> res & body .~ (T.drop 2 <$> toMaybe (not . T.null) b) - where (top, b) = T.breakOn "\n\n" pack - -getResult :: Either String a -> a -getResult x = let Right e = x in e - -fixLoginPacket :: Packet -> Packet -fixLoginPacket pkt = if pkt^.command == "login" - then pkt & args %~ (<> getResult (parseOnly parseArgs . T.cons '\n' . fromJust $ pkt^.body)) - else pkt - -subPacket :: Packet -> Maybe Packet -subPacket = (parsePacket <$>) . view body - -okay :: Packet -> Bool -okay (Packet _ _ a _) = let e = a ^. at "e" in isNothing e || e == Just "ok" - -parsePrivclasses :: T.Text -> [Privclass] -parsePrivclasses = map (liftM2 (,) (!! 1) (read . T.unpack . head) . T.splitOn ":") - . filter (not . T.null) - . T.splitOn "\n" - -readable :: Packet -> T.Text -readable (Packet cmd param arg bod) = cmd <> maybe "" (' ' `T.cons`) param - <> formattedArgs (M.toList arg) - <> maybe "" ("\n\n" <>) bod - <> "\n\0" - where - formattedArgs [] = "" - formattedArgs q = ("\n" <>) . T.intercalate "\n" . map (uncurry (\x y -> x <> "=" <> y)) $ q diff --git a/Kevin/Damn/Protocol.hs b/Kevin/Damn/Protocol.hs deleted file mode 100644 --- a/Kevin/Damn/Protocol.hs +++ /dev/null @@ -1,196 +0,0 @@ -module Kevin.Damn.Protocol ( - initialize, - cleanup, - listen, - errHandlers -) where - -import Control.Applicative ((<$>)) -import Control.Exception.Lens -import Data.List (delete, nub, minimumBy) -import Data.Maybe (fromJust, fromMaybe) -import Data.Monoid -import Data.Ord (comparing) -import qualified Data.Text as T -import Data.Time.Clock.POSIX (getPOSIXTime) -import Kevin.Base -import Kevin.Damn.Packet -import Kevin.Damn.Protocol.Send -import qualified Kevin.IRC.Protocol.Send as I -import Kevin.Util.Entity -import Kevin.Util.Logger -import Kevin.Util.Tablump - -initialize :: KevinIO () -initialize = sendHandshake - -cleanup :: KevinIO () -cleanup = klog Blue "cleanup server" - -listen :: KevinIO () -listen = fix (\f -> flip catches errHandlers $ do k <- get_ - pkt <- io $ parsePacket <$> readServer k - respond pkt (view command pkt) - f) - --- main responder -respond :: Packet -> T.Text -> KevinIO () -respond _ "dAmnServer" = do s <- use_ settings - sendLogin (s^.name) (s^.authtoken) - -respond pkt "login" = if okay pkt - then do j <- kevin $ do loggedIn .= True - use joining - mapM_ sendJoin j - else I.sendNotice $ "Login failed: " <> pkt ^. args.ix "e" - -respond pkt "join" = do roomname <- deformatRoom $ pkt^.parameter._Just - if okay pkt - then do kevin $ joining %= (roomname:) - uname <- use_ name - I.sendJoin uname roomname - else I.sendNotice $ T.concat ["Couldn't join ", roomname, ": ", pkt^.args.ix "e"] - -respond pkt "part" = do roomname <- deformatRoom $ pkt^.parameter._Just - if okay pkt - then do uname <- use_ name - removeRoom roomname - I.sendPart uname roomname Nothing - else I.sendNotice $ T.concat ["Couldn't part ", roomname, ": ", pkt^.args.ix "e"] - -respond pkt "property" = do roomname <- deformatRoom (pkt^.parameter._Just) - case pkt^.args.ix "p" of "privclasses" -> setPrivclasses roomname . parsePrivclasses $ pkt^.body._Just - - "topic" -> do uname <- use_ name - I.sendTopic uname roomname (fromMaybe uname $ pkt^.args.at "by") - (T.replace "\n" " - " . entityDecode . tablumpDecode $ pkt^.body._Just) - (pkt^.args.ix "ts") - - "title" -> setTitle roomname (T.replace "\n" " - " . entityDecode . tablumpDecode $ pkt^.body._Just) - - "members" -> do k <- get_ - let members = map (mkUser roomname (k^.privclasses) . parsePacket) - . init . T.splitOn "\n\n" - $ pkt^.body._Just - pc = privclass . head . filter (\x -> username x == k^.name) $ members - n = nub members - setUsers roomname members - when (roomname `elem` k^.joining) $ do I.sendUserList (k^.name) n roomname - pclevel <- getPrivclassLevel roomname pc - I.sendSetUserMode (k^.name) roomname pclevel - kevin $ joining %= delete roomname - - "info" -> do us <- use_ name - curtime <- io $ floor <$> getPOSIXTime - let fixedPacket = parsePacket . T.init - . T.replace "\n\nusericon" "\nusericon" - . readable $ pkt - uname = T.drop 6 $ pkt^.parameter._Just - rn = fixedPacket^.args.ix "realname" - conns = map (\pk -> let x = parsePacket $ "conn" <> pk - in ( read (T.unpack $ x^.args.ix "online") :: Int - , read (T.unpack $ x^.args.ix "idle" ) :: Int - , map (T.drop 8) . filter (not . T.null) . T.splitOn "\n\n" $ x^.body._Just - )) . tail . T.splitOn "conn" $ fixedPacket^.body._Just - allRooms = nub $ conns >>= (\(_,_,c) -> c) - (onlinespan,idle,_) = minimumBy (comparing (view _1)) conns - signon = curtime - onlinespan - I.sendWhoisReply us uname (entityDecode rn) allRooms idle signon - - q -> klogError $ "Unrecognized property " ++ T.unpack q - -respond spk "recv" = deformatRoom (spk^.parameter._Just) >>= - \roomname -> case pkt^.command of "join" -> do let usname = pkt^.parameter._Just - pcs <- gets_ $ view privclasses - countUser <- numUsers roomname usname - let us = mkUser roomname pcs modifiedPkt - addUser roomname us - if countUser == 0 - then do I.sendJoin usname roomname - pclevel <- getPrivclassLevel roomname $ modifiedPkt^.args.ix "pc" - I.sendSetUserMode usname roomname pclevel - else I.sendNoticeClone (username us) (succ countUser) roomname - - "part" -> do let uname = pkt^.parameter._Just - removeUser roomname uname - countUser <- numUsers roomname uname - if countUser < 1 - then I.sendPart uname roomname $ pkt^.args.at "r" - else I.sendNoticeUnclone uname countUser roomname - - "msg" -> do let uname = arg "from" - msg = pkt^.body._Just - un <- use_ name - unless (un == uname) $ I.sendChanMsg uname roomname (entityDecode $ tablumpDecode msg) - - "action" -> do let uname = arg "from" - msg = pkt^.body._Just - un <- use_ name - unless (un == uname) $ I.sendChanAction uname roomname (entityDecode $ tablumpDecode msg) - - "privchg" -> do let user = pkt^.parameter._Just - by = arg "by" - newPc = arg "pc" - oldPc <- getPrivclass roomname user - oldPcLevel <- getPrivclassLevel roomname (fromMaybe "" oldPc) - newPcLevel <- getPrivclassLevel roomname newPc - setUserPrivclass roomname user newPc - I.sendRoomNotice roomname $ T.concat [ user, " has been moved" - , maybe "" (" from " <>) oldPc - , " to ", newPc, " by ", by - ] - I.sendChangeUserMode user roomname oldPcLevel newPcLevel - - "kicked" -> do let uname = pkt^.parameter._Just - removeUserAll roomname uname - I.sendKick uname (arg "by") roomname $ pkt^.body.traverse ^? notNull_ - - "admin" -> case pkt^.parameter._Just of "create" -> I.sendRoomNotice roomname $ T.concat [ "Privclass ", arg "name" - , " created by ", arg "by" - , " with: ", arg "privs" ] - "update" -> I.sendRoomNotice roomname $ T.concat [ "Privclass ", arg "name" - , " updated by ", arg "by" - , " with: ", arg "privs" ] - "rename" -> I.sendRoomNotice roomname $ T.concat [ "Privclass ", arg "prev" - , " renamed to ", arg "name" - , " by ", arg "by" ] - "move" -> I.sendRoomNotice roomname $ T.concat [ arg "n", " users in privclass " - , arg "prev", " moved to " - , arg "name", " by ", arg "by" ] - "remove" -> I.sendRoomNotice roomname $ T.concat [ "Privclass", arg "name" - , " removed by ", arg "by" ] - "show" -> mapM_ (I.sendRoomNotice roomname) . T.splitOn "\n" $ pkt^.body._Just - "privclass" -> I.sendRoomNotice roomname $ "Admin error: " <> arg "e" - q -> klogError $ "Unknown admin packet type " ++ show q - - x -> klogError $ "Unknown packet type " ++ show x - - where pkt = fromJust $ subPacket spk - modifiedPkt = parsePacket (T.replace "\n\npc" "\npc" $ readable pkt) - arg s = pkt^.args.ix s - -respond pkt "kicked" = do roomname <- deformatRoom $ pkt^.parameter._Just - uname <- use_ name - removeRoom roomname - I.sendKick uname (pkt^.args.ix "by") roomname $ pkt^.body.traverse ^? notNull_ - -respond pkt "send" = I.sendNotice $ "Send error: " <> pkt^.args.ix "e" - -respond _ "ping" = get_ >>= \k -> io . writeServer k $ ("pong\n\0" :: T.Text) - -respond _ str = klog Yellow $ "Got the packet called " ++ T.unpack str - - -mkUser :: Chatroom -> PrivclassStore -> Packet -> User -mkUser room st p = User (p^.parameter._Just) - (g "pc") - (fromMaybe 0 $ st^.at room >>= (^.at (g "pc"))) - (g "symbol") - (entityDecode $ g "realname") - (g "typename") - (g "gpc") - where g s = p^.args.ix s - -errHandlers :: [Handler KevinIO ()] -errHandlers = [ handler_ _KevinException $ klogError "Malformed communication from server" - , handler _IOException (\e -> klogError $ "server: " ++ show e) ] diff --git a/Kevin/Damn/Protocol/Send.hs b/Kevin/Damn/Protocol/Send.hs deleted file mode 100644 --- a/Kevin/Damn/Protocol/Send.hs +++ /dev/null @@ -1,115 +0,0 @@ -module Kevin.Damn.Protocol.Send ( - sendPacket, - formatRoom, - deformatRoom, - - sendHandshake, - sendLogin, - sendJoin, - sendPart, - sendMsg, - sendAction, - sendNpMsg, - sendPromote, - sendDemote, - sendBan, - sendUnban, - sendKick, - sendGet, - sendWhois, - sendSet, - sendAdmin, - sendKill -) where - -import Data.Char (toLower) -import Data.List (sort) -import Data.Monoid -import qualified Data.Text as T -import Kevin.Base -import Kevin.Version - -maybeBody :: Maybe T.Text -> T.Text -maybeBody = maybe "" ("\n\n" <>) - -sendPacket :: T.Text -> KevinIO () -sendPacket p = get_ >>= \k -> io . writeServer k . T.snoc p $ '\0' - -formatRoom :: T.Text -> KevinIO T.Text -formatRoom b = case T.splitAt 1 b of ("#",s) -> return $ "chat:" <> s - ("&",s) -> do uname <- use_ name - return . ("pchat:" <>) . T.intercalate ":" . sort . map (T.map toLower) $ [uname, s] - r -> return $ "chat" <> uncurry (<>) r - -deformatRoom :: T.Text -> KevinIO T.Text -deformatRoom room = if "chat:" `T.isPrefixOf` room - then return $ '#' `T.cons` T.drop 5 room - else do uname <- use_ name - return $ T.cons '&' (head (filter (/= uname) . T.splitOn ":" . T.drop 6 $ room)) - -type Str = T.Text -- just make it shorter -type Room = Str -type Username = Str -type Pc = Str - --- * Communication to the server -sendHandshake :: KevinIO () -sendLogin :: Username -> Str -> KevinIO () -sendJoin, sendPart :: Room -> KevinIO () -sendMsg, sendAction, sendNpMsg :: Room -> Str -> KevinIO () -sendPromote, sendDemote :: Room -> Username -> Maybe Pc -> KevinIO () -sendBan, sendUnban :: Room -> Username -> KevinIO () -sendKick :: Room -> Username -> Maybe Str -> KevinIO () -sendGet :: Room -> Str -> KevinIO () -sendWhois :: Username -> KevinIO () -sendSet :: Room -> Str -> Str -> KevinIO () -sendAdmin :: Room -> Str -> KevinIO () -sendKill :: Username -> Str -> KevinIO () - -sendHandshake = sendPacket $ printf "dAmnClient 0.3\nagent=kevin%s\n" [versionStr] - -sendLogin u token = sendPacket $ printf "login %s\npk=%s\n" [u, token] - -sendJoin room = do roomname <- formatRoom room - sendPacket $ printf "join %s\n" [roomname] - -sendPart room = do roomname <- formatRoom room - sendPacket $ printf "part %s\n" [roomname] - -sendMsg = sendNpMsg - -sendAction room msg = do roomname <- formatRoom room - sendPacket $ printf "send %s\n\naction main\n\n%s" [roomname, msg] - -sendNpMsg room msg = do roomname <- formatRoom room - sendPacket $ printf "send %s\n\nnpmsg main\n\n%s" [roomname, msg] - -sendPromote room us pc = do roomname <- formatRoom room - sendPacket $ printf "send %s\n\npromote %s%s" [roomname, us, maybeBody pc] - -sendDemote room us pc = do roomname <- formatRoom room - sendPacket $ printf "send %s\n\ndemote %s%s" [roomname, us, maybeBody pc] - -sendBan room us = do roomname <- formatRoom room - sendPacket $ printf "send %s\n\nban %s\n\n" [roomname, us] - -sendUnban room us = do roomname <- formatRoom room - sendPacket $ printf "send %s\n\nunban %s\n\n" [roomname, us] - -sendKick room us reason = do roomname <- formatRoom room - sendPacket $ printf "kick %s\nu=%s%s\n" [roomname, us, maybeBody reason] - -sendGet room prop = do guard $ prop `elem` ["title", "topic", "privclasses", "members"] - roomname <- formatRoom room - sendPacket $ printf "get %s\np=%s\n" [roomname, prop] - -sendWhois us = sendPacket $ printf "get login:%s\np=info\n" [us] - -sendSet room prop val = do guard (prop == "topic" || prop == "title") - roomname <- formatRoom room - sendPacket $ printf "set %s\np=%s\n\n%s\n" [roomname, prop, val] - -sendAdmin room cmd = do roomname <- formatRoom room - sendPacket $ printf "send %s\n\nadmin\n\n%s" [roomname, cmd] - -sendKill = undefined diff --git a/Kevin/IRC/Packet.hs b/Kevin/IRC/Packet.hs deleted file mode 100644 --- a/Kevin/IRC/Packet.hs +++ /dev/null @@ -1,88 +0,0 @@ -module Kevin.IRC.Packet ( - Packet(..), - prefix, command, params, - - parsePacket, - readable -) where - -import Control.Applicative ((<|>), (<$>), (<*>), (*>), (<*)) -import Control.Lens -import Control.Monad -import Data.Attoparsec.Text -import Data.Char -import Data.Monoid -import qualified Data.Text as T -import Prelude hiding (takeWhile) - -data Packet = Packet { _prefix :: Maybe T.Text - , _command :: T.Text - , _params :: [T.Text] - } - | BadPacket deriving (Show) - -makeLenses ''Packet - -badChars :: String -badChars = "\x20\x0\xd\xa" - -spaces :: Parser T.Text -spaces = takeWhile1 isSpace - -servername :: Parser T.Text -servername = takeWhile1 (inClass "a-z0-9.-") - -username :: Parser T.Text -username = do n <- nick - u <- option "" (T.cons <$> char '!' <*> user) - h <- option "" (T.cons <$> char '@' <*> servername) - return $ T.concat [n, u, h] - -nick :: Parser T.Text -nick = T.cons <$> letter <*> takeWhile (inClass "a-zA-Z0-9[]\\`^{}-") - -user :: Parser T.Text -user = takeWhile1 (notInClass badChars) - -parsePrefix :: Parser T.Text -parsePrefix = username <|> servername - -parseCommand :: Parser T.Text -parseCommand = takeWhile1 isAlpha <|> liftM3 (\a b c -> T.pack [a,b,c]) digit digit digit - -parseParams :: Parser [T.Text] -parseParams = (colonParam <|> nonColonParam) `sepBy` spaces - -colonParam :: Parser T.Text -colonParam = char ':' *> takeWhile (notInClass "\x0\xd\xa") - -nonColonParam :: Parser T.Text -nonColonParam = takeWhile (notInClass badChars) - -crlf :: Parser T.Text -crlf = string "\r\n" - -messageBegin :: Parser (Maybe T.Text) -messageBegin = Just <$> (char ':' *> parsePrefix <* spaces) - -packetParser :: Parser Packet -packetParser = do pr <- option Nothing messageBegin - cmd <- T.map toUpper <$> parseCommand - spaces - par <- filter (not . T.null) <$> parseParams - option "" crlf - return $ Packet pr cmd par - -parsePacket :: T.Text -> Packet -parsePacket str = case parseOnly packetParser str of Left _ -> BadPacket - Right p -> p - -showParams :: [T.Text] -> T.Text -showParams = T.unwords . map (\str -> if " " `T.isInfixOf` str - then T.cons ':' str - else str) - -readable :: Packet -> T.Text -readable (Packet (Just str) cmd pms) = (<> "\r\n") $ T.unwords [T.cons ':' str, cmd, showParams pms] -readable (Packet Nothing c p) = (<> "\r\n") $ T.unwords [c, showParams p] -readable _ = "" diff --git a/Kevin/IRC/Protocol.hs b/Kevin/IRC/Protocol.hs deleted file mode 100644 --- a/Kevin/IRC/Protocol.hs +++ /dev/null @@ -1,164 +0,0 @@ -module Kevin.IRC.Protocol ( - cleanup, - listen, - errHandlers, - getAuthInfo -) where - -import Control.Applicative ((<$>)) -import Control.Arrow -import Control.Exception.Lens -import Control.Monad.State -import Data.Function (on) -import Data.List (nubBy) -import Data.Maybe -import Data.Monoid -import qualified Data.Text as T -import qualified Data.Text.IO as T -import Kevin.Base -import qualified Kevin.Damn.Protocol.Send as D -import Kevin.IRC.Packet -import Kevin.IRC.Protocol.Send -import Kevin.Util.Entity -import Kevin.Util.Logger -import Kevin.Util.Token -import Kevin.Version - -type KevinState = StateT Settings IO - -cleanup :: KevinIO () -cleanup = klog Green "cleanup client" - -listen :: KevinIO () -listen = fix (\f -> flip catches errHandlers $ do k <- get_ - pkt <- io $ parsePacket <$> readClient k - respond pkt (view command pkt) - f) - -respond :: Packet -> T.Text -> KevinIO () -respond BadPacket _ = sendNotice "Bad packet, try again." -respond pkt "JOIN" = do l <- gets_ (view loggedIn) - if l - then mapM_ D.sendJoin rooms - else kevin $ joining %= (rooms ++) - where rooms = T.splitOn "," $ pkt^.params._head - -respond pkt "PART" = mapM_ D.sendPart . T.splitOn "," $ pkt^.params._head - -respond pkt "PRIVMSG" = do let (room:msg:_) = pkt^.params - if "\1ACTION" `T.isPrefixOf` msg - then do let newMsg = T.drop 8 $ T.init msg - D.sendAction room $ entityEncode newMsg - else D.sendMsg room $ entityEncode msg - -respond pkt "MODE" = if length (pkt^.params) > 1 - then do let (toggle,mode) = first (=="+") . T.splitAt 1 $ pkt^.params.ix 1 - case mode of "b" -> if' toggle - D.sendBan - D.sendUnban - (pkt^.params._head) - (fromMaybe "random unparseable garbage" . unmask $ pkt^.params._last) - "o" -> if' toggle - D.sendPromote - D.sendDemote - (pkt^.params._head) - (pkt^.params._last) - Nothing - _ -> sendRoomNotice (pkt^.params._head) $ "Unsupported mode " <> mode - else do uname <- use_ name - sendChanMode uname (pkt^.params._head) - -respond pkt "TOPIC" = case pkt^.params of [] -> sendNotice "Malformed packet" - [room] -> D.sendGet room "topic" - (room:topic:_) -> D.sendSet room "topic" topic - -respond pkt "TITLE" = case pkt^.params of [] -> sendNotice "Malformed packet" - [room] -> do title <- gets_ . view $ titles.ix room - let p = T.concat ["Title for ", room, ": "] - mapM_ (sendRoomNotice room . (p <>)) (T.splitOn "\n" title) - (room:title) -> D.sendSet room "title" $ T.unwords title - -respond pkt "PING" = sendPong $ pkt^.params._head - -respond pkt "WHOIS" = D.sendWhois $ pkt^.params._head - -respond pkt "NAMES" = do let room = pkt^.params._head - k <- get_ - sendUserList (k^.name) (nubBy ((==) `on` username) (k^.users.ix room)) room - -respond pkt "KICK" = let p = pkt^.params - in D.sendKick (head p) - (p !! 1) - (if length p > 2 - then Just $ last p - else Nothing) - -respond _ "QUIT" = klogError "client quit" >> undefined - -respond pkt "ADMIN" = D.sendAdmin p $ T.intercalate " " ps - where (p:ps) = pkt^.params - -respond pkt "PROMOTE" = case pkt^.params of (room:user:group:_) -> D.sendPromote room user $ Just group - (room:_) -> sendRoomNotice room "Usage: /promote #room username group" - _ -> sendNotice "Usage: /promote #room username group" - -respond _ str = klogError $ T.unpack str - - -unmask :: T.Text -> Maybe T.Text -unmask y = case T.split (`elem` "@!") y of [s] -> Just s - xs -> listToMaybe $ filter (not . T.isInfixOf "*") xs - -errHandlers :: [Handler KevinIO ()] -errHandlers = [ handler_ _KevinException $ klogError "Bad communication from client" - , handler _IOException (\e -> klogError $ "client: " ++ show e) ] - --- * Authentication-getting function -notice :: Handle -> T.Text -> IO () -notice h str = do klogNow Blue ("client -> " ++ T.unpack asStr) - T.hPutStr h (asStr <> "\r\n") - where asStr = printf "NOTICE AUTH :%s" [str] - -getAuthInfo :: Handle -> Bool -> KevinState () -getAuthInfo handle = fix (\f authRetry -> do pkt <- io $ parsePacket <$> T.hGetLine handle - io $ klogNow Yellow $ "client <- " ++ T.unpack (readable pkt) - case pkt^.command of "PASS" -> do password .= pkt^.params._head - passed .= True - "NICK" -> do name .= pkt^.params._head - nicked .= True - "USER" -> usered .= True - _ -> io $ klogNow Red $ "invalid packet: " ++ show pkt - if authRetry - then checkToken handle - else do p <- use passed - n <- use nicked - u <- use usered - if p && n && u - then welcome handle - else f False) - -welcome :: Handle -> KevinState () -welcome handle = do nick <- use name - mapM_ (\x -> io $ do - klogNow Blue ("client -> " ++ T.unpack x) - T.hPutStr handle (x <> "\r\n")) [ - printf ":%s 001 %s :Welcome to dAmnServer %s!%s@chat.deviantart.com" [hostname, nick, nick, nick], - printf ":%s 002 %s :Your host is chat.deviantart.com, running dAmnServer 0.3" [hostname, nick], - printf ":%s 003 %s :This server was created Thu Apr 28 1994 at 05:30:00 EDT" [hostname, nick], - printf ":%s 004 %s chat.deviantart.com dAmnServer0.3 qov i" [hostname, nick], - printf ":%s 005 %s PREFIX=(qov)~@+" [hostname, nick], - printf ":%s 375 %s :- chat.deviantart.com Message of the day -" [hostname, nick], - printf ":%s 372 %s :- deviantART chat on IRC brought to you by kevin %s, created" [hostname, nick, versionStr], - printf ":%s 372 %s :- and maintained by Joel Taylor " [hostname, nick], - printf ":%s 376 %s :End of MOTD command" [hostname, nick]] - checkToken handle - where hostname = "chat.deviantart.com" - -checkToken :: Handle -> KevinState () -checkToken handle = do s <- get - io $ notice handle "Fetching token..." - tok <- io $ getToken (s^.name) (s^.password) - case tok of Just t -> do authtoken .= t - io $ notice handle "Successfully authenticated." - Nothing -> do io $ notice handle "Bad password, try again. (/quote pass yourpassword)" - getAuthInfo handle True diff --git a/Kevin/IRC/Protocol/Send.hs b/Kevin/IRC/Protocol/Send.hs deleted file mode 100644 --- a/Kevin/IRC/Protocol/Send.hs +++ /dev/null @@ -1,129 +0,0 @@ -module Kevin.IRC.Protocol.Send ( - sendJoin, - sendPart, - sendSetUserMode, - sendChangeUserMode, - sendNotice, - sendRoomNotice, - sendChanMsg, - sendChanAction, - sendKick, - sendTopic, - sendChanMode, - sendUserList, - sendPong, - sendNoticeClone, - sendNoticeUnclone, - sendWhoisReply -) where - -import Data.Monoid -import qualified Data.Text as T -import Kevin.Base - -hostname :: T.Text -hostname = ":chat.deviantart.com" - -getHost :: T.Text -> T.Text -getHost u = T.concat [":", u, "!", u, "@chat.deviantart.com"] - -sendPacket :: T.Text -> KevinIO () -sendPacket p = get_ >>= \k -> io . writeClient k $ p <> "\r\n" - -maybeBody :: Maybe T.Text -> T.Text -maybeBody = maybe "" (" :" <>) - -type Str = T.Text -type Room = Str -type Username = Str - -sendJoin :: Username -> Room -> KevinIO () -sendPart :: Username -> Room -> Maybe Str -> KevinIO () -sendSetUserMode :: Username -> Room -> Int -> KevinIO () -sendChangeUserMode :: Username -> Room -> Int -> Int -> KevinIO () -sendNotice :: Str -> KevinIO () -sendRoomNotice :: Room -> Str -> KevinIO () -sendChanMsg, sendChanAction :: Username -> Room -> Str -> KevinIO () -sendKick :: Username -> Username -> Room -> Maybe Str -> KevinIO () -sendTopic :: Username -> Room -> Username -> Str -> Str -> KevinIO () -sendChanMode :: Username -> Room -> KevinIO () -sendUserList :: Username -> [User] -> Room -> KevinIO () -sendPong :: T.Text -> KevinIO () -sendNoticeClone :: Username -> Int -> Room -> KevinIO () -sendNoticeUnclone :: Username -> Int -> Room -> KevinIO () -sendWhoisReply :: Username -> Username -> Username -> [Room] -> Int -> Int -> KevinIO () - -sendJoin us rm = sendPacket $ printf "%s JOIN :%s" [getHost us, rm] - -sendPart us rm msg = sendPacket $ printf "%s PART %s%s" [getHost us, rm, maybeBody msg] - -sendSetUserMode us rm m = unless (T.null mode) $ sendPacket $ printf "%s MODE %s +%s %s" [hostname, rm, mode, us] - where mode = levelToMode m - -sendChangeUserMode us rm old new = unless (oldMode == newMode) $ sendPacket $ printf "%s MODE %s %s" [hostname, rm, modesAndUser] - where oldMode = levelToMode old - newMode = levelToMode new - modesAndUser = case (oldMode, newMode) of ("", "") -> T.concat ["-v ", us] - ("", _) -> T.concat ["+", newMode, " ", us] - (_, "") -> T.concat ["-", oldMode, " ", us] - (a, b) -> T.concat ["-", a, "+", b, " ", us, " ", us] - - -sendNotice = sendPacket . printf "NOTICE AUTH :%s" . return - -sendRoomNotice room n = sendPacket $ printf "%s NOTICE %s :%s" [hostname, room, n] - -sendChanMsg sender room msg = mapM_ (\x -> sendPacket $ printf "%s PRIVMSG %s :%s" [getHost sender, room, x]) . T.splitOn "\n" $ msg - -sendChanAction sender room msg = mapM_ (\x -> sendPacket $ printf "%s PRIVMSG %s :\1ACTION %s\1" [getHost sender, room, x]) . T.splitOn "\n" $ msg - -sendKick kickee kicker room msg = sendPacket $ printf "%s KICK %s %s%s" [getHost kicker, room, kickee, maybeBody msg] - -sendTopic us rm maker top startdate = do sendPacket $ printf "%s 332 %s %s :%s" [hostname, us, rm, top] - sendPacket $ printf "%s 333 %s %s %s %s" [hostname, us, rm, maker, startdate] - -sendChanMode us rm = do sendPacket $ printf "%s 324 %s %s +t" [hostname, us, rm] - sendPacket $ printf "%s 329 %s %s 767529000" [hostname, us, rm] - -sendUserList us uss rm = do mapM_ (\nms -> sendPacket $ printf "%s 353 %s = %s :%s" [hostname, us, rm, T.unwords nms]) chunkedNames - sendPacket $ printf "%s 366 %s %s :End of /NAMES list." [hostname, us, rm] - where names = map (\u -> T.concat [levelToSym $ privclassLevel u, username u]) uss - chunkedNames = reverse . map reverse . subchunk' 432 names $ [[]] - subchunk' n = fix (\f x y -> let hy = head y - hx = head x - ty = tail y - tx = tail x - in if null x - then y - else f tx $ if sum (map T.length hy) + T.length hx <= n - then (hx:hy):ty - else [hx]:y) - -sendPong p = sendPacket $ printf "%s PONG chat.deviantart.com :%s" [hostname, p] - -sendNoticeClone uname i rm = sendPacket $ printf "%s NOTICE %s :%s has joined again (now joined %s times)" [hostname, rm, uname, T.pack $ show i] - -sendNoticeUnclone uname i rm = sendPacket $ printf "%s NOTICE %s :%s has parted (now joined %s)" [hostname, rm, uname, times] - where times | i == 1 = "once" - | otherwise = T.pack (show i) <> " times" - -sendWhoisReply me us rn rooms idle signon = do sendPacket $ printf "%s 311 %s %s %s chat.deviantart.com * :%s" [hostname, me, us, us, rn] - sendPacket $ printf "%s 307 %s %s :is a registered nick" [hostname, me, us] - sendPacket $ printf "%s 319 %s %s :%s" [hostname, me, us, T.intercalate " " . map (T.cons '#') $ rooms] - sendPacket $ printf "%s 312 %s %s chat.deviantart.com :dAmn" [hostname, me, us] - sendPacket $ printf "%s 317 %s %s %s %s :seconds idle, signon time" [hostname, me, us, T.pack $ show idle, T.pack $ show signon] - sendPacket $ printf "%s 318 %s %s :End of /WHOIS list." [hostname, me, us] - -levelToSym :: Int -> T.Text -levelToSym x | x > 0 && x <= 35 = "" - | x > 35 && x <= 70 = "+" - | x > 70 && x < 99 = "@" - | x == 99 = "~" - | otherwise = "" - -levelToMode :: Int -> T.Text -levelToMode x = case levelToSym x of "" -> "" - "+" -> "v" - "@" -> "o" - "~" -> "q" - _ -> error "levelToSym, what are you doing" diff --git a/Kevin/Protocol.hs b/Kevin/Protocol.hs deleted file mode 100644 --- a/Kevin/Protocol.hs +++ /dev/null @@ -1,57 +0,0 @@ -module Kevin.Protocol (kevinServer) where - -import Control.Exception.Lens -import Control.Monad.State -import Data.Default -import Data.Monoid (mempty) -import Kevin.Base -import qualified Kevin.Damn.Protocol as S -import qualified Kevin.IRC.Protocol as C -import Kevin.Util.Logger -import Prelude - -watchInterrupt :: [Handler IO (Maybe Kevin)] -watchInterrupt = [ handler _AsyncException throw - , handler_ id (return Nothing) ] - -mkKevin :: Socket -> IO (Maybe Kevin) -mkKevin sock = flip catches watchInterrupt . withSocketsDo - $ do (client, _, _) <- accept sock - hSetBuffering client NoBuffering - klogNow Blue "received a client" - s <- execStateT (C.getAuthInfo client False) def - damnSock <- connectTo "chat.deviantart.com" $ PortNumber 3900 - hSetBuffering damnSock NoBuffering - logChan <- newChan - damnChan <- newChan - ircChan <- newChan - return . Just $ Kevin damnSock - client - damnChan - ircChan - s - mempty - mempty - mempty - mempty - False - logChan - -mkListener :: Int -> IO Socket -mkListener = listenOn . PortNumber . fromIntegral - -kevinServer :: Int -> IO () -kevinServer n = do sock <- mkListener n - putStrLn $ "Listening on port " ++ show n - forever $ do kev <- mkKevin sock - case kev of Just k -> listen k - Nothing -> return () - -listen :: Kevin -> IO () -listen k = do mvar <- newTVarIO k - runLogger (logger k) - runPrinter (dChan k) (damn k) - runPrinter (iChan k) (irc k) - forkIO . void $ runReaderT (bracket_ S.initialize (S.cleanup >> io (closeClient k)) S.listen) mvar - forkIO . void $ runReaderT (bracket_ (return ()) (C.cleanup >> io (closeServer k)) C.listen) mvar - return () diff --git a/Kevin/Settings.hs b/Kevin/Settings.hs deleted file mode 100644 --- a/Kevin/Settings.hs +++ /dev/null @@ -1,18 +0,0 @@ -module Kevin.Settings where - -import Control.Lens -import Data.Default -import Data.Text - -data Settings = Settings { _name :: Text - , _password :: Text - , _authtoken :: Text - , _passed :: Bool - , _nicked :: Bool - , _usered :: Bool - } deriving (Show) - -makeClassy ''Settings - -instance Default Settings where - def = Settings "" "" "" False False False diff --git a/Kevin/Types.hs b/Kevin/Types.hs deleted file mode 100644 --- a/Kevin/Types.hs +++ /dev/null @@ -1,95 +0,0 @@ -module Kevin.Types ( - Kevin(Kevin, damn, irc, dChan, iChan, logger), - KevinIO, - KevinS, - Privclass, - Chatroom, - User(..), - Title, - PrivclassStore, - UserStore, - TitleStore, - kevin, - use_, - get_, - gets_, - - -- lenses - users, privclasses, titles, joining, loggedIn, - - -- other accessors - settings, - - if' -) where - -import Control.Concurrent -import Control.Concurrent.STM.TVar -import Control.Lens -import Control.Monad.Reader -import Control.Monad.STM (STM, atomically) -import Control.Monad.State -import qualified Data.Map as M -import qualified Data.Text as T -import Kevin.Settings -import System.IO - -if' :: Bool -> a -> a -> a -if' x y z = if x then y else z - -type Chatroom = T.Text - -data User = User { username :: T.Text - , privclass :: T.Text - , privclassLevel :: Int - , symbol :: T.Text - , realname :: T.Text - , typename :: T.Text - , gpc :: T.Text - } deriving (Eq, Show) - -type UserStore = M.Map Chatroom [User] - -type Privclasses = M.Map T.Text Int -type PrivclassStore = M.Map Chatroom Privclasses -type Privclass = (T.Text, Int) - -type Title = T.Text -type TitleStore = M.Map Chatroom Title - -data Kevin = Kevin { damn :: Handle - , irc :: Handle - , dChan :: Chan T.Text - , iChan :: Chan T.Text - , _kevinSettings :: Settings - , _users :: UserStore - , _privclasses :: PrivclassStore - , _titles :: TitleStore - , _joining :: [T.Text] - , _loggedIn :: Bool - , logger :: Chan String - } - -makeLenses ''Kevin - -instance HasSettings Kevin where - settings = kevinSettings - -type KevinS = StateT Kevin STM - -kevin :: KevinS a -> KevinIO a -kevin m = ask >>= \v -> liftIO $ atomically $ do s <- readTVar v - (a, t) <- runStateT m s - writeTVar v t - return a - -type KevinIO = ReaderT (TVar Kevin) IO - -use_ :: Getting a Kevin a -> KevinIO a -use_ = gets_ . view - -get_ :: KevinIO Kevin -get_ = ask >>= liftIO . readTVarIO - -gets_ :: (Kevin -> a) -> KevinIO a -gets_ = flip liftM get_ diff --git a/Kevin/Util/Entity.hs b/Kevin/Util/Entity.hs deleted file mode 100644 --- a/Kevin/Util/Entity.hs +++ /dev/null @@ -1,139 +0,0 @@ -module Kevin.Util.Entity ( - entityEncode, - entityDecode -) where - -import Control.Applicative ((<|>), (<$>), (<*>)) -import Control.Monad (guard) -import Control.Monad.Fix -import Data.Attoparsec.Text -import Data.Char -import Data.Maybe -import Data.Monoid -import qualified Data.Text as T -import qualified Data.Text.Read as R -import Prelude hiding (take) - -decodeCharacter :: Parser T.Text -decodeCharacter = entityNumeric <|> entityNamed <|> take 1 - -entityNumeric :: Parser T.Text -entityNumeric = do string "&#" - entity <- (<>) <$> option "" (string "x") <*> takeWhile1 isHexDigit - char ';' - return . fromMaybe (T.concat ["&#", entity, ";"]) $ (if "x" `T.isPrefixOf` entity - then lookupHexEntity - else lookupNumericEntity) entity - -entityNamed :: Parser T.Text -entityNamed = do char '&' - entity <- T.cons <$> letter <*> takeWhile1 isAlphaNum - char ';' - return . fromMaybe (T.concat ["&", entity, ";"]) . lookupNamedEntity $ entity - -decodeParser :: Parser T.Text -decodeParser = T.concat <$> many1 decodeCharacter - -entityDecode :: T.Text -> T.Text -entityDecode "" = "" -entityDecode str = case parseOnly decodeParser str of Left err -> error $ "entityDecode: " ++ err - Right s -> s - -entityEncode :: T.Text -> T.Text -entityEncode = T.pack . concat . entityEncodeS . T.unpack - -entityEncodeS :: String -> [String] -entityEncodeS = fix (\f str -> case str of [] -> [] - (x:xs) -> if x < '\127' - then [x]:f xs - else ("&#" ++ show (ord x) ++ ";"):f xs) - -lookupNamedEntity :: T.Text -> Maybe T.Text -lookupNamedEntity ent = (T.singleton . chr) <$> lookup ent namedEntities - -lookupHexEntity :: T.Text -> Maybe T.Text -lookupHexEntity e = case R.hexadecimal $ T.cons '0' e of Right (n,_) -> do guard $ n < ord maxBound - return . T.singleton . chr $ n - Left _ -> Nothing - -lookupNumericEntity :: T.Text -> Maybe T.Text -lookupNumericEntity e = case R.decimal e of Right (n,_) -> do guard $ n < ord maxBound - return . T.singleton . chr $ n - Left _ -> Nothing - -namedEntities :: [(T.Text, Int)] -namedEntities = [ ("quot", 34), ("amp", 38), ("apos", 39), ("lt", 60) - , ("gt", 62), ("nbsp", 160), ("iexcl", 161), ("cent", 162) - , ("pound", 163), ("curren", 164), ("yen", 165) - , ("brvbar", 166), ("sect", 167), ("uml", 168), ("copy", 169) - , ("ordf", 170), ("laquo", 171), ("not", 172), ("shy", 173) - , ("reg", 174), ("macr", 175), ("deg", 176), ("plusmn", 177) - , ("sup2", 178), ("sup3", 179), ("acute", 180), ("micro", 181) - , ("para", 182), ("middot", 183), ("cedil", 184), ("sup1", 185) - , ("ordm", 186), ("raquo", 187), ("frac14", 188) - , ("frac12", 189), ("frac34", 190), ("iquest", 191) - , ("Agrave", 192), ("Aacute", 193), ("Acirc", 194) - , ("Atilde", 195), ("Auml", 196), ("Aring", 197) - , ("AElig", 198), ("Ccedil", 199), ("Egrave", 200) - , ("Eacute", 201), ("Ecirc", 202), ("Euml", 203) - , ("Igrave", 204), ("Iacute", 205), ("Icirc", 206) - , ("Iuml", 207), ("ETH", 208), ("Ntilde", 209), ("Ograve", 210) - , ("Oacute", 211), ("Ocirc", 212), ("Otilde", 213) - , ("Ouml", 214), ("times", 215), ("Oslash", 216) - , ("Ugrave", 217), ("Uacute", 218), ("Ucirc", 219) - , ("Uuml", 220), ("Yacute", 221), ("THORN", 222) - , ("szlig", 223), ("agrave", 224), ("aacute", 225) - , ("acirc", 226), ("atilde", 227), ("auml", 228) - , ("aring", 229), ("aelig", 230), ("ccedil", 231) - , ("egrave", 232), ("eacute", 233), ("ecirc", 234) - , ("euml", 235), ("igrave", 236), ("iacute", 237) - , ("icirc", 238), ("iuml", 239), ("eth", 240), ("ntilde", 241) - , ("ograve", 242), ("oacute", 243), ("ocirc", 244) - , ("otilde", 245), ("ouml", 246), ("divide", 247) - , ("oslash", 248), ("ugrave", 249), ("uacute", 250) - , ("ucirc", 251), ("uuml", 252), ("yacute", 253) - , ("thorn", 254), ("yuml", 255), ("OElig", 338), ("oelig", 339) - , ("Scaron", 352), ("scaron", 353), ("Yuml", 376) - , ("fnof", 402), ("circ", 710), ("tilde", 732), ("Alpha", 913) - , ("Beta", 914), ("Gamma", 915), ("Delta", 916) - , ("Epsilon", 917), ("Zeta", 918), ("Eta", 919), ("Theta", 920) - , ("Iota", 921), ("Kappa", 922), ("Lambda", 923), ("Mu", 924) - , ("Nu", 925), ("Xi", 926), ("Omicron", 927), ("Pi", 928) - , ("Rho", 929), ("Sigma", 931), ("Tau", 932), ("Upsilon", 933) - , ("Phi", 934), ("Chi", 935), ("Psi", 936), ("Omega", 937) - , ("alpha", 945), ("beta", 946), ("gamma", 947), ("delta", 948) - , ("epsilon", 949), ("zeta", 950), ("eta", 951), ("theta", 952) - , ("iota", 953), ("kappa", 954), ("lambda", 955), ("mu", 956) - , ("nu", 957), ("xi", 958), ("omicron", 959), ("pi", 960) - , ("rho", 961), ("sigmaf", 962), ("sigma", 963), ("tau", 964) - , ("upsilon", 965), ("phi", 966), ("chi", 967), ("psi", 968) - , ("omega", 969), ("thetasym", 977), ("upsih", 978) - , ("piv", 982), ("ensp", 8194), ("emsp", 8195) - , ("thinsp", 8201), ("zwnj", 8204), ("zwj", 8205) - , ("lrm", 8206), ("rlm", 8207), ("ndash", 8211) - , ("mdash", 8212), ("lsquo", 8216), ("rsquo", 8217) - , ("sbquo", 8218), ("ldquo", 8220), ("rdquo", 8221) - , ("bdquo", 8222), ("dagger", 8224), ("Dagger", 8225) - , ("bull", 8226), ("hellip", 8230), ("permil", 8240) - , ("prime", 8242), ("Prime", 8243), ("lsaquo", 8249) - , ("rsaquo", 8250), ("oline", 8254), ("frasl", 8260) - , ("euro", 8364), ("image", 8465), ("weierp", 8472) - , ("real", 8476), ("trade", 8482), ("alefsym", 8501) - , ("larr", 8592), ("uarr", 8593), ("rarr", 8594) - , ("darr", 8595), ("harr", 8596), ("crarr", 8629) - , ("lArr", 8656), ("uArr", 8657), ("rArr", 8658) - , ("dArr", 8659), ("hArr", 8660), ("forall", 8704) - , ("part", 8706), ("exist", 8707), ("empty", 8709) - , ("nabla", 8711), ("isin", 8712), ("notin", 8713) - , ("ni", 8715), ("prod", 8719), ("sum", 8721), ("minus", 8722) - , ("lowast", 8727), ("radic", 8730), ("prop", 8733) - , ("infin", 8734), ("ang", 8736), ("and", 8743), ("or", 8744) - , ("cap", 8745), ("cup", 8746), ("int", 8747), ("there4", 8756) - , ("sim", 8764), ("cong", 8773), ("asymp", 8776), ("ne", 8800) - , ("equiv", 8801), ("le", 8804), ("ge", 8805), ("sub", 8834) - , ("sup", 8835), ("nsub", 8836), ("sube", 8838), ("supe", 8839) - , ("oplus", 8853), ("otimes", 8855), ("perp", 8869) - , ("sdot", 8901), ("lceil", 8968), ("rceil", 8969) - , ("lfloor", 8970), ("rfloor", 8971), ("lang", 9001) - , ("rang", 9002), ("loz", 9674), ("spades", 9824) - , ("clubs", 9827), ("hearts", 9829), ("diams", 9830)] diff --git a/Kevin/Util/Logger.hs b/Kevin/Util/Logger.hs deleted file mode 100644 --- a/Kevin/Util/Logger.hs +++ /dev/null @@ -1,59 +0,0 @@ -module Kevin.Util.Logger ( - klog, - klog_, - klogNow, - klogError, - klogWarn, - Color(..), - runLogger, - printf -) where - -import Control.Concurrent -import Control.Monad.State -import Data.Char (isSpace) -import qualified Data.Text as T -import Kevin.Types - -data Color = Red | Blue | Green | Cyan | Magenta | Yellow | Gray - -colorAsNum :: Color -> Int -colorAsNum Red = 31 -colorAsNum Green = 32 -colorAsNum Yellow = 33 -colorAsNum Blue = 34 -colorAsNum Magenta = 35 -colorAsNum Cyan = 36 -colorAsNum Gray = 37 - -runLogger :: Chan String -> IO () -runLogger ch = void . forkIO . forever $ readChan ch >>= putStrLn - -interleave :: [a] -> [a] -> [a] -interleave xs [] = xs -interleave [] ys = ys -interleave (x:xs) (y:ys) = x:y:interleave xs ys - -printf :: T.Text -> [T.Text] -> T.Text -printf str reps = T.concat $ interleave (T.splitOn "%s" str) reps - -render :: Color -> String -> String -render col str = "\027[" ++ show (colorAsNum col) - ++ "m" ++ rtrimmed - ++ "\027[0m" - where - rtrimmed = reverse . dropWhile (\x -> isSpace x || x == '\x0') . reverse $ str - -klog_ :: Chan String -> Color -> String -> IO () -klog_ ch col str = writeChan ch $ render col str - -klogNow :: Color -> String -> IO () -klogNow c s = putStrLn $ render c s - -klog :: Color -> String -> KevinIO () -klog c str = gets_ logger >>= \ch -> liftIO $ klog_ ch c str - -klogError, klogWarn :: String -> KevinIO () - -klogError = klog Red . ("ERROR :: " ++) -klogWarn = klog Yellow . ("WARNING :: " ++) diff --git a/Kevin/Util/Tablump.hs b/Kevin/Util/Tablump.hs deleted file mode 100644 --- a/Kevin/Util/Tablump.hs +++ /dev/null @@ -1,76 +0,0 @@ -{-# OPTIONS_GHC -fno-warn-incomplete-patterns #-} - -module Kevin.Util.Tablump ( - tablumpDecode -) where - -import Control.Arrow -import Control.Monad.Fix -import qualified Data.Text as T -import System.IO.Unsafe -import Text.Printf -import Text.Regex.PCRE -import Text.Regex.PCRE.String - -fromRight :: (Show a) => Either a b -> b -fromRight (Left x) = error $ "fromRight on Left " ++ show x -fromRight (Right a) = a - -{-# NOINLINE regexReplace #-} -regexReplace :: Regex -> ([String] -> String) -> String -> String -regexReplace find replace = fix (\f str -> - case fromRight . unsafePerformIO $ regexec find str of Just (bef, _, af, matches) -> concat [bef, replace matches, f af] - Nothing -> str) - -{-# NOINLINE regexen #-} -regexen :: [(Regex, [String] -> String)] -regexen = let ($$) = (,) in map ( - first (fromRight . unsafePerformIO - . compile defaultCompOpt defaultExecOpt) - ) . reverse $ [ - "&b\t" $$ const "\2", - "&/b\t" $$ const "\15", - "&i\t" $$ const "\22", - "&/i\t" $$ const "\15", - "&u\t" $$ const "\31", - "&/u\t" $$ const "\15", - "&s\t" $$ const "", - "&/s\t" $$ const "", - "&sup\t" $$ const "", - "&/sup\t" $$ const "", - "&sub\t" $$ const "", - "&/sub\t" $$ const "", - "&code\t" $$ const "", - "&/code\t" $$ const "", - "&br\t" $$ const "\n", - "&ul\t" $$ const "", - "&/ul\t" $$ const "", - "&ol\t" $$ const "", - "&/ol\t" $$ const "", - "&li\t" $$ const "- ", - "&/li\t" $$ const "\n", - "&bcode\t" $$ const "", - "&/bcode\t" $$ const "", - "&/a\t" $$ const ")", - "&/acro\t" $$ const "", - "&/abbr\t" $$ const "", - "&p\t" $$ const "", - "&/p\t" $$ const "\n", - "&emote\t(.+?)\t.+?\t.+?\t.+?\t.+?\t" $$ head, - "&a\t(.+?)\t.*?\t" $$ \(x:_) -> printf "%s (" x, - "&link\t(.+?)\t&\t" $$ head, - "&link\t(.+?)\t(.+?)\t&\t" $$ \(x:y:_) -> printf "%s (%s)" x y, - "&dev\t.+?\t(.+?)\t" $$ head, - "&avatar\t(.+?)\t.+?\t" $$ \(x:_) -> printf ":icon%s:" x, - "&thumb\t.+?\t(.+?)\t.+?\t.+?\t.+?\t.+?\t" $$ \(x:_) -> printf "[thumb: %s]" x, - "&img\t(.+?)\t(.*?)\t(.*?)\t" $$ \(x:y:z:_) -> printf "%s" x y z, - "&iframe\t(.+?)\t(.*?)\t(.*?)\t" $$ \(x:y:z:_) -> printf "