{-# 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{..}) p :: Pandoc
p =
case (Maybe String
_blog, Maybe Bool
_htmlOnly) of
(Just xmlrpc :: String
xmlrpc, h :: Maybe Bool
h) | Maybe Bool
h Maybe Bool -> Maybe Bool -> Bool
forall a. Eq a => a -> a -> Bool
/= Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
True -> do
Map String String
uploaded <- IO (Map String String)
readUploadedImages
(p' :: Pandoc
p', uploaded' :: Map String String
uploaded') <- StateT (Map String String) IO Pandoc
-> Map String String -> IO (Pandoc, Map String String)
forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
runStateT ((Inline -> StateT (Map String String) IO Inline)
-> Pandoc -> StateT (Map String String) IO Pandoc
forall (m :: * -> *) a b.
(Monad m, Data a, Data b) =>
(a -> m a) -> b -> m b
bottomUpM (String -> Inline -> StateT (Map String String) IO Inline
uploadOneImage String
xmlrpc) Pandoc
p) Map String String
uploaded
Map String String -> IO ()
writeUploadedImages Map String String
uploaded'
Pandoc -> IO Pandoc
forall (m :: * -> *) a. Monad m => a -> m a
return Pandoc
p'
_ -> Pandoc -> IO Pandoc
forall (m :: * -> *) a. Monad m => a -> m a
return Pandoc
p
where
uploadOneImage :: String -> Inline -> StateT (M.Map FilePath URL) IO Inline
uploadOneImage :: String -> Inline -> StateT (Map String String) IO Inline
uploadOneImage xmlrpc :: String
xmlrpc i :: Inline
i@(Image attr :: Attr
attr altText :: [Inline]
altText (imgUrlT :: Text
imgUrlT, imgTitle :: Text
imgTitle))
| String -> Bool
isLocal String
imgUrl = do
Map String String
uploaded <- StateT (Map String String) IO (Map String String)
forall (m :: * -> *) s. Monad m => StateT s m s
get
case String -> Map String String -> Maybe String
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup String
imgUrl Map String String
uploaded of
Just url :: String
url -> Inline -> StateT (Map String String) IO Inline
forall (m :: * -> *) a. Monad m => a -> m a
return (Inline -> StateT (Map String String) IO Inline)
-> Inline -> StateT (Map String String) IO Inline
forall a b. (a -> b) -> a -> b
$ Attr -> [Inline] -> Target -> Inline
Image Attr
attr [Inline]
altText (String -> Text
T.pack String
url, Text
imgTitle)
Nothing -> do
Maybe Value
res <- IO (Maybe Value) -> StateT (Map String String) IO (Maybe Value)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IO (Maybe Value) -> StateT (Map String String) IO (Maybe Value))
-> IO (Maybe Value) -> StateT (Map String String) IO (Maybe Value)
forall a b. (a -> b) -> a -> b
$ String -> String -> BlogLiterately -> IO (Maybe Value)
uploadIt String
xmlrpc String
imgUrl BlogLiterately
bl
case Maybe Value
res of
Just (ValueStruct (String -> [(String, Value)] -> Maybe Value
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup "url" -> Just (ValueString newUrl :: String
newUrl))) -> do
(Map String String -> Map String String)
-> StateT (Map String String) IO ()
forall (m :: * -> *) s. Monad m => (s -> s) -> StateT s m ()
modify (String -> String -> Map String String -> Map String String
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert String
imgUrl String
newUrl)
Inline -> StateT (Map String String) IO Inline
forall (m :: * -> *) a. Monad m => a -> m a
return (Inline -> StateT (Map String String) IO Inline)
-> Inline -> StateT (Map String String) IO Inline
forall a b. (a -> b) -> a -> b
$ Attr -> [Inline] -> Target -> Inline
Image Attr
attr [Inline]
altText (String -> Text
T.pack String
newUrl, Text
imgTitle)
_ -> do
IO () -> StateT (Map String String) IO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> StateT (Map String String) IO ())
-> (String -> IO ()) -> String -> StateT (Map String String) IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> IO ()
putStrLn (String -> StateT (Map String String) IO ())
-> String -> StateT (Map String String) IO ()
forall a b. (a -> b) -> a -> b
$ "Warning: upload of " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
imgUrl String -> String -> String
forall a. [a] -> [a] -> [a]
++ " failed."
Inline -> StateT (Map String String) IO Inline
forall (m :: * -> *) a. Monad m => a -> m a
return Inline
i
| Bool
otherwise = Inline -> StateT (Map String String) IO Inline
forall (m :: * -> *) a. Monad m => a -> m a
return Inline
i
where
imgUrl :: String
imgUrl = Text -> String
T.unpack Text
imgUrlT
uploadOneImage _ i :: Inline
i = Inline -> StateT (Map String String) IO Inline
forall (m :: * -> *) a. Monad m => a -> m a
return Inline
i
isLocal :: String -> Bool
isLocal imgUrl :: String
imgUrl = (String -> Bool) -> [String] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
none (String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` String
imgUrl) ["http", "/"]
none :: (a -> Bool) -> t a -> Bool
none pr :: a -> Bool
pr = (a -> Bool) -> t a -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (Bool -> Bool
not (Bool -> Bool) -> (a -> Bool) -> a -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Bool
pr)
uploadedImagesFile :: String
uploadedImagesFile :: String
uploadedImagesFile = ".BlogLiterately-uploaded-images"
readUploadedImages :: IO (M.Map FilePath URL)
readUploadedImages :: IO (Map String String)
readUploadedImages = do
Bool
e <- String -> IO Bool
doesFileExist String
uploadedImagesFile
case Bool
e of
False -> Map String String -> IO (Map String String)
forall (m :: * -> *) a. Monad m => a -> m a
return Map String String
forall k a. Map k a
M.empty
True -> do
String
txt <- String -> IO String
readFile String
uploadedImagesFile
let m :: Map String String
m = Map String String -> Maybe (Map String String) -> Map String String
forall a. a -> Maybe a -> a
fromMaybe (Map String String
forall k a. Map k a
M.empty) (String -> Maybe (Map String String)
forall a. Read a => String -> Maybe a
readMay String
txt)
String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
txt Int -> IO (Map String String) -> IO (Map String String)
forall a b. a -> b -> b
`seq` Map String String -> IO (Map String String)
forall (m :: * -> *) a. Monad m => a -> m a
return Map String String
m
readMay :: Read a => String -> Maybe a
readMay :: String -> Maybe a
readMay s :: String
s = case ReadS a
forall a. Read a => ReadS a
reads String
s of
[(a :: a
a,"")] -> a -> Maybe a
forall a. a -> Maybe a
Just a
a
_ -> Maybe a
forall a. Maybe a
Nothing
writeUploadedImages :: M.Map FilePath URL -> IO ()
writeUploadedImages :: Map String String -> IO ()
writeUploadedImages m :: Map String String
m = String -> String -> IO ()
writeFile String
uploadedImagesFile (Map String String -> String
forall a. Show a => a -> String
show Map String String
m)
uploadIt :: String -> FilePath -> BlogLiterately -> IO (Maybe Value)
uploadIt :: String -> String -> BlogLiterately -> IO (Maybe Value)
uploadIt url :: String
url filePath :: String
filePath (BlogLiterately{..}) = do
String -> IO ()
putStr (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ "Uploading " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
filePath String -> String -> String
forall a. [a] -> [a] -> [a]
++ "..."
Maybe Value
mmedia <- String -> IO (Maybe Value)
mkMediaObject String
filePath
case Maybe Value
mmedia of
Nothing -> do
String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ "\nFile not found: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
filePath
Maybe Value -> IO (Maybe Value)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Value
forall a. Maybe a
Nothing
Just media :: Value
media -> do
Value
val <- String -> String -> String -> String -> String -> Value -> IO Value
forall a. Remote a => String -> String -> a
remote String
url "metaWeblog.newMediaObject"
(String -> Maybe String -> String
forall a. a -> Maybe a -> a
fromMaybe "default" Maybe String
_blogid)
(String -> Maybe String -> String
forall a. a -> Maybe a -> a
fromMaybe "" Maybe String
_user)
(String -> Maybe String -> String
forall a. a -> Maybe a -> a
fromMaybe "" Maybe String
_password)
Value
media
String -> IO ()
putStrLn "done."
Maybe Value -> IO (Maybe Value)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Value -> IO (Maybe Value))
-> Maybe Value -> IO (Maybe Value)
forall a b. (a -> b) -> a -> b
$ Value -> Maybe Value
forall a. a -> Maybe a
Just Value
val
mkMediaObject :: FilePath -> IO (Maybe Value)
mkMediaObject :: String -> IO (Maybe Value)
mkMediaObject filePath :: String
filePath = do
Bool
exists <- String -> IO Bool
doesFileExist String
filePath
if Bool -> Bool
not Bool
exists
then Maybe Value -> IO (Maybe Value)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Value
forall a. Maybe a
Nothing
else do
ByteString
bits <- String -> IO ByteString
B.readFile String
filePath
Maybe Value -> IO (Maybe Value)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Value -> IO (Maybe Value))
-> (Value -> Maybe Value) -> Value -> IO (Maybe Value)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Value -> Maybe Value
forall a. a -> Maybe a
Just (Value -> IO (Maybe Value)) -> Value -> IO (Maybe Value)
forall a b. (a -> b) -> a -> b
$ [(String, Value)] -> Value
ValueStruct
[ ("name", String -> Value
forall a. XmlRpcType a => a -> Value
toValue String
fileName)
, ("type", String -> Value
forall a. XmlRpcType a => a -> Value
toValue String
fileType)
, ("bits", ByteString -> Value
ValueBase64 ByteString
bits)
]
where
fileName :: String
fileName = String -> String
takeFileName String
filePath
fileType :: String
fileType = case ((Char -> Char) -> String -> String
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> String -> String
forall a. Int -> [a] -> [a]
drop 1 (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
takeExtension) String
fileName of
"png" -> "image/png"
"jpg" -> "image/jpeg"
"jpeg" -> "image/jpeg"
"gif" -> "image/gif"
_ -> "image/png"