{-# 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 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?://[^\\)]*\\)"

-- | Find all the URL matches using 'urlPattern' in a given 'Text' suitable
-- for being opened. Surrounding @<@ and @>@ are removed.
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

-- | Generate a list of URLs from the current focus and subfocus.
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
  ]

-- | Deduplicates URLs, combining their identifiers while preserving order.
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