{-# 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_ =
       String -> [String] -> [(String, Value)]
forall a. XmlRpcType [a] => String -> [a] -> [(String, Value)]
mkArray String
"categories" [String]
categories_
    [(String, Value)] -> [(String, Value)] -> [(String, Value)]
forall a. [a] -> [a] -> [a]
++ String -> [String] -> [(String, Value)]
forall a. XmlRpcType [a] => String -> [a] -> [(String, Value)]
mkArray String
"mt_keywords" [String]
tags_
    [(String, Value)] -> [(String, Value)] -> [(String, Value)]
forall a. [a] -> [a] -> [a]
++ [ (String
"title", String -> Value
forall a. XmlRpcType a => a -> Value
toValue String
title_)
       , (String
"description", String -> Value
forall a. XmlRpcType a => a -> Value
toValue String
text_)
       ]
    [(String, Value)] -> [(String, Value)] -> [(String, Value)]
forall a. [a] -> [a] -> [a]
++ [ (String
"post_type", String -> Value
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 :: String -> [a] -> [(String, Value)]
mkArray String
_    []     = []
mkArray String
name [a]
values = [(String
name, [a] -> Value
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 <- String -> String -> String -> String -> String -> IO Value
forall a. Remote a => String -> String -> a
remote String
url String
"metaWeblog.getPost" String
pid String
usr String
pwd
  Maybe String -> IO (Maybe String)
forall (m :: * -> *) a. Monad m => a -> m a
return (Value
v Value -> Getting (First String) Value String -> Maybe String
forall s a. s -> Getting (First a) s a -> Maybe a
^? ([(String, Value)] -> Const (First String) [(String, Value)])
-> Value -> Const (First String) Value
Prism' Value [(String, Value)]
_ValueStruct (([(String, Value)] -> Const (First String) [(String, Value)])
 -> Value -> Const (First String) Value)
-> ((String -> Const (First String) String)
    -> [(String, Value)] -> Const (First String) [(String, Value)])
-> Getting (First String) Value String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([(String, Value)] -> Map String Value)
-> Optic'
     (->) (Const (First String)) [(String, Value)] (Map String Value)
forall (p :: * -> * -> *) (f :: * -> *) s a.
(Profunctor p, Contravariant f) =>
(s -> a) -> Optic' p f s a
to [(String, Value)] -> Map String Value
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList Optic'
  (->) (Const (First String)) [(String, Value)] (Map String Value)
-> ((String -> Const (First String) String)
    -> Map String Value -> Const (First String) (Map String Value))
-> (String -> Const (First String) String)
-> [(String, Value)]
-> Const (First String) [(String, Value)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Index (Map String Value)
-> Lens' (Map String Value) (Maybe (IxValue (Map String Value)))
forall m. At m => Index m -> Lens' m (Maybe (IxValue m))
at String
Index (Map String Value)
"link" ((Maybe Value -> Const (First String) (Maybe Value))
 -> Map String Value -> Const (First String) (Map String Value))
-> ((String -> Const (First String) String)
    -> Maybe Value -> Const (First String) (Maybe Value))
-> (String -> Const (First String) String)
-> Map String Value
-> Const (First String) (Map String Value)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Value -> Const (First String) Value)
-> Maybe Value -> Const (First String) (Maybe Value)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse ((Value -> Const (First String) Value)
 -> Maybe Value -> Const (First String) (Maybe Value))
-> Getting (First String) Value String
-> (String -> Const (First String) String)
-> Maybe Value
-> Const (First String) (Maybe Value)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Getting (First String) Value String
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 <- String -> String -> Int -> String -> String -> Int -> IO Value
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 = (String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
isInfixOf (String -> String -> Bool)
-> (String -> String) -> String -> String -> Bool
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` (Char -> Char) -> String -> String
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower) String
search String
s
      posts :: [Map String Value]
posts  = Value
res Value
-> Getting (Endo [Map String Value]) Value (Map String Value)
-> [Map String Value]
forall s a. s -> Getting (Endo [a]) s a -> [a]
^.. ([Value] -> Const (Endo [Map String Value]) [Value])
-> Value -> Const (Endo [Map String Value]) Value
Prism' Value [Value]
_ValueArray (([Value] -> Const (Endo [Map String Value]) [Value])
 -> Value -> Const (Endo [Map String Value]) Value)
-> ((Map String Value
     -> Const (Endo [Map String Value]) (Map String Value))
    -> [Value] -> Const (Endo [Map String Value]) [Value])
-> Getting (Endo [Map String Value]) Value (Map String Value)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Value -> Const (Endo [Map String Value]) Value)
-> [Value] -> Const (Endo [Map String Value]) [Value]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse ((Value -> Const (Endo [Map String Value]) Value)
 -> [Value] -> Const (Endo [Map String Value]) [Value])
-> Getting (Endo [Map String Value]) Value (Map String Value)
-> (Map String Value
    -> Const (Endo [Map String Value]) (Map String Value))
-> [Value]
-> Const (Endo [Map String Value]) [Value]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([(String, Value)]
 -> Const (Endo [Map String Value]) [(String, Value)])
-> Value -> Const (Endo [Map String Value]) Value
Prism' Value [(String, Value)]
_ValueStruct (([(String, Value)]
  -> Const (Endo [Map String Value]) [(String, Value)])
 -> Value -> Const (Endo [Map String Value]) Value)
-> ((Map String Value
     -> Const (Endo [Map String Value]) (Map String Value))
    -> [(String, Value)]
    -> Const (Endo [Map String Value]) [(String, Value)])
-> Getting (Endo [Map String Value]) Value (Map String Value)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([(String, Value)] -> Map String Value)
-> (Map String Value
    -> Const (Endo [Map String Value]) (Map String Value))
-> [(String, Value)]
-> Const (Endo [Map String Value]) [(String, Value)]
forall (p :: * -> * -> *) (f :: * -> *) s a.
(Profunctor p, Contravariant f) =>
(s -> a) -> Optic' p f s a
to [(String, Value)] -> Map String Value
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList
      posts' :: [Map String Value]
posts' = (Map String Value -> Bool)
-> [Map String Value] -> [Map String Value]
forall a. (a -> Bool) -> [a] -> [a]
filter (\Map String Value
p -> Bool -> (String -> Bool) -> Maybe String -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False String -> Bool
matches (Map String Value
p Map String Value
-> ((String -> Const (First String) String)
    -> Map String Value -> Const (First String) (Map String Value))
-> Maybe String
forall s a. s -> Getting (First a) s a -> Maybe a
^? Index (Map String Value)
-> Lens' (Map String Value) (Maybe (IxValue (Map String Value)))
forall m. At m => Index m -> Lens' m (Maybe (IxValue m))
at String
Index (Map String Value)
"title" ((Maybe Value -> Const (First String) (Maybe Value))
 -> Map String Value -> Const (First String) (Map String Value))
-> ((String -> Const (First String) String)
    -> Maybe Value -> Const (First String) (Maybe Value))
-> (String -> Const (First String) String)
-> Map String Value
-> Const (First String) (Map String Value)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Value -> Const (First String) Value)
-> Maybe Value -> Const (First String) (Maybe Value)
forall a b. Prism (Maybe a) (Maybe b) a b
_Just ((Value -> Const (First String) Value)
 -> Maybe Value -> Const (First String) (Maybe Value))
-> Getting (First String) Value String
-> (String -> Const (First String) String)
-> Maybe Value
-> Const (First String) (Maybe Value)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Getting (First String) Value String
Prism' Value String
_ValueString)) [Map String Value]
posts
  Maybe String -> IO (Maybe String)
forall (m :: * -> *) a. Monad m => a -> m a
return ([Map String Value]
posts' [Map String Value]
-> Getting (First String) [Map String Value] String -> Maybe String
forall s a. s -> Getting (First a) s a -> Maybe a
^? (Map String Value -> Const (First String) (Map String Value))
-> [Map String Value] -> Const (First String) [Map String Value]
forall s a. Cons s s a a => Traversal' s a
_head ((Map String Value -> Const (First String) (Map String Value))
 -> [Map String Value] -> Const (First String) [Map String Value])
-> ((String -> Const (First String) String)
    -> Map String Value -> Const (First String) (Map String Value))
-> Getting (First String) [Map String Value] String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Index (Map String Value)
-> Lens' (Map String Value) (Maybe (IxValue (Map String Value)))
forall m. At m => Index m -> Lens' m (Maybe (IxValue m))
at String
Index (Map String Value)
"link" ((Maybe Value -> Const (First String) (Maybe Value))
 -> Map String Value -> Const (First String) (Map String Value))
-> ((String -> Const (First String) String)
    -> Maybe Value -> Const (First String) (Maybe Value))
-> (String -> Const (First String) String)
-> Map String Value
-> Const (First String) (Map String Value)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Value -> Const (First String) Value)
-> Maybe Value -> Const (First String) (Maybe Value)
forall a b. Prism (Maybe a) (Maybe b) a b
_Just ((Value -> Const (First String) Value)
 -> Maybe Value -> Const (First String) (Maybe Value))
-> Getting (First String) Value String
-> (String -> Const (First String) String)
-> Maybe Value
-> Const (First String) (Maybe Value)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Getting (First String) Value String
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
blBlogLiterately
-> Getting (Maybe String) BlogLiterately (Maybe String)
-> Maybe String
forall s a. s -> Getting a s a -> a
^.Getting (Maybe String) BlogLiterately (Maybe String)
Lens' BlogLiterately (Maybe String)
blog, BlogLiterately
blBlogLiterately
-> Getting (Maybe Bool) BlogLiterately (Maybe Bool) -> Maybe Bool
forall s a. s -> Getting a s a -> a
^.Getting (Maybe Bool) BlogLiterately (Maybe Bool)
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
blBlogLiterately
-> Getting (Maybe String) BlogLiterately (Maybe String)
-> Maybe String
forall s a. s -> Getting a s a -> a
^.Getting (Maybe String) BlogLiterately (Maybe String)
Lens' BlogLiterately (Maybe String)
postid of
        Maybe String
Nothing  -> do
          String
pid <- String
-> String
-> String
-> String
-> String
-> [(String, Value)]
-> Bool
-> IO String
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 (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Post ID: " String -> String -> String
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 IO (Maybe String) -> (Maybe String -> IO ()) -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= IO () -> (String -> IO ()) -> Maybe String -> IO ()
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (() -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()) String -> IO ()
putStrLn
        Just String
pid -> do
          Bool
success <- String
-> String
-> String
-> String
-> String
-> [(String, Value)]
-> Bool
-> IO Bool
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 IO (Maybe String) -> (Maybe String -> IO ()) -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= IO () -> (String -> IO ()) -> Maybe String -> IO ()
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (() -> IO ()
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
blBlogLiterately
-> Getting [String] BlogLiterately [String] -> [String]
forall s a. s -> Getting a s a -> a
^.Getting [String] BlogLiterately [String]
Lens' BlogLiterately [String]
categories) (BlogLiterately
blBlogLiterately
-> Getting [String] BlogLiterately [String] -> [String]
forall s a. s -> Getting a s a -> a
^.Getting [String] BlogLiterately [String]
Lens' BlogLiterately [String]
tags)
             (BlogLiterately -> Bool
page' BlogLiterately
bl)