{-# LANGUAGE OverloadedStrings #-}
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)
type UrlPair = (Text, [Identifier])
urlPattern :: Regex
Right Regex
urlPattern =
CompOption -> ExecOption -> ByteString -> Either String Regex
compile
forall regex compOpt execOpt.
RegexOptions regex compOpt execOpt =>
compOpt
defaultCompOpt
forall regex compOpt execOpt.
RegexOptions regex compOpt execOpt =>
execOpt
defaultExecOpt{captureGroups :: Bool
captureGroups=Bool
False}
ByteString
"https?://([[:alnum:]-]+\\.)*([[:alnum:]-]+)(:[[:digit:]]+)?(/[-0-9a-zA-Z$_.+!*'(),%?&=:@/;~#]*)?|\
\<https?://[^>]*>|\
\\\(https?://[^\\)]*\\)"
urlMatches :: LText.Text -> [Text]
urlMatches :: Text -> [Text]
urlMatches Text
txt = Text -> Text
removeBrackets forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {a} {a}. (Integral a, Integral a) => (a, a) -> Text
extractText forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall s a. HasCallStack => s -> Getting (Endo a) s a -> a
^?! forall m. Ixed m => Index m -> Traversal' m (IxValue m)
ix MatchLength
0)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall regex source.
RegexLike regex source =>
regex -> source -> [MatchArray]
matchAll Regex
urlPattern (Text -> String
LText.unpack Text
txt)
where
extractText :: (a, a) -> Text
extractText (a
off,a
len) = Text -> Text
LText.toStrict
forall a b. (a -> b) -> a -> b
$ Int64 -> Text -> Text
LText.take (forall a b. (Integral a, Num b) => a -> b
fromIntegral a
len)
forall a b. (a -> b) -> a -> b
$ Int64 -> Text -> Text
LText.drop (forall a b. (Integral a, Num b) => a -> b
fromIntegral a
off) Text
txt
removeBrackets :: Text -> Text
removeBrackets Text
t =
case Text -> Maybe (Char, Text)
Text.uncons Text
t of
Just (Char
'<',Text
t') | Bool -> Bool
not (Text -> Bool
Text.null Text
t') -> Text -> Text
Text.init Text
t'
Just (Char
'(',Text
t') | Bool -> Bool
not (Text -> Bool
Text.null Text
t') -> Text -> Text
Text.init Text
t'
Maybe (Char, Text)
_ -> Text
t
urlList :: ClientState -> [UrlPair]
urlList :: ClientState -> [UrlPair]
urlList ClientState
st = [UrlPair] -> [UrlPair]
urlDedup forall a b. (a -> b) -> a -> b
$ Focus -> Subfocus -> ClientState -> [UrlPair]
urlListForFocus Focus
focus Subfocus
subfocus ClientState
st
where
focus :: Focus
focus = forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Lens' ClientState Focus
clientFocus ClientState
st
subfocus :: Subfocus
subfocus = forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Lens' ClientState Subfocus
clientSubfocus ClientState
st
urlListForFocus :: Focus -> Subfocus -> ClientState -> [UrlPair]
urlListForFocus :: Focus -> Subfocus -> ClientState -> [UrlPair]
urlListForFocus Focus
focus Subfocus
subfocus ClientState
st = case (Maybe NetworkState
netM, Subfocus
subfocus) of
(Just NetworkState
cs, FocusChanList Maybe MatchLength
min' Maybe MatchLength
max') ->
ClientState
-> Maybe MatchLength
-> Maybe MatchLength
-> NetworkState
-> [UrlPair]
matchesTopic ClientState
st Maybe MatchLength
min' Maybe MatchLength
max' NetworkState
cs
(Just NetworkState
cs, Subfocus
FocusWho) ->
ClientState -> NetworkState -> [UrlPair]
matchesWhoReply ClientState
st NetworkState
cs
(Maybe NetworkState
_, Subfocus
_) ->
forall a s. Getting (Endo [a]) s a -> s -> [a]
toListOf (Lens' ClientState (Map Focus Window)
clientWindows forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall m. Ixed m => Index m -> Traversal' m (IxValue m)
ix Focus
focus forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lens' Window WindowLines
winMessages forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s t a b. Each s t a b => Traversal s t a b
each forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) s a. Foldable f => (s -> f a) -> Fold s a
folding (ClientState -> WindowLine -> [UrlPair]
matchesMsg ClientState
st)) ClientState
st
where
netM :: Maybe NetworkState
netM = do
Text
net <- Focus -> Maybe Text
focusNetwork Focus
focus
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view (Lens' ClientState (HashMap Text NetworkState)
clientConnections forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall m. At m => Index m -> Lens' m (Maybe (IxValue m))
at Text
net) ClientState
st
matchesMsg :: ClientState -> WindowLine -> [UrlPair]
matchesMsg :: ClientState -> WindowLine -> [UrlPair]
matchesMsg ClientState
st WindowLine
wl =
[ (Text
url, forall a. Maybe a -> [a]
maybeToList forall a b. (a -> b) -> a -> b
$ forall s (m :: * -> *) r a.
MonadReader s m =>
LensLike' (Const r) s a -> (a -> r) -> m r
views Lens' WindowLine IrcSummary
wlSummary IrcSummary -> Maybe Identifier
summaryActor WindowLine
wl)
| Text
url <- forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Text -> [Text]
urlMatches forall a b. (a -> b) -> a -> b
$ forall a. ClientState -> (a -> Text) -> [a] -> [a]
clientFilter ClientState
st forall a. a -> a
id [forall s (m :: * -> *) r a.
MonadReader s m =>
LensLike' (Const r) s a -> (a -> r) -> m r
views Getter WindowLine Text
wlText forall a. a -> a
id WindowLine
wl]
]
matchesTopic :: ClientState -> Maybe Int -> Maybe Int -> NetworkState -> [UrlPair]
matchesTopic :: ClientState
-> Maybe MatchLength
-> Maybe MatchLength
-> NetworkState
-> [UrlPair]
matchesTopic ClientState
st Maybe MatchLength
min' Maybe MatchLength
max' NetworkState
cs =
[ (Text
url, [Identifier
chan])
| (Identifier
chan, MatchLength
_, Text
topic) <- ClientState
-> Maybe MatchLength
-> Maybe MatchLength
-> [(Identifier, MatchLength, Text)]
-> [(Identifier, MatchLength, Text)]
clientFilterChannels ClientState
st Maybe MatchLength
min' Maybe MatchLength
max' forall a b. (a -> b) -> a -> b
$ forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view (Lens' NetworkState ChannelList
csChannelList forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lens' ChannelList [(Identifier, MatchLength, Text)]
clsItems) NetworkState
cs
, Text
url <- Text -> [Text]
urlMatches forall a b. (a -> b) -> a -> b
$ Text -> Text
LText.fromStrict Text
topic
]
matchesWhoReply :: ClientState -> NetworkState -> [UrlPair]
matchesWhoReply :: ClientState -> NetworkState -> [UrlPair]
matchesWhoReply ClientState
st NetworkState
cs =
[ (Text
url, [UserInfo -> Identifier
userNick forall a b. (a -> b) -> a -> b
$ forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Lens' WhoReplyItem UserInfo
whoUserInfo WhoReplyItem
wri])
| WhoReplyItem
wri <- forall a. ClientState -> (a -> Text) -> [a] -> [a]
clientFilter ClientState
st WhoReplyItem -> Text
whoFilterText forall a b. (a -> b) -> a -> b
$ forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view (Lens' NetworkState WhoReply
csWhoReply forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lens' WhoReply [WhoReplyItem]
whoItems) NetworkState
cs
, Text
url <- Text -> [Text]
urlMatches forall a b. (a -> b) -> a -> b
$ Text -> Text
LText.fromStrict forall a b. (a -> b) -> a -> b
$ forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Lens' WhoReplyItem Text
whoRealname WhoReplyItem
wri
]
urlDedup :: [UrlPair] -> [UrlPair]
urlDedup :: [UrlPair] -> [UrlPair]
urlDedup [UrlPair]
pairs = forall {a} {a} {b}.
Hashable a =>
HashMap a [a] -> [(a, [a])] -> [(a, b)] -> [(a, [a])]
rebuildList HashMap Text [Identifier]
hmap [] [UrlPair]
pairs
where
rebuildList :: HashMap a [a] -> [(a, [a])] -> [(a, b)] -> [(a, [a])]
rebuildList HashMap a [a]
_ [(a, [a])]
pairs' [] = forall a. [a] -> [a]
reverse [(a, [a])]
pairs'
rebuildList HashMap a [a]
hmap' [(a, [a])]
pairs' ((a
url, b
_):[(a, b)]
rest)
| forall k v. HashMap k v -> Bool
HashMap.null HashMap Text [Identifier]
hmap = forall a. [a] -> [a]
reverse [(a, [a])]
pairs'
| Bool
otherwise = case Maybe [a]
ids of
Just [a]
keys -> HashMap a [a] -> [(a, [a])] -> [(a, b)] -> [(a, [a])]
rebuildList HashMap a [a]
hmapU ((a
url, forall a. [a] -> [a]
reverse [a]
keys)forall a. a -> [a] -> [a]
:[(a, [a])]
pairs') [(a, b)]
rest
Maybe [a]
Nothing -> HashMap a [a] -> [(a, [a])] -> [(a, b)] -> [(a, [a])]
rebuildList HashMap a [a]
hmapU [(a, [a])]
pairs' [(a, b)]
rest
where
(Maybe [a]
ids, HashMap a [a]
hmapU) = forall (f :: * -> *) k v.
(Functor f, Eq k, Hashable k) =>
(Maybe v -> f (Maybe v)) -> k -> HashMap k v -> f (HashMap k v)
HashMap.alterF (\Maybe [a]
v -> (Maybe [a]
v, forall a. Maybe a
Nothing)) a
url HashMap a [a]
hmap'
hmap :: HashMap Text [Identifier]
hmap = forall k v.
(Eq k, Hashable k) =>
(v -> v -> v) -> [(k, v)] -> HashMap k v
HashMap.fromListWith forall a. Eq a => [a] -> [a] -> [a]
List.union [UrlPair]
pairs