diff --git a/Kevin/Base.hs b/Kevin/Base.hs --- a/Kevin/Base.hs +++ b/Kevin/Base.hs @@ -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 diff --git a/Kevin/Chatrooms.hs b/Kevin/Chatrooms.hs new file mode 100644 --- /dev/null +++ b/Kevin/Chatrooms.hs @@ -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 diff --git a/Kevin/Damn/Protocol.hs b/Kevin/Damn/Protocol.hs --- a/Kevin/Damn/Protocol.hs +++ b/Kevin/Damn/Protocol.hs @@ -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") 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 @@ -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 diff --git a/Kevin/IRC/Packet.hs b/Kevin/IRC/Packet.hs --- a/Kevin/IRC/Packet.hs +++ b/Kevin/IRC/Packet.hs @@ -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[]\\`^{}-") diff --git a/Kevin/IRC/Protocol.hs b/Kevin/IRC/Protocol.hs --- a/Kevin/IRC/Protocol.hs +++ b/Kevin/IRC/Protocol.hs @@ -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)" 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 @@ -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] diff --git a/Kevin/Protocol.hs b/Kevin/Protocol.hs --- a/Kevin/Protocol.hs +++ b/Kevin/Protocol.hs @@ -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 () diff --git a/Kevin/Settings.hs b/Kevin/Settings.hs --- a/Kevin/Settings.hs +++ b/Kevin/Settings.hs @@ -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 diff --git a/Kevin/Types.hs b/Kevin/Types.hs --- a/Kevin/Types.hs +++ b/Kevin/Types.hs @@ -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 diff --git a/Kevin/Util/Token.hs b/Kevin/Util/Token.hs --- a/Kevin/Util/Token.hs +++ b/Kevin/Util/Token.hs @@ -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)] diff --git a/kevin.cabal b/kevin.cabal --- a/kevin.cabal +++ b/kevin.cabal @@ -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"