+--
+-- Syntax highlighting.
+--
+-----------------------------------------------------------------------------
+
+module Text.BlogLiterately.Highlight
+ ( HsHighlight(..)
+ , colourIt
+ , litify
+ , StylePrefs
+ , defaultStylePrefs
+ , getStylePrefs
+ , bakeStyles
+ , replaceBreaks
+ , colouriseCodeBlock
+ , colourisePandoc
+ ) where
+
+import Control.Monad ( liftM )
+import Data.Maybe ( isNothing )
+import qualified System.IO.UTF8 as U ( readFile )
+
+import Text.Pandoc ( Pandoc(..)
+ , Block (CodeBlock, RawBlock) )
+import Text.Pandoc.Highlighting ( highlight, formatHtmlBlock )
+import Language.Haskell.HsColour ( hscolour, Output(..) )
+import Language.Haskell.HsColour.Colourise ( defaultColourPrefs )
+import System.Console.CmdArgs ( Data, Typeable )
+import Text.XML.HaXml
+import Text.XML.HaXml.Posn ( noPos )
+import Text.Blaze.Html.Renderer.String ( renderHtml )
+
+import Text.BlogLiterately.Block ( unTag )
+
+-- | Four modes for highlighting Haskell.
+data HsHighlight =
+ HsColourInline StylePrefs -- ^ Use hscolour and inline the styles.
+ | HsColourCSS -- ^ Use hscolour in conjunction with
+ -- an external CSS style sheet.
+ | HsKate -- ^ Use highlighting-kate.
+ | HsNoHighlight -- ^ Do not highlight Haskell.
+ deriving (Data,Typeable,Show,Eq)
+
+{-
+
+The literate Haskell that Pandoc finds in a file ends up in various
+`CodeBlock` elements of the `Pandoc` document. Other code can also
+wind up in `CodeBlock` elements -- normal markdown formatted code.
+The `Attr` component has metadata about what's in the code block:
+
+ [haskell]
+ type Attr = ( String, -- code block identifier
+ , [String] -- list of code classes
+ , [(String, String)] -- name/value pairs
+ )
+
+Thanks to some feedback from the Pandoc author, John MacFarlane, I
+learned that the CodeBlock *may* contain markers about the kind of
+code contained within the block. LHS (bird-style or LaTex style) will
+always have an `Attr` of the form `("",["sourceCode","haskell"],[])`,
+and other `CodeBlock` elements are the markdown code blocks *may* have
+an identifier, classes, or key/value pairs. Pandoc captures this info
+when the file contains code blocks in the delimited (rather than
+indented) format, which allows an optional meta-data specification,
+e.g.
+
+~~~~~~~~~~~
+~~~~~~~ { .bash }
+x=$1
+echo $x
+~~~~~~~
+~~~~~~~~~~~
+
+Although Pandoc supports the above format for marking code blocks (and
+annotating the kind of code within the block) I'll also keep my
+notation as another option for use with indented blocks, i.e. if you
+write:
+
+
+ [haskell]
+ foo :: String -> String
+
+
+it is a Haskell block. You can also use other annotations, *e.g.*
+
+
+ [cpp]
+ cout << "Hello World!";
+
+
+If highlighting-kate is specified for highlighting Haskell blocks, the
+distinction between the literate blocks and the delimited blocks is
+lost (this is simply how the Pandoc highlighting module currently
+works).
+
+I'll adopt the rule that if you specify a class or classes using
+Pandoc's delimited code block syntax, I'll assume that there is no
+additional tag within the block in Blog Literately syntax. I still
+need my `unTag` function to parse the code block.
+
+
+To highlight the syntax using hscolour (which produces HTML), I'm
+going to need to transform the `String` from a `CodeBlock` element to
+a `String` suitable for the `RawHtml` element (because the hscolour
+library transforms Haskell text to HTML). Pandoc strips off the
+prepended > characters from the literate Haskell, so I need to put
+them back, and also tell hscolour whether the source it is colouring
+is literate or not. The hscolour function looks like:
+
+ [haskell]
+ hscolour :: Output -- ^ Output format.
+ -> ColourPrefs -- ^ Colour preferences...
+ -> Bool -- ^ Whether to include anchors.
+ -> Bool -- ^ Whether output document is partial or complete.
+ -> String -- ^ Title for output.
+ -> Bool -- ^ Whether input document is literate haskell
+ -> String -- ^ Haskell source code.
+ -> String -- ^ Coloured Haskell source code.
+
+Since I still don't like the `ICSS` output from hscolour, I'm going to
+provide two options for hscolouring to users: one that simply uses
+hscolour's `CSS` format, so the user can provide definitions in their
+blog's stylesheet to control the rendering, and a post-processing
+option to transform the `CSS` class-based rendering into a inline
+style based rendering (for people who can't update their stylesheet).
+`colourIt` performs the initial transformation:
+
+-}
+
+-- | Use hscolour to syntax highlight some Haskell code. The first
+-- argument indicates whether the code is literate Haskell.
+colourIt :: Bool -> String -> String
+colourIt literate srcTxt =
+ hscolour CSS defaultColourPrefs False True "" literate srcTxt'
+ where srcTxt' | literate = litify srcTxt
+ | otherwise = srcTxt
+
+-- | Prepend literate Haskell markers to some source code.
+litify :: String -> String
+litify = unlines . map ("> " ++) . lines
+
+{-
+Hscolour uses HTML `span` elements and CSS classes like 'hs-keyword'
+or `hs-keyglyph` to markup Haskell code. What I want to do is take
+each marked `span` element and replace the `class` attribute with an
+inline `style` element that has the markup I want for that kind of
+source. Style preferences are specified as a list of name/value
+pairs:
+-}
+
+-- | Style preferences are specified as a list of mappings from class
+-- attributes to CSS style attributes.
+type StylePrefs = [(String,String)]
+
+-- | A default style that produces something that looks like the
+-- source listings on Hackage.
+defaultStylePrefs :: StylePrefs
+defaultStylePrefs =
+ [ ("hs-keyword","color: blue; font-weight: bold;")
+ , ("hs-keyglyph","color: red;")
+ , ("hs-layout","color: red;")
+ , ("hs-comment","color: green;")
+ , ("hs-conid", "")
+ , ("hs-varid", "")
+ , ("hs-conop", "")
+ , ("hs-varop", "")
+ , ("hs-str", "color: teal;")
+ , ("hs-chr", "color: teal;")
+ , ("hs-number", "")
+ , ("hs-cpp", "")
+ , ("hs-selection", "")
+ , ("hs-variantselection", "")
+ , ("hs-definition", "")
+ ]
+
+-- | Read style preferences in from a file using the @Read@ instance
+-- for @StylePrefs@, or return the default style if the file name is
+-- empty.
+getStylePrefs :: FilePath -> IO StylePrefs
+getStylePrefs "" = return defaultStylePrefs
+getStylePrefs fname = liftM read (U.readFile fname)
+
+-- | Take a @String@ of HTML produced by hscolour, and \"bake\" styles
+-- into it by replacing class attributes with appropriate style
+-- attributes.
+bakeStyles :: StylePrefs -> String -> String
+bakeStyles prefs s = verbatim $ filtDoc (xmlParse "bake-input" s)
+ where
+
+ -- filter the document (an Hscoloured fragment of Haskell source)
+ filtDoc (Document p s e m) = c where
+ [c] = filts (CElem e noPos)
+
+ -- the filter is a fold of individual filters for each CSS class
+ filts = mkElem "pre" [(foldXml $ foldl o keep $ map filt prefs) `o` replaceTag "code"]
+
+ -- an individual filter replaces the attributes of a tag with
+ -- a style attribute when it has a specific 'class' attribute.
+ filt (cls,style) =
+ replaceAttrs [("style",style)] `when`
+ (attrval $ (N "class", AttValue [Left cls]))
+
+{- Highlighting-Kate uses @\
@ in code blocks to indicate
+ newlines. WordPress (and possibly others) chooses to strip them
+ away when found in @\@ sections of uploaded HTML. So we
+ need to turn them back to newlines.
+-}
+
+-- | Replace @\
@ tags with newlines.
+replaceBreaks :: String -> String
+replaceBreaks s = verbatim $ filtDoc (xmlParse "input" s)
+ where
+ -- filter the document (a highlighting-kate highlighted fragment of
+ -- haskell source)
+ filtDoc (Document p s e m) = c where
+ [c] = filts (CElem e noPos)
+ filts = foldXml (literal "\n" `when` tag "br")
+
+{-
+Note/todo: the above is a function that could be made better in a
+few ways and then factored out into a library. A way to handle the
+above would be to allow the preferences to be specified as an actual
+CSS style sheet, which then would be baked into the HTML. Such a
+function could be separately useful, and could be used to 'bake' in
+the highlighting-kate styles.
+-}
+
+-- | Transform a @CodeBlock@ into a @RawHtml@ block, where
+-- the content contains marked up Haskell (possibly with literate
+-- markers), or marked up non-Haskell, if highlighting of non-Haskell has
+-- been selected.
+colouriseCodeBlock :: HsHighlight -> Bool -> Block -> Block
+colouriseCodeBlock hsHighlight otherHighlight b@(CodeBlock attr@(_,classes,_) s)
+
+ | tag == Just "haskell" || haskell
+ = case hsHighlight of
+ HsColourInline style ->
+ RawBlock "html" $ bakeStyles style $ colourIt lit src
+ HsColourCSS -> RawBlock "html" $ colourIt lit src
+ HsNoHighlight -> RawBlock "html" $ simpleHTML hsrc
+ HsKate -> case tag of
+ Nothing -> myHighlightK attr hsrc
+ Just t -> myHighlightK ("", t:classes,[]) hsrc
+
+ | otherHighlight
+ = case tag of
+ Nothing -> myHighlightK attr src
+ Just t -> myHighlightK ("",[t],[]) src
+
+ | otherwise
+ = RawBlock "html" $ simpleHTML src
+
+ where
+ (tag,src)
+ | null classes = unTag s
+ | otherwise = (Nothing, s)
+ hsrc
+ | lit = litify src
+ | otherwise = src
+ lit = "sourceCode" `elem` classes
+ haskell = "haskell" `elem` classes
+ simpleHTML s = "" ++ s ++ "
"
+ myHighlightK attr s = case highlight formatHtmlBlock attr s of
+ Nothing -> RawBlock "html" $ simpleHTML s
+ Just html -> RawBlock "html" $ replaceBreaks $ renderHtml html
+
+colouriseCodeBlock _ _ b = b
+
+-- | Perform syntax highlighting on an entire Pandoc document.
+colourisePandoc :: HsHighlight -> Bool -> Pandoc -> Pandoc
+colourisePandoc hsHighlight otherHighlight (Pandoc m blocks) =
+ Pandoc m $ map (colouriseCodeBlock hsHighlight otherHighlight) blocks
diff --git a/src/Text/BlogLiterately/Image.hs b/src/Text/BlogLiterately/Image.hs
new file mode 100644
--- /dev/null
+++ b/src/Text/BlogLiterately/Image.hs
@@ -0,0 +1,104 @@
+{-# LANGUAGE ViewPatterns #-}
+{-# LANGUAGE RecordWildCards #-}
+
+-----------------------------------------------------------------------------
+-- |
+-- Module : Text.BlogLiterately.Image
+-- Copyright : (c) 2012 Brent Yorgey
+-- License : GPL (see LICENSE)
+-- Maintainer : Brent Yorgey
+--
+-- Uploading images embedded in posts to the server.
+--
+-----------------------------------------------------------------------------
+
+module Text.BlogLiterately.Image
+ (
+ uploadAllImages
+ , uploadIt
+ , mkMediaObject
+ ) where
+
+import Control.Arrow ( first, (>>>), arr
+ , Kleisli(..), runKleisli )
+import qualified Control.Category as C ( Category, id )
+import Control.Monad ( liftM, unless )
+import Control.Monad.IO.Class ( liftIO )
+import Control.Monad.Trans.Reader ( ReaderT, runReaderT, ask )
+import qualified Data.ByteString.Char8 as B
+import Data.Char ( toLower )
+import Data.Functor ( (<$>) )
+import Data.List ( isPrefixOf, intercalate )
+import Data.Maybe ( fromMaybe )
+import System.Directory ( doesFileExist )
+import System.FilePath ( takeFileName, takeExtension )
+import System.IO
+import qualified System.IO.UTF8 as U ( readFile )
+import System.Process ( ProcessHandle, waitForProcess
+ , runInteractiveCommand )
+import Text.Pandoc
+import Network.XmlRpc.Client ( remote )
+import Network.XmlRpc.Internals ( Value(..), toValue )
+
+import Text.BlogLiterately.Options
+
+-- | Transform a document by uploading any \"local\" images to the
+-- server, and replacing their filenames with the URLs returned by the
+-- server.
+uploadAllImages :: BlogLiterately -> (Pandoc -> IO Pandoc)
+uploadAllImages bl@(BlogLiterately{..}) =
+ case blog of
+ Just xmlrpc -> bottomUpM (uploadOneImage xmlrpc)
+ _ -> return
+ where
+ uploadOneImage :: String -> Inline -> IO Inline
+ uploadOneImage xmlrpc i@(Image altText (imgUrl, imgTitle))
+ | isLocal imgUrl = do
+ res <- uploadIt xmlrpc imgUrl bl
+ case res of
+ Just (ValueStruct (lookup "url" -> Just (ValueString newUrl))) ->
+ return $ Image altText (newUrl, imgTitle)
+ _ -> do
+ putStrLn $ "Warning: upload of " ++ imgUrl ++ " failed."
+ return i
+ | otherwise = return i
+ uploadOneImage _ i = return i
+
+ isLocal imgUrl = none (`isPrefixOf` imgUrl) ["http", "/"]
+ none p = all (not . p)
+
+-- | Upload a file using the @metaWeblog.newMediaObject@ XML-RPC method
+-- call.
+uploadIt :: String -> FilePath -> BlogLiterately -> IO (Maybe Value)
+uploadIt url filePath (BlogLiterately{..}) = do
+ putStr $ "Uploading " ++ filePath ++ "..."
+ mmedia <- mkMediaObject filePath
+ case mmedia of
+ Nothing -> do
+ putStrLn $ "\nFile not found: " ++ filePath
+ return Nothing
+ Just media -> do
+ val <- remote url "metaWeblog.newMediaObject" blogid user (fromMaybe "" password) media
+ putStrLn "done."
+ return $ Just val
+
+-- | Prepare a file for upload.
+mkMediaObject :: FilePath -> IO (Maybe Value)
+mkMediaObject filePath = do
+ exists <- doesFileExist filePath
+ if not exists
+ then return Nothing
+ else do
+ bits <- B.readFile filePath
+ return . Just $ ValueStruct
+ [ ("name", toValue fileName)
+ , ("type", toValue fileType)
+ , ("bits", ValueBase64 bits)
+ ]
+ where
+ fileName = takeFileName filePath
+ fileType = case (map toLower . drop 1 . takeExtension) fileName of
+ "png" -> "image/png"
+ "jpg" -> "image/jpeg"
+ "jpeg" -> "image/jpeg"
+ "gif" -> "image/gif"
diff --git a/src/Text/BlogLiterately/LaTeX.hs b/src/Text/BlogLiterately/LaTeX.hs
new file mode 100644
--- /dev/null
+++ b/src/Text/BlogLiterately/LaTeX.hs
@@ -0,0 +1,41 @@
+
+-----------------------------------------------------------------------------
+-- |
+-- Module : Text.BlogLiterately.LaTeX
+-- Copyright : (c) 2012 Brent Yorgey
+-- License : GPL (see LICENSE)
+-- Maintainer : Brent Yorgey
+--
+-- Utilities for working with embedded LaTeX.
+--
+-----------------------------------------------------------------------------
+
+module Text.BlogLiterately.LaTeX
+ (
+ wpTeXify
+ ) where
+
+import Data.List ( isPrefixOf )
+import Text.Pandoc
+
+-- | WordPress can render LaTeX, but expects it in a special non-standard
+-- format (@\$latex foo\$@). The @wpTeXify@ function formats LaTeX code
+-- using this format so that it can be processed by WordPress.
+wpTeXify :: Pandoc -> Pandoc
+wpTeXify = bottomUp formatDisplayTex . bottomUp formatInlineTex
+ where formatInlineTex :: [Inline] -> [Inline]
+ formatInlineTex (Math InlineMath tex : is)
+ = (Str $ "$latex " ++ unPrefix "latex" tex ++ "$") : is
+ formatInlineTex is = is
+
+ formatDisplayTex :: [Block] -> [Block]
+ formatDisplayTex (Para [Math DisplayMath tex] : bs)
+ = RawBlock "html" ""
+ : Plain [Str $ "$latex " ++ "\\displaystyle " ++ unPrefix "latex" tex ++ "$"]
+ : RawBlock "html" "
"
+ : bs
+ formatDisplayTex bs = bs
+
+ unPrefix pre s
+ | pre `isPrefixOf` s = drop (length pre) s
+ | otherwise = s
diff --git a/src/Text/BlogLiterately/Options.hs b/src/Text/BlogLiterately/Options.hs
new file mode 100644
--- /dev/null
+++ b/src/Text/BlogLiterately/Options.hs
@@ -0,0 +1,108 @@
+{-# LANGUAGE DeriveDataTypeable #-}
+
+-----------------------------------------------------------------------------
+-- |
+-- Module : Text.BlogLiterately.Options
+-- Copyright : (c) 2008-2010 Robert Greayer, 2012 Brent Yorgey
+-- License : GPL (see LICENSE)
+-- Maintainer : Brent Yorgey
+--
+-- Configuation and command-line options.
+--
+-----------------------------------------------------------------------------
+
+module Text.BlogLiterately.Options
+ ( BlogLiterately(..)
+ , blOpts
+ )
+ where
+
+import System.Console.CmdArgs
+
+import Text.BlogLiterately.Highlight
+
+-- | Configuration record (and command-line options) for @BlogLiterately@.
+data BlogLiterately = BlogLiterately
+ { style :: String -- ^ Name of a style file
+ , hsHighlight :: HsHighlight -- ^ Haskell highlighting mode
+ , otherHighlight :: Bool -- ^ Use highlighting-kate for
+ -- non-Haskell?
+ , wplatex :: Bool -- ^ Format LaTeX for WordPress?
+ , ghci :: Bool -- ^ Automatically process ghci sessions?
+ , uploadImages :: Bool -- ^ Automatically upload images?
+ , categories :: [String] -- ^ Categories for the post
+ , tags :: [String] -- ^ Tags for the post
+ , blogid :: String -- ^ Blog-specific identifier
+ -- (e.g. for blogging software
+ -- handling multiple blogs)
+ , blog :: Maybe String -- ^ Blog xmlrpc URL
+ , user :: String -- ^ Blog user name
+ , password :: Maybe String -- ^ Blog password (omit to be interactively prompted)
+ , title :: String -- ^ Post title
+ , file :: String -- ^ File to post
+ , postid :: Maybe String -- ^ ID of a post to update
+ , page :: Bool -- ^ Create a \"page\" instead of a post
+ , publish :: Bool -- ^ Should the post be published?
+ -- (Otherwise it is uploaded as a draft.)
+ , xtra :: [String] -- ^ Extension arguments, for use e.g. by
+ -- custom transforms
+ }
+ deriving (Show,Data,Typeable)
+
+-- | Command-line configuration for use with @cmdargs@.
+blOpts :: BlogLiterately
+blOpts = BlogLiterately
+ { style = "" &= help "style specification (for --hscolour-icss)"
+ &= typFile
+ , hsHighlight = enum
+ [ (HsColourInline defaultStylePrefs)
+ &= explicit
+ &= name "hscolour-icss"
+ &= help "highlight haskell: hscolour, inline style (default)"
+ , HsColourCSS
+ &= explicit
+ &= name "hscolour-css"
+ &= help "highlight haskell: hscolour, separate stylesheet"
+ , HsNoHighlight
+ &= explicit
+ &= name "hs-nohighlight"
+ &= help "no haskell highlighting"
+ , HsKate
+ &= explicit
+ &= name "hs-kate"
+ &= help "highlight haskell with highlighting-kate"
+ ]
+ , otherHighlight = enum
+ [ True
+ &= explicit
+ &= name "other-kate"
+ &= help "highlight other code with highlighting-kate"
+ ]
+ , wplatex = def &= help "reformat inline LaTeX the way WordPress expects"
+ , ghci = def &= help "run [ghci] blocks through ghci and include output"
+ , uploadImages = def &= name "upload-images" &= explicit &= help "upload local images"
+ , page = def &= help "create a \"page\" instead of a post (WordPress only)"
+ , publish = def &= help "publish post (otherwise it's uploaded as a draft)"
+ , categories = def
+ &= explicit
+ &= name "category"
+ &= help "post category (can specify more than one)"
+ , tags = def
+ &= explicit
+ &= name "tag"
+ &= help "tag (can specify more than one)"
+
+ , xtra = def
+ &= help "extension arguments, for use with custom extensions"
+ , blogid = "default" &= help "Blog specific identifier" &= typ "ID"
+ , postid = def &= help "Post to replace (if any)" &= typ "ID"
+
+ , blog = def &= typ "URL" &= help "blog XML-RPC url (if omitted, html goes to stdout)"
+ , user = def &= typ "USER" &= help "user name"
+ , password = def &= typ "PASSWORD" &= help "password"
+ , title = def &= typ "TITLE" &= help "post title"
+ , file = def &= argPos 0 &= typ "FILE"
+ }
+ &= program "BlogLiterately"
+ &= summary ("BlogLierately v0.4, (c) Robert Greayer 2008-2010, Brent Yorgey 2012\n" ++
+ "This program comes with ABSOLUTELY NO WARRANTY\n")
diff --git a/src/Text/BlogLiterately/Post.hs b/src/Text/BlogLiterately/Post.hs
new file mode 100644
--- /dev/null
+++ b/src/Text/BlogLiterately/Post.hs
@@ -0,0 +1,114 @@
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE FlexibleContexts #-}
+
+-----------------------------------------------------------------------------
+-- |
+-- Module : Text.BlogLiterately.Post
+-- Copyright : (c) 2008-2010 Robert Greayer, 2012 Brent Yorgey
+-- License : GPL (see LICENSE)
+-- Maintainer : Brent Yorgey
+--
+-- Uploading posts to the server.
+--
+-----------------------------------------------------------------------------
+
+module Text.BlogLiterately.Post
+ (
+ mkPost, mkArray, postIt
+ ) where
+
+import Control.Monad ( unless )
+import Data.Maybe ( fromMaybe )
+
+import Network.XmlRpc.Client ( remote )
+import Network.XmlRpc.Internals ( Value(..), toValue, XmlRpcType )
+
+import Text.BlogLiterately.Options
+
+{-
+The metaWeblog API defines `newPost` and `editPost` procedures that
+look like:
+
+ [other]
+ metaWeblog.newPost (blogid, username, password, struct, publish)
+ returns string
+ metaWeblog.editPost (postid, username, password, struct, publish)
+ returns true
+
+For WordPress blogs, the `blogid` is ignored. The user name and
+password are simply strings, and `publish` is a flag indicating
+whether to load the post as a draft, or to make it public immediately.
+The `postid` is an identifier string which is assigned when you
+initially create a post. The interesting bit is the `struct` field,
+which is an XML-RPC structure defining the post along with some
+meta-data, like the title. I want be able to provide the post body, a
+title, and lists of categories and tags. For the body and title, we
+could just let HaXR convert the values automatically into the XML-RPC
+`Value` type, since they all have the same Haskell type (`String`) and
+thus can be put into a list. But the categories and tags are lists of
+strings, so we need to explicitly convert everything to a `Value`,
+then combine:
+-}
+
+-- | Prepare a post for uploading by creating something of the proper
+-- form to be an argument to an XML-RPC call.
+mkPost :: String -- ^ Post title
+ -> String -- ^ Post content
+ -> [String] -- ^ List of categories
+ -> [String] -- ^ List of tags
+ -> Bool -- ^ @True@ = page, @False@ = post
+ -> [(String, Value)]
+mkPost title text categories tags page =
+ mkArray "categories" categories
+ ++ mkArray "mt_keywords" tags
+ ++ [ ("title", toValue title)
+ , ("description", toValue text)
+ ]
+ ++ [ ("post_type", toValue "page") | page ]
+
+-- | Given a name and a list of values, create a named \"array\" field
+-- suitable for inclusion in an XML-RPC struct.
+mkArray :: XmlRpcType [a] => String -> [a] -> [(String, Value)]
+mkArray _ [] = []
+mkArray name values = [(name, toValue values)]
+
+{-
+The HaXR library exports a function for invoking XML-RPC procedures:
+
+ [haskell]
+ remote :: Remote a =>
+ String -- ^ Server URL. May contain username and password on
+ -- the format username:password\@ before the hostname.
+ -> String -- ^ Remote method name.
+ -> a -- ^ Any function
+ -- @(XmlRpcType t1, ..., XmlRpcType tn, XmlRpcType r) =>
+ -- t1 -> ... -> tn -> IO r@
+
+The function requires an URL and a method name, and returns a function
+of type `Remote a => a`. Based on the instances defined for `Remote`,
+any function with zero or more parameters in the class `XmlRpcType`
+and a return type of `XmlRpcType r => IO r` will work, which means you
+can simply 'feed' `remote` additional arguments as required by the
+remote procedure, and as long as you make the call in an IO context,
+it will typecheck. `postIt` calls `metaWeblog.newPost` or
+`metaWeblog.editPost` (or simply prints the HTML to stdout) as
+appropriate:
+-}
+
+-- | Given a configuration and a formatted post, upload it to the server.
+postIt :: BlogLiterately -> String -> IO ()
+postIt (BlogLiterately{..}) html =
+ case blog of
+ Nothing -> putStr html
+ Just url -> do
+ let pwd = fromMaybe "" password
+ case postid of
+ Nothing -> do
+ pid <- remote url "metaWeblog.newPost" blogid user pwd
+ (mkPost title html categories tags page) publish
+ putStrLn $ "Post ID: " ++ pid
+ Just pid -> do
+ success <- remote url "metaWeblog.editPost" pid user pwd
+ (mkPost title html categories tags page) publish
+ unless success $ putStrLn "update failed!"
+
diff --git a/src/Text/BlogLiterately/Run.hs b/src/Text/BlogLiterately/Run.hs
new file mode 100644
--- /dev/null
+++ b/src/Text/BlogLiterately/Run.hs
@@ -0,0 +1,79 @@
+{-# LANGUAGE RecordWildCards #-}
+
+-----------------------------------------------------------------------------
+-- |
+-- Module : Text.BlogLiterately.Run
+-- Copyright : (c) 2012 Brent Yorgey
+-- License : GPL (see LICENSE)
+-- Maintainer : Brent Yorgey
+--
+-- Functions for creating @BlogLiterately@ executables. By default,
+-- installing this library results in the installation of a standard
+-- executable, called @BlogLiterately@, which corresponds to
+-- 'blogLiterately' from this module. However, you can create your
+-- own custom executables with extra custom functionality using
+-- 'blogLiteratelyWith' or 'blogLiteratelyCustom'. For example:
+--
+-- > module Main where
+-- > myCustomXF = Transform ...
+-- > main = blogLiteratelyWith [myCustomXF]
+--
+-- See "Text.BlogLiterately.Transform" for examples of transforms and
+-- help in creating your own.
+--
+-----------------------------------------------------------------------------
+
+module Text.BlogLiterately.Run
+ (
+ blogLiterately
+ , blogLiteratelyWith
+ , blogLiteratelyCustom
+
+ ) where
+
+import System.Console.CmdArgs ( cmdArgs)
+import System.IO ( hFlush, stdout )
+import qualified System.IO.UTF8 as U ( readFile )
+
+import Text.BlogLiterately.Highlight
+import Text.BlogLiterately.Options
+import Text.BlogLiterately.Post
+import Text.BlogLiterately.Transform
+
+-- | The default BlogLiterately application.
+blogLiterately :: IO ()
+blogLiterately = blogLiteratelyCustom standardTransforms
+
+-- | Like 'blogLiterately', but with the ability to specify custom
+-- 'Transform's which will be applied /after/ the standard ones.
+blogLiteratelyWith :: [Transform] -> IO ()
+blogLiteratelyWith ts = blogLiteratelyCustom (standardTransforms ++ ts)
+
+-- | Like 'blogLiterately', but with the ability to /replace/ the
+-- standard 'Transform's with your own. Use this to implement
+-- custom interleaving orders of the standard transforms and your
+-- own, to exclude some or all of the standard transforms, etc.
+blogLiteratelyCustom :: [Transform] -> IO ()
+blogLiteratelyCustom ts = do
+ bl <- cmdArgs blOpts
+ let (BlogLiterately{..}) = bl
+
+ prefs <- getStylePrefs style
+ let hsHighlight' = case hsHighlight of
+ HsColourInline _ -> HsColourInline prefs
+ _ -> hsHighlight
+ bl' = bl { hsHighlight = hsHighlight' }
+
+ pwd <- case (blog, password) of
+ (Just _, Nothing) -> passwordPrompt
+ _ -> return password
+ let bl'' = bl' { password = pwd }
+
+ html <- xformDoc bl'' ts =<< U.readFile file
+ postIt bl'' html
+
+passwordPrompt :: IO (Maybe String)
+passwordPrompt = do
+ putStr "Password: " >> hFlush stdout
+ pwd <- getLine
+ return $ Just pwd
diff --git a/src/Text/BlogLiterately/Transform.hs b/src/Text/BlogLiterately/Transform.hs
new file mode 100644
--- /dev/null
+++ b/src/Text/BlogLiterately/Transform.hs
@@ -0,0 +1,139 @@
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE TypeOperators #-}
+
+-----------------------------------------------------------------------------
+-- |
+-- Module : Text.BlogLiterately.Transform
+-- Copyright : (c) 2008-2010 Robert Greayer, 2012 Brent Yorgey
+-- License : GPL (see LICENSE)
+-- Maintainer : Brent Yorgey
+--
+-- Tools for putting together a pipeline transforming the source for a
+-- post into a completely formatted HTML document.
+--
+-----------------------------------------------------------------------------
+
+module Text.BlogLiterately.Transform
+ ( -- * Transforms
+ Transform(..), runTransform, runTransforms
+
+ -- * Standard transforms
+ , wptexifyXF
+ , ghciXF
+ , imagesXF
+ , highlightXF
+ , standardTransforms
+
+ -- * Transforming documents
+ , xformDoc
+
+ -- * Utilities
+ , whenA, fixLineEndings
+ ) where
+
+import Control.Arrow ( first, (>>>), arr
+ , Kleisli(..), runKleisli )
+import qualified Control.Category as C ( Category, id )
+import qualified Data.Traversable as T
+
+import Text.Pandoc
+import Text.Blaze.Html.Renderer.String ( renderHtml )
+
+import Text.BlogLiterately.Ghci
+import Text.BlogLiterately.Highlight
+import Text.BlogLiterately.Image
+import Text.BlogLiterately.LaTeX
+import Text.BlogLiterately.Options
+
+-- | A document transformation consists of two parts: an actual
+-- transformation, expressed as a function over Pandoc documents, and
+-- a condition specifying whether the transformation should actually
+-- be applied.
+--
+-- The transformation itself takes a 'BlogLiterately' configuration
+-- as an argument. You may of course ignore it if you do not need
+-- to know anything about the configuration. The @--xtra@ (or @-x@)
+-- flag is also provided especially as a method of getting
+-- information from the command-line to custom extensions. Arguments
+-- passed via @-x@ on the command line are available from the 'xtra'
+-- field of the 'BlogLiterately' configuration.
+--
+-- The transformation is then specified as a @'Kleisli' IO 'Pandoc'
+-- 'Pandoc'@ arrow, which is isomorphic to @Pandoc -> IO Pandoc@. If
+-- you have a pure function of type @Pandoc -> Pandoc@, wrap it in a
+-- call to 'arr' to produce a 'Kleisli' arrow. If you have a
+-- function @Pandoc -> IO Pandoc@, wrap it in the 'Kleisli'
+-- constructor.
+--
+-- For examples, see the implementations of the standard transforms
+-- below.
+data Transform = Transform
+ { getTransform :: BlogLiterately -> Kleisli IO Pandoc Pandoc
+ -- ^ A document transformation, which can depend on
+ -- BlogLiterately options and can have effects in
+ -- the @IO@ monad.
+ , xfCond :: BlogLiterately -> Bool
+ -- ^ A condition under which to run the transformation.
+ }
+
+-- | Run a 'Transform' (if its condition is met).
+runTransform :: Transform -> BlogLiterately -> Kleisli IO Pandoc Pandoc
+runTransform t bl = getTransform t bl `whenA` xfCond t bl
+
+-- | Run a pipeline of 'Transform's.
+runTransforms :: [Transform] -> BlogLiterately -> Kleisli IO Pandoc Pandoc
+runTransforms ts = foldr (>>>) (C.id) . T.traverse runTransform ts
+
+-- | Format embedded LaTeX for WordPress (if the @wplatex@ flag is set).
+wptexifyXF :: Transform
+wptexifyXF = Transform (const (arr wpTeXify)) wplatex
+
+-- | Format embedded @ghci@ sessions (if the @ghci@ flag is set).
+ghciXF :: Transform
+ghciXF = Transform (Kleisli . formatInlineGhci . file) ghci
+
+-- | Upload embedded local images to the server (if the @uploadImages@
+-- flag is set).
+imagesXF :: Transform
+imagesXF = Transform (Kleisli . uploadAllImages) uploadImages
+
+-- | Perform syntax highlighting on code blocks.
+highlightXF :: Transform
+highlightXF = Transform
+ (\bl -> arr (colourisePandoc (hsHighlight bl) (otherHighlight bl)))
+ (const True)
+
+-- | The standard set of transforms that are run by default:
+-- 'wptexifyXF', 'ghciXF', 'imagesXF', 'highlightXF'.
+standardTransforms :: [Transform]
+standardTransforms = [wptexifyXF, ghciXF, imagesXF, highlightXF]
+
+-- | Transform a complete input document string to an HTML output
+-- string, given a list of transformation passes.
+xformDoc :: BlogLiterately -> [Transform] -> (String -> IO String)
+xformDoc bl xforms = runKleisli $
+ arr fixLineEndings
+ >>> arr (readMarkdown parseOpts)
+
+ >>> runTransforms xforms bl
+
+ >>> arr (writeHtml writeOpts)
+ >>> arr renderHtml
+ where
+ writeOpts = defaultWriterOptions
+ { writerReferenceLinks = True }
+ parseOpts = defaultParserState
+ { stateLiterateHaskell = True }
+
+-- | Turn @CRLF@ pairs into a single @LF@. This is necessary since
+-- 'readMarkdown' is picky about line endings.
+fixLineEndings :: String -> String
+fixLineEndings [] = []
+fixLineEndings ('\r':'\n':cs) = '\n':fixLineEndings cs
+fixLineEndings (c:cs) = c:fixLineEndings cs
+
+-- | A useful arrow utility for running some part of a pipeline
+-- conditionally.
+whenA :: C.Category (~>) => (a ~> a) -> Bool -> (a ~> a)
+whenA a p | p = a
+ | otherwise = C.id