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
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)
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
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"