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

    , contextual :: String -> Cmd (ModuleT Bool LB) ()
contextual = \String
text -> do
      Bool
alive <- ModuleT Bool LB Bool -> Cmd (ModuleT Bool LB) Bool
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift ModuleT Bool LB Bool
forall (m :: * -> *). MonadLBState m => m (LBState m)
readMS
      if Bool
alive Bool -> Bool -> Bool
&& (Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
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  -> () -> Cmd (ModuleT Bool LB) ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
               Just String
url
                 | String -> 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
                     Maybe String
title <- String -> Cmd (ModuleT Bool LB) (Maybe String)
forall (m :: * -> *). MonadLB m => String -> m (Maybe String)
fetchTitle String
url
                     Maybe String
tiny  <- String -> Cmd (ModuleT Bool LB) (Maybe String)
forall (m :: * -> *). MonadLB m => String -> m (Maybe String)
fetchTiny  String
url
                     String -> Cmd (ModuleT Bool LB) ()
forall (m :: * -> *). Monad m => String -> Cmd m ()
say (String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
", " ([Maybe String] -> [String]
forall a. [Maybe a] -> [a]
catMaybes [Maybe String
title, Maybe String
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 () -> Cmd (ModuleT Bool LB) ()
forall (m :: * -> *) a. Monad m => a -> m a
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 (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 :: String -> m (Maybe String)
fetchTitle String
url = (Maybe String -> Maybe String)
-> m (Maybe String) -> m (Maybe String)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((String -> String) -> Maybe String -> Maybe String
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 :: String -> m (Maybe String)
fetchTiny String
url = do
    (URI
_, Response String
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 Response String -> ResponseCode
forall a. Response a -> ResponseCode
rspCode Response String
response of
      (Int
2,Int
0,Int
0) -> Maybe String -> m (Maybe String)
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 (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
    MatchResult String
mr <- Regex -> String -> Maybe (MatchResult String)
forall regex source target (m :: * -> *).
(RegexContext regex source target, MonadFail m) =>
regex -> source -> m target
matchM Regex
begreg String
text
    let kind :: String
kind = MatchResult String -> String
forall a. MatchResult a -> a
mrMatch MatchResult String
mr
        rest :: String
rest = MatchResult String -> String
forall a. MatchResult a -> a
mrAfter MatchResult String
mr
        url :: String
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
    String -> Maybe String
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> Maybe String) -> String -> Maybe String
forall a b. (a -> b) -> a -> b
$ [String] -> String -> String
stripSuffixes [String]
ignoredUrlSuffixes (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ String
kind String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
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 :: 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 <- Regex -> String -> Maybe (MatchResult String)
forall regex source target (m :: * -> *).
(RegexContext regex source target, MonadFail m) =>
regex -> source -> m target
matchM Regex
begreg String
text
    let kind :: String
kind = MatchResult String -> String
forall a. MatchResult a -> a
mrMatch MatchResult String
mr
        rest :: String
rest = MatchResult String -> String
forall a. MatchResult a -> a
mrAfter MatchResult String
mr
        url :: String
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
    String -> Maybe String
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> Maybe String) -> String -> Maybe String
forall a b. (a -> b) -> a -> b
$ [String] -> String -> String
stripSuffixes [String]
ignoredUrlSuffixes (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ String
kind String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
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 :: 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
    | 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 (t :: * -> *) a. Foldable t => t a -> Int
length String
str Int -> Int -> Int
forall a. Num a => a -> a -> a
- String -> 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)