diff --git a/BlogLiterately.cabal b/BlogLiterately.cabal --- a/BlogLiterately.cabal +++ b/BlogLiterately.cabal @@ -1,5 +1,5 @@ Name: BlogLiterately -Version: 0.8.1.6 +Version: 0.8.2 Synopsis: A tool for posting Haskelly articles to blogs Description: Write blog posts in Markdown format, then use BlogLiterately to do syntax highlighting, format ghci sessions, and upload @@ -26,7 +26,7 @@ Maintainer: Brent Yorgey Stability: experimental Build-Type: Simple -Tested-With: GHC ==7.6.3, GHC ==7.8.4, GHC ==7.10.1 +Tested-With: GHC ==7.6.3, GHC ==7.8.4, GHC ==7.10.3, GHC ==8.0.1 Extra-Source-Files: CHANGES.md README.markdown doc/BlogLiteratelyDoc.lhs @@ -39,7 +39,7 @@ location: git://github.com/byorgey/BlogLiterately.git Library - Build-Depends: base >= 4.0 && < 4.9, + Build-Depends: base >= 4.0 && < 4.10, process, filepath, directory, @@ -62,7 +62,9 @@ pandoc-citeproc >= 0.1.2 && < 0.10, highlighting-kate >= 0.5 && < 0.7, data-default >= 0.5 && < 0.6, - lens >= 3.8 && < 4.14 + lens >= 3.8 && < 4.14, + tagsoup >= 0.13.4 && < 0.14, + HTTP >= 4000.3 && < 4000.4 Exposed-modules: Text.BlogLiterately Text.BlogLiterately.Block Text.BlogLiterately.Ghci diff --git a/CHANGES.md b/CHANGES.md --- a/CHANGES.md +++ b/CHANGES.md @@ -1,3 +1,11 @@ +0.8.2 (25 March 2016) +--------------------- + + * New feature: support various types of "special links" which are + automatically replaced with appropriate URLs. Initial support for + wikipedia links, Google "feeling lucky" search, and links to other + posts on the same blog specified by ID or search term. + 0.8.1.6 (22 March 2016) ----------------------- diff --git a/doc/BlogLiteratelyDoc.lhs b/doc/BlogLiteratelyDoc.lhs --- a/doc/BlogLiteratelyDoc.lhs +++ b/doc/BlogLiteratelyDoc.lhs @@ -224,6 +224,52 @@ Note that an extra `$latex...` won't be added to the beginning of LaTeX expressions which already appear to be in WordPress format. +Special links +------------- + +Certain special link types can be replaced with appropriate URLs. A +special link is one where the URL is of the form `::` +where `` is used to identify the special link type, and `` +is passed as a parameter to a function which can use it to generate a +URL. Currently, four types of special links are supported by default +(and you can easily add your own): + +`lucky::` + +: The first Google result for ``. + +`wiki::` + +: The Wikipedia page for `<title>`. (Note that the page is not + checked for existence.) + +`post::nnnn` + +: Link to the blog post on your blog with post ID `nnnn`. Note that + this form of special link is invoked when `nnnn` consists of all + digits, so it only works on blogs which use numerical identifiers for + post IDs (as Wordpress does). + +`post::<search>` + +: Link to the most recent blog post (among the + 20 most recent posts) containing `<search>` in its title. + +For example, a post written in Markdown format containing + +``` + This is a post about the game of [Go](wiki::Go (game)). +``` + +will be formatted in HTML as + +``` + <p>This is a post about the game of <a href="https://en.wikipedia.org/wiki/Go%20(game)">Go</a>.</p> +``` + +You can easily add your own new types of special links. See the +`SpecialLink` type and the `mkSpecialLinksXF` function. + Table of contents ----------------- diff --git a/src/Text/BlogLiterately/Post.hs b/src/Text/BlogLiterately/Post.hs --- a/src/Text/BlogLiterately/Post.hs +++ b/src/Text/BlogLiterately/Post.hs @@ -9,17 +9,20 @@ -- License : GPL (see LICENSE) -- Maintainer : Brent Yorgey <byorgey@gmail.com> -- --- Uploading posts to the server. +-- Uploading posts to the server and fetching posts from the server. -- ----------------------------------------------------------------------------- module Text.BlogLiterately.Post ( - mkPost, mkArray, postIt + mkPost, mkArray, postIt, getPostURL, findTitle ) where import Control.Lens (at, makePrisms, to, traverse, - (^.), (^?)) + (^.), (^..), (^?), _Just, _head) +import Data.Char (toLower) +import Data.Function (on) +import Data.List (isInfixOf) import qualified Data.Map as M import Network.XmlRpc.Client (remote) @@ -104,6 +107,17 @@ getPostURL url pid usr pwd = do v <- remote url "metaWeblog.getPost" pid usr pwd return (v ^? _ValueStruct . to M.fromList . at "link" . traverse . _ValueString) + +-- | Look at the last n posts and find the most recent whose title +-- contains the search term (case insensitive); return its permalink +-- URL. +findTitle :: Int -> String -> String -> String -> String -> IO (Maybe String) +findTitle numPrev url search usr pwd = do + res <- remote url "metaWeblog.getRecentPosts" (0::Int) usr pwd numPrev + let matches s = (isInfixOf `on` map toLower) search s + posts = res ^.. _ValueArray . traverse . _ValueStruct . to M.fromList + posts' = filter (\p -> maybe False matches (p ^? at "title" . _Just . _ValueString)) posts + return (posts' ^? _head . at "link" . _Just . _ValueString) -- | Given a configuration and a formatted post, upload it to the server. postIt :: BlogLiterately -> String -> IO () diff --git a/src/Text/BlogLiterately/Transform.hs b/src/Text/BlogLiterately/Transform.hs --- a/src/Text/BlogLiterately/Transform.hs +++ b/src/Text/BlogLiterately/Transform.hs @@ -1,6 +1,6 @@ + {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TypeOperators #-} @@ -35,6 +35,14 @@ , centerImagesXF , citationsXF + -- * Link generation + , specialLinksXF + , mkSpecialLinksXF + , standardSpecialLinks + , luckyLink + , wikiLink + , postLink + -- * Transforms , Transform(..), pureTransform, ioTransform, runTransform, runTransforms @@ -51,12 +59,18 @@ (.=), (.~), (^.), _1, _2, _Just) import Control.Monad.State -import Data.List (intercalate, isPrefixOf) +import Data.Char (isDigit, toLower) +import Data.List (intercalate, isInfixOf, + isPrefixOf) +import Data.List.Split (splitOn) import qualified Data.Map as M +import Data.Maybe (fromMaybe) import Data.Monoid (mappend) import Data.Monoid (mempty, (<>)) import qualified Data.Set as S import Data.Traversable (traverse) +import Network.HTTP (getRequest, getResponseBody, + simpleHTTP) import System.Directory (doesFileExist, getAppUserDataDirectory) import System.Exit (exitFailure) @@ -64,6 +78,7 @@ import System.IO (hFlush, stdout) import Text.Blaze.Html.Renderer.String (renderHtml) import Text.CSL.Pandoc (processCites') +import Text.HTML.TagSoup import Text.Pandoc import Text.Pandoc.Error (PandocError) import Text.Parsec (ParseError) @@ -78,6 +93,7 @@ import Text.BlogLiterately.LaTeX (wpTeXify) import Text.BlogLiterately.Options import Text.BlogLiterately.Options.Parse (readBLOptions) +import Text.BlogLiterately.Post (findTitle, getPostURL) -- | A document transformation consists of two parts: an actual -- transformation, expressed as a function over Pandoc documents, and @@ -177,12 +193,142 @@ where centerImage :: [Block] -> [Block] centerImage (img@(Para [Image _attr _altText (_imgUrl, _imgTitle)]) : bs) = - RawBlock "html" "<div style=\"text-align: center;\">" + RawBlock (Format "html") "<div style=\"text-align: center;\">" : img - : RawBlock "html" "</div>" + : RawBlock (Format "html") "</div>" : bs centerImage bs = bs +-- | Replace special links with appropriate URLs. Currently, four +-- types of special links are supported: +-- +-- [@lucky::<search>@] The first Google result for @<search>@. +-- +-- [@wiki::<title>@] The Wikipedia page for @<title>@. Note that +-- the page is not checked for existence. +-- +-- [@post::nnnn@] Link to the blog post with post ID @nnnn@. Note +-- that this form of special link is invoked when @nnnn@ consists of +-- all digits, so it only works on blogs which use numerical +-- identifiers for post IDs (as Wordpress does). +-- +-- [@post::<search>@] Link to the most recent blog post (among the +-- 20 most recent posts) containing @<search>@ in its title. +-- +-- For example, a post written in Markdown format containing +-- +-- @ +-- This is a post about the game of [Go](wiki::Go (game)). +-- @ +-- +-- will be formatted in HTML as +-- +-- @ +-- <p>This is a post about the game of <a href="https://en.wikipedia.org/wiki/Go%20(game)">Go</a>.</p> +-- @ +-- +-- You can also create a Transform with your own special link types, +-- using 'mkSpecialLinksXF', and I am happy to receive pull requests +-- adding new types of standard special links. +specialLinksXF :: Transform +specialLinksXF = mkSpecialLinksXF standardSpecialLinks + +-- | The standard special link types included in 'specialLinksXF': +-- 'luckyLink', 'wikiLink', and 'postLink'. +standardSpecialLinks :: [SpecialLink] +standardSpecialLinks = [luckyLink, wikiLink, postLink] + +-- | A special link consists of two parts: +-- +-- * An identifier string. If the identifier string is @<id>@, this +-- will trigger for links which are of the form @<id>::XXXX@. +-- +-- * A URL generation function. It takes as input the string +-- following the @::@ (the @XXXX@ in the example above), the +-- configuration record, and must output a URL. +-- +-- For example, +-- +-- @("twitter", \u _ -> return $ "https://twitter.com/" ++ u)@ +-- +-- is a simple 'SpecialLink' which causes links of the form +-- @twitter::user@ to be replaced by @https://twitter.com/user@. +type SpecialLink = (String, String -> BlogLiterately -> IO String) + +-- | Create a transformation which looks for the given special links +-- and replaces them appropriately. You can use this function with +-- your own types of special links. +mkSpecialLinksXF :: [SpecialLink] -> Transform +mkSpecialLinksXF links = ioTransform (specialLinks links) (const True) + +-- | Create a document transformation which looks for the given +-- special links and replaces them appropriately. +specialLinks :: [SpecialLink] -> BlogLiterately -> Pandoc -> IO Pandoc +specialLinks links bl = bottomUpM specialLink + where + specialLink :: Inline -> IO Inline + specialLink i@(Link attrs alt (url, title)) + | Just (typ, target) <- getSpecial url + = mkLink <$> case lookup (map toLower typ) links of + Just mkURL -> mkURL target bl + Nothing -> return target + where + mkLink u = Link attrs alt (u, title) + + specialLink i = return i + + getSpecial url + | "::" `isInfixOf` url = + let (typ:rest) = splitOn "::" url + in Just (typ, intercalate "::" rest) + | otherwise = Nothing + +-- | Turn @lucky::<search>@ into a link to the first Google result for +-- @<search>@. +luckyLink :: SpecialLink +luckyLink = ("lucky", getLucky) + where + getLucky searchTerm _ = do + results <- openURL $ "http://www.google.com/search?q=" ++ searchTerm + let tags = parseTags results + anchor = take 1 . dropWhile (~/= "<a>") . dropWhile (~/= "<h3 class='r'>") $ tags + url = case anchor of + [t@(TagOpen{})] -> takeWhile (/='&') . dropWhile (/='h') . fromAttrib "href" $ t + _ -> searchTerm + return url + +-- | Get the contents of the given URL in a simple way. +openURL :: String -> IO String +openURL x = getResponseBody =<< simpleHTTP (getRequest x) + +-- | Given @wiki::<title>@, generate a link to the Wikipedia page for +-- @<title>@. Note that the page is not checked for existence. +wikiLink :: SpecialLink +wikiLink = ("wiki", \target _ -> return $ "https://en.wikipedia.org/wiki/" ++ target) + +-- | @postLink@ handles two types of special links. +-- +-- [@post::nnnn@] Link to the blog post with post ID @nnnn@. Note that +-- this form of special link is invoked when @nnnn@ consists of all +-- digits, so it only works on blogs which use numerical identifiers +-- for post IDs (as Wordpress does). +-- +-- [@post::<search>@] Link to the most recent blog post (among the +-- 20 most recent posts) containing @<search>@ in its title. +postLink :: SpecialLink +postLink = ("post", getPostLink) + where + getPostLink target bl = + fromMaybe target <$> + case (all isDigit target, bl ^. blog) of + (_ , Nothing ) -> return Nothing + (True , Just url) -> getPostURL url target (user' bl) (password' bl) + (False, Just url) -> findTitle 20 url target (user' bl) (password' bl) + + -- If all digits, replace with permalink for that postid + -- Otherwise, search titles of 20 most recent posts. + -- Choose most recent that matches. + -- | Potentially extract a title from the metadata block, and set it -- in the options record. titleXF :: Transform @@ -295,6 +441,8 @@ -- -- * 'centerImagesXF': center images occurring in their own paragraph -- +-- * 'specialLinksXF': replace special link types with URLs +-- -- * 'highlightOptsXF': load the requested highlighting style file -- -- * 'highlightXF': perform syntax highlighting @@ -318,6 +466,7 @@ , ghciXF , uploadImagesXF , centerImagesXF + , specialLinksXF , highlightOptsXF , highlightXF , citationsXF