{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ViewPatterns    #-}

-----------------------------------------------------------------------------
-- |
-- Module      :  Text.BlogLiterately.Image
-- Copyright   :  (c) 2012 Brent Yorgey
-- License     :  GPL (see LICENSE)
-- Maintainer  :  Brent Yorgey <byorgey@gmail.com>
--
-- Uploading images embedded in posts to the server.
--
-----------------------------------------------------------------------------

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

-- | Transform a document by uploading any \"local\" images to the
--   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 :: BlogLiterately -> Pandoc -> IO Pandoc
uploadAllImages bl :: BlogLiterately
bl@(BlogLiterately{[String]
Maybe Bool
Maybe String
Maybe HsHighlight
_xtra :: BlogLiterately -> [String]
_citations :: BlogLiterately -> Maybe Bool
_htmlOnly :: BlogLiterately -> Maybe Bool
_publish :: BlogLiterately -> Maybe Bool
_page :: BlogLiterately -> Maybe Bool
_postid :: BlogLiterately -> Maybe String
_format :: BlogLiterately -> Maybe String
_file :: BlogLiterately -> Maybe String
_title :: BlogLiterately -> Maybe String
_password :: BlogLiterately -> Maybe String
_user :: BlogLiterately -> Maybe String
_blog :: BlogLiterately -> Maybe String
_profile :: BlogLiterately -> Maybe String
_blogid :: BlogLiterately -> Maybe String
_tags :: BlogLiterately -> [String]
_categories :: BlogLiterately -> [String]
_uploadImages :: BlogLiterately -> Maybe Bool
_ghci :: BlogLiterately -> Maybe Bool
_math :: BlogLiterately -> Maybe String
_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 String
_xtra :: [String]
_citations :: Maybe Bool
_htmlOnly :: Maybe Bool
_publish :: Maybe Bool
_page :: Maybe Bool
_postid :: Maybe String
_format :: Maybe String
_file :: Maybe String
_title :: Maybe String
_password :: Maybe String
_user :: Maybe String
_blog :: Maybe String
_profile :: Maybe String
_blogid :: Maybe String
_tags :: [String]
_categories :: [String]
_uploadImages :: Maybe Bool
_ghci :: Maybe Bool
_math :: Maybe String
_wplatex :: Maybe Bool
_rawlatex :: Maybe Bool
_toc :: Maybe Bool
_litHaskell :: Maybe Bool
_otherHighlight :: Maybe Bool
_hsHighlight :: Maybe HsHighlight
_style :: Maybe String
..}) Pandoc
p =
  case (Maybe String
_blog, Maybe Bool
_htmlOnly) of
    (Just String
xmlrpc, 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
      (Pandoc
p', 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'
    (Maybe String, Maybe Bool)
_           -> 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 String
xmlrpc i :: Inline
i@(Image Attr
attr [Inline]
altText (Text
imgUrlT, 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 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] -> (Text, Text) -> Inline
Image Attr
attr [Inline]
altText (String -> Text
T.pack String
url, Text
imgTitle)
            Maybe String
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 String
"url" -> Just (ValueString 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] -> (Text, Text) -> Inline
Image Attr
attr [Inline]
altText (String -> Text
T.pack String
newUrl, Text
imgTitle)
                Maybe Value
_ -> 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
$ String
"Warning: upload of " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
imgUrl String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" 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 String
_ Inline
i = Inline -> StateT (Map String String) IO Inline
forall (m :: * -> *) a. Monad m => a -> m a
return Inline
i

    isLocal :: String -> Bool
isLocal 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) [String
"http", String
"/"]
    none :: (a -> Bool) -> t a -> Bool
none 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 = String
".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 :: IO (Map String String)
readUploadedImages = do
  Bool
e <- String -> IO Bool
doesFileExist String
uploadedImagesFile
  case Bool
e of
    Bool
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
    Bool
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)
`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 String
s = case ReadS a
forall a. Read a => ReadS a
reads String
s of
              [(a
a,String
"")] -> a -> Maybe a
forall a. a -> Maybe a
Just a
a
              [(a, String)]
_        -> Maybe a
forall a. Maybe 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 :: Map String String -> IO ()
writeUploadedImages 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)

-- | Upload a file using the @metaWeblog.newMediaObject@ XML-RPC method
--   call.
uploadIt :: String -> FilePath -> BlogLiterately -> IO (Maybe Value)
uploadIt :: String -> String -> BlogLiterately -> IO (Maybe Value)
uploadIt String
url String
filePath (BlogLiterately{[String]
Maybe Bool
Maybe String
Maybe HsHighlight
_xtra :: [String]
_citations :: Maybe Bool
_htmlOnly :: Maybe Bool
_publish :: Maybe Bool
_page :: Maybe Bool
_postid :: Maybe String
_format :: Maybe String
_file :: Maybe String
_title :: Maybe String
_password :: Maybe String
_user :: Maybe String
_blog :: Maybe String
_profile :: Maybe String
_blogid :: Maybe String
_tags :: [String]
_categories :: [String]
_uploadImages :: Maybe Bool
_ghci :: Maybe Bool
_math :: Maybe String
_wplatex :: Maybe Bool
_rawlatex :: Maybe Bool
_toc :: Maybe Bool
_litHaskell :: Maybe Bool
_otherHighlight :: Maybe Bool
_hsHighlight :: Maybe HsHighlight
_style :: Maybe String
_xtra :: BlogLiterately -> [String]
_citations :: BlogLiterately -> Maybe Bool
_htmlOnly :: BlogLiterately -> Maybe Bool
_publish :: BlogLiterately -> Maybe Bool
_page :: BlogLiterately -> Maybe Bool
_postid :: BlogLiterately -> Maybe String
_format :: BlogLiterately -> Maybe String
_file :: BlogLiterately -> Maybe String
_title :: BlogLiterately -> Maybe String
_password :: BlogLiterately -> Maybe String
_user :: BlogLiterately -> Maybe String
_blog :: BlogLiterately -> Maybe String
_profile :: BlogLiterately -> Maybe String
_blogid :: BlogLiterately -> Maybe String
_tags :: BlogLiterately -> [String]
_categories :: BlogLiterately -> [String]
_uploadImages :: BlogLiterately -> Maybe Bool
_ghci :: BlogLiterately -> Maybe Bool
_math :: BlogLiterately -> Maybe String
_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 String
..}) = do
  String -> IO ()
putStr (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Uploading " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
filePath String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"..."
  Maybe Value
mmedia <- String -> IO (Maybe Value)
mkMediaObject String
filePath
  case Maybe Value
mmedia of
    Maybe Value
Nothing -> do
      String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"\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 Value
media -> do
      Value
val <- String -> String -> String -> String -> String -> Value -> IO Value
forall a. Remote a => String -> String -> a
remote String
url String
"metaWeblog.newMediaObject"
               (String -> Maybe String -> String
forall a. a -> Maybe a -> a
fromMaybe String
"default" Maybe String
_blogid)
               (String -> Maybe String -> String
forall a. a -> Maybe a -> a
fromMaybe String
"" Maybe String
_user)
               (String -> Maybe String -> String
forall a. a -> Maybe a -> a
fromMaybe String
"" Maybe String
_password)
               Value
media
      String -> IO ()
putStrLn String
"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

-- | Prepare a file for upload.
mkMediaObject :: FilePath -> IO (Maybe Value)
mkMediaObject :: String -> IO (Maybe Value)
mkMediaObject 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
        [ (String
"name", String -> Value
forall a. XmlRpcType a => a -> Value
toValue String
fileName)
        , (String
"type", String -> Value
forall a. XmlRpcType a => a -> Value
toValue String
fileType)
        , (String
"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 Int
1 (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
takeExtension) String
fileName of
                 String
"png"  -> String
"image/png"
                 String
"jpg"  -> String
"image/jpeg"
                 String
"jpeg" -> String
"image/jpeg"
                 String
"gif"  -> String
"image/gif"
                 String
_      -> String
"image/png"