From de0f7f7d2e3c93244c9f9e6cf46b1a8fe3871275 Mon Sep 17 00:00:00 2001 From: TheDaemoness Date: Sat, 30 Sep 2023 13:10:40 -0700 Subject: [PATCH] Move URL extraction to its own module --- glirc.cabal | 1 + src/Client/Commands.hs | 1 + src/Client/State.hs | 77 --------------------- src/Client/State/Url.hs | 116 ++++++++++++++++++++++++++++++++ src/Client/View/UrlSelection.hs | 5 +- 5 files changed, 120 insertions(+), 80 deletions(-) create mode 100644 src/Client/State/Url.hs diff --git a/glirc.cabal b/glirc.cabal index 2ffabc4b..16e76267 100644 --- a/glirc.cabal +++ b/glirc.cabal @@ -123,6 +123,7 @@ library Client.State.Extensions Client.State.Focus Client.State.Network + Client.State.Url Client.State.Window Client.UserHost Client.WhoReply diff --git a/src/Client/Commands.hs b/src/Client/Commands.hs index cf3a3c45..d83e2aa3 100644 --- a/src/Client/Commands.hs +++ b/src/Client/Commands.hs @@ -36,6 +36,7 @@ import Client.State import Client.State.Extensions (clientCommandExtension, clientStartExtensions) import Client.State.Focus import Client.State.Network (csNick, isChannelIdentifier, sendMsg) +import Client.State.Url import Control.Applicative (liftA2, (<|>)) import Control.Exception (displayException, try) import Control.Lens diff --git a/src/Client/State.hs b/src/Client/State.hs index ce452eb1..d1a6cd30 100644 --- a/src/Client/State.hs +++ b/src/Client/State.hs @@ -109,12 +109,6 @@ module Client.State , esActive , esMVar , esStablePtr - - -- * URL view - , urlPattern - , urlMatches - , urlList - ) where import Client.CApi @@ -134,7 +128,6 @@ import qualified Client.State.EditBox as Edit import Client.State.Focus import Client.State.Network import Client.State.Window -import Client.WhoReply (WhoReplyItem, whoFilterText, whoUserInfo, whoItems, whoRealname) import ContextFilter import Control.Applicative import Control.Concurrent.MVar @@ -848,76 +841,6 @@ clientActiveCommand st = _ -> Nothing --- | Regular expression for matching HTTP/HTTPS URLs in chat text. -urlPattern :: Regex -Right urlPattern = - compile - defaultCompOpt - defaultExecOpt{captureGroups=False} - "https?://([[:alnum:]-]+\\.)*([[:alnum:]-]+)(:[[:digit:]]+)?(/[-0-9a-zA-Z$_.+!*'(),%?&=:@/;~#]*)?|\ - \]*>|\ - \\\(https?://[^\\)]*\\)" - - --- | Find all the URL matches using 'urlPattern' in a given 'Text' suitable --- for being opened. Surrounding @<@ and @>@ are removed. -urlMatches :: LText.Text -> [Text] -urlMatches txt = removeBrackets . extractText . (^?! ix 0) - <$> matchAll urlPattern (LText.unpack txt) - where - extractText (off,len) = LText.toStrict - $ LText.take (fromIntegral len) - $ LText.drop (fromIntegral off) txt - - removeBrackets t = - case Text.uncons t of - Just ('<',t') | not (Text.null t') -> Text.init t' - Just ('(',t') | not (Text.null t') -> Text.init t' - _ -> t - --- | Generate a list of URLs from the current focus and subfocus. -urlList :: ClientState -> [(Text, [Identifier])] -urlList st = urlDedup $ urlFn st - where - urlFn = case (network, subfocus) of - (Just net, FocusChanList min' max') -> - matchesTopic min' max' . view (clientConnections . at net) - (Just net, FocusWho) -> - matchesWhoReply . view (clientConnections . at net) - (_, _) -> - toListOf (clientWindows . ix focus . winMessages . each . folding matchesMsg) - focus = view clientFocus st - subfocus = view clientSubfocus st - network = focusNetwork focus - matchesMsg wl = - [ (url, maybeToList $ views wlSummary summaryActor wl) - | url <- concatMap urlMatches $ clientFilter st id [views wlText id wl] - ] - matchesTopic _ _ Nothing = [] - matchesTopic min' max' (Just cs) = - [ (url, [chan]) - | (chan, _, topic) <- clientFilterChannels st min' max' $ view (csChannelList . clsItems) cs - , url <- urlMatches $ LText.fromStrict topic - ] - matchesWhoReply Nothing = [] - matchesWhoReply (Just cs) = - [ (url, [userNick $ view whoUserInfo wri]) - | wri <- clientFilter st whoFilterText $ view (csWhoReply . whoItems) cs - , url <- urlMatches $ LText.fromStrict $ view whoRealname wri - ] - urlDedup :: [(Text, [Identifier])] -> [(Text, [Identifier])] - urlDedup pairs = rebuildList hmap [] pairs - where - rebuildList _ pairs' [] = reverse pairs' - rebuildList hmap' pairs' ((url, _):rest) - | HashMap.null hmap = reverse pairs' - | otherwise = case ids of - Just keys -> rebuildList hmapU ((url, reverse keys):pairs') rest - Nothing -> rebuildList hmapU pairs' rest - where - (ids, hmapU) = HashMap.alterF (\v -> (v, Nothing)) url hmap' - hmap = HashMap.fromListWith union pairs - -- | Remove a network connection and unlink it from the network map. -- This operation assumes that the network connection exists and should -- only be applied once per connection. diff --git a/src/Client/State/Url.hs b/src/Client/State/Url.hs new file mode 100644 index 00000000..33f8132a --- /dev/null +++ b/src/Client/State/Url.hs @@ -0,0 +1,116 @@ +{-# LANGUAGE OverloadedStrings #-} + +{-| +Module : Client.State.Url +Description : Function for extracting URLs from text +Copyright : (c) Eric Mertens, 2016 +License : ISC +Maintainer : emertens@gmail.com + +-} + +module Client.State.Url + ( UrlPair + , urlList + ) where + +import Client.Message (summaryActor) +import Client.State +import Client.State.Focus (Subfocus(..), focusNetwork, Focus) +import Client.State.Network +import Client.State.Window +import Client.WhoReply +import Control.Lens +import qualified Data.HashMap.Strict as HashMap +import qualified Data.List as List +import Data.Maybe +import Data.Text (Text) +import qualified Data.Text as Text +import qualified Data.Text.Lazy as LText +import Irc.Identifier (Identifier) +import Irc.UserInfo (UserInfo(..)) +import Text.Regex.TDFA +import Text.Regex.TDFA.ByteString (compile) + +-- | A URL and identifiers of those who provided that URL. +type UrlPair = (Text, [Identifier]) + +-- | Regular expression for matching HTTP/HTTPS URLs in chat text. +urlPattern :: Regex +Right urlPattern = + compile + defaultCompOpt + defaultExecOpt{captureGroups=False} + "https?://([[:alnum:]-]+\\.)*([[:alnum:]-]+)(:[[:digit:]]+)?(/[-0-9a-zA-Z$_.+!*'(),%?&=:@/;~#]*)?|\ + \]*>|\ + \\\(https?://[^\\)]*\\)" + +-- | Find all the URL matches using 'urlPattern' in a given 'Text' suitable +-- for being opened. Surrounding @<@ and @>@ are removed. +urlMatches :: LText.Text -> [Text] +urlMatches txt = removeBrackets . extractText . (^?! ix 0) + <$> matchAll urlPattern (LText.unpack txt) + where + extractText (off,len) = LText.toStrict + $ LText.take (fromIntegral len) + $ LText.drop (fromIntegral off) txt + + removeBrackets t = + case Text.uncons t of + Just ('<',t') | not (Text.null t') -> Text.init t' + Just ('(',t') | not (Text.null t') -> Text.init t' + _ -> t + +-- | Generate a list of URLs from the current focus and subfocus. +urlList :: ClientState -> [UrlPair] +urlList st = urlDedup $ urlListForFocus focus subfocus st + where + focus = view clientFocus st + subfocus = view clientSubfocus st + +urlListForFocus :: Focus -> Subfocus -> ClientState -> [UrlPair] +urlListForFocus focus subfocus st = case (netM, subfocus) of + (Just cs, FocusChanList min' max') -> + matchesTopic st min' max' cs + (Just cs, FocusWho) -> + matchesWhoReply st cs + (_, _) -> + toListOf (clientWindows . ix focus . winMessages . each . folding (matchesMsg st)) st + where + netM = do + net <- focusNetwork focus + view (clientConnections . at net) st + +matchesMsg :: ClientState -> WindowLine -> [UrlPair] +matchesMsg st wl = + [ (url, maybeToList $ views wlSummary summaryActor wl) + | url <- concatMap urlMatches $ clientFilter st id [views wlText id wl] + ] + +matchesTopic :: ClientState -> Maybe Int -> Maybe Int -> NetworkState -> [UrlPair] +matchesTopic st min' max' cs = + [ (url, [chan]) + | (chan, _, topic) <- clientFilterChannels st min' max' $ view (csChannelList . clsItems) cs + , url <- urlMatches $ LText.fromStrict topic + ] + +matchesWhoReply :: ClientState -> NetworkState -> [UrlPair] +matchesWhoReply st cs = + [ (url, [userNick $ view whoUserInfo wri]) + | wri <- clientFilter st whoFilterText $ view (csWhoReply . whoItems) cs + , url <- urlMatches $ LText.fromStrict $ view whoRealname wri + ] + +-- | Deduplicates URLs, combining their identifiers while preserving order. +urlDedup :: [UrlPair] -> [UrlPair] +urlDedup pairs = rebuildList hmap [] pairs + where + rebuildList _ pairs' [] = reverse pairs' + rebuildList hmap' pairs' ((url, _):rest) + | HashMap.null hmap = reverse pairs' + | otherwise = case ids of + Just keys -> rebuildList hmapU ((url, reverse keys):pairs') rest + Nothing -> rebuildList hmapU pairs' rest + where + (ids, hmapU) = HashMap.alterF (\v -> (v, Nothing)) url hmap' + hmap = HashMap.fromListWith List.union pairs diff --git a/src/Client/View/UrlSelection.hs b/src/Client/View/UrlSelection.hs index aceea560..12c81bee 100644 --- a/src/Client/View/UrlSelection.hs +++ b/src/Client/View/UrlSelection.hs @@ -21,15 +21,14 @@ import Client.Image.Palette import Client.Image.LineWrap import Client.State import Client.State.Focus +import Client.State.Url import Control.Lens import Data.HashMap.Strict (HashMap) import Data.List (intersperse, foldl1') -import Data.Text (Text) import Graphics.Vty.Attributes import Irc.Identifier import Text.Read (readMaybe) - -- | Generate the lines used for the view when typing @/url@ urlSelectionView :: Int {- ^ render width -} -> @@ -61,7 +60,7 @@ draw :: Palette {- ^ palette -} -> Int {- ^ selected index -} -> Int {- ^ url index -} -> - (Text, [Identifier]) {- ^ sender and url text -} -> + UrlPair {- ^ sender and url text -} -> [Image'] {- ^ rendered lines -} draw w hilites pal selected i (url, who) = reverse