{-# 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{[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"

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

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

-- | Upload a file using the @metaWeblog.newMediaObject@ XML-RPC method
--   call.
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

-- | Prepare a file for upload.
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"