diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,8 @@ +1.1.1.1 +------- +* Better error handling +* Added a stack.yaml + 1.1.1 ----- * Add `/grep` filter command diff --git a/driver/ClientState.hs b/driver/ClientState.hs --- a/driver/ClientState.hs +++ b/driver/ClientState.hs @@ -12,6 +12,7 @@ import Control.Monad (foldM, guard) import Data.ByteString (ByteString) import Data.Char (isControl) +import Data.Foldable (for_) import Data.Functor.Compose import Data.Map (Map) import Data.Maybe (fromMaybe) @@ -45,10 +46,10 @@ data ClientConnection = ClientConnection { _ccServerSettings :: ServerSettings - , _ccSendChan :: TChan ByteString , _ccConnection :: IrcConnection - , _ccRecvThread :: ThreadId - , _ccSendThread :: ThreadId + , _ccSendChan :: Maybe (TChan ByteString) + , _ccRecvThread :: Maybe ThreadId + , _ccSendThread :: Maybe ThreadId } data ClientState = ClientState @@ -200,7 +201,8 @@ clientSend :: ByteString -> ClientState -> IO () clientSend x st = - atomically (writeTChan (view (clientServer0.ccSendChan) st) x) + for_ (view (clientServer0.ccSendChan) st) $ \chan -> + atomically (writeTChan chan x) focusedName :: ClientState -> Identifier focusedName st = diff --git a/driver/Main.hs b/driver/Main.hs --- a/driver/Main.hs +++ b/driver/Main.hs @@ -121,30 +121,49 @@ Maybe Handle {- ^ error log -} -> IO ClientConnection startIrcConnection config recvChan settings hErr = - do h <- connect config settings - sendChan <- atomically newTChan - sendThreadId <- forkIO (sendLoop sendChan h) - recvThreadId <- forkIO (socketLoop recvChan h hErr) + do connectRes <- try (connect config settings) + case connectRes of + Left e -> connectionFailed e + Right h -> connectionSuceeded h - let utf8Bytes = Text.encodeUtf8 . Text.pack - nick = mkId (utf8Bytes (view ssNick settings)) - user = utf8Bytes (view ssUser settings) - real = utf8Bytes (view ssReal settings) - sasl = over (mapped.both) utf8Bytes (view ssSaslCredential settings) - pass = over mapped utf8Bytes (view ssPassword settings) + where + utf8Bytes = Text.encodeUtf8 . Text.pack + nick = mkId (utf8Bytes (view ssNick settings)) + user = utf8Bytes (view ssUser settings) + real = utf8Bytes (view ssReal settings) + sasl = over (mapped.both) utf8Bytes (view ssSaslCredential settings) + pass = over mapped utf8Bytes (view ssPassword settings) - initializeConnection pass nick user real h + connectionSuceeded h = + do sendChan <- atomically newTChan + sendThreadId <- forkIO (sendLoop sendChan h) + recvThreadId <- forkIO (socketLoop recvChan h hErr) + initializeConnection pass nick user real h + return ClientConnection + { _ccServerSettings = settings + , _ccConnection = defaultIrcConnection + { _connNick = nick + , _connSasl = sasl + } + , _ccSendChan = Just sendChan + , _ccRecvThread = Just recvThreadId + , _ccSendThread = Just sendThreadId + } - return ClientConnection - { _ccServerSettings = settings - , _ccSendChan = sendChan - , _ccConnection = defaultIrcConnection - { _connNick = nick - , _connSasl = sasl - } - , _ccRecvThread = recvThreadId - , _ccSendThread = sendThreadId - } + connectionFailed (SomeException e) = + do let eUtf8 = utf8Bytes (show e) + now <- getCurrentTime + atomically (writeTChan recvChan (now, Error eUtf8)) + return ClientConnection + { _ccServerSettings = settings + , _ccConnection = defaultIrcConnection + { _connNick = nick + , _connSasl = sasl + } + , _ccSendChan = Nothing + , _ccRecvThread = Nothing + , _ccSendThread = Nothing + } initializeConnection :: Maybe ByteString {- ^ server password -} -> @@ -557,25 +576,18 @@ ] --- Exploratory! doReconnect :: ClientState -> IO ClientState doReconnect st = do let server0 = view clientServer0 st - views ccRecvThread killThread server0 - views ccSendThread killThread server0 + traverse_ killThread (view ccRecvThread server0) + traverse_ killThread (view ccSendThread server0) let settings = view ccServerSettings server0 recvChan = view clientRecvChan st hErr = view clientErrors st config = view clientConfig st - res <- try (startIrcConnection config recvChan settings hErr) - case res of - Right server0' -> return (set clientServer0 server0' st) - Left e -> do - now <- getCurrentTime - let eUtf8 = Text.encodeUtf8 (Text.pack (ioeGetErrorString e)) - atomically (writeTChan recvChan (now, Error eUtf8)) - return st + server0' <- startIrcConnection config recvChan settings hErr + return (set clientServer0 server0' st) doNick :: ClientState -> @@ -908,21 +920,33 @@ getOne :: Connection -> Maybe Handle -> IO (UTCTime, MsgFromServer) getOne h hErr = do xs <- getRawIrcLine h - let debug x = for_ hErr (`hPrint` x) case parseRawIrcMsg xs of - Nothing -> - do debug xs - t <- getCurrentTime - return (t,Error ("Parse: " <> xs)) - Just msg -> - do t <- maybe getCurrentTime return (msgTime msg) - case ircMsgToServerMsg msg of - Nothing -> - do debug msg - return (t,Error ("Unknown: " <> xs)) - Just x -> - do debug x - return (t,x) + _ | B.null xs -> connectionClosed + Nothing -> unparsableLine xs + Just rawMsg -> + do t <- maybe getCurrentTime return (msgTime rawMsg) + case ircMsgToServerMsg rawMsg of + Nothing -> unhandledMsg t rawMsg + Just msg -> handledMsg t msg + where + debugPrint x = for_ hErr (`hPrint` x) + + connectionClosed = + do t <- getCurrentTime + return (t,Error "Connection closed") + + unparsableLine xs = + do debugPrint xs + t <- getCurrentTime + return (t,Error ("Unparsable IRC line: " <> xs)) + + unhandledMsg t rawMsg = + do debugPrint rawMsg + return (t,Error ("Unhandled IRC line: " <> Text.encodeUtf8 (Text.pack (show rawMsg)))) + + handledMsg t msg = + do debugPrint msg + return (t,msg) readEitherTChan :: TChan a -> TChan b -> IO (Either a b) readEitherTChan a b = diff --git a/irc-core.cabal b/irc-core.cabal --- a/irc-core.cabal +++ b/irc-core.cabal @@ -1,5 +1,5 @@ name: irc-core -version: 1.1.1 +version: 1.1.1.1 homepage: https://github.com/glguy/irc-core bug-reports: https://github.com/glguy/irc-core/issues license: BSD3 @@ -11,6 +11,7 @@ build-type: Simple cabal-version: >=1.10 synopsis: An IRC client library and text client +tested-with: GHC == 7.8.4, GHC == 7.10.1 description: This package provides an IRC connection library as well as a console-based IRC client that uses the library. @@ -68,6 +69,7 @@ extra-source-files: README.md CHANGELOG.md + stack.yaml -- Use time-1.5 and drop old-locale flag time15 @@ -125,6 +127,7 @@ Views.BanList Views.Channel Views.ChannelInfo + Paths_irc_core hs-source-dirs: driver ghc-options: -threaded build-depends: irc-core, diff --git a/stack.yaml b/stack.yaml new file mode 100644 --- /dev/null +++ b/stack.yaml @@ -0,0 +1,8 @@ +flags: {} +packages: +- '.' +extra-deps: +- config-value-0.4.0.1 +- time-1.5.0.1 +- vty-5.4.0 +resolver: lts-3.2