{-# 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 = forall st. Module st
newModule
    { moduleCmds :: ModuleT Bool LB [Command (ModuleT Bool LB)]
moduleCmds = forall (m :: * -> *) a. Monad m => a -> m a
return
        [ (String -> Command Identity
command String
"url-title")
            { help :: Cmd (ModuleT Bool LB) ()
help = forall (m :: * -> *). Monad m => String -> Cmd m ()
say String
"url-title <url>. Fetch the page title."
            , process :: String -> Cmd (ModuleT Bool LB) ()
process =
                  forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall (m :: * -> *). Monad m => String -> Cmd m ()
say String
"Url not valid.") (Maybe String -> Cmd (ModuleT Bool LB) ()
mbSay forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< forall (m :: * -> *). MonadLB m => String -> m (Maybe String)
fetchTitle)
                forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Maybe String
containsUrl
            }
        , (String -> Command Identity
command String
"tiny-url")
            { help :: Cmd (ModuleT Bool LB) ()
help = forall (m :: * -> *). Monad m => String -> Cmd m ()
say String
"tiny-url <url>. Shorten <url>."
            , process :: String -> Cmd (ModuleT Bool LB) ()
process =
                  forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall (m :: * -> *). Monad m => String -> Cmd m ()
say String
"Url not valid.") (Maybe String -> Cmd (ModuleT Bool LB) ()
mbSay forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< forall (m :: * -> *). MonadLB m => String -> m (Maybe String)
fetchTiny)
                forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Maybe String
containsUrl
            }
        , (String -> Command Identity
command String
"url-on")
            { privileged :: Bool
privileged = Bool
True
            , help :: Cmd (ModuleT Bool LB) ()
help = forall (m :: * -> *). Monad m => String -> Cmd m ()
say String
"url-on: enable automatic URL summaries"
            , process :: String -> Cmd (ModuleT Bool LB) ()
process = forall a b. a -> b -> a
const forall a b. (a -> b) -> a -> b
$ do
                forall (m :: * -> *). MonadLBState m => LBState m -> m ()
writeMS Bool
True
                forall (m :: * -> *). Monad m => String -> Cmd m ()
say String
"Url enabled"
            }
        , (String -> Command Identity
command String
"url-off")
            { privileged :: Bool
privileged = Bool
True
            , help :: Cmd (ModuleT Bool LB) ()
help = forall (m :: * -> *). Monad m => String -> Cmd m ()
say String
"url-off: disable automatic URL summaries"
            , process :: String -> Cmd (ModuleT Bool LB) ()
process = forall a b. a -> b -> a
const forall a b. (a -> b) -> a -> b
$ do
                forall (m :: * -> *). MonadLBState m => LBState m -> m ()
writeMS Bool
False
                forall (m :: * -> *). Monad m => String -> Cmd m ()
say String
"Url disabled"
            }
        ]
    , moduleDefState :: LB Bool
moduleDefState              = forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True -- url on
    , moduleSerialize :: Maybe (Serial Bool)
moduleSerialize             = forall a. a -> Maybe a
Just forall s. (Show s, Read s) => Serial s
stdSerial

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

mbSay :: Maybe String -> Cmd (ModuleT Bool LB) ()
mbSay :: Maybe String -> Cmd (ModuleT Bool LB) ()
mbSay = forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall (m :: * -> *) a. Monad m => a -> m a
return ()) 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 = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (String
urlTitlePrompt forall a. [a] -> [a] -> [a]
++)) (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
    (URI
_, Response String
response) <- forall (m :: * -> *) conn a.
MonadLB m =>
BrowserAction conn a -> m a
browseLB (forall ty.
HStream ty =>
Request ty -> BrowserAction (HandleStream ty) (URI, Response ty)
request (String -> Request_String
getRequest (String
tinyurl forall a. [a] -> [a] -> [a]
++ String
url)))
    case forall a. Response a -> ResponseCode
rspCode Response String
response of
      (Int
2,Int
0,Int
0) -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ String -> Maybe String
findTiny (forall a. Response a -> a
rspBody Response String
response)
      ResponseCode
_       -> forall (m :: * -> *) a. Monad m => a -> m a
return 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
    MatchResult String
mr <- forall regex source target (m :: * -> *).
(RegexContext regex source target, MonadFail m) =>
regex -> source -> m target
matchM Regex
begreg String
text
    let kind :: String
kind = forall a. MatchResult a -> a
mrMatch MatchResult String
mr
        rest :: String
rest = forall a. MatchResult a -> a
mrAfter MatchResult String
mr
        url :: String
url = forall a. (a -> Bool) -> [a] -> [a]
takeWhile (forall a. Eq a => a -> a -> Bool
/=Char
' ') String
rest
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ [String] -> String -> String
stripSuffixes [String]
ignoredUrlSuffixes forall a b. (a -> b) -> a -> b
$ String
kind forall a. [a] -> [a] -> [a]
++ String
url
    where
        begreg :: Regex
        begreg :: Regex
begreg = forall regex compOpt execOpt source.
RegexMaker regex compOpt execOpt source =>
compOpt -> execOpt -> source -> regex
makeRegexOpts CompOption
opts forall regex compOpt execOpt.
RegexOptions regex compOpt execOpt =>
execOpt
defaultExecOpt String
"http://tinyurl.com/"
        opts :: CompOption
opts = forall regex compOpt execOpt.
RegexOptions regex compOpt execOpt =>
compOpt
defaultCompOpt {caseSensitive :: Bool
caseSensitive = Bool
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
    MatchResult String
mr <- forall regex source target (m :: * -> *).
(RegexContext regex source target, MonadFail m) =>
regex -> source -> m target
matchM Regex
begreg String
text
    let kind :: String
kind = forall a. MatchResult a -> a
mrMatch MatchResult String
mr
        rest :: String
rest = forall a. MatchResult a -> a
mrAfter MatchResult String
mr
        url :: String
url = forall a. (a -> Bool) -> [a] -> [a]
takeWhile (forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` String
" \n\t\v") String
rest
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ [String] -> String -> String
stripSuffixes [String]
ignoredUrlSuffixes forall a b. (a -> b) -> a -> b
$ String
kind forall a. [a] -> [a] -> [a]
++ String
url
    where
        begreg :: Regex
begreg = forall regex compOpt execOpt source.
RegexMaker regex compOpt execOpt source =>
compOpt -> execOpt -> source -> regex
makeRegexOpts CompOption
opts forall regex compOpt execOpt.
RegexOptions regex compOpt execOpt =>
execOpt
defaultExecOpt String
"https?://"
        opts :: CompOption
opts = forall regex compOpt execOpt.
RegexOptions regex compOpt execOpt =>
compOpt
defaultCompOpt { caseSensitive :: Bool
caseSensitive = Bool
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
    | forall a. Eq a => [a] -> [a] -> Bool
isSuffixOf String
s String
str   = forall a. Int -> [a] -> [a]
take (forall (t :: * -> *) a. Foldable t => t a -> Int
length String
str forall a. Num a => a -> a -> a
- forall (t :: * -> *) a. Foldable t => t a -> Int
length String
s) 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 = forall a b c. (a -> b -> c) -> b -> a -> c
flip (forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b c. (a -> b -> c) -> b -> a -> c
flip forall a. Eq a => [a] -> [a] -> Bool
isSubstringOf)
    where
      isSubstringOf :: [a] -> [a] -> Bool
isSubstringOf [a]
s [a]
str = forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (forall a. Eq a => [a] -> [a] -> Bool
isPrefixOf [a]
s) (forall a. [a] -> [[a]]
tails [a]
str)