tellbot 0.5.1.2 → 0.5.1.4

raw patch · 4 files changed

+62/−27 lines, 4 filesdep +bytestringdep +tagsoupdep +text

Dependencies added: bytestring, tagsoup, text

Files

• CHANGELOG.md +9/−0
• src/HTML.hs +33/−13
• src/Main.hs +5/−2
• tellbot.cabal +15/−12

@@ -1,6 +1,15 @@ tellbot CHANGELOG ================= +### 0.5.1.4++- fixed HTML entities to correctly decode them+- removed newlines from title++### 0.5.1.3++- added regex list support to filter trusted hosts+ ### 0.5.1.2  - added HTML in other-modules (doesn’t compile otherwise)

@@ -1,32 +1,52 @@ module HTML where -import Control.Applicative ( pure ) import Control.Exception ( SomeException, catch ) import Control.Monad ( guard )+import Data.ByteString.Lazy ( toStrict ) import Data.List ( isPrefixOf ) import Network.HTTP.Conduit+import Data.Text as T ( drop, dropEnd, pack, strip, unpack )+import Data.Text.Encoding ( decodeUtf8 )+import Text.HTML.TagSoup import Text.Regex.Posix ( (=~) ) -htmlTitle :: String -> IO (Maybe String)-htmlTitle url = do-    -- test http; if it fails, test https-    http <- flip catch handleException $ fmap (extractTitle . show) $ simpleHttp httpPrefixedURL-    case http of-      Just _ -> pure http-      Nothing -> flip catch handleException $ fmap (extractTitle . show) $ simpleHttp httpsPrefixedURL+htmlTitle :: FilePath -> String -> IO (Maybe String)+htmlTitle regPath url = do+    regexps <- flip catch handleException . fmap lines $ readFile regPath +    print regexps+    if (safeHost regexps url) then do+      title <- flip catch handleException $ fmap (extractTitle . concat . lines . unpack . decodeUtf8 . toStrict) $ simpleHttp httpPrefixedURL+      case title of+        Just _ -> pure title+        Nothing -> flip catch handleException $ fmap (extractTitle . unpack . decodeUtf8 . toStrict) $ simpleHttp httpsPrefixedURL+      else+        pure Nothing   where     httpPrefixedURL = if "http://" `isPrefixOf` url then url else "http://" ++ url     httpsPrefixedURL = if "https://" `isPrefixOf` url then url else "https://" ++ url-    handleException :: SomeException -> IO (Maybe String)-    handleException _ = pure Nothing+    handleException :: (Monoid m) => SomeException -> IO m+    handleException _ = pure mempty      extractTitle :: String -> Maybe String extractTitle body = do     guard (not $ null titleHTML)-    pure $ dropAround (length "<title>") (length "</title>") titleHTML+    pure . escape . chomp $ removeMarker titleHTML   where     titleHTML :: String     titleHTML = body =~ "<title>[^<]*</title>" -dropAround :: Int -> Int -> String -> String-dropAround s e = reverse . drop e . reverse . drop s+removeMarker ::String -> String+removeMarker = unpack . T.drop (length "<title>") . dropEnd (length "</title>") . pack++chomp :: String -> String+chomp = unpack . strip . pack++escape :: String -> String+escape = fromTagText . head . parseTags++-- Filter an URL so that we don’t make overviews of unknown hosts. Pretty+-- cool to prevent people from going onto sensitive websites.+--+-- All the regex should be put in a file. One per row.+safeHost :: [String] -> String -> Bool+safeHost regexps url = any (url =~) regexps

@@ -20,7 +20,7 @@ import System.IO  version :: Version-version = Version [0,5,1,2] ["Apfelschorle"]+version = Version [0,5,1,4] ["Apfelschorle"]  type Failable   = EitherT String Identity type FailableIO = EitherT String IO@@ -64,6 +64,9 @@ reconnectDelay :: Int reconnectDelay = 1000000 -- 1s +regPath :: FilePath+regPath = "./regexps"+ session :: ConInfo -> Session a -> IO a session cinfo s = do     (a,_,_) <- runRWST s cinfo M.empty@@ -191,7 +194,7 @@       tellStories fromNick       let url = extractUrl content       unless (null url) $ do-        title <- liftIO $ htmlTitle url+        title <- liftIO $ htmlTitle regPath url         traverse_ (\t -> msgIRC chan $ "« " ++ t ++ " »") title       when (head content == '!') $ do         onCmd fromNick to (tail content)

@@ -1,5 +1,5 @@ name:                tellbot-version:             0.5.1.2+version:             0.5.1.4 synopsis:            IRC tellbot description:         An IRC bot that can be used to create queuing message.                      It also offers a simple administration IRC bot interface.@@ -23,17 +23,20 @@   other-modules:       HTML   default-extensions:  FlexibleInstances -  build-depends:       base         >= 4.5  && < 5-                     , network      >= 2.4  && < 2.7-                     , errors       >= 1.4  && < 1.5-                     , mtl          >= 2.1  && < 2.3-                     , transformers >= 0.3  && < 0.5-                     , split        >= 0.2  && < 0.3-                     , containers   >= 0.4  && < 0.6-                     , bifunctors   >= 4.1  && < 4.3-                     , time         >= 1.4  && < 1.6-                     , http-conduit >= 2.1  && < 2.2-                     , regex-posix  >= 0.95 && < 0.96+  build-depends:       base              >= 4.5  && < 5+                     , network           >= 2.4  && < 2.7+                     , errors            >= 1.4  && < 1.5+                     , mtl               >= 2.1  && < 2.3+                     , transformers      >= 0.3  && < 0.5+                     , split             >= 0.2  && < 0.3+                     , containers        >= 0.4  && < 0.6+                     , bifunctors        >= 4.1  && < 4.3+                     , time              >= 1.4  && < 1.6+                     , http-conduit      >= 2.1  && < 2.2+                     , regex-posix       >= 0.95 && < 0.96+                     , text              >= 1.2  && < 1.3+                     , bytestring        >= 0.10 && < 0.11+                     , tagsoup           >= 0.13 && < 0.14    hs-source-dirs:      src