{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE RecordWildCards  #-}
{-# LANGUAGE TemplateHaskell  #-}

-----------------------------------------------------------------------------
-- |
-- Module      :  Text.BlogLiterately.Post
-- Copyright   :  (c) 2008-2010 Robert Greayer, 2012 Brent Yorgey
-- License     :  GPL (see LICENSE)
-- Maintainer  :  Brent Yorgey <byorgey@gmail.com>
--
-- Uploading posts to the server and fetching posts from the server.
--
-----------------------------------------------------------------------------

module Text.BlogLiterately.Post
    (
      mkPost, mkArray, postIt, getPostURL, findTitle
    ) where

import           Control.Lens                (at, makePrisms, to, traverse,
                                              (^.), (^..), (^?), _Just, _head)
import           Data.Char                   (toLower)
import           Data.Function               (on)
import           Data.List                   (isInfixOf)
import qualified Data.Map                    as M

import           Network.XmlRpc.Client       (remote)
import           Network.XmlRpc.Internals    (Value (..), XmlRpcType, toValue)

import           Text.BlogLiterately.Options

{-
The metaWeblog API defines `newPost` and `editPost` procedures that
look like:

    [other]
    metaWeblog.newPost (blogid, username, password, struct, publish)
        returns string
    metaWeblog.editPost (postid, username, password, struct, publish)
        returns true

For WordPress blogs, the `blogid` is ignored.  The user name and
password are simply strings, and `publish` is a flag indicating
whether to load the post as a draft, or to make it public immediately.
The `postid` is an identifier string which is assigned when you
initially create a post. The interesting bit is the `struct` field,
which is an XML-RPC structure defining the post along with some
meta-data, like the title.  I want be able to provide the post body, a
title, and lists of categories and tags.  For the body and title, we
could just let HaXR convert the values automatically into the XML-RPC
`Value` type, since they all have the same Haskell type (`String`) and
thus can be put into a list.  But the categories and tags are lists of
strings, so we need to explicitly convert everything to a `Value`,
then combine:
-}

-- | Prepare a post for uploading by creating something of the proper
--   form to be an argument to an XML-RPC call.
mkPost :: String    -- ^ Post title
       -> String    -- ^ Post content
       -> [String]  -- ^ List of categories
       -> [String]  -- ^ List of tags
       -> Bool      -- ^ @True@ = page, @False@ = post
       -> [(String, Value)]
mkPost :: String
-> String -> [String] -> [String] -> Bool -> [(String, Value)]
mkPost String
title_ String
text_ [String]
categories_ [String]
tags_ Bool
page_ =
       forall a. XmlRpcType [a] => String -> [a] -> [(String, Value)]
mkArray String
"categories" [String]
categories_
    forall a. [a] -> [a] -> [a]
++ forall a. XmlRpcType [a] => String -> [a] -> [(String, Value)]
mkArray String
"mt_keywords" [String]
tags_
    forall a. [a] -> [a] -> [a]
++ [ (String
"title", forall a. XmlRpcType a => a -> Value
toValue String
title_)
       , (String
"description", forall a. XmlRpcType a => a -> Value
toValue String
text_)
       ]
    forall a. [a] -> [a] -> [a]
++ [ (String
"post_type", forall a. XmlRpcType a => a -> Value
toValue String
"page") | Bool
page_ ]

-- | Given a name and a list of values, create a named \"array\" field
--   suitable for inclusion in an XML-RPC struct.
mkArray :: XmlRpcType [a] => String -> [a] -> [(String, Value)]
mkArray :: forall a. XmlRpcType [a] => String -> [a] -> [(String, Value)]
mkArray String
_    []     = []
mkArray String
name [a]
values = [(String
name, forall a. XmlRpcType a => a -> Value
toValue [a]
values)]

{-
The HaXR library exports a function for invoking XML-RPC procedures:

    [haskell]
    remote :: Remote a =>
        String -- ^ Server URL. May contain username and password on
               --   the format username:password\@ before the hostname.
           -> String -- ^ Remote method name.
           -> a      -- ^ Any function
         -- @(XmlRpcType t1, ..., XmlRpcType tn, XmlRpcType r) =>
                     -- t1 -> ... -> tn -> IO r@

The function requires an URL and a method name, and returns a function
of type `Remote a => a`.  Based on the instances defined for `Remote`,
any function with zero or more parameters in the class `XmlRpcType`
and a return type of `XmlRpcType r => IO r` will work, which means you
can simply 'feed' `remote` additional arguments as required by the
remote procedure, and as long as you make the call in an IO context,
it will typecheck.  `postIt` calls `metaWeblog.newPost` or
`metaWeblog.editPost` (or simply prints the HTML to stdout) as
appropriate:
-}

makePrisms ''Value

-- | Get the URL for a given post.
getPostURL :: String -> String -> String -> String -> IO (Maybe String)
getPostURL :: String -> String -> String -> String -> IO (Maybe String)
getPostURL String
url String
pid String
usr String
pwd = do
  Value
v <- forall a. Remote a => String -> String -> a
remote String
url String
"metaWeblog.getPost" String
pid String
usr String
pwd
  forall (m :: * -> *) a. Monad m => a -> m a
return (Value
v forall s a. s -> Getting (First a) s a -> Maybe a
^? Prism' Value [(String, Value)]
_ValueStruct forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (p :: * -> * -> *) (f :: * -> *) s a.
(Profunctor p, Contravariant f) =>
(s -> a) -> Optic' p f s a
to forall k a. Ord k => [(k, a)] -> Map k a
M.fromList forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall m. At m => Index m -> Lens' m (Maybe (IxValue m))
at String
"link" forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse forall b c a. (b -> c) -> (a -> b) -> a -> c
. Prism' Value String
_ValueString)

-- | Look at the last n posts and find the most recent whose title
--   contains the search term (case insensitive); return its permalink
--   URL.
findTitle :: Int -> String -> String -> String -> String -> IO (Maybe String)
findTitle :: Int -> String -> String -> String -> String -> IO (Maybe String)
findTitle Int
numPrev String
url String
search String
usr String
pwd = do
  Value
res <- forall a. Remote a => String -> String -> a
remote String
url String
"metaWeblog.getRecentPosts" (Int
0::Int) String
usr String
pwd Int
numPrev
  let matches :: String -> Bool
matches String
s = (forall a. Eq a => [a] -> [a] -> Bool
isInfixOf forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower) String
search String
s
      posts :: [Map String Value]
posts  = Value
res forall s a. s -> Getting (Endo [a]) s a -> [a]
^.. Prism' Value [Value]
_ValueArray forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse forall b c a. (b -> c) -> (a -> b) -> a -> c
. Prism' Value [(String, Value)]
_ValueStruct forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (p :: * -> * -> *) (f :: * -> *) s a.
(Profunctor p, Contravariant f) =>
(s -> a) -> Optic' p f s a
to forall k a. Ord k => [(k, a)] -> Map k a
M.fromList
      posts' :: [Map String Value]
posts' = forall a. (a -> Bool) -> [a] -> [a]
filter (\Map String Value
p -> forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False String -> Bool
matches (Map String Value
p forall s a. s -> Getting (First a) s a -> Maybe a
^? forall m. At m => Index m -> Lens' m (Maybe (IxValue m))
at String
"title" forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. Prism (Maybe a) (Maybe b) a b
_Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. Prism' Value String
_ValueString)) [Map String Value]
posts
  forall (m :: * -> *) a. Monad m => a -> m a
return ([Map String Value]
posts' forall s a. s -> Getting (First a) s a -> Maybe a
^? forall s a. Cons s s a a => Traversal' s a
_head forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall m. At m => Index m -> Lens' m (Maybe (IxValue m))
at String
"link" forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. Prism (Maybe a) (Maybe b) a b
_Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. Prism' Value String
_ValueString)

-- | Given a configuration and a formatted post, upload it to the server.
postIt :: BlogLiterately -> String -> IO ()
postIt :: BlogLiterately -> String -> IO ()
postIt BlogLiterately
bl String
html =
  case (BlogLiterately
blforall s a. s -> Getting a s a -> a
^.Lens' BlogLiterately (Maybe String)
blog, BlogLiterately
blforall s a. s -> Getting a s a -> a
^.Lens' BlogLiterately (Maybe Bool)
htmlOnly) of
    (Maybe String
Nothing  , Maybe Bool
_         ) -> String -> IO ()
putStr String
html
    (Maybe String
_        , Just Bool
True ) -> String -> IO ()
putStr String
html
    (Just String
url , Maybe Bool
_         ) -> do
      let pwd :: String
pwd = BlogLiterately -> String
password' BlogLiterately
bl
      case BlogLiterately
blforall s a. s -> Getting a s a -> a
^.Lens' BlogLiterately (Maybe String)
postid of
        Maybe String
Nothing  -> do
          String
pid <- forall a. Remote a => String -> String -> a
remote String
url String
"metaWeblog.newPost"
                   (BlogLiterately -> String
blogid' BlogLiterately
bl)
                   (BlogLiterately -> String
user' BlogLiterately
bl)
                   String
pwd
                   [(String, Value)]
post
                   (BlogLiterately -> Bool
publish' BlogLiterately
bl)
          String -> IO ()
putStrLn forall a b. (a -> b) -> a -> b
$ String
"Post ID: " forall a. [a] -> [a] -> [a]
++ String
pid
          String -> String -> String -> String -> IO (Maybe String)
getPostURL String
url String
pid (BlogLiterately -> String
user' BlogLiterately
bl) String
pwd forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall (m :: * -> *) a. Monad m => a -> m a
return ()) String -> IO ()
putStrLn
        Just String
pid -> do
          Bool
success <- forall a. Remote a => String -> String -> a
remote String
url String
"metaWeblog.editPost" String
pid
                       (BlogLiterately -> String
user' BlogLiterately
bl)
                       String
pwd
                       [(String, Value)]
post
                       (BlogLiterately -> Bool
publish' BlogLiterately
bl)
          case Bool
success of
            Bool
True  -> String -> String -> String -> String -> IO (Maybe String)
getPostURL String
url String
pid (BlogLiterately -> String
user' BlogLiterately
bl) String
pwd forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall (m :: * -> *) a. Monad m => a -> m a
return ()) String -> IO ()
putStrLn
            Bool
False -> String -> IO ()
putStrLn String
"Update failed!"
  where
    post :: [(String, Value)]
post = String
-> String -> [String] -> [String] -> Bool -> [(String, Value)]
mkPost
             (BlogLiterately -> String
title' BlogLiterately
bl)
             String
html (BlogLiterately
blforall s a. s -> Getting a s a -> a
^.Lens' BlogLiterately [String]
categories) (BlogLiterately
blforall s a. s -> Getting a s a -> a
^.Lens' BlogLiterately [String]
tags)
             (BlogLiterately -> Bool
page' BlogLiterately
bl)