kevin 0.2 → 0.4
raw patch · 12 files changed
+264/−247 lines, 12 filesdep +MonadCatchIO-transformersdep +lensdep −MonadCatchIO-mtldep −data-lensdep −data-lens-templatedep ~cprng-aesdep ~networkdep ~stm
Dependencies added: MonadCatchIO-transformers, lens
Dependencies removed: MonadCatchIO-mtl, data-lens, data-lens-template
Dependency ranges changed: cprng-aes, network, stm, tls, tls-extra
Files
- Kevin/Base.hs +10/−89
- Kevin/Chatrooms.hs +77/−0
- Kevin/Damn/Protocol.hs +54/−54
- Kevin/Damn/Protocol/Send.hs +4/−4
- Kevin/IRC/Packet.hs +1/−1
- Kevin/IRC/Protocol.hs +19/−14
- Kevin/IRC/Protocol/Send.hs +3/−11
- Kevin/Protocol.hs +9/−10
- Kevin/Settings.hs +13/−34
- Kevin/Types.hs +34/−22
- Kevin/Util/Token.hs +2/−3
- kevin.cabal +38/−5
Kevin/Base.hs view
@@ -3,34 +3,12 @@ KevinException(..), KevinServer(..), User(..),- - -- * Modifiers- addUser,- removeUser,- removeUserAll,- setUsers,- numUsers,- - addPrivclass,- setPrivclasses,- getPcLevel,- getPc,- setUserPrivclass,- changePrivclassName,- - removeRoom,- - setTitle,- - -- * Exports+ module K,- - -- * Working with KevinState+ io, runPrinter,- - if',- + printf ) where @@ -38,8 +16,7 @@ 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, findIndices)-import Data.Maybe+import Data.List (intercalate) import System.IO as K import System.IO.Error import Control.Exception as K (IOException)@@ -50,19 +27,13 @@ import Control.Concurrent.Chan as K import Control.Concurrent.STM.TVar as K import Control.Exception+import Control.Lens as K import Control.Monad.CatchIO as K import Kevin.Settings as K-import qualified Data.Map as M+import Kevin.Chatrooms as K import Data.Typeable-import Data.Lens.Common as K import Kevin.Types -if' :: Bool -> a -> a -> a-if' x y z = if x then y else z--mapWhen :: (a -> Bool) -> (a -> a) -> [a] -> [a]-mapWhen f g = map (\x -> if f x then g x else x)- runPrinter :: Chan T.Text -> Handle -> IO () runPrinter ch h = void $ forkIO $ forever $ readChan ch >>= T.hPutStr h . T.encodeUtf8 @@ -81,7 +52,7 @@ instance Exception KevinException -- 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 @@ -96,7 +67,7 @@ else throwIO $ mkIOError eofErrorType "read timeout" (Just h) Nothing hGetSep :: Char -> Handle -> IO String-hGetSep sep h = fix (\f -> hGetCharTimeout h 90000 >>= \ch -> if ch == sep then return "" else (ch:) <$> f)+hGetSep sep h = fix (\f -> hGetCharTimeout h 180000 >>= \ch -> if ch == sep then return "" else (ch:) <$> f) instance KevinServer Kevin where readClient k = do@@ -107,63 +78,13 @@ line <- T.pack <$> hGetSep '\NUL' (damn k) klog_ (logger k) Cyan $ "server <- " ++ padLines 10 line return line- + writeClient k pkt = do klog_ (logger k) Blue $ "client -> " ++ padLines 10 pkt writeChan (iChan k) pkt writeServer k pkt = do klog_ (logger k) Magenta $ "server -> " ++ padLines 10 pkt writeChan (dChan k) pkt- + closeClient = hClose . irc closeServer = hClose . damn---- Kevin modifiers-removeRoom :: Chatroom -> Kevin -> Kevin-removeRoom c = (privclasses ^%= M.delete c) . (users ^%= M.delete c)--addUser :: Chatroom -> User -> UserStore -> UserStore-addUser = (. return) . M.insertWith (++)--numUsers :: Chatroom -> T.Text -> UserStore -> Int-numUsers room us st = case M.lookup room st of- Just usrs -> length $ findIndices (\u -> us == username u) usrs- Nothing -> 0--removeUser :: Chatroom -> T.Text -> UserStore -> UserStore-removeUser room us = M.adjust (removeOne' (\x -> username x == us)) room--removeUserAll :: Chatroom -> T.Text -> UserStore -> UserStore-removeUserAll room us = M.adjust (filter (\x -> username x /= us)) room--removeOne' :: (User -> Bool) -> [User] -> [User]-removeOne' _ [] = []-removeOne' f (x:xs) = if f x then xs else x:removeOne' f xs--setUsers :: Chatroom -> [User] -> UserStore -> UserStore-setUsers = M.insert--addPrivclass :: Chatroom -> Privclass -> PrivclassStore -> PrivclassStore-addPrivclass room (p,i) = M.insertWith M.union room (M.singleton p i)--setPrivclasses :: Chatroom -> [Privclass] -> PrivclassStore -> PrivclassStore-setPrivclasses room ps = M.insert room (M.fromList ps)--getPc :: Chatroom -> T.Text -> UserStore -> Maybe T.Text-getPc room user st = case M.lookup room st of- Just qs -> privclass <$> listToMaybe (filter (\u -> username u == user) qs)- Nothing -> Nothing--getPcLevel :: Chatroom -> T.Text -> PrivclassStore -> Int-getPcLevel room pcname store = fromMaybe 0 $ M.lookup room store >>= M.lookup pcname--setUserPrivclass :: Chatroom -> T.Text -> T.Text -> Kevin -> Kevin-setUserPrivclass room user pc k = (users ^%= M.adjust (mapWhen ((user ==) . username) (\u -> u {privclass = pc, privclassLevel = pclevel})) room) k- where- pclevel = getPcLevel room pc $ k ^. privclasses--changePrivclassName :: Chatroom -> T.Text -> T.Text -> UserStore -> UserStore-changePrivclassName room old new = M.adjust (mapWhen ((old ==) . privclass) (\u -> u {privclass = new})) room--setTitle :: Chatroom -> Title -> TitleStore -> TitleStore-setTitle = M.insert
+ Kevin/Chatrooms.hs view
@@ -0,0 +1,77 @@+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 Data.Monoid+import qualified Data.Text as T+import qualified Data.Map as M+import Data.Maybe+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 .= 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)++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 .= Just t
Kevin/Damn/Protocol.hs view
@@ -17,7 +17,6 @@ import Kevin.Damn.Protocol.Send import qualified Kevin.IRC.Protocol.Send as I import Control.Applicative ((<$>))-import Control.Arrow ((&&&)) import Data.Time.Clock.POSIX (getPOSIXTime) initialize :: KevinIO ()@@ -36,23 +35,23 @@ -- main responder respond :: Packet -> T.Text -> KevinIO () respond _ "dAmnServer" = do- set <- gets_ settings- let uname = getUsername set- token = getAuthtoken set- sendLogin uname token+ s <- use_ settings+ sendLogin (s^.name) (s^.authtoken) respond pkt "login" = if okay pkt then do- modify_ $ loggedIn ^= True- gets_ (^. joining) >>= mapM_ sendJoin+ j <- kevin $ do+ loggedIn .= True+ use joining+ mapM_ sendJoin j else I.sendNotice $ "Login failed: " `T.append` getArg "e" pkt respond pkt "join" = do roomname <- deformatRoom . fromJust . parameter $ pkt if okay pkt then do- modify_ $ joining ^%= (roomname:)- uname <- gets_ $ getUsername . settings+ kevin $ joining %= (roomname:)+ uname <- use_ name I.sendJoin uname roomname else I.sendNotice $ T.concat ["Couldn't join ", roomname, ": ", getArg "e" pkt] @@ -60,8 +59,8 @@ roomname <- deformatRoom . fromJust . parameter $ pkt if okay pkt then do- uname <- gets_ $ getUsername . settings- modify_ $ removeRoom roomname+ uname <- use_ name+ removeRoom roomname I.sendPart uname roomname Nothing else I.sendNotice $ T.concat ["Couldn't part ", roomname, ": ", getArg "e" pkt] @@ -69,28 +68,28 @@ case getArg "p" pkt of "privclasses" -> do let pcs = parsePrivclasses . fromJust . body $ pkt- modify_ $ privclasses ^%= setPrivclasses roomname pcs- + setPrivclasses roomname pcs+ "topic" -> do- uname <- gets_ $ getUsername . settings+ uname <- use_ name I.sendTopic uname roomname (getArg "by" pkt) (T.replace "\n" " - " . entityDecode . tablumpDecode . fromJust . body $ pkt) (getArg "ts" pkt)- - "title" -> modify_ $ titles ^%= setTitle roomname (T.replace "\n" " - " . entityDecode . tablumpDecode . fromJust . body $ pkt)- ++ "title" -> setTitle roomname (T.replace "\n" " - " . entityDecode . tablumpDecode . fromJust . body $ pkt)+ "members" -> do- (pcs,(uname,j)) <- gets_ $ getL privclasses &&& getUsername . settings &&& getL joining- let members = map (mkUser roomname pcs . parsePacket) . init . splitOn "\n\n" . fromJust $ body pkt- pc = privclass . head . filter (\x -> username x == uname) $ members+ 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- modify_ $ users ^%= setUsers roomname members- when (roomname `elem` j) $ do- I.sendUserList uname n roomname- I.sendWhoList uname n roomname- I.sendSetUserMode uname roomname $ getPcLevel roomname pc pcs- modify_ $ joining ^%= delete roomname- + 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 <- gets_ $ getUsername . settings+ 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@@ -100,59 +99,60 @@ (onlinespan,idle) = head . sortBy (comparing fst) . map (\(a,b,_) -> (a,b)) $ conns signon = curtime - onlinespan I.sendWhoisReply us uname (entityDecode rn) allRooms idle signon- + q -> klogError $ "Unrecognized property " ++ T.unpack q respond spk "recv" = deformatRoom (fromJust $ parameter spk) >>= \roomname -> case command pkt of "join" -> do let usname = fromJust $ parameter pkt- (pcs,countUser) <- gets_ $ getL privclasses &&& numUsers roomname usname . getL users+ pcs <- gets_ $ view privclasses+ countUser <- numUsers roomname usname let us = mkUser roomname pcs modifiedPkt- modify_ $ users ^%= addUser roomname us+ addUser roomname us if countUser == 0 then do I.sendJoin usname roomname- I.sendSetUserMode usname roomname $ getPcLevel roomname (getArg "pc" modifiedPkt) pcs+ pclevel <- getPrivclassLevel roomname (getArg "pc" modifiedPkt)+ I.sendSetUserMode usname roomname pclevel else I.sendNoticeClone (username us) (succ countUser) roomname- + "part" -> do let uname = fromJust $ parameter pkt- modify_ $ users ^%= removeUser roomname uname- countUser <- gets_ $ numUsers roomname uname . getL users+ removeUser roomname uname+ countUser <- numUsers roomname uname if countUser < 1 then I.sendPart uname roomname $ case getArg "r" pkt of { "" -> Nothing; x -> Just x } else I.sendNoticeUnclone uname countUser roomname- + "msg" -> do let uname = arg "from" msg = fromJust (body pkt)- un <- gets_ $ getUsername . settings+ un <- use_ name unless (un == uname) $ I.sendChanMsg uname roomname (entityDecode $ tablumpDecode msg)- + "action" -> do let uname = arg "from" msg = fromJust (body pkt)- un <- gets_ $ getUsername . settings+ un <- use_ name unless (un == uname) $ I.sendChanAction uname roomname (entityDecode $ tablumpDecode msg)- + "privchg" -> do- (pcs,us) <- gets_ $ getL privclasses &&& getL users let user = fromJust $ parameter pkt by = arg "by"- oldPc = getPc roomname user us newPc = arg "pc"- oldPcLevel = fmap (\p -> getPcLevel roomname p pcs) oldPc- newPcLevel = getPcLevel roomname newPc pcs- modify_ $ setUserPrivclass roomname user newPc+ 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.sendChangeUserMode user roomname (fromMaybe 0 oldPcLevel) newPcLevel+ I.sendChangeUserMode user roomname oldPcLevel newPcLevel "kicked" -> do let uname = fromJust $ parameter pkt- modify_ $ users ^%= removeUserAll roomname uname+ removeUserAll roomname uname I.sendKick uname (arg "by") roomname $ case body pkt of {Just "" -> Nothing; x -> x}- + "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"]@@ -162,18 +162,18 @@ "show" -> mapM_ (I.sendRoomNotice roomname) . T.splitOn "\n" . fromJust . body $ pkt "privclass" -> I.sendRoomNotice roomname $ "Admin error: " `T.append` 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" (fromJust $ body spk)) arg = flip getArg pkt- + respond pkt "kicked" = do roomname <- deformatRoom (fromJust $ parameter pkt)- uname <- gets_ $ getUsername . settings- modify_ $ removeRoom roomname+ uname <- use_ name+ removeRoom roomname I.sendKick uname (getArg "by" pkt) roomname $ case body pkt of {Just "" -> Nothing; x -> x} respond pkt "send" = I.sendNotice $ T.concat ["Send error: ", getArg "e" pkt]@@ -186,7 +186,7 @@ mkUser :: Chatroom -> PrivclassStore -> Packet -> User mkUser room st p = User (fromJust $ parameter p) (g "pc")- (getPcLevel room (g "pc") st)+ (fromMaybe 0 $ st^.at room >>= (^.at (g "pc"))) (g "symbol") (entityDecode $ g "realname") (g "typename")
Kevin/Damn/Protocol/Send.hs view
@@ -2,7 +2,7 @@ sendPacket, formatRoom, deformatRoom,- + sendHandshake, sendLogin, sendJoin,@@ -34,11 +34,11 @@ sendPacket p = get_ >>= \k -> io . writeServer k . T.snoc p $ '\0' formatRoom :: T.Text -> KevinIO T.Text-formatRoom b = +formatRoom b = case T.splitAt 1 b of ("#",s) -> return $ "chat:" `T.append` s ("&",s) -> do- uname <- gets_ (getUsername . settings)+ 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 @@ -46,7 +46,7 @@ deformatRoom room = if "chat:" `T.isPrefixOf` room then return $ '#' `T.cons` T.drop 5 room else do- uname <- gets_ (getUsername . settings)+ uname <- use_ name return $ '&' `T.cons` head (filter (/= uname) . T.splitOn ":" . T.drop 6 $ room) type Str = T.Text -- just make it shorter
Kevin/IRC/Packet.hs view
@@ -31,7 +31,7 @@ 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[]\\`^{}-")
Kevin/IRC/Protocol.hs view
@@ -40,7 +40,7 @@ l <- gets_ (^. loggedIn) if l then mapM_ D.sendJoin rooms- else modify_ $ joining ^%= (rooms ++)+ else kevin $ joining %= (rooms ++) where rooms = T.splitOn "," . head . params $ pkt @@ -62,7 +62,7 @@ "o" -> if' toggle D.sendPromote D.sendDemote (head $ params pkt) (last $ params pkt) Nothing _ -> sendRoomNotice (head $ params pkt) $ "Unsupported mode " `T.append` mode else do- uname <- gets_ (getUsername . settings)+ uname <- use_ name sendChanMode uname (head $ params pkt) respond pkt "TOPIC" = case params pkt of@@ -74,7 +74,7 @@ [] -> sendNotice "Malformed packet" [room] -> do title <- gets_ $ M.lookup room . (^. titles)- let pre = T.concat ["Title for ", room, ": "] in mapM_ (sendRoomNotice room . T.append pre) (T.splitOn "\n" $ fromMaybe "" title)+ 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)@@ -83,8 +83,8 @@ respond pkt "NAMES" = do let (room:_) = params pkt- (me,uss) <- gets_ $ getUsername . settings &&& M.lookup room . getL users- sendUserList me (nubBy ((==) `on` username) $ fromMaybe [] uss) room+ 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) @@ -120,14 +120,20 @@ pkt <- io $ parsePacket <$> T.hGetLine handle io $ klogNow Yellow $ "client <- " ++ T.unpack (readable pkt) case command pkt of- "PASS" -> modify (setHasPassed . setPassword (head $ params pkt))- "NICK" -> modify (setHasNicked . setUsername (head $ params pkt))- "USER" -> modify setHasUsered+ "PASS" -> do+ password .= head (params pkt)+ passed .= True+ "NICK" -> do+ name .= head (params pkt)+ nicked .= True+ "USER" -> usered .= True _ -> io $ klogNow Red $ "invalid packet: " ++ show pkt if authRetry then checkToken handle else do- (p,(n,u)) <- gets (hasPassed &&& hasNicked &&& hasUsered)+ p <- use passed+ n <- use nicked+ u <- use usered if p && n && u then welcome handle else f False@@ -135,7 +141,7 @@ welcome :: Handle -> KevinState () welcome handle = do- nick <- gets getUsername+ nick <- use name mapM_ (\x -> io $ klogNow Blue ("client -> " ++ T.unpack x) >> T.hPutStr handle (x `T.append` "\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],@@ -152,13 +158,12 @@ checkToken :: Handle -> KevinState () checkToken handle = do- nick <- gets getUsername- pass <- gets getPassword+ s <- get io $ notice handle "Fetching token..."- tok <- io $ getToken nick pass+ tok <- io $ getToken (s^.name) (s^.password) case tok of Just t -> do- modify (setAuthtoken t)+ authtoken .= t io $ notice handle "Successfully authenticated." Nothing -> do io $ notice handle "Bad password, try again. (/quote pass yourpassword)"
Kevin/IRC/Protocol/Send.hs view
@@ -11,13 +11,12 @@ sendTopic, sendChanMode, sendUserList,- sendWhoList, sendPong, sendNoticeClone, sendNoticeUnclone, sendWhoisReply ) where- + import Kevin.Base import qualified Data.Text as T @@ -48,7 +47,6 @@ sendTopic :: Username -> Room -> Username -> Str -> Str -> KevinIO () sendChanMode :: Username -> Room -> KevinIO () sendUserList :: Username -> [User] -> Room -> KevinIO ()-sendWhoList :: Username -> [User] -> Room -> KevinIO () sendPong :: T.Text -> KevinIO () sendNoticeClone :: Username -> Int -> Room -> KevinIO () sendNoticeUnclone :: Username -> Int -> Room -> KevinIO ()@@ -102,9 +100,9 @@ sendPacket $ printf "%s 329 %s %s 767529000" [hostname, us, rm] sendUserList us uss rm = do- mapM_ (\nms -> + 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]+ 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 $ [[]]@@ -113,12 +111,6 @@ else if sum (map T.length hy) + T.length hx <= n then f tx ((hx:hy):ty) else f tx ([hx]:y))--sendWhoList us uss rm = do- mapM_ (sendPacket . (\u ->- printf "%s 352 %s %s %s chat.deviantart.com chat.deviantart.com %s Hr%s :0 %s" [hostname, us, rm, username u, username u, symbol u, realname u]- )) uss- sendPacket $ printf "%s 315 %s %s :End of WHO list." [hostname, us, rm] sendPong p = sendPacket $ printf "%s PONG chat.deviantart.com :%s" [hostname, p]
Kevin/Protocol.hs view
@@ -6,7 +6,6 @@ import qualified Control.Exception as E import qualified Kevin.IRC.Protocol as C import qualified Kevin.Damn.Protocol as S-import System.IO (hSetBuffering, BufferMode(..)) import Control.Monad.State import Data.Monoid (mempty) @@ -19,7 +18,7 @@ (client, _, _) <- accept sock hSetBuffering client NoBuffering klogNow Blue "received a client"- set <- execStateT (C.getAuthInfo client False) emptySettings+ s <- execStateT (C.getAuthInfo client False) emptySettings damnSock <- connectTo "chat.deviantart.com" $ PortNumber 3900 hSetBuffering damnSock NoBuffering logChan <- newChan@@ -29,7 +28,7 @@ client damnChan ircChan- set+ s mempty mempty mempty@@ -51,11 +50,11 @@ Nothing -> return () listen :: Kevin -> IO ()-listen kevin = do- mvar <- newTVarIO kevin- runLogger (logger kevin)- runPrinter (dChan kevin) (damn kevin)- runPrinter (iChan kevin) (irc kevin)- forkIO . void $ runReaderT (bracket_ S.initialize (S.cleanup >> io (closeClient kevin)) S.listen) mvar- forkIO . void $ runReaderT (bracket_ (return ()) (C.cleanup >> io (closeServer kevin)) C.listen) mvar+listen k = do+ mvar <- newTVarIO k+ runLogger (logger k)+ runPrinter (dChan k) (damn k)+ runPrinter (iChan k) (irc k)+ forkIO . void $ runReaderT (bracket_ S.initialize (S.cleanup >> io (closeClient k)) S.listen) mvar+ forkIO . void $ runReaderT (bracket_ (return ()) (C.cleanup >> io (closeServer k)) C.listen) mvar return ()
Kevin/Settings.hs view
@@ -1,39 +1,18 @@-module Kevin.Settings (- Settings(..),- emptySettings,- setUsername,- setAuthtoken,- setPassword,- setHasPassed,- setHasNicked,- setHasUsered-) where- +{-# LANGUAGE TemplateHaskell #-}+module Kevin.Settings where++import Control.Lens import Data.Text -data Settings = Settings { getUsername :: Text- , getPassword :: Text- , getAuthtoken :: Text- , hasPassed :: Bool- , hasNicked :: Bool- , hasUsered :: Bool+data Settings = Settings { _name :: Text+ , _password :: Text+ , _authtoken :: Text+ , _passed :: Bool+ , _nicked :: Bool+ , _usered :: Bool } deriving (Show) -emptySettings :: Settings-emptySettings = Settings { getUsername = ""- , getPassword = ""- , getAuthtoken = ""- , hasPassed = False- , hasNicked = False- , hasUsered = False- }--setUsername, setAuthtoken, setPassword :: Text -> Settings -> Settings-setHasPassed, setHasNicked, setHasUsered :: Settings -> Settings+makeClassy ''Settings -setUsername str set = set { getUsername = str }-setAuthtoken str set = set { getAuthtoken = str }-setPassword str set = set { getPassword = str }-setHasPassed set = set { hasPassed = True }-setHasNicked set = set { hasNicked = True }-setHasUsered set = set { hasUsered = True }+emptySettings :: Settings+emptySettings = Settings "" "" "" False False False
Kevin/Types.hs view
@@ -1,6 +1,7 @@ module Kevin.Types (- Kevin(Kevin),+ Kevin(Kevin, damn, irc, dChan, iChan, logger), KevinIO,+ KevinS, Privclass, Chatroom, User(..),@@ -8,28 +9,35 @@ PrivclassStore, UserStore, TitleStore,+ kevin,+ use_, get_, gets_,- put_,- modify_,- + -- lenses users, privclasses, titles, joining, loggedIn,- + -- other accessors- damn, irc, dChan, iChan, settings, logger-) where+ settings, + if'+) where+ import qualified Data.Text as T import qualified Data.Map as M import System.IO import Control.Concurrent import Control.Concurrent.STM.TVar+import Control.Monad.Trans import Control.Monad.Reader-import Control.Monad.STM (atomically)+import Control.Monad.State+import Control.Monad.STM (STM, atomically) import Kevin.Settings-import Data.Lens.Template+import Control.Lens +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@@ -54,7 +62,7 @@ , irc :: Handle , dChan :: Chan T.Text , iChan :: Chan T.Text- , settings :: Settings+ , _kevinSettings :: Settings , _users :: UserStore , _privclasses :: PrivclassStore , _titles :: TitleStore@@ -63,23 +71,27 @@ , logger :: Chan String } -$( makeLens ''Kevin )+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 t a b -> KevinIO a+use_ = gets_ . view+ get_ :: KevinIO Kevin get_ = ask >>= liftIO . readTVarIO -put_ :: Kevin -> KevinIO ()-put_ k = ask >>= io . atomically . flip writeTVar k- gets_ :: (Kevin -> a) -> KevinIO a gets_ = flip liftM get_--modify_ :: (Kevin -> Kevin) -> KevinIO ()-modify_ f = do- var <- ask- io . atomically $ modifyTVar var f--io :: MonadIO m => IO a -> m a-io = liftIO
Kevin/Util/Token.hs view
@@ -14,7 +14,7 @@ import qualified Data.Text as T import Data.Text.Encoding (decodeUtf8) -recvUntil :: TLSCtx a -> B.ByteString -> IO B.ByteString+recvUntil :: TLSCtx -> B.ByteString -> IO B.ByteString recvUntil ctx str = do line <- recvData ctx if str `B.isInfixOf` line@@ -28,8 +28,7 @@ getToken uname pass = do let params = defaultParams { pCiphers = ciphersuite_all , onCertificatesRecv = certificateChecks- [certificateVerifyChain,- return . certificateVerifyDomain "chat.deviantart.com"]+ [return . certificateVerifyDomain "chat.deviantart.com"] } headers = [("Connection", "closed"), ("Content-Type", "application/x-www-form-urlencoded")] :: [(String,String)]
kevin.cabal view
@@ -1,5 +1,5 @@ Name: kevin-Version: 0.2+Version: 0.4 Synopsis: a dAmn ↔ IRC proxy Description: a dAmn ↔ IRC proxy License: GPL@@ -16,8 +16,41 @@ Executable kevin Main-is: Main.hs- Build-Depends: attoparsec == 0.10.*, base == 4.*, bytestring == 0.9.*, containers == 0.4.*, cprng-aes == 0.2.*, data-lens == 2.10.*, data-lens-template == 2.1.*, HTTP == 4000.2.*, MonadCatchIO-mtl == 0.3.*, mtl == 2.1.*, network == 2.3.*, regex-pcre-builtin == 0.94.*, stm == 2.3.*, text == 0.11.*, time == 1.4.*, tls == 0.9.*, tls-extra == 0.4.*- Other-Modules: Kevin, Kevin.Protocol, Kevin.Base, Kevin.Util.Logger, Kevin.IRC.Protocol, Kevin.Damn.Protocol, Kevin.Util.Entity, Kevin.Util.Tablump, Kevin.Damn.Packet, Kevin.Damn.Protocol.Send, Kevin.IRC.Protocol.Send, Kevin.IRC.Packet, Kevin.Settings, Kevin.Types, Kevin.Util.Token- extensions: CPP, DeriveDataTypeable, ExistentialQuantification, OverloadedStrings, ScopedTypeVariables, TemplateHaskell+ + 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+ + extensions: CPP, DeriveDataTypeable, ExistentialQuantification, FlexibleContexts, OverloadedStrings, ScopedTypeVariables, TemplateHaskell ghc-options: -Wall -fno-warn-unused-do-bind -threaded- cpp-options: -DVERSION="0.2"+ cpp-options: -DVERSION="0.4"