{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ViewPatterns #-}
module Text.BlogLiterately.Image
(
uploadAllImages
, uploadIt
, mkMediaObject
) where
import qualified Data.Text as T
import Control.Monad.IO.Class (liftIO)
import Control.Monad.Trans.Class (lift)
import Control.Monad.Trans.State (StateT, get, modify, runStateT)
import qualified Data.ByteString.Char8 as B
import Data.Char (toLower)
import Data.List (isPrefixOf)
import qualified Data.Map as M
import Data.Maybe (fromMaybe)
import System.Directory (doesFileExist)
import System.FilePath (takeExtension, takeFileName)
import Network.XmlRpc.Client (remote)
import Network.XmlRpc.Internals (Value (..), toValue)
import Text.Pandoc
import Text.BlogLiterately.Options
type URL = String
uploadAllImages :: BlogLiterately -> Pandoc -> IO Pandoc
uploadAllImages :: BlogLiterately -> Pandoc -> IO Pandoc
uploadAllImages bl :: BlogLiterately
bl@(BlogLiterately{[FilePath]
Maybe Bool
Maybe FilePath
Maybe HsHighlight
_xtra :: BlogLiterately -> [FilePath]
_citations :: BlogLiterately -> Maybe Bool
_htmlOnly :: BlogLiterately -> Maybe Bool
_publish :: BlogLiterately -> Maybe Bool
_page :: BlogLiterately -> Maybe Bool
_postid :: BlogLiterately -> Maybe FilePath
_format :: BlogLiterately -> Maybe FilePath
_file :: BlogLiterately -> Maybe FilePath
_title :: BlogLiterately -> Maybe FilePath
_password :: BlogLiterately -> Maybe FilePath
_user :: BlogLiterately -> Maybe FilePath
_blog :: BlogLiterately -> Maybe FilePath
_profile :: BlogLiterately -> Maybe FilePath
_blogid :: BlogLiterately -> Maybe FilePath
_tags :: BlogLiterately -> [FilePath]
_categories :: BlogLiterately -> [FilePath]
_uploadImages :: BlogLiterately -> Maybe Bool
_ghci :: BlogLiterately -> Maybe Bool
_math :: BlogLiterately -> Maybe FilePath
_wplatex :: BlogLiterately -> Maybe Bool
_rawlatex :: BlogLiterately -> Maybe Bool
_toc :: BlogLiterately -> Maybe Bool
_litHaskell :: BlogLiterately -> Maybe Bool
_otherHighlight :: BlogLiterately -> Maybe Bool
_hsHighlight :: BlogLiterately -> Maybe HsHighlight
_style :: BlogLiterately -> Maybe FilePath
_xtra :: [FilePath]
_citations :: Maybe Bool
_htmlOnly :: Maybe Bool
_publish :: Maybe Bool
_page :: Maybe Bool
_postid :: Maybe FilePath
_format :: Maybe FilePath
_file :: Maybe FilePath
_title :: Maybe FilePath
_password :: Maybe FilePath
_user :: Maybe FilePath
_blog :: Maybe FilePath
_profile :: Maybe FilePath
_blogid :: Maybe FilePath
_tags :: [FilePath]
_categories :: [FilePath]
_uploadImages :: Maybe Bool
_ghci :: Maybe Bool
_math :: Maybe FilePath
_wplatex :: Maybe Bool
_rawlatex :: Maybe Bool
_toc :: Maybe Bool
_litHaskell :: Maybe Bool
_otherHighlight :: Maybe Bool
_hsHighlight :: Maybe HsHighlight
_style :: Maybe FilePath
..}) Pandoc
p =
case (Maybe FilePath
_blog, Maybe Bool
_htmlOnly) of
(Just FilePath
xmlrpc, Maybe Bool
h) | Maybe Bool
h forall a. Eq a => a -> a -> Bool
/= forall a. a -> Maybe a
Just Bool
True -> do
Map FilePath FilePath
uploaded <- IO (Map FilePath FilePath)
readUploadedImages
(Pandoc
p', Map FilePath FilePath
uploaded') <- forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
runStateT (forall (m :: * -> *) a b.
(Monad m, Data a, Data b) =>
(a -> m a) -> b -> m b
bottomUpM (FilePath -> Inline -> StateT (Map FilePath FilePath) IO Inline
uploadOneImage FilePath
xmlrpc) Pandoc
p) Map FilePath FilePath
uploaded
Map FilePath FilePath -> IO ()
writeUploadedImages Map FilePath FilePath
uploaded'
forall (m :: * -> *) a. Monad m => a -> m a
return Pandoc
p'
(Maybe FilePath, Maybe Bool)
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return Pandoc
p
where
uploadOneImage :: String -> Inline -> StateT (M.Map FilePath URL) IO Inline
uploadOneImage :: FilePath -> Inline -> StateT (Map FilePath FilePath) IO Inline
uploadOneImage FilePath
xmlrpc i :: Inline
i@(Image Attr
attr [Inline]
altText (Text
imgUrlT, Text
imgTitle))
| FilePath -> Bool
isLocal FilePath
imgUrl = do
Map FilePath FilePath
uploaded <- forall (m :: * -> *) s. Monad m => StateT s m s
get
case forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup FilePath
imgUrl Map FilePath FilePath
uploaded of
Just FilePath
url -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Attr -> [Inline] -> (Text, Text) -> Inline
Image Attr
attr [Inline]
altText (FilePath -> Text
T.pack FilePath
url, Text
imgTitle)
Maybe FilePath
Nothing -> do
Maybe Value
res <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ FilePath -> FilePath -> BlogLiterately -> IO (Maybe Value)
uploadIt FilePath
xmlrpc FilePath
imgUrl BlogLiterately
bl
case Maybe Value
res of
Just (ValueStruct (forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup FilePath
"url" -> Just (ValueString FilePath
newUrl))) -> do
forall (m :: * -> *) s. Monad m => (s -> s) -> StateT s m ()
modify (forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert FilePath
imgUrl FilePath
newUrl)
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Attr -> [Inline] -> (Text, Text) -> Inline
Image Attr
attr [Inline]
altText (FilePath -> Text
T.pack FilePath
newUrl, Text
imgTitle)
Maybe Value
_ -> do
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> IO ()
putStrLn forall a b. (a -> b) -> a -> b
$ FilePath
"Warning: upload of " forall a. [a] -> [a] -> [a]
++ FilePath
imgUrl forall a. [a] -> [a] -> [a]
++ FilePath
" failed."
forall (m :: * -> *) a. Monad m => a -> m a
return Inline
i
| Bool
otherwise = forall (m :: * -> *) a. Monad m => a -> m a
return Inline
i
where
imgUrl :: FilePath
imgUrl = Text -> FilePath
T.unpack Text
imgUrlT
uploadOneImage FilePath
_ Inline
i = forall (m :: * -> *) a. Monad m => a -> m a
return Inline
i
isLocal :: FilePath -> Bool
isLocal FilePath
imgUrl = forall {t :: * -> *} {a}. Foldable t => (a -> Bool) -> t a -> Bool
none (forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` FilePath
imgUrl) [FilePath
"http", FilePath
"/"]
none :: (a -> Bool) -> t a -> Bool
none a -> Bool
pr = forall {t :: * -> *} {a}. Foldable t => (a -> Bool) -> t a -> Bool
all (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Bool
pr)
uploadedImagesFile :: String
uploadedImagesFile :: FilePath
uploadedImagesFile = FilePath
".BlogLiterately-uploaded-images"
readUploadedImages :: IO (M.Map FilePath URL)
readUploadedImages :: IO (Map FilePath FilePath)
readUploadedImages = do
Bool
e <- FilePath -> IO Bool
doesFileExist FilePath
uploadedImagesFile
case Bool
e of
Bool
False -> forall (m :: * -> *) a. Monad m => a -> m a
return forall k a. Map k a
M.empty
Bool
True -> do
FilePath
txt <- FilePath -> IO FilePath
readFile FilePath
uploadedImagesFile
let m :: Map FilePath FilePath
m = forall a. a -> Maybe a -> a
fromMaybe (forall k a. Map k a
M.empty) (forall a. Read a => FilePath -> Maybe a
readMay FilePath
txt)
forall (t :: * -> *) a. Foldable t => t a -> Int
length FilePath
txt seq :: forall a b. a -> b -> b
`seq` forall (m :: * -> *) a. Monad m => a -> m a
return Map FilePath FilePath
m
readMay :: Read a => String -> Maybe a
readMay :: forall a. Read a => FilePath -> Maybe a
readMay FilePath
s = case forall a. Read a => ReadS a
reads FilePath
s of
[(a
a,FilePath
"")] -> forall a. a -> Maybe a
Just a
a
[(a, FilePath)]
_ -> forall a. Maybe a
Nothing
writeUploadedImages :: M.Map FilePath URL -> IO ()
writeUploadedImages :: Map FilePath FilePath -> IO ()
writeUploadedImages Map FilePath FilePath
m = FilePath -> FilePath -> IO ()
writeFile FilePath
uploadedImagesFile (forall a. Show a => a -> FilePath
show Map FilePath FilePath
m)
uploadIt :: String -> FilePath -> BlogLiterately -> IO (Maybe Value)
uploadIt :: FilePath -> FilePath -> BlogLiterately -> IO (Maybe Value)
uploadIt FilePath
url FilePath
filePath (BlogLiterately{[FilePath]
Maybe Bool
Maybe FilePath
Maybe HsHighlight
_xtra :: [FilePath]
_citations :: Maybe Bool
_htmlOnly :: Maybe Bool
_publish :: Maybe Bool
_page :: Maybe Bool
_postid :: Maybe FilePath
_format :: Maybe FilePath
_file :: Maybe FilePath
_title :: Maybe FilePath
_password :: Maybe FilePath
_user :: Maybe FilePath
_blog :: Maybe FilePath
_profile :: Maybe FilePath
_blogid :: Maybe FilePath
_tags :: [FilePath]
_categories :: [FilePath]
_uploadImages :: Maybe Bool
_ghci :: Maybe Bool
_math :: Maybe FilePath
_wplatex :: Maybe Bool
_rawlatex :: Maybe Bool
_toc :: Maybe Bool
_litHaskell :: Maybe Bool
_otherHighlight :: Maybe Bool
_hsHighlight :: Maybe HsHighlight
_style :: Maybe FilePath
_xtra :: BlogLiterately -> [FilePath]
_citations :: BlogLiterately -> Maybe Bool
_htmlOnly :: BlogLiterately -> Maybe Bool
_publish :: BlogLiterately -> Maybe Bool
_page :: BlogLiterately -> Maybe Bool
_postid :: BlogLiterately -> Maybe FilePath
_format :: BlogLiterately -> Maybe FilePath
_file :: BlogLiterately -> Maybe FilePath
_title :: BlogLiterately -> Maybe FilePath
_password :: BlogLiterately -> Maybe FilePath
_user :: BlogLiterately -> Maybe FilePath
_blog :: BlogLiterately -> Maybe FilePath
_profile :: BlogLiterately -> Maybe FilePath
_blogid :: BlogLiterately -> Maybe FilePath
_tags :: BlogLiterately -> [FilePath]
_categories :: BlogLiterately -> [FilePath]
_uploadImages :: BlogLiterately -> Maybe Bool
_ghci :: BlogLiterately -> Maybe Bool
_math :: BlogLiterately -> Maybe FilePath
_wplatex :: BlogLiterately -> Maybe Bool
_rawlatex :: BlogLiterately -> Maybe Bool
_toc :: BlogLiterately -> Maybe Bool
_litHaskell :: BlogLiterately -> Maybe Bool
_otherHighlight :: BlogLiterately -> Maybe Bool
_hsHighlight :: BlogLiterately -> Maybe HsHighlight
_style :: BlogLiterately -> Maybe FilePath
..}) = do
FilePath -> IO ()
putStr forall a b. (a -> b) -> a -> b
$ FilePath
"Uploading " forall a. [a] -> [a] -> [a]
++ FilePath
filePath forall a. [a] -> [a] -> [a]
++ FilePath
"..."
Maybe Value
mmedia <- FilePath -> IO (Maybe Value)
mkMediaObject FilePath
filePath
case Maybe Value
mmedia of
Maybe Value
Nothing -> do
FilePath -> IO ()
putStrLn forall a b. (a -> b) -> a -> b
$ FilePath
"\nFile not found: " forall a. [a] -> [a] -> [a]
++ FilePath
filePath
forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
Just Value
media -> do
Value
val <- forall a. Remote a => FilePath -> FilePath -> a
remote FilePath
url FilePath
"metaWeblog.newMediaObject"
(forall a. a -> Maybe a -> a
fromMaybe FilePath
"default" Maybe FilePath
_blogid)
(forall a. a -> Maybe a -> a
fromMaybe FilePath
"" Maybe FilePath
_user)
(forall a. a -> Maybe a -> a
fromMaybe FilePath
"" Maybe FilePath
_password)
Value
media
FilePath -> IO ()
putStrLn FilePath
"done."
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just Value
val
mkMediaObject :: FilePath -> IO (Maybe Value)
mkMediaObject :: FilePath -> IO (Maybe Value)
mkMediaObject FilePath
filePath = do
Bool
exists <- FilePath -> IO Bool
doesFileExist FilePath
filePath
if Bool -> Bool
not Bool
exists
then forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
else do
ByteString
bits <- FilePath -> IO ByteString
B.readFile FilePath
filePath
forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ [(FilePath, Value)] -> Value
ValueStruct
[ (FilePath
"name", forall a. XmlRpcType a => a -> Value
toValue FilePath
fileName)
, (FilePath
"type", forall a. XmlRpcType a => a -> Value
toValue FilePath
fileType)
, (FilePath
"bits", ByteString -> Value
ValueBase64 ByteString
bits)
]
where
fileName :: FilePath
fileName = FilePath -> FilePath
takeFileName FilePath
filePath
fileType :: FilePath
fileType = case (forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Int -> [a] -> [a]
drop Int
1 forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> FilePath
takeExtension) FilePath
fileName of
FilePath
"png" -> FilePath
"image/png"
FilePath
"jpg" -> FilePath
"image/jpeg"
FilePath
"jpeg" -> FilePath
"image/jpeg"
FilePath
"gif" -> FilePath
"image/gif"
FilePath
_ -> FilePath
"image/png"