abhin4v/hask-irc
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Some cleanup and refactoring

Browse Source
This commit is contained in:
Abhinav Sarkar 2014-05-24 23:49:52 +05:30
parent 7f31362300
commit 200cc93e1b
12 changed files with 107 additions and 140 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
Main.hs
View File

@ -1,7 +1,4 @@
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverlappingInstances #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Main (main) where

9
Network/IRC/Bot.hs
View File

@ -1,8 +1,3 @@
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskell #-}
module Network.IRC.Bot
@ -126,7 +121,7 @@ messageProcessLoop lineChan commandChan !idleFor = do
where
dispatchHandlers Bot { .. } message =
forM_ (mapValues msgHandlers) $ \msgHandler -> fork $
forM_ (mapValues msgHandlers) $ \msgHandler -> void . fork $
handle (\(e :: SomeException) ->
errorM $ "Exception while processing message: " ++ show e) $ do
mCmd <- handleMessage msgHandler botConfig message
@ -139,7 +134,7 @@ eventProcessLoop (eventChan, latch) lineChan commandChan bot@Bot {.. } = do
Just (QuitEvent, _) -> latchIt latch
_ -> do
debugM $ "Event: " ++ show event
forM_ (mapValues msgHandlers) $ \msgHandler -> fork $
forM_ (mapValues msgHandlers) $ \msgHandler -> void . fork $
handle (\(ex :: SomeException) ->
errorM $ "Exception while processing event: " ++ show ex) $ do
resp <- handleEvent msgHandler botConfig event

4
Network/IRC/Client.hs
View File

@ -1,7 +1,3 @@
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskell #-}
module Network.IRC.Client (runBot) where

3
Network/IRC/Handlers.hs
View File

@ -1,7 +1,4 @@
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
module Network.IRC.Handlers (coreMsgHandlerNames, mkMsgHandler) where

3
Network/IRC/Handlers/Auth.hs
View File

@ -1,8 +1,5 @@
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeFamilies #-}

4
Network/IRC/Handlers/MessageLogger.hs
View File

@ -1,8 +1,4 @@
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Network.IRC.Handlers.MessageLogger (mkMsgHandler) where

101
Network/IRC/Handlers/NickTracker.hs
View File

