{-# 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, actualFocus)
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
    CompOption
forall regex compOpt execOpt.
RegexOptions regex compOpt execOpt =>
compOpt
defaultCompOpt
    ExecOption
forall regex compOpt execOpt.
RegexOptions regex compOpt execOpt =>
execOpt
defaultExecOpt{captureGroups=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 (Text -> Text) -> (MatchArray -> Text) -> MatchArray -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (MatchLength, MatchLength) -> Text
forall {a} {a}. (Integral a, Integral a) => (a, a) -> Text
extractText ((MatchLength, MatchLength) -> Text)
-> (MatchArray -> (MatchLength, MatchLength)) -> MatchArray -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (MatchArray
-> Getting
     (Endo (MatchLength, MatchLength))
     MatchArray
     (MatchLength, MatchLength)
-> (MatchLength, MatchLength)
forall s a. HasCallStack => s -> Getting (Endo a) s a -> a
^?! Index MatchArray -> Traversal' MatchArray (IxValue MatchArray)
forall m. Ixed m => Index m -> Traversal' m (IxValue m)
ix MatchLength
Index MatchArray
0)
             (MatchArray -> Text) -> [MatchArray] -> [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Regex -> String -> [MatchArray]
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
                          (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ Int64 -> Text -> Text
LText.take (a -> Int64
forall a b. (Integral a, Num b) => a -> b
fromIntegral a
len)
                          (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ Int64 -> Text -> Text
LText.drop (a -> Int64
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') -> HasCallStack => Text -> Text
Text -> Text
Text.init Text
t'
       Just (Char
'(',Text
t') | Bool -> Bool
not (Text -> Bool
Text.null Text
t') -> HasCallStack => Text -> Text
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 ([UrlPair] -> [UrlPair]) -> [UrlPair] -> [UrlPair]
forall a b. (a -> b) -> a -> b
$ Focus -> Subfocus -> ClientState -> [UrlPair]
urlListForFocus Focus
focus Subfocus
subfocus ClientState
st
  where
    focus :: Focus
focus = Getting Focus ClientState Focus -> ClientState -> Focus
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting Focus ClientState Focus
Lens' ClientState Focus
clientFocus ClientState
st
    subfocus :: Subfocus
subfocus = Getting Subfocus ClientState Subfocus -> ClientState -> Subfocus
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting Subfocus ClientState Subfocus
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 Text
_ 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, FocusWho Text
_) ->
    ClientState -> NetworkState -> [UrlPair]
matchesWhoReply ClientState
st NetworkState
cs
  (Maybe NetworkState
_, Subfocus
_) ->
    Getting (Endo [UrlPair]) ClientState UrlPair
-> ClientState -> [UrlPair]
forall a s. Getting (Endo [a]) s a -> s -> [a]
toListOf ((Map Focus Window -> Const (Endo [UrlPair]) (Map Focus Window))
-> ClientState -> Const (Endo [UrlPair]) ClientState
Lens' ClientState (Map Focus Window)
clientWindows ((Map Focus Window -> Const (Endo [UrlPair]) (Map Focus Window))
 -> ClientState -> Const (Endo [UrlPair]) ClientState)
-> ((UrlPair -> Const (Endo [UrlPair]) UrlPair)
    -> Map Focus Window -> Const (Endo [UrlPair]) (Map Focus Window))
-> Getting (Endo [UrlPair]) ClientState UrlPair
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Index (Map Focus Window)
-> Traversal' (Map Focus Window) (IxValue (Map Focus Window))
forall m. Ixed m => Index m -> Traversal' m (IxValue m)
ix Index (Map Focus Window)
Focus
focus ((Window -> Const (Endo [UrlPair]) Window)
 -> Map Focus Window -> Const (Endo [UrlPair]) (Map Focus Window))
-> ((UrlPair -> Const (Endo [UrlPair]) UrlPair)
    -> Window -> Const (Endo [UrlPair]) Window)
-> (UrlPair -> Const (Endo [UrlPair]) UrlPair)
-> Map Focus Window
-> Const (Endo [UrlPair]) (Map Focus Window)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (WindowLines -> Const (Endo [UrlPair]) WindowLines)
-> Window -> Const (Endo [UrlPair]) Window
Lens' Window WindowLines
winMessages ((WindowLines -> Const (Endo [UrlPair]) WindowLines)
 -> Window -> Const (Endo [UrlPair]) Window)
-> ((UrlPair -> Const (Endo [UrlPair]) UrlPair)
    -> WindowLines -> Const (Endo [UrlPair]) WindowLines)
-> (UrlPair -> Const (Endo [UrlPair]) UrlPair)
-> Window
-> Const (Endo [UrlPair]) Window
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (WindowLine -> Const (Endo [UrlPair]) WindowLine)
-> WindowLines -> Const (Endo [UrlPair]) WindowLines
forall s t a b. Each s t a b => Traversal s t a b
Traversal WindowLines WindowLines WindowLine WindowLine
each ((WindowLine -> Const (Endo [UrlPair]) WindowLine)
 -> WindowLines -> Const (Endo [UrlPair]) WindowLines)
-> ((UrlPair -> Const (Endo [UrlPair]) UrlPair)
    -> WindowLine -> Const (Endo [UrlPair]) WindowLine)
-> (UrlPair -> Const (Endo [UrlPair]) UrlPair)
-> WindowLines
-> Const (Endo [UrlPair]) WindowLines
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (WindowLine -> [UrlPair]) -> Fold WindowLine UrlPair
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 -> Maybe Text) -> Focus -> Maybe Text
forall a b. (a -> b) -> a -> b
$ Subfocus -> Focus -> Focus
actualFocus Subfocus
subfocus Focus
focus
      Getting (Maybe NetworkState) ClientState (Maybe NetworkState)
-> ClientState -> Maybe NetworkState
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view ((HashMap Text NetworkState
 -> Const (Maybe NetworkState) (HashMap Text NetworkState))
-> ClientState -> Const (Maybe NetworkState) ClientState
Lens' ClientState (HashMap Text NetworkState)
clientConnections ((HashMap Text NetworkState
  -> Const (Maybe NetworkState) (HashMap Text NetworkState))
 -> ClientState -> Const (Maybe NetworkState) ClientState)
-> ((Maybe NetworkState
     -> Const (Maybe NetworkState) (Maybe NetworkState))
    -> HashMap Text NetworkState
    -> Const (Maybe NetworkState) (HashMap Text NetworkState))
-> Getting (Maybe NetworkState) ClientState (Maybe NetworkState)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Index (HashMap Text NetworkState)
-> Lens'
     (HashMap Text NetworkState)
     (Maybe (IxValue (HashMap Text NetworkState)))
forall m. At m => Index m -> Lens' m (Maybe (IxValue m))
at Text
Index (HashMap Text NetworkState)
net) ClientState
st

matchesMsg :: ClientState -> WindowLine -> [UrlPair]
matchesMsg :: ClientState -> WindowLine -> [UrlPair]
matchesMsg ClientState
st WindowLine
wl =
  [ (Text
url, Maybe Identifier -> [Identifier]
forall a. Maybe a -> [a]
maybeToList (Maybe Identifier -> [Identifier])
-> Maybe Identifier -> [Identifier]
forall a b. (a -> b) -> a -> b
$ LensLike' (Const (Maybe Identifier)) WindowLine IrcSummary
-> (IrcSummary -> Maybe Identifier)
-> WindowLine
-> Maybe Identifier
forall s (m :: * -> *) r a.
MonadReader s m =>
LensLike' (Const r) s a -> (a -> r) -> m r
views LensLike' (Const (Maybe Identifier)) WindowLine IrcSummary
Lens' WindowLine IrcSummary
wlSummary IrcSummary -> Maybe Identifier
summaryActor WindowLine
wl)
  | Text
url <- (Text -> [Text]) -> [Text] -> [Text]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Text -> [Text]
urlMatches ([Text] -> [Text]) -> [Text] -> [Text]
forall a b. (a -> b) -> a -> b
$ ClientState -> (Text -> Text) -> [Text] -> [Text]
forall a. ClientState -> (a -> Text) -> [a] -> [a]
clientFilter ClientState
st Text -> Text
forall a. a -> a
id [LensLike' (Const Text) WindowLine Text
-> (Text -> Text) -> WindowLine -> Text
forall s (m :: * -> *) r a.
MonadReader s m =>
LensLike' (Const r) s a -> (a -> r) -> m r
views LensLike' (Const Text) WindowLine Text
Getter WindowLine Text
wlText Text -> Text
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' ([(Identifier, MatchLength, Text)]
 -> [(Identifier, MatchLength, Text)])
-> [(Identifier, MatchLength, Text)]
-> [(Identifier, MatchLength, Text)]
forall a b. (a -> b) -> a -> b
$ Getting
  [(Identifier, MatchLength, Text)]
  NetworkState
  [(Identifier, MatchLength, Text)]
-> NetworkState -> [(Identifier, MatchLength, Text)]
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view ((ChannelList
 -> Const [(Identifier, MatchLength, Text)] ChannelList)
-> NetworkState
-> Const [(Identifier, MatchLength, Text)] NetworkState
Lens' NetworkState ChannelList
csChannelList ((ChannelList
  -> Const [(Identifier, MatchLength, Text)] ChannelList)
 -> NetworkState
 -> Const [(Identifier, MatchLength, Text)] NetworkState)
-> (([(Identifier, MatchLength, Text)]
     -> Const
          [(Identifier, MatchLength, Text)]
          [(Identifier, MatchLength, Text)])
    -> ChannelList
    -> Const [(Identifier, MatchLength, Text)] ChannelList)
-> Getting
     [(Identifier, MatchLength, Text)]
     NetworkState
     [(Identifier, MatchLength, Text)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([(Identifier, MatchLength, Text)]
 -> Const
      [(Identifier, MatchLength, Text)]
      [(Identifier, MatchLength, Text)])
-> ChannelList
-> Const [(Identifier, MatchLength, Text)] ChannelList
Lens' ChannelList [(Identifier, MatchLength, Text)]
clsItems) NetworkState
cs
  , Text
url <- Text -> [Text]
urlMatches (Text -> [Text]) -> Text -> [Text]
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 (UserInfo -> Identifier) -> UserInfo -> Identifier
forall a b. (a -> b) -> a -> b
$ Getting UserInfo WhoReplyItem UserInfo -> WhoReplyItem -> UserInfo
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting UserInfo WhoReplyItem UserInfo
Lens' WhoReplyItem UserInfo
whoUserInfo WhoReplyItem
wri])
  | WhoReplyItem
wri <- ClientState
-> (WhoReplyItem -> Text) -> [WhoReplyItem] -> [WhoReplyItem]
forall a. ClientState -> (a -> Text) -> [a] -> [a]
clientFilter ClientState
st WhoReplyItem -> Text
whoFilterText ([WhoReplyItem] -> [WhoReplyItem])
-> [WhoReplyItem] -> [WhoReplyItem]
forall a b. (a -> b) -> a -> b
$ Getting [WhoReplyItem] NetworkState [WhoReplyItem]
-> NetworkState -> [WhoReplyItem]
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view ((WhoReply -> Const [WhoReplyItem] WhoReply)
-> NetworkState -> Const [WhoReplyItem] NetworkState
Lens' NetworkState WhoReply
csWhoReply ((WhoReply -> Const [WhoReplyItem] WhoReply)
 -> NetworkState -> Const [WhoReplyItem] NetworkState)
-> (([WhoReplyItem] -> Const [WhoReplyItem] [WhoReplyItem])
    -> WhoReply -> Const [WhoReplyItem] WhoReply)
-> Getting [WhoReplyItem] NetworkState [WhoReplyItem]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([WhoReplyItem] -> Const [WhoReplyItem] [WhoReplyItem])
-> WhoReply -> Const [WhoReplyItem] WhoReply
Lens' WhoReply [WhoReplyItem]
whoItems) NetworkState
cs
  , Text
url <- Text -> [Text]
urlMatches (Text -> [Text]) -> Text -> [Text]
forall a b. (a -> b) -> a -> b
$ Text -> Text
LText.fromStrict (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ Getting Text WhoReplyItem Text -> WhoReplyItem -> Text
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting Text WhoReplyItem Text
Lens' WhoReplyItem Text
whoRealname WhoReplyItem
wri
  ]

-- | Deduplicates URLs, combining their identifiers while preserving order.
urlDedup :: [UrlPair] -> [UrlPair]
urlDedup :: [UrlPair] -> [UrlPair]
urlDedup [UrlPair]
pairs = HashMap Text [Identifier] -> [UrlPair] -> [UrlPair] -> [UrlPair]
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' [] = [(a, [a])] -> [(a, [a])]
forall a. [a] -> [a]
reverse [(a, [a])]
pairs'
    rebuildList HashMap a [a]
hmap' [(a, [a])]
pairs' ((a
url, b
_):[(a, b)]
rest)
      | HashMap Text [Identifier] -> Bool
forall k v. HashMap k v -> Bool
HashMap.null HashMap Text [Identifier]
hmap = [(a, [a])] -> [(a, [a])]
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, [a] -> [a]
forall a. [a] -> [a]
reverse [a]
keys)(a, [a]) -> [(a, [a])] -> [(a, [a])]
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) = (Maybe [a] -> (Maybe [a], Maybe [a]))
-> a -> HashMap a [a] -> (Maybe [a], HashMap a [a])
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, Maybe [a]
forall a. Maybe a
Nothing)) a
url HashMap a [a]
hmap'
    hmap :: HashMap Text [Identifier]
hmap = ([Identifier] -> [Identifier] -> [Identifier])
-> [UrlPair] -> HashMap Text [Identifier]
forall k v.
(Eq k, Hashable k) =>
(v -> v -> v) -> [(k, v)] -> HashMap k v
HashMap.fromListWith [Identifier] -> [Identifier] -> [Identifier]
forall a. Eq a => [a] -> [a] -> [a]
List.union [UrlPair]
pairs