irc-core 1.1.4 → 1.1.5

raw patch · 5 files changed

+122/−58 lines, 5 filesdep ~data-default-classdep ~lensdep ~vtyPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependency ranges changed: data-default-class, lens, vty

API changes (from Hackage documentation)

Files

• CHANGELOG.md +6/−0
• driver/ImageUtils.hs +47/−21
• driver/Main.hs +55/−29
• irc-core.cabal +5/−5
• src/Irc/Model.hs +9/−3

@@ -1,3 +1,9 @@+1.1.5+-------+* Show effects of control-modifiers inline when composing chat messages+* Show time since last transmitted ping+* Automatically split long chat messages+ 1.1.4 ------- * Support host-specific server-certificate sections

@@ -19,7 +19,8 @@ data Formatting = Formatting   { _fmtFore :: Maybe Color   , _fmtBack :: Maybe Color-  , _fmtBold, _fmtItalic, _fmtUnderline, _fmtReverse :: !Bool+  , _fmtBold, _fmtItalic, _fmtUnderline, _fmtReverse+  , _fmtExplicit :: !Bool   }  makeLenses ''Formatting@@ -57,26 +58,43 @@   where   (a,b) = Text.break isControl t +  normalFormatting = defaultFormatting { _fmtExplicit = view fmtExplicit fmt }++  explicit img+    | view fmtExplicit fmt = img+    | otherwise = emptyImage+   rest = case Text.uncons b of     Nothing -> emptyImage-    Just ('\x02',xs) -> ircFormattedText' (over fmtBold      not fmt) xs-    Just ('\x0F',xs) -> ircFormattedText' defaultFormatting           xs-    Just ('\x16',xs) -> ircFormattedText' (over fmtReverse   not fmt) xs-    Just ('\x1D',xs) -> ircFormattedText' (over fmtItalic    not fmt) xs-    Just ('\x1F',xs) -> ircFormattedText' (over fmtUnderline not fmt) xs-    Just ('\x03',xs)-      | Just (fore,xs1) <- colorNumber xs ->-         case Text.uncons xs1 of-           Just (',',xs2)-              | Just (back,xs3) <- colorNumber xs2 -> ircFormattedText'-                                                        (set fmtFore (Just fore)-                                                        (set fmtBack (Just back) fmt)) xs3-           _ -> ircFormattedText' (set fmtFore (Just fore)-                                  (set fmtBack Nothing fmt)) xs1-      | otherwise -> ircFormattedText' (set fmtFore Nothing (set fmtBack Nothing fmt)) xs+    Just (b', xs) ->+      explicit (explicitControlImage b') <|>+      case b' of+        '\^B' -> ircFormattedText' (over fmtBold      not fmt) xs+        '\^O' -> ircFormattedText' normalFormatting            xs+        '\^V' -> ircFormattedText' (over fmtReverse   not fmt) xs+        '\^]' -> ircFormattedText' (over fmtItalic    not fmt) xs+        '\^_' -> ircFormattedText' (over fmtUnderline not fmt) xs+        '\^C'+          | Just (fore,xs1) <- colorNumber xs ->+             case Text.uncons xs1 of+               Just (',',xs2)+                  | Just (back,xs3) <- colorNumber xs2 ->+                      explicit (colorNumbers xs3) <|>+                      ircFormattedText'+                        (set fmtFore (Just fore)+                        (set fmtBack (Just back) fmt)) xs3 -    Just (_,xs) -> ircFormattedText' fmt xs+               _ -> explicit (colorNumbers xs1) <|>+                    ircFormattedText'+                      (set fmtFore (Just fore)+                      (set fmtBack Nothing fmt)) xs1 +          | otherwise -> ircFormattedText' (set fmtFore Nothing (set fmtBack Nothing fmt)) xs+          where+            colorNumbers t = text' defAttr (Text.take (Text.length xs - Text.length t) xs)++        _ -> ircFormattedText' fmt xs+ colorNumber :: Text -> Maybe (Color, Text) colorNumber t =   do (c1,c2,t1) <- splitNumber t@@ -121,8 +139,12 @@   , _fmtItalic    = False   , _fmtUnderline = False   , _fmtReverse   = False+  , _fmtExplicit  = False   } +explicitFormatting :: Formatting+explicitFormatting = defaultFormatting { _fmtExplicit = True }+ formattingAttr :: Formatting -> Attr formattingAttr fmt   = addForeColor@@ -158,12 +180,16 @@   case break isControl xs of     (a,[]) -> string attr a     (a,b:bs) -> string attr a-            <|> char (withStyle attr reverseVideo)-                     (controls ! fromEnum b)+            <|> explicitControlImage b             <|> stringWithControls attr bs -  where-  controls = listArray (0,0x1f) ('@':['A'..'Z']++"[\\]^_")+explicitControlImage :: Char -> Image+explicitControlImage x =+  char (withStyle defAttr reverseVideo)+       (controlNames ! fromEnum x)++controlNames :: Array Int Char+controlNames = listArray (0,0x1f) ('@':['A'..'Z']++"[\\]^_")  nameHighlighter ::   ByteString -> Set Identifier -> Identifier -> [Color] -> Image