@ -1,8 +1,5 @@
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeFamilies #-}
@ -43,58 +40,60 @@ saveNickTrack nt = do
$(makeAcidic ''NickTracking ['getByNick, 'getByCanonicalNick, 'saveNickTrack])
nickTrackerMsg :: MonadMsgHandler m => IORef (AcidState NickTracking) -> Message -> m (Maybe Command)
nickTrackerMsg state = go
nickTrackerMsg state message = case message of
ChannelMsg { .. } -> updateNickTrack state user msg msgTime >> handleCommands msg
ActionMsg { .. } -> updateNickTrack state user msg msgTime >> return Nothing
JoinMsg { .. } -> updateNickTrack state user "" msgTime >> return Nothing
PartMsg { .. } -> updateNickTrack state user msg msgTime >> return Nothing
QuitMsg { .. } -> updateNickTrack state user msg msgTime >> return Nothing
NickMsg { .. } -> handleNickChange state user newNick msgTime >> return Nothing
NamesMsg { .. } ->
mapM_ (\n -> updateNickTrack state (User n "") "" msgTime) nicks >> return Nothing
_ -> return Nothing
where
go ChannelMsg { .. } = updateNickTrack user msg msgTime >> handleCommands msg
go ActionMsg { .. } = updateNickTrack user msg msgTime >> return Nothing
go JoinMsg { .. } = updateNickTrack user "" msgTime >> return Nothing
go PartMsg { .. } = updateNickTrack user msg msgTime >> return Nothing
go QuitMsg { .. } = updateNickTrack user msg msgTime >> return Nothing
go NickMsg { .. } = handleNickChange user newNick msgTime >> return Nothing
go NamesMsg { .. } =
mapM_ (\n -> updateNickTrack (User n "") "" msgTime) nicks >> return Nothing
go _ = return Nothing
updateNickTrack user message msgTime = io $ do
acid <- readIORef state
let nck = userNick user
mnt <- query acid . GetByNick $ Nick nck
(message', lastMessageOn', cn) <- case (message, mnt) of
("", Just (NickTrack { .. })) -> return (lastMessage, lastMessageOn, canonicalNick)
(_, Just (NickTrack { .. })) -> return (message, msgTime, canonicalNick)
_ -> do
cn <- newCanonicalNick
return (message, msgTime, cn)
update acid . SaveNickTrack $
NickTrack (Nick nck) cn (LastSeenOn msgTime) lastMessageOn' message'
handleNickChange user newNick msgTime = io $ do
acid <- readIORef state
let prevNick = userNick user
mpnt <- query acid . GetByNick $ Nick prevNick
mnt <- query acid . GetByNick $ Nick newNick
mInfo <- case (mpnt, mnt) of
(Nothing, _) -> newCanonicalNick >>= \cn -> return $ Just ("", cn, msgTime)
(Just pnt, Nothing) ->
return $ Just (lastMessage pnt, canonicalNick pnt, lastMessageOn pnt)
(Just pnt, Just nt) | canonicalNick pnt == canonicalNick nt -> do
let nt' = maximumByEx (comparing lastMessageOn) [pnt, nt]
return $ Just (lastMessage nt', canonicalNick nt', lastMessageOn nt')
_ -> return Nothing
whenJust mInfo $ \(message, cn, lastMessageOn') ->
update acid . SaveNickTrack $
NickTrack (Nick newNick) cn (LastSeenOn msgTime) lastMessageOn' message
newCanonicalNick = map (CanonicalNick . pack . U.toString) U.nextRandom
commands = [ ("!nick", handleNickCommand)
, ("!seen", handleSeenCommand) ]
handleCommands message = case find ((`isPrefixOf` message) . fst) commands of
handleCommands msg = case find ((`isPrefixOf` msg) . fst) commands of
Nothing -> return Nothing
Just (_, handler) -> handler state message
Just (_, handler) -> handler state msg
updateNickTrack :: MonadMsgHandler m => IORef (AcidState NickTracking) -> User -> Text -> UTCTime -> m ()
updateNickTrack state user message msgTime = io $ do
acid <- readIORef state
let nck = userNick user
mnt <- query acid . GetByNick $ Nick nck
(message', lastMessageOn', cn) <- case (message, mnt) of
("", Just (NickTrack { .. })) -> return (lastMessage, lastMessageOn, canonicalNick)
(_, Just (NickTrack { .. })) -> return (message, msgTime, canonicalNick)
_ -> do
cn <- newCanonicalNick
return (message, msgTime, cn)
update acid . SaveNickTrack $
NickTrack (Nick nck) cn (LastSeenOn msgTime) lastMessageOn' message'
handleNickChange :: MonadMsgHandler m => IORef (AcidState NickTracking) -> User -> Text -> UTCTime -> m ()
handleNickChange state user newNick msgTime = io $ do
acid <- readIORef state
let prevNick = userNick user
mpnt <- query acid . GetByNick $ Nick prevNick
mnt <- query acid . GetByNick $ Nick newNick
mInfo <- case (mpnt, mnt) of
(Nothing, _) -> newCanonicalNick >>= \cn -> return $ Just ("", cn, msgTime)
(Just pnt, Nothing) ->
return $ Just (lastMessage pnt, canonicalNick pnt, lastMessageOn pnt)
(Just pnt, Just nt) | canonicalNick pnt == canonicalNick nt -> do
let nt' = maximumByEx (comparing lastMessageOn) [pnt, nt]
return $ Just (lastMessage nt', canonicalNick nt', lastMessageOn nt')
_ -> return Nothing
whenJust mInfo $ \(message, cn, lastMessageOn') ->
update acid . SaveNickTrack $
NickTrack (Nick newNick) cn (LastSeenOn msgTime) lastMessageOn' message
newCanonicalNick :: IO CanonicalNick
newCanonicalNick = map (CanonicalNick . pack . U.toString) U.nextRandom
withNickTracks :: MonadMsgHandler m
=> (Text -> [NickTrack] -> IO Text) -> IORef (AcidState NickTracking) -> Text
@ -142,7 +141,7 @@ mkMsgHandler BotConfig { .. } _ "nicktracker" = do
state <- io (openLocalState emptyNickTracking >>= newIORef)
return . Just $ newMsgHandler { onMessage = nickTrackerMsg state
, onStop = stopNickTracker state
, onHelp = return $ mapFromList helpMsgs}
, onHelp = return helpMsgs }
where
helpMsgs = mapFromList [
("!nick", "Shows the user's other nicks. !nick <user nick>"),

11
Network/IRC/Handlers/NickTracker/Types.hs
View File

@ -1,5 +1,4 @@
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE TemplateHaskell #-}
module Network.IRC.Handlers.NickTracker.Types where
@ -14,11 +13,11 @@ newtype CanonicalNick = CanonicalNick Text deriving (Eq, Ord, Show, Data, Typeab
newtype LastSeenOn = LastSeenOn UTCTime deriving (Eq, Ord, Show, Data, Typeable)
data NickTrack = NickTrack {
nick :: Nick,
canonicalNick :: CanonicalNick,
lastSeenOn :: LastSeenOn,
lastMessageOn :: UTCTime,
lastMessage :: Text
nick :: !Nick,
canonicalNick :: !CanonicalNick,
lastSeenOn :: !LastSeenOn,
lastMessageOn :: !UTCTime,
lastMessage :: !Text
} deriving (Eq, Ord, Show, Data, Typeable)
instance Indexable NickTrack where

4
Network/IRC/Protocol.hs
View File

@ -1,7 +1,3 @@
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
module Network.IRC.Protocol (msgFromLine, lineFromCommand) where
import ClassyPrelude

3
Network/IRC/Types.hs
View File

@ -3,10 +3,7 @@
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RecordWildCards #-}
module Network.IRC.Types
( Nick

4
Network/IRC/Util.hs
View File

@ -1,7 +1,3 @@
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Network.IRC.Util where
import ClassyPrelude

98
hask-irc.cabal
View File

@ -49,31 +49,32 @@ build-type: Simple
cabal-version: >=1.10
library
other-extensions: Safe
default-extensions: NoImplicitPrelude, OverloadedStrings, RecordWildCards, ScopedTypeVariables,
BangPatterns, TupleSections
build-depends: base >=4.5 && <4.8,
text >=0.11 && <0.12,
mtl >=2.1 && <2.2,
network >=2.3 && <2.5,
configurator >=0.2,
time >=1.4.0,
curl-aeson ==0.0.3,
aeson >=0.6.0.0,
HTTP >=4000,
transformers >=0.3,
classy-prelude ==0.9.1,
text-format >=0.3.1,
filepath >=1.3,
directory >=1.2,
lifted-base >=0.2,
unix >=2.7,
convertible >=1.1,
hslogger >=1.2.4,
hslogger-template >=2.0,
ixset >=1.0,
acid-state >=0.12,
safecopy >=0.8,
uuid >=1.3
build-depends: base >=4.5 && <4.8,
text >=0.11 && <0.12,
mtl >=2.1 && <2.2,
network >=2.3 && <2.5,
configurator >=0.2 && <0.3,
time >=1.4 && <1.5,
curl-aeson >=0.0.3 && <0.1,
aeson >=0.6.0.0 && <0.7,
HTTP >=4000 && <5000,
transformers >=0.3 && <0.4,
classy-prelude >=0.9 && <1.0,
text-format >=0.3 && <0.4,
filepath >=1.3 && <1.4,
directory >=1.2 && <1.3,
lifted-base >=0.2 && <0.3,
unix >=2.7 && <2.8,
convertible >=1.1 && <1.2,
hslogger >=1.2 && <1.3,
hslogger-template >=2.0 && <2.1,
ixset >=1.0 && <1.1,
acid-state >=0.12 && <0.13,
safecopy >=0.8 && <0.9,
uuid >=1.3 && <1.4
exposed-modules: Network.IRC.Types, Network.IRC.Protocol,
Network.IRC.Handlers, Network.IRC.Client
@ -91,32 +92,33 @@ executable hask-irc
-- other-modules:
-- LANGUAGE extensions used by modules in this package.
other-extensions: Safe
default-extensions: NoImplicitPrelude, OverloadedStrings, RecordWildCards, ScopedTypeVariables,
BangPatterns, TupleSections
-- Other library packages from which modules are imported.
build-depends: base >=4.5 && <4.8,
text >=0.11 && <0.12,
mtl >=2.1 && <2.2,
network >=2.3 && <2.5,
configurator >=0.2,
time >=1.4.0,
curl-aeson ==0.0.3,
aeson >=0.6.0.0,
HTTP >=4000,
transformers >=0.3,
classy-prelude ==0.9.1,
text-format >=0.3.1,
filepath >=1.3,
directory >=1.2,
lifted-base >=0.2,
unix >=2.7,
convertible >=1.1,
hslogger >=1.2.4,
hslogger-template >=2.0,
ixset >=1.0,
acid-state >=0.12,
safecopy >=0.8,
uuid >=1.3
build-depends: base >=4.5 && <4.8,
text >=0.11 && <0.12,
mtl >=2.1 && <2.2,
network >=2.3 && <2.5,
configurator >=0.2 && <0.3,
time >=1.4 && <1.5,
curl-aeson >=0.0.3 && <0.1,
aeson >=0.6.0.0 && <0.7,
HTTP >=4000 && <5000,
transformers >=0.3 && <0.4,
classy-prelude >=0.9 && <1.0,
text-format >=0.3 && <0.4,
filepath >=1.3 && <1.4,
directory >=1.2 && <1.3,
lifted-base >=0.2 && <0.3,
unix >=2.7 && <2.8,
convertible >=1.1 && <1.2,
hslogger >=1.2 && <1.3,
hslogger-template >=2.0 && <2.1,
ixset >=1.0 && <1.1,
acid-state >=0.12 && <0.13,
safecopy >=0.8 && <0.9,
uuid >=1.3 && <1.4
-- Directories containing source files.
-- hs-source-dirs: