Url.hs

{-# 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 urlPattern =
  compile
    defaultCompOpt
    defaultExecOpt{captureGroups=False}
    "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 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 $ actualFocus subfocus 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