diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,9 @@ +1.1.4 +------- +* Support host-specific server-certificate sections +* Make message parsing more permissive for use with slack irc bridge +* Fix parsing of INVITE reply message + 1.1.3 ------- * Support for running commands upon connection diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -104,9 +104,10 @@ * "JOIN #favoritechannel,#otherchannel" * "PRIVMSG mybot another command" --- Specify additional certificates beyond the system CAs -server-certificates: - * "/path/to/extra/certificate.pem" + -- Specify additional certificates beyond the system CAs + server-certificates: + * "/path/to/extra/certificate.pem" + ``` Commands diff --git a/driver/ClientState.hs b/driver/ClientState.hs --- a/driver/ClientState.hs +++ b/driver/ClientState.hs @@ -23,7 +23,6 @@ import Data.Time (TimeZone, UTCTime) import Graphics.Vty.Image import System.IO (Handle) -import qualified Config import qualified Data.ByteString as B import qualified Data.Map as Map import qualified Data.Set as Set @@ -76,7 +75,6 @@ , _clientAutomation :: [EventHandler] , _clientTimers :: Map UTCTime [TimerEvent] , _clientTimeZone :: TimeZone - , _clientConfig :: Config.Value } -- TODO: split this record into logical pieces diff --git a/driver/CommandArgs.hs b/driver/CommandArgs.hs --- a/driver/CommandArgs.hs +++ b/driver/CommandArgs.hs @@ -188,6 +188,12 @@ let p = maybe defaultSocksPort fromIntegral $ defaultNum hostTxt "socks-port" args return (h,p) + + , _ssServerCerts = toListOf + ( cmdArgConfigValue + . configPath hostTxt "server-certificates" + . values . text . unpacked + ) args } diff --git a/driver/Connection.hs b/driver/Connection.hs --- a/driver/Connection.hs +++ b/driver/Connection.hs @@ -21,7 +21,6 @@ import Data.Default.Class (def) import Data.Maybe (fromMaybe) import Data.Monoid ((<>)) -import Data.Text.Lens (unpacked) import Data.X509 (CertificateChain(..)) import Data.X509.CertificateStore (CertificateStore, makeCertificateStore) import Data.X509.File (readSignedObject, readKeyFile) @@ -30,8 +29,6 @@ import Network.TLS import Network.TLS.Extra (ciphersuite_strong) import System.X509 (getSystemCertificateStore) -import qualified Config -import qualified Config.Lens as Config import qualified Data.ByteString.Char8 as B8 import ServerSettings @@ -44,10 +41,10 @@ return (if B8.null b then b else B8.init b) -- empty lines will still fail, just later and nicely -buildConnectionParams :: Config.Value -> ServerSettings -> IO ConnectionParams -buildConnectionParams config args = +buildConnectionParams :: ServerSettings -> IO ConnectionParams +buildConnectionParams args = do useSecure <- if view ssTls args - then fmap Just (buildTlsSettings config args) + then fmap Just (buildTlsSettings args) else return Nothing let proxySettings = fmap (uncurry SockSettingsSimple) @@ -67,24 +64,16 @@ Nothing | view ssTls args -> 6697 | otherwise -> 6667 -buildCertificateStore :: Config.Value -> IO CertificateStore -buildCertificateStore config = +buildCertificateStore :: ServerSettings -> IO CertificateStore +buildCertificateStore args = do systemStore <- getSystemCertificateStore - userCerts <- traverse readSignedObject (configExtraCertificates config) + userCerts <- traverse readSignedObject (view ssServerCerts args) let userStore = makeCertificateStore (concat userCerts) return (userStore <> systemStore) -configExtraCertificates :: Config.Value -> [FilePath] -configExtraCertificates = - toListOf $ Config.key "server-certificates" - . Config.list - . folded - . Config.text - . unpacked - -buildTlsSettings :: Config.Value -> ServerSettings -> IO TLSSettings -buildTlsSettings config args = - do store <- buildCertificateStore config +buildTlsSettings :: ServerSettings -> IO TLSSettings +buildTlsSettings args = + do store <- buildCertificateStore args let portString = B8.pack (show (view ssPort args)) paramsClient = defaultParamsClient (view ssHostName args) portString @@ -120,8 +109,8 @@ [] -> fail "No private keys found" _ -> fail "Too many private keys found" -connect :: Config.Value -> ServerSettings -> IO Connection -connect config args = do +connect :: ServerSettings -> IO Connection +connect args = do connectionContext <- initConnectionContext - connectionParams <- buildConnectionParams config args + connectionParams <- buildConnectionParams args connectTo connectionContext connectionParams diff --git a/driver/Main.hs b/driver/Main.hs --- a/driver/Main.hs +++ b/driver/Main.hs @@ -31,7 +31,6 @@ import Network.Connection import System.IO import System.IO.Error (isEOFError) -import qualified Config import qualified Config.Lens as C import qualified Data.ByteString as B import qualified Data.ByteString.Char8 as B8 @@ -86,8 +85,7 @@ withVty $ \vty -> do _ <- forkIO (vtyEventLoop vtyEventChan vty) settings <- initialServerSettings args - server0 <- startIrcConnection (view cmdArgConfigValue args) - recvChan settings hErr + server0 <- startIrcConnection recvChan settings hErr (width,height) <- displayBounds (outputIface vty) zone <- getCurrentTimeZone @@ -112,7 +110,6 @@ , _clientAutomation = [ctcpHandler,cancelDeopTimerOnDeop,connectCmds] , _clientTimers = mempty , _clientTimeZone = zone - , _clientConfig = view cmdArgConfigValue args } st1 <- schedulePing st0 @@ -124,13 +121,12 @@ bracket (mkVty cfg) shutdown k startIrcConnection :: - Config.Value {- ^ user configuration -} -> TChan (UTCTime, MsgFromServer) {- ^ incoming client events -} -> ServerSettings {- ^ network parameters -} -> Maybe Handle {- ^ error log -} -> IO ClientConnection -startIrcConnection config recvChan settings hErr = - do connectRes <- try (connect config settings) +startIrcConnection recvChan settings hErr = + do connectRes <- try (connect settings) case connectRes of Left e -> connectionFailed e Right h -> connectionSuceeded h @@ -609,8 +605,7 @@ let settings = view ccServerSettings server0 recvChan = view clientRecvChan st hErr = view clientErrors st - config = view clientConfig st - server0' <- startIrcConnection config recvChan settings hErr + server0' <- startIrcConnection recvChan settings hErr return (set clientServer0 server0' st) doNick :: diff --git a/driver/ServerSettings.hs b/driver/ServerSettings.hs --- a/driver/ServerSettings.hs +++ b/driver/ServerSettings.hs @@ -22,6 +22,7 @@ , _ssTlsClientKey :: Maybe FilePath , _ssConnectCmds :: [Text] , _ssSocksProxy :: Maybe (HostName,PortNumber) + , _ssServerCerts :: [FilePath] } makeLenses ''ServerSettings 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.3 +version: 1.1.4 homepage: https://github.com/glguy/irc-core bug-reports: https://github.com/glguy/irc-core/issues license: BSD3 @@ -11,7 +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.2 +tested-with: GHC == 7.8.4, GHC == 7.10.3 description: This package provides an IRC connection library as well as a console-based IRC client that uses the library. @@ -89,7 +89,7 @@ -- to use an absurd amount of RAM when compiling. -- The base >= 4.7.0.2 is to protect people from finding -- this out the hard way. - build-depends: base >= 4.7.0.2 && < 4.9, + build-depends: base >= 4.7.0.2 && < 4.10, array >= 0.5 && < 0.6, attoparsec >= 0.12.1.2 && < 0.14, @@ -99,11 +99,11 @@ free >= 4.11 && < 4.13, lens >= 4.7 && < 4.14, text >= 1.2.0.4 && < 1.3, - transformers >= 0.2 && < 0.5, + transformers >= 0.2 && < 0.6, regex-tdfa >= 1.2 && < 1.3 if flag(time15) - build-depends: time >= 1.5 && < 1.6 + build-depends: time >= 1.5 && < 1.7 else build-depends: time >= 1.4.2 && < 1.5, old-locale >= 1.0.0.6 && < 1.1 @@ -141,7 +141,7 @@ x509-validation >= 1.5.1 && < 1.7, array >= 0.5 && < 0.6, - base >= 4.7 && < 4.9, + base >= 4.7 && < 4.10, bytestring >= 0.10.4.0 && < 0.11, containers >= 0.5 && < 0.6, config-value >= 0.4 && < 0.5, @@ -150,16 +150,20 @@ filepath >= 1.3.0.2 && < 1.5, lens >= 4.7 && < 4.14, network >= 2.6.0.2 && < 2.7, - old-locale >= 1.0.0.6 && < 1.1, split >= 0.2.2 && < 0.3, stm >= 2.4.4 && < 2.5, text >= 1.2.0.4 && < 1.3, - time >= 1.4.2 && < 1.6, vty >= 5.2.7 && < 5.5, haskell-lexer >= 1.0 && < 1.1, - transformers >= 0.2 && < 0.5, + transformers >= 0.2 && < 0.6, regex-tdfa >= 1.2 && < 1.3 default-language: Haskell2010 + + if flag(time15) + build-depends: time >= 1.5 && < 1.7 + else + build-depends: time >= 1.4.2 && < 1.5, + old-locale >= 1.0.0.6 && < 1.1 source-repository head type: git diff --git a/src/Irc/Core.hs b/src/Irc/Core.hs --- a/src/Irc/Core.hs +++ b/src/Irc/Core.hs @@ -148,7 +148,7 @@ | Away UserInfo (Maybe ByteString) | Ping ByteString - | Pong ByteString (Maybe ByteString) + | Pong (Maybe ByteString) ByteString | Notice UserInfo Identifier ByteString | Topic UserInfo Identifier ByteString | PrivMsg UserInfo Identifier ByteString @@ -393,7 +393,7 @@ ("333",[_,chan,who,time]) -> Just (RplTopicWhoTime (mkId chan) who (asTimeStamp time)) - ("341",[_,nick,chan,_]) -> + ("341",_:nick:chan:_) -> Just (RplInviting (mkId nick) (mkId chan)) ("346",[_,chan,mask,who,time]) -> @@ -692,8 +692,8 @@ ("PING",[txt]) -> Just (Ping txt) - ("PONG",[server ]) -> Just (Pong server Nothing) - ("PONG",[server,txt]) -> Just (Pong server (Just txt)) + ("PONG",[txt ]) -> Just (Pong Nothing txt) + ("PONG",[server,txt]) -> Just (Pong (Just server) txt) ("PRIVMSG",[dst,txt]) -> do src <- msgPrefix ircmsg diff --git a/src/Irc/Model.hs b/src/Irc/Model.hs --- a/src/Irc/Model.hs +++ b/src/Irc/Model.hs @@ -275,15 +275,15 @@ Ping x -> sendMessage (pongCmd x) >> return conn -- Treat numbers as POSIX times when PING was sent - Pong _ (Just txt) + Pong _ txt | Just sec <- readMaybe (B8.unpack txt) -> do now <- getStamp let past = posixSecondsToUTCTime (realToFrac (sec :: Pico)) delta = realToFrac (now `diffUTCTime` past) return (set connPingTime (Just delta) conn) - Pong server mbMsg -> - doServerMessage "Pong" (server <> maybe "" (" "<>) mbMsg) conn + Pong mbServer msg -> + doServerMessage "Pong" (maybe "" (<>" ") mbServer <> msg) conn RplWelcome txt -> doServerMessage "Welcome" txt $ set connPhase ActivePhase conn @@ -825,7 +825,8 @@ supportedCaps = saslSupport ++ ["away-notify","account-notify","userhost-in-names", "extended-join","multi-prefix", - "znc.in/server-time-iso","server-time"] + "znc.in/server-time-iso","server-time", + "znc.in/self-message"] saslSupport = case view connSasl conn of Nothing -> []