{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TemplateHaskell #-}
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
mkPost :: String
-> String
-> [String]
-> [String]
-> Bool
-> [(String, Value)]
mkPost :: String
-> String -> [String] -> [String] -> Bool -> [(String, Value)]
mkPost title_ :: String
title_ text_ :: String
text_ categories_ :: [String]
categories_ tags_ :: [String]
tags_ page_ :: Bool
page_ =
String -> [String] -> [(String, Value)]
forall a. XmlRpcType [a] => String -> [a] -> [(String, Value)]
mkArray "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 "mt_keywords" [String]
tags_
[(String, Value)] -> [(String, Value)] -> [(String, Value)]
forall a. [a] -> [a] -> [a]
++ [ ("title", String -> Value
forall a. XmlRpcType a => a -> Value
toValue String
title_)
, ("description", String -> Value
forall a. XmlRpcType a => a -> Value
toValue String
text_)
]
[(String, Value)] -> [(String, Value)] -> [(String, Value)]
forall a. [a] -> [a] -> [a]
++ [ ("post_type", String -> Value
forall a. XmlRpcType a => a -> Value
toValue "page") | Bool
page_ ]
mkArray :: XmlRpcType [a] => String -> [a] -> [(String, Value)]
mkArray :: String -> [a] -> [(String, Value)]
mkArray _ [] = []
mkArray name :: String
name values :: [a]
values = [(String
name, [a] -> Value
forall a. XmlRpcType a => a -> Value
toValue [a]
values)]
makePrisms ''Value
getPostURL :: String -> String -> String -> String -> IO (Maybe String)
getPostURL :: String -> String -> String -> String -> IO (Maybe String)
getPostURL url :: String
url pid :: String
pid usr :: String
usr pwd :: String
pwd = do
Value
v <- String -> String -> String -> String -> String -> IO Value
forall a. Remote a => String -> String -> a
remote String
url "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 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)
findTitle :: Int -> String -> String -> String -> String -> IO (Maybe String)
findTitle :: Int -> String -> String -> String -> String -> IO (Maybe String)
findTitle numPrev :: Int
numPrev url :: String
url search :: String
search usr :: String
usr pwd :: String
pwd = do
Value
res <- String -> String -> Int -> String -> String -> Int -> IO Value
forall a. Remote a => String -> String -> a
remote String
url "metaWeblog.getRecentPosts" (0::Int) String
usr String
pwd Int
numPrev
let matches :: String -> Bool
matches s :: 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 (\p :: 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 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 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)
postIt :: BlogLiterately -> String -> IO ()
postIt :: BlogLiterately -> String -> IO ()
postIt bl :: BlogLiterately
bl html :: 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
(Nothing , _ ) -> String -> IO ()
putStr String
html
(_ , Just True ) -> String -> IO ()
putStr String
html
(Just url :: String
url , _ ) -> 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
Nothing -> do
String
pid <- String
-> String
-> String
-> String
-> String
-> [(String, Value)]
-> Bool
-> IO String
forall a. Remote a => String -> String -> a
remote String
url "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
$ "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 pid :: 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 "metaWeblog.editPost" String
pid
(BlogLiterately -> String
user' BlogLiterately
bl)
String
pwd
[(String, Value)]
post
(BlogLiterately -> Bool
publish' BlogLiterately
bl)
case Bool
success of
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
False -> String -> IO ()
putStrLn "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)