    {-# LANGUAGE PatternGuards #-}
    -- | Fetch URL page titles of HTML links.
    module Lambdabot.Plugin.Reference.Url (urlPlugin) where

    import Lambdabot.Plugin
    import Lambdabot.Util.Browser

    import Control.Monad
    import Control.Monad.Trans
    import Data.List
    import Data.Maybe
    import Network.Browser
    import Network.HTTP
    import Text.Regex.TDFA

    urlPlugin :: Module Bool
    urlPlugin :: Module Bool
    urlPlugin = Module Bool
    forall st. Module st
    newModule
        { moduleCmds = return
            [ (command "url-title")
                { help = say "url-title <url>. Fetch the page title."
                , process =
                      maybe (say "Url not valid.") (mbSay <=< fetchTitle)
                    . containsUrl
                }
            , (command "tiny-url")
                { help = say "tiny-url <url>. Shorten <url>."
                , process =
                      maybe (say "Url not valid.") (mbSay <=< fetchTiny)
                    . containsUrl
                }
            , (command "url-on")
                { privileged = True
                , help = say "url-on: enable automatic URL summaries"
                , process = const $ do
                    writeMS True
                    say "Url enabled"
                }
            , (command "url-off")
                { privileged = True
                , help = say "url-off: disable automatic URL summaries"
                , process = const $ do
                    writeMS False
                    say "Url disabled"
                }
            ]
        , moduleDefState              = return True -- url on
        , moduleSerialize             = Just stdSerial

        , contextual = \String
    text -> do
          alive <- ModuleT Bool LB Bool -> Cmd (ModuleT Bool LB) Bool
    forall (m :: * -> *) a. Monad m => m a -> Cmd m a
    forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
    (MonadTrans t, Monad m) =>
    m a -> t m a
    lift ModuleT Bool LB Bool
    ModuleT Bool LB (LBState (ModuleT Bool LB))
    forall (m :: * -> *). MonadLBState m => m (LBState m)
    readMS
          if alive && (not $ areSubstringsOf ignoredStrings text)
            then case containsUrl text of
                   Maybe String
    Nothing  -> () -> Cmd (ModuleT Bool LB) ()
    forall a. a -> Cmd (ModuleT Bool LB) a
    forall (m :: * -> *) a. Monad m => a -> m a
    return ()
                   Just String
    url
                     | String -> Int
    forall a. [a] -> Int
    forall (t :: * -> *) a. Foldable t => t a -> Int
    length String
    url Int -> Int -> Bool
    forall a. Ord a => a -> a -> Bool
    > Int
    60 -> do
                         title <- String -> Cmd (ModuleT Bool LB) (Maybe String)
    forall (m :: * -> *). MonadLB m => String -> m (Maybe String)
    fetchTitle String
    url
                         tiny  <- fetchTiny  url
                         say (intercalate ", " (catMaybes [title, tiny]))
                     | Bool
    otherwise -> Maybe String -> Cmd (ModuleT Bool LB) ()
    mbSay (Maybe String -> Cmd (ModuleT Bool LB) ())
    -> Cmd (ModuleT Bool LB) (Maybe String) -> Cmd (ModuleT Bool LB) ()
    forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
    =<< String -> Cmd (ModuleT Bool LB) (Maybe String)
    forall (m :: * -> *). MonadLB m => String -> m (Maybe String)
    fetchTitle String
    url
            else return ()
        }

    mbSay :: Maybe String -> Cmd (ModuleT Bool LB) ()
    mbSay :: Maybe String -> Cmd (ModuleT Bool LB) ()
    mbSay = Cmd (ModuleT Bool LB) ()
    -> (String -> Cmd (ModuleT Bool LB) ())
    -> Maybe String
    -> Cmd (ModuleT Bool LB) ()
    forall b a. b -> (a -> b) -> Maybe a -> b
    maybe (() -> Cmd (ModuleT Bool LB) ()
    forall a. a -> Cmd (ModuleT Bool LB) a
    forall (m :: * -> *) a. Monad m => a -> m a
    return ()) String -> Cmd (ModuleT Bool LB) ()
    forall (m :: * -> *). Monad m => String -> Cmd m ()
    say

    ------------------------------------------------------------------------

    -- | The string that I prepend to the quoted page title.
    urlTitlePrompt :: String
    urlTitlePrompt :: String
    urlTitlePrompt = String
    "Title: "

    -- | Fetch the title of the specified URL.
    fetchTitle :: MonadLB m => String -> m (Maybe String)
    fetchTitle :: forall (m :: * -> *). MonadLB m => String -> m (Maybe String)
    fetchTitle String
    url = (Maybe String -> Maybe String)
    -> m (Maybe String) -> m (Maybe String)
    forall a b. (a -> b) -> m a -> m b
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    fmap ((String -> String) -> Maybe String -> Maybe String
    forall a b. (a -> b) -> Maybe a -> Maybe b
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    fmap (String
    urlTitlePrompt String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++)) (BrowserAction (HandleStream String) (Maybe String)
    -> m (Maybe String)
    forall (m :: * -> *) conn a.
    MonadLB m =>
    BrowserAction conn a -> m a
    browseLB (String -> BrowserAction (HandleStream String) (Maybe String)
    urlPageTitle String
    url))

    -- | base url for fetching tiny urls
    tinyurl :: String
    tinyurl :: String
    tinyurl = String
    "http://tinyurl.com/api-create.php?url="

    -- | Fetch the title of the specified URL.
    fetchTiny :: MonadLB m => String -> m (Maybe String)
    fetchTiny :: forall (m :: * -> *). MonadLB m => String -> m (Maybe String)
    fetchTiny String
    url = do
        (_, response) <- BrowserAction (HandleStream String) (URI, Response String)
    -> m (URI, Response String)
    forall (m :: * -> *) conn a.
    MonadLB m =>
    BrowserAction conn a -> m a
    browseLB (Request String
    -> BrowserAction (HandleStream String) (URI, Response String)
    forall ty.
    HStream ty =>
    Request ty -> BrowserAction (HandleStream ty) (URI, Response ty)
    request (String -> Request String
    getRequest (String
    tinyurl String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    url)))
        case rspCode response of
          (Int
    2,Int
    0,Int
    0) -> Maybe String -> m (Maybe String)
    forall a. a -> m a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (Maybe String -> m (Maybe String))
    -> Maybe String -> m (Maybe String)
    forall a b. (a -> b) -> a -> b
    $ String -> Maybe String
    findTiny (Response String -> String
    forall a. Response a -> a
    rspBody Response String
    response)
          ResponseCode
    _       -> Maybe String -> m (Maybe String)
    forall a. a -> m a
    forall (m :: * -> *) a. Monad m => a -> m a
    return Maybe String
    forall a. Maybe a
    Nothing

    -- | Tries to find the start of a tinyurl
    findTiny :: String -> Maybe String
    findTiny :: String -> Maybe String
    findTiny String
    text = do
        mr <- Regex -> String -> Maybe (MatchResult String)
    forall regex source target (m :: * -> *).
    (RegexContext regex source target, MonadFail m) =>
    regex -> source -> m target
    forall (m :: * -> *).
    MonadFail m =>
    Regex -> String -> m (MatchResult String)
    matchM Regex
    begreg String
    text
        let kind = MatchResult String -> String
    forall a. MatchResult a -> a
    mrMatch MatchResult String
    mr
            rest = MatchResult String -> String
    forall a. MatchResult a -> a
    mrAfter MatchResult String
    mr
            url = (Char -> Bool) -> String -> String
    forall a. (a -> Bool) -> [a] -> [a]
    takeWhile (Char -> Char -> Bool
    forall a. Eq a => a -> a -> Bool
    /=Char
    ' ') String
    rest
        return $ stripSuffixes ignoredUrlSuffixes $ kind ++ url
        where
            begreg :: Regex
            begreg :: Regex
    begreg = CompOption -> ExecOption -> String -> Regex
    forall regex compOpt execOpt source.
    RegexMaker regex compOpt execOpt source =>
    compOpt -> execOpt -> source -> regex
    makeRegexOpts CompOption
    opts ExecOption
    forall regex compOpt execOpt.
    RegexOptions regex compOpt execOpt =>
    execOpt
    defaultExecOpt String
    "http://tinyurl.com/"
            opts :: CompOption
    opts = CompOption
    forall regex compOpt execOpt.
    RegexOptions regex compOpt execOpt =>
    compOpt
    defaultCompOpt {caseSensitive = False}

    -- | List of strings that, if present in a contextual message, will
    -- prevent the looking up of titles.  This list can be used to stop
    -- responses to lisppaste for example.  Another important use is to
    -- another lambdabot looking up a url title that contains another
    -- url in it (infinite loop).  Ideally, this list could be added to
    -- by an admin via a privileged command (TODO).
    ignoredStrings :: [String]
    ignoredStrings :: [String]
    ignoredStrings =
        [String
    "paste",                -- Ignore lisppaste, rafb.net
         String
    "cpp.sourcforge.net",   -- C++ paste bin
         String
    "HaskellIrcPastePage",  -- Ignore paste page
         String
    "title of that page",   -- Ignore others like the old me
         String
    urlTitlePrompt]         -- Ignore others like me

    -- | Suffixes that should be stripped off when identifying URLs in
    -- contextual messages.  These strings may be punctuation in the
    -- current sentence vs part of a URL.  Included here is the NUL
    -- character as well.
    ignoredUrlSuffixes :: [String]
    ignoredUrlSuffixes :: [String]
    ignoredUrlSuffixes = [String
    ".", String
    ",", String
    ";", String
    ")", String
    "\"", String
    "\1", String
    "\n"]

    -- | Searches a string for an embedded URL and returns it.
    containsUrl :: String -> Maybe String
    containsUrl :: String -> Maybe String
    containsUrl String
    text = do
        mr <- Regex -> String -> Maybe (MatchResult String)
    forall regex source target (m :: * -> *).
    (RegexContext regex source target, MonadFail m) =>
    regex -> source -> m target
    forall (m :: * -> *).
    MonadFail m =>
    Regex -> String -> m (MatchResult String)
    matchM Regex
    begreg String
    text
        let kind = MatchResult String -> String
    forall a. MatchResult a -> a
    mrMatch MatchResult String
    mr
            rest = MatchResult String -> String
    forall a. MatchResult a -> a
    mrAfter MatchResult String
    mr
            url = (Char -> Bool) -> String -> String
    forall a. (a -> Bool) -> [a] -> [a]
    takeWhile (Char -> String -> Bool
    forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
    `notElem` String
    " \n\t\v") String
    rest
        return $ stripSuffixes ignoredUrlSuffixes $ kind ++ url
        where
            begreg :: Regex
    begreg = CompOption -> ExecOption -> String -> Regex
    forall regex compOpt execOpt source.
    RegexMaker regex compOpt execOpt source =>
    compOpt -> execOpt -> source -> regex
    makeRegexOpts CompOption
    opts ExecOption
    forall regex compOpt execOpt.
    RegexOptions regex compOpt execOpt =>
    execOpt
    defaultExecOpt String
    "https?://"
            opts :: CompOption
    opts = CompOption
    forall regex compOpt execOpt.
    RegexOptions regex compOpt execOpt =>
    compOpt
    defaultCompOpt { caseSensitive = False }

    -- | Utility function to remove potential suffixes from a string.
    -- Note, once a suffix is found, it is stripped and returned, no other
    -- suffixes are searched for at that point.
    stripSuffixes :: [String] -> String -> String
    stripSuffixes :: [String] -> String -> String
    stripSuffixes []   String
    str   = String
    str
    stripSuffixes (String
    s:[String]
    ss) String
    str
        | String -> String -> Bool
    forall a. Eq a => [a] -> [a] -> Bool
    isSuffixOf String
    s String
    str   = Int -> String -> String
    forall a. Int -> [a] -> [a]
    take (String -> Int
    forall a. [a] -> Int
    forall (t :: * -> *) a. Foldable t => t a -> Int
    length String
    str Int -> Int -> Int
    forall a. Num a => a -> a -> a
    - String -> Int
    forall a. [a] -> Int
    forall (t :: * -> *) a. Foldable t => t a -> Int
    length String
    s) (String -> String) -> String -> String
    forall a b. (a -> b) -> a -> b
    $ String
    str
        | Bool
    otherwise          = [String] -> String -> String
    stripSuffixes [String]
    ss String
    str

    -- | Utility function to check of any of the Strings in the specified
    -- list are substrings of the String.
    areSubstringsOf :: [String] -> String -> Bool
    areSubstringsOf :: [String] -> String -> Bool
    areSubstringsOf = (String -> [String] -> Bool) -> [String] -> String -> Bool
    forall a b c. (a -> b -> c) -> b -> a -> c
    flip ((String -> Bool) -> [String] -> Bool
    forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
    any ((String -> Bool) -> [String] -> Bool)
    -> (String -> String -> Bool) -> String -> [String] -> Bool
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . (String -> String -> Bool) -> String -> String -> Bool
    forall a b c. (a -> b -> c) -> b -> a -> c
    flip String -> String -> Bool
    forall a. Eq a => [a] -> [a] -> Bool
    isSubstringOf)
        where
          isSubstringOf :: [a] -> [a] -> Bool
    isSubstringOf [a]
    s [a]
    str = ([a] -> Bool) -> [[a]] -> Bool
    forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
    any ([a] -> [a] -> Bool
    forall a. Eq a => [a] -> [a] -> Bool
    isPrefixOf [a]
    s) ([a] -> [[a]]
    forall a. [a] -> [[a]]
    tails [a]
    str)