@@ -185,7 +185,8 @@  driver :: Vty -> TChan Event -> TChan (UTCTime, MsgFromServer) -> ClientState -> IO () driver vty vtyEventChan ircMsgChan st0 =-  do let (scroll', pic) = picForState st0+  do now <- getCurrentTime+     let (scroll', pic) = picForState now st0          st1 = set clientScrollPos scroll' st0      update vty pic      e <- readEitherTChan vtyEventChan ircMsgChan@@ -207,9 +208,9 @@   processTimerEvent e st =     case e of       TransmitPing ->-        do sendTimestampPing st-           st' <- schedulePing st-           considerTimers st'+        do st1 <- sendTimestampPing st+           st2 <- schedulePing st1+           considerTimers st2        DropOperator chan ->         do clientSend (modeCmd chan ["-o",views connNick idBytes conn]) st@@ -285,7 +286,9 @@     '/':_ -> case commandEvent st of                (img, Nothing) -> (img, return (KeepGoing st))                (img, Just m ) -> (img, m)-    txt -> (stringWithControls defAttr txt, fmap KeepGoing (doSendMessageCurrent SendPriv st))+    txt -> ( ircFormattedText' explicitFormatting (Text.pack txt)+           , fmap KeepGoing (doSendMessageCurrent SendPriv st)+           )  keyEvent :: Key -> [Modifier] -> ClientState -> IO KeyEventResult keyEvent k ms st =@@ -355,6 +358,18 @@       doSendMessage sendType c (Text.pack (clientInput st)) st     _ -> return st +-- Pessimistic maximum length computation for the message part for+-- privmsg and notice. Note that the need for the limit is because+-- the server will limit the length of the message sent out to each+-- client, not just the length of the messages it will recieve.+computeMaxMessageLength :: Identifier -> String -> Identifier -> Int+computeMaxMessageLength nick user target+  = 512+  - 63 -- max hostname+  - length (":~!@ PRIVMSG :\r\n"::String)+  - B8.length (idBytes nick)+  - length user+  - B8.length (idBytes target)  doSendMessage :: SendType -> Identifier -> Text -> ClientState -> IO ClientState @@ -363,22 +378,29 @@  doSendMessage sendType target message st =   do let bs = case sendType of-                SendPriv -> privMsgCmd target (Text.encodeUtf8 message)-                SendAction -> privMsgCmd target ("\SOHACTION " <>-                                                 Text.encodeUtf8 message <> "\SOH")-                SendNotice -> noticeCmd target (Text.encodeUtf8 message)-                SendCtcp cmd -> ctcpRequestCmd target+                SendPriv -> map (privMsgCmd target . Text.encodeUtf8) messages+                                -- long actions aren't split up+                SendAction -> [privMsgCmd target ("\SOHACTION " <>+                                                 Text.encodeUtf8 message <> "\SOH")]+                SendNotice -> map (noticeCmd target . Text.encodeUtf8) messages+                SendCtcp cmd -> [ctcpRequestCmd target                                  (Text.encodeUtf8 (Text.pack (map toUpper cmd)))-                                 (Text.encodeUtf8 message)-     clientSend bs st+                                 (Text.encodeUtf8 message)]+     mapM_ (`clientSend` st) bs      now <- getCurrentTime-     let myNick = view connNick conn-         myModes = view (connChannels . ix target' . chanUsers . ix myNick) conn+     let myModes = view (connChannels . ix target' . chanUsers . ix myNick) conn      return (addMessage target' (fakeMsg now myModes) (clearInput st))    where-  conn = view (clientServer0 . ccConnection) st+  myNick = view connNick conn +  maxMessageLength =+    computeMaxMessageLength myNick (view (ccServerSettings.ssUser) ircconn) target+  messages = Text.chunksOf maxMessageLength message++  ircconn = view clientServer0 st+  conn = view ccConnection ircconn+   (statusmsg, target') = splitStatusMsg target conn    fakeMsg now modes = IrcMessage@@ -587,14 +609,14 @@   , ("reconnect", [], pure (doReconnect st'))    , ("ping", [],-    (\msg -> st' <$ doPingCmd msg st')+    (\msg -> doPingCmd msg st')     <$> pRemainingNoSp)    ] -doPingCmd :: String -> ClientState -> IO ()+doPingCmd :: String -> ClientState -> IO ClientState doPingCmd ""  st = sendTimestampPing st-doPingCmd msg st = clientSend (pingCmd (Text.encodeUtf8 (Text.pack msg))) st+doPingCmd msg st = st <$ clientSend (pingCmd (Text.encodeUtf8 (Text.pack msg))) st  doReconnect :: ClientState -> IO ClientState doReconnect st =@@ -737,8 +759,8 @@ -- Primary UI rendering ------------------------------------------------------------------------ -picForState :: ClientState -> (Int,Picture)-picForState st = (scroll', pic)+picForState :: UTCTime -> ClientState -> (Int,Picture)+picForState now st = (scroll', pic)   where   conn = view (clientServer0 . ccConnection) st @@ -760,7 +782,7 @@     , mainFocusImage     ] -  divider = dividerImage st+  divider = dividerImage now st    -- Pad the main image when it doesn't fill the screen   -- so that it starts at the bottom of the frame@@ -841,26 +863,29 @@   beginning = char (withForeColor defAttr brightBlack) '^'   ending    = char (withForeColor defAttr brightBlack) '$' -dividerImage :: ClientState -> Image-dividerImage st+dividerImage :: UTCTime -> ClientState -> Image+dividerImage now st   = extendToWidth (nickPart <|> channelPart <|> lagPart)   where   conn = view (clientServer0 . ccConnection) st    myNick = view connNick conn -  lagPart =-    case view connPingTime conn of-      Just s ->+  drawLagTime color s =        let s' = realToFrac s :: Centi -- truncate to two decimal places            sStr = showFixed True s' <> "s"        in                 string defAttr "-["-            <|> string (withForeColor defAttr yellow) sStr+            <|> string (withForeColor defAttr color) sStr             <|> string defAttr "]" -      _ -> emptyImage+  lagPart =+    case view connPingTime conn of+      NoPing        -> emptyImage+      PingSent when -> drawLagTime red (realToFrac (diffUTCTime now when))+      PingTime s    -> drawLagTime yellow s +   channelPart =     ifoldr (\i x xs -> drawOne i x <|> xs)            emptyImage@@ -1050,10 +1075,11 @@      let pingTime = addUTCTime 60 now      return (addTimerEvent pingTime TransmitPing st) -sendTimestampPing :: ClientState -> IO ()+sendTimestampPing :: ClientState -> IO ClientState sendTimestampPing st =   do now <- getCurrentTime      let ts = realToFrac (utcTimeToPOSIXSeconds now) :: Pico          chopTrailingZeros = True          tsStr = B8.pack (showFixed chopTrailingZeros ts)      clientSend (pingCmd tsStr) st+     return $! set (clientServer0.ccConnection.connPingTime) (PingSent now) st

@@ -1,5 +1,5 @@ name:                irc-core-version:             1.1.4+version:             1.1.5 homepage:            https://github.com/glguy/irc-core bug-reports:         https://github.com/glguy/irc-core/issues license:             BSD3@@ -97,7 +97,7 @@                        base64-bytestring>= 1.0.0.1  && < 1.1,                        containers       >= 0.5      && < 0.6,                        free             >= 4.11     && < 4.13,-                       lens             >= 4.7      && < 4.14,+                       lens             >= 4.7      && < 4.15,                        text             >= 1.2.0.4  && < 1.3,                        transformers     >= 0.2      && < 0.6,                        regex-tdfa       >= 1.2      && < 1.3@@ -134,7 +134,7 @@                   connection       >= 0.2.4    && < 0.3,                  tls              >= 1.2.16   && < 1.4,-                 data-default-class >= 0.0.1  && < 0.1,+                 data-default-class >= 0.0.1  && < 0.2,                  x509             >= 1.5.0.1  && < 1.7,                  x509-system      >= 1.5.0    && < 1.7,                  x509-store       >= 1.5.0    && < 1.7,@@ -148,12 +148,12 @@                  deepseq          >= 1.3.0.2  && < 1.5,                  directory        >= 1.2.1.0  && < 1.3,                  filepath         >= 1.3.0.2  && < 1.5,-                 lens             >= 4.7      && < 4.14,+                 lens             >= 4.7      && < 4.15,                  network          >= 2.6.0.2  && < 2.7,                  split            >= 0.2.2    && < 0.3,                  stm              >= 2.4.4    && < 2.5,                  text             >= 1.2.0.4  && < 1.3,-                 vty              >= 5.2.7    && < 5.5,+                 vty              >= 5.2.7    && < 5.6,                  haskell-lexer    >= 1.0      && < 1.1,                  transformers     >= 0.2      && < 0.6,                  regex-tdfa       >= 1.2      && < 1.3

@@ -34,6 +34,9 @@   , connPingTime   , defaultIrcConnection +  -- * Ping information+  , PingStatus(..)+   -- * Phases   , Phase(..) @@ -141,10 +144,13 @@   , _connUmode    :: !ByteString   , _connSnoMask  :: !ByteString   , _connPhase    :: !Phase-  , _connPingTime :: Maybe Pico -- No read instance for NominalDiffTime+  , _connPingTime :: !PingStatus   }   deriving (Read, Show) +data PingStatus = PingTime Pico | PingSent UTCTime | NoPing+  deriving (Read, Show)+ -- | 'IrcConnection' value with everything unspecified defaultIrcConnection :: IrcConnection defaultIrcConnection = IrcConnection@@ -167,7 +173,7 @@   , _connUmode     = ""   , _connSnoMask   = ""   , _connPhase     = RegistrationPhase-  , _connPingTime  = Nothing+  , _connPingTime  = NoPing   }  data Phase@@ -280,7 +286,7 @@                 do now <- getStamp                    let past = posixSecondsToUTCTime (realToFrac (sec :: Pico))                        delta = realToFrac (now `diffUTCTime` past)-                   return (set connPingTime (Just delta) conn)+                   return (set connPingTime (PingTime delta) conn)         Pong mbServer msg ->          doServerMessage "Pong" (maybe "" (<>" ") mbServer <> msg) conn