diff --git a/BlogLiterately.cabal b/BlogLiterately.cabal --- a/BlogLiterately.cabal +++ b/BlogLiterately.cabal @@ -1,5 +1,5 @@ Name: BlogLiterately -Version: 0.5.1 +Version: 0.5.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 @@ -53,14 +53,15 @@ filepath, directory, bytestring, - split >= 0.1.4 && < 0.2, + containers, + split >= 0.1.4 && < 0.3, utf8-string >= 0.3 && < 0.4, transformers >= 0.3 && < 0.4, parsec >= 3 && < 3.2, HaXml >= 1.22 && < 1.24, hscolour >= 1.20 && < 1.21, blaze-html >= 0.5 && < 0.6, - cmdargs >= 0.9.5 && < 0.10, + cmdargs >= 0.9.5 && < 0.11, haxr >= 3000.9 && < 3000.10, pandoc >= 1.9.3 && < 1.10 Exposed-modules: Text.BlogLiterately @@ -86,7 +87,7 @@ Executable BlogLiterately Build-Depends: base, BlogLiterately, - cmdargs >= 0.9.5 && < 0.10, + cmdargs >= 0.9.5 && < 0.11, utf8-string >= 0.3 && < 0.4 Main-Is: BlogLiterately.hs hs-source-dirs: main diff --git a/CHANGES b/CHANGES --- a/CHANGES +++ b/CHANGES @@ -1,3 +1,13 @@ +0.5.2: 20 August 2012 + + * improvement to behavior of --upload-images flag: cache uploaded + image server URLs, even across multiple runs, to avoid uploading + the same image multiple times + + * bump dep upper bounds: + - split to < 0.3 + - cmdargs to < 0.11 + 0.5.1: 30 July 2012 * Escape < and > characters in ghci output diff --git a/doc/BlogLiteratelyDoc.lhs b/doc/BlogLiteratelyDoc.lhs --- a/doc/BlogLiteratelyDoc.lhs +++ b/doc/BlogLiteratelyDoc.lhs @@ -223,26 +223,26 @@ `metaWeblog.newMediaObject` RPC call), and the local file name replaced with the URL returned by the server. -A few caveats: +Uploaded images, and their associated server URLs, will be tracked in +a file called `.BlogLiterately-uploaded-images`. A given image will +only be uploaded once, even across multiple runs of @BlogLiterately@. +In practice, this means that the @--upload-images@ option can be left +on while uploading multiple draft versions of a post, and only new +images will be uploaded each time. Note, however, that images are +tracked by *file name*, not contents, so modifications to an image +(while leaving the name the same) will be ignored. As a workaround, +delete @.BlogLiterately-uploaded-images@ (or just the entry for the +modified image), or give the modified image a different name. -* There is no mechanism for uploading only some of the images. So if - you upload a post with a bunch of images but then want to change just - one of the images, you must either re-upload them all, or upload the - single image manually. +A few caveats: -* Also, the `newMediaObject` call has an optional `replace` parameter, but +* The `newMediaObject` call has an optional `replace` parameter, but `BlogLiterately` does not use it, since it's too dangerous: if `replace` is set and you happen to use the same file name as some other image file that already exists on your blog, the old image would be deleted. However, this means that if you upload an image multiple - times you will get multiple copies on your blog. - -* As a consequence of the above, best practice is probably to write your - post while doing a combination of previewing locally to see the post - with images and uploading without the `--upload-images` flag to see - what the post looks like on your blog (except with a bunch of broken - images). Once you're confident everything looks good, do a final - upload with `--upload-images` (and perhaps `--publish`) set. + times you will get multiple copies on your blog. (Although this is mitigated + somewhat by the mechanism to cache uploaded image URLs.) Customization ------------- diff --git a/src/Text/BlogLiterately/Image.hs b/src/Text/BlogLiterately/Image.hs --- a/src/Text/BlogLiterately/Image.hs +++ b/src/Text/BlogLiterately/Image.hs @@ -19,16 +19,19 @@ , mkMediaObject ) where -import Control.Arrow ( first, (>>>), arr +import Control.Arrow ( first, second, (>>>), 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.Class ( lift ) import Control.Monad.Trans.Reader ( ReaderT, runReaderT, ask ) +import Control.Monad.Trans.State ( StateT, runStateT, get, modify ) import qualified Data.ByteString.Char8 as B import Data.Char ( toLower ) import Data.Functor ( (<$>) ) import Data.List ( isPrefixOf, intercalate ) +import qualified Data.Map as M import Data.Maybe ( fromMaybe ) import System.Directory ( doesFileExist ) import System.FilePath ( takeFileName, takeExtension ) @@ -36,36 +39,75 @@ 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 +type URL = String + -- | 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{..}) = +-- server, and replacing their filenames with the URLs returned by +-- the server. Only upload any given image once (determined by file +-- name), even across runs: uploaded images and their associated URL +-- on the server is tracked in a special dotfile, +-- @.BlogLiterately-uploaded-images@. +uploadAllImages :: BlogLiterately -> Pandoc -> IO Pandoc +uploadAllImages bl@(BlogLiterately{..}) p = case blog of - Just xmlrpc -> bottomUpM (uploadOneImage xmlrpc) - _ -> return + Just xmlrpc -> do + uploaded <- readUploadedImages + (p', uploaded') <- runStateT (bottomUpM (uploadOneImage xmlrpc) p) uploaded + writeUploadedImages uploaded' + return p' + _ -> return p where - uploadOneImage :: String -> Inline -> IO Inline + uploadOneImage :: String -> Inline -> StateT (M.Map FilePath URL) 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 + uploaded <- get + case M.lookup imgUrl uploaded of + Just url -> return $ Image altText (url, imgTitle) + Nothing -> do + res <- lift $ uploadIt xmlrpc imgUrl bl + case res of + Just (ValueStruct (lookup "url" -> Just (ValueString newUrl))) -> do + modify (M.insert imgUrl newUrl) + return $ Image altText (newUrl, imgTitle) + _ -> do + liftIO . 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) + +uploadedImagesFile = ".BlogLiterately-uploaded-images" + +-- | Read the list of previously uploaded images and their associated URLs from +-- a special dotfile (namely, @.BlogLiterately-uploaded-images@). +readUploadedImages :: IO (M.Map FilePath URL) +readUploadedImages = do + e <- doesFileExist uploadedImagesFile + case e of + False -> return M.empty + True -> do + txt <- readFile uploadedImagesFile + let m = fromMaybe (M.empty) (readMay txt) + length txt `seq` return m + +readMay :: Read a => String -> Maybe a +readMay s = case reads s of + [(a,"")] -> Just a + _ -> Nothing + +-- | Write out the list of uploaded images and their associated URLs +-- to a special dotfile (namely, @.BlogLiterately-uploaded-images@). +writeUploadedImages :: M.Map FilePath URL -> IO () +writeUploadedImages m = writeFile uploadedImagesFile (show m) -- | Upload a file using the @metaWeblog.newMediaObject@ XML-RPC method -- call.