{-# LANGUAGE PatternGuards #-}
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
, 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
urlTitlePrompt :: String
urlTitlePrompt :: String
urlTitlePrompt = String
"Title: "
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))
tinyurl :: String
tinyurl :: String
tinyurl = String
"http://tinyurl.com/api-create.php?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
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}
ignoredStrings :: [String]
ignoredStrings :: [String]
ignoredStrings =
[String
"paste",
String
"cpp.sourcforge.net",
String
"HaskellIrcPastePage",
String
"title of that page",
String
urlTitlePrompt]
ignoredUrlSuffixes :: [String]
ignoredUrlSuffixes :: [String]
ignoredUrlSuffixes = [String
".", String
",", String
";", String
")", String
"\"", String
"\1", String
"\n"]
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 }
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
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)