/usr/share/doc/libghc-blogliterately-doc/html/src/Text-BlogLiterately-Post.html is in libghc-blogliterately-doc 0.8.1.5-1.
This file is owned by root:root, with mode 0o644.
The actual contents of the file can be viewed below.
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 | <?xml version="1.0" encoding="UTF-8"?>
<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Strict//EN" "http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd">
<html>
<head>
<!-- Generated by HsColour, http://code.haskell.org/~malcolm/hscolour/ -->
<title>src/Text/BlogLiterately/Post.hs</title>
<link type='text/css' rel='stylesheet' href='hscolour.css' />
</head>
<body>
<pre><a name="line-1"></a><span class='hs-comment'>{-# LANGUAGE FlexibleContexts #-}</span>
<a name="line-2"></a><span class='hs-comment'>{-# LANGUAGE RecordWildCards #-}</span>
<a name="line-3"></a><span class='hs-comment'>{-# LANGUAGE TemplateHaskell #-}</span>
<a name="line-4"></a>
<a name="line-5"></a><span class='hs-comment'>-----------------------------------------------------------------------------</span>
<a name="line-6"></a><span class='hs-comment'>-- |</span>
<a name="line-7"></a><span class='hs-comment'>-- Module : Text.BlogLiterately.Post</span>
<a name="line-8"></a><span class='hs-comment'>-- Copyright : (c) 2008-2010 Robert Greayer, 2012 Brent Yorgey</span>
<a name="line-9"></a><span class='hs-comment'>-- License : GPL (see LICENSE)</span>
<a name="line-10"></a><span class='hs-comment'>-- Maintainer : Brent Yorgey <byorgey@gmail.com></span>
<a name="line-11"></a><span class='hs-comment'>--</span>
<a name="line-12"></a><span class='hs-comment'>-- Uploading posts to the server.</span>
<a name="line-13"></a><span class='hs-comment'>--</span>
<a name="line-14"></a><span class='hs-comment'>-----------------------------------------------------------------------------</span>
<a name="line-15"></a>
<a name="line-16"></a><span class='hs-keyword'>module</span> <span class='hs-conid'>Text</span><span class='hs-varop'>.</span><span class='hs-conid'>BlogLiterately</span><span class='hs-varop'>.</span><span class='hs-conid'>Post</span>
<a name="line-17"></a> <span class='hs-layout'>(</span>
<a name="line-18"></a> <span class='hs-varid'>mkPost</span><span class='hs-layout'>,</span> <span class='hs-varid'>mkArray</span><span class='hs-layout'>,</span> <span class='hs-varid'>postIt</span>
<a name="line-19"></a> <span class='hs-layout'>)</span> <span class='hs-keyword'>where</span>
<a name="line-20"></a>
<a name="line-21"></a><span class='hs-keyword'>import</span> <span class='hs-conid'>Control</span><span class='hs-varop'>.</span><span class='hs-conid'>Lens</span> <span class='hs-layout'>(</span><span class='hs-varid'>at</span><span class='hs-layout'>,</span> <span class='hs-varid'>makePrisms</span><span class='hs-layout'>,</span> <span class='hs-varid'>to</span><span class='hs-layout'>,</span> <span class='hs-varid'>traverse</span><span class='hs-layout'>,</span>
<a name="line-22"></a> <span class='hs-layout'>(</span><span class='hs-varop'>^.</span><span class='hs-layout'>)</span><span class='hs-layout'>,</span> <span class='hs-layout'>(</span><span class='hs-varop'>^?</span><span class='hs-layout'>)</span><span class='hs-layout'>)</span>
<a name="line-23"></a><span class='hs-keyword'>import</span> <span class='hs-keyword'>qualified</span> <span class='hs-conid'>Data</span><span class='hs-varop'>.</span><span class='hs-conid'>Map</span> <span class='hs-keyword'>as</span> <span class='hs-conid'>M</span>
<a name="line-24"></a>
<a name="line-25"></a><span class='hs-keyword'>import</span> <span class='hs-conid'>Network</span><span class='hs-varop'>.</span><span class='hs-conid'>XmlRpc</span><span class='hs-varop'>.</span><span class='hs-conid'>Client</span> <span class='hs-layout'>(</span><span class='hs-varid'>remote</span><span class='hs-layout'>)</span>
<a name="line-26"></a><span class='hs-keyword'>import</span> <span class='hs-conid'>Network</span><span class='hs-varop'>.</span><span class='hs-conid'>XmlRpc</span><span class='hs-varop'>.</span><span class='hs-conid'>Internals</span> <span class='hs-layout'>(</span><span class='hs-conid'>Value</span> <span class='hs-layout'>(</span><span class='hs-keyglyph'>..</span><span class='hs-layout'>)</span><span class='hs-layout'>,</span> <span class='hs-conid'>XmlRpcType</span><span class='hs-layout'>,</span> <span class='hs-varid'>toValue</span><span class='hs-layout'>)</span>
<a name="line-27"></a>
<a name="line-28"></a><span class='hs-keyword'>import</span> <span class='hs-conid'>Text</span><span class='hs-varop'>.</span><span class='hs-conid'>BlogLiterately</span><span class='hs-varop'>.</span><span class='hs-conid'>Options</span>
<a name="line-29"></a>
<a name="line-30"></a><span class='hs-comment'>{-
<a name="line-31"></a>The metaWeblog API defines `newPost` and `editPost` procedures that
<a name="line-32"></a>look like:
<a name="line-33"></a>
<a name="line-34"></a> [other]
<a name="line-35"></a> metaWeblog.newPost (blogid, username, password, struct, publish)
<a name="line-36"></a> returns string
<a name="line-37"></a> metaWeblog.editPost (postid, username, password, struct, publish)
<a name="line-38"></a> returns true
<a name="line-39"></a>
<a name="line-40"></a>For WordPress blogs, the `blogid` is ignored. The user name and
<a name="line-41"></a>password are simply strings, and `publish` is a flag indicating
<a name="line-42"></a>whether to load the post as a draft, or to make it public immediately.
<a name="line-43"></a>The `postid` is an identifier string which is assigned when you
<a name="line-44"></a>initially create a post. The interesting bit is the `struct` field,
<a name="line-45"></a>which is an XML-RPC structure defining the post along with some
<a name="line-46"></a>meta-data, like the title. I want be able to provide the post body, a
<a name="line-47"></a>title, and lists of categories and tags. For the body and title, we
<a name="line-48"></a>could just let HaXR convert the values automatically into the XML-RPC
<a name="line-49"></a>`Value` type, since they all have the same Haskell type (`String`) and
<a name="line-50"></a>thus can be put into a list. But the categories and tags are lists of
<a name="line-51"></a>strings, so we need to explicitly convert everything to a `Value`,
<a name="line-52"></a>then combine:
<a name="line-53"></a>-}</span>
<a name="line-54"></a>
<a name="line-55"></a><a name="mkPost"></a><span class='hs-comment'>-- | Prepare a post for uploading by creating something of the proper</span>
<a name="line-56"></a><span class='hs-comment'>-- form to be an argument to an XML-RPC call.</span>
<a name="line-57"></a><span class='hs-definition'>mkPost</span> <span class='hs-keyglyph'>::</span> <span class='hs-conid'>String</span> <span class='hs-comment'>-- ^ Post title</span>
<a name="line-58"></a> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>String</span> <span class='hs-comment'>-- ^ Post content</span>
<a name="line-59"></a> <span class='hs-keyglyph'>-></span> <span class='hs-keyglyph'>[</span><span class='hs-conid'>String</span><span class='hs-keyglyph'>]</span> <span class='hs-comment'>-- ^ List of categories</span>
<a name="line-60"></a> <span class='hs-keyglyph'>-></span> <span class='hs-keyglyph'>[</span><span class='hs-conid'>String</span><span class='hs-keyglyph'>]</span> <span class='hs-comment'>-- ^ List of tags</span>
<a name="line-61"></a> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>Bool</span> <span class='hs-comment'>-- ^ @True@ = page, @False@ = post</span>
<a name="line-62"></a> <span class='hs-keyglyph'>-></span> <span class='hs-keyglyph'>[</span><span class='hs-layout'>(</span><span class='hs-conid'>String</span><span class='hs-layout'>,</span> <span class='hs-conid'>Value</span><span class='hs-layout'>)</span><span class='hs-keyglyph'>]</span>
<a name="line-63"></a><span class='hs-definition'>mkPost</span> <span class='hs-varid'>title_</span> <span class='hs-varid'>text_</span> <span class='hs-varid'>categories_</span> <span class='hs-varid'>tags_</span> <span class='hs-varid'>page_</span> <span class='hs-keyglyph'>=</span>
<a name="line-64"></a> <span class='hs-varid'>mkArray</span> <span class='hs-str'>"categories"</span> <span class='hs-varid'>categories_</span>
<a name="line-65"></a> <span class='hs-varop'>++</span> <span class='hs-varid'>mkArray</span> <span class='hs-str'>"mt_keywords"</span> <span class='hs-varid'>tags_</span>
<a name="line-66"></a> <span class='hs-varop'>++</span> <span class='hs-keyglyph'>[</span> <span class='hs-layout'>(</span><span class='hs-str'>"title"</span><span class='hs-layout'>,</span> <span class='hs-varid'>toValue</span> <span class='hs-varid'>title_</span><span class='hs-layout'>)</span>
<a name="line-67"></a> <span class='hs-layout'>,</span> <span class='hs-layout'>(</span><span class='hs-str'>"description"</span><span class='hs-layout'>,</span> <span class='hs-varid'>toValue</span> <span class='hs-varid'>text_</span><span class='hs-layout'>)</span>
<a name="line-68"></a> <span class='hs-keyglyph'>]</span>
<a name="line-69"></a> <span class='hs-varop'>++</span> <span class='hs-keyglyph'>[</span> <span class='hs-layout'>(</span><span class='hs-str'>"post_type"</span><span class='hs-layout'>,</span> <span class='hs-varid'>toValue</span> <span class='hs-str'>"page"</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>|</span> <span class='hs-varid'>page_</span> <span class='hs-keyglyph'>]</span>
<a name="line-70"></a>
<a name="line-71"></a><a name="mkArray"></a><span class='hs-comment'>-- | Given a name and a list of values, create a named \"array\" field</span>
<a name="line-72"></a><span class='hs-comment'>-- suitable for inclusion in an XML-RPC struct.</span>
<a name="line-73"></a><span class='hs-definition'>mkArray</span> <span class='hs-keyglyph'>::</span> <span class='hs-conid'>XmlRpcType</span> <span class='hs-keyglyph'>[</span><span class='hs-varid'>a</span><span class='hs-keyglyph'>]</span> <span class='hs-keyglyph'>=></span> <span class='hs-conid'>String</span> <span class='hs-keyglyph'>-></span> <span class='hs-keyglyph'>[</span><span class='hs-varid'>a</span><span class='hs-keyglyph'>]</span> <span class='hs-keyglyph'>-></span> <span class='hs-keyglyph'>[</span><span class='hs-layout'>(</span><span class='hs-conid'>String</span><span class='hs-layout'>,</span> <span class='hs-conid'>Value</span><span class='hs-layout'>)</span><span class='hs-keyglyph'>]</span>
<a name="line-74"></a><span class='hs-definition'>mkArray</span> <span class='hs-keyword'>_</span> <span class='hs-conid'>[]</span> <span class='hs-keyglyph'>=</span> <span class='hs-conid'>[]</span>
<a name="line-75"></a><span class='hs-definition'>mkArray</span> <span class='hs-varid'>name</span> <span class='hs-varid'>values</span> <span class='hs-keyglyph'>=</span> <span class='hs-keyglyph'>[</span><span class='hs-layout'>(</span><span class='hs-varid'>name</span><span class='hs-layout'>,</span> <span class='hs-varid'>toValue</span> <span class='hs-varid'>values</span><span class='hs-layout'>)</span><span class='hs-keyglyph'>]</span>
<a name="line-76"></a>
<a name="line-77"></a><span class='hs-comment'>{-
<a name="line-78"></a>The HaXR library exports a function for invoking XML-RPC procedures:
<a name="line-79"></a>
<a name="line-80"></a> [haskell]
<a name="line-81"></a> remote :: Remote a =>
<a name="line-82"></a> String -- ^ Server URL. May contain username and password on
<a name="line-83"></a> -- the format username:password\@ before the hostname.
<a name="line-84"></a> -> String -- ^ Remote method name.
<a name="line-85"></a> -> a -- ^ Any function
<a name="line-86"></a> -- @(XmlRpcType t1, ..., XmlRpcType tn, XmlRpcType r) =>
<a name="line-87"></a> -- t1 -> ... -> tn -> IO r@
<a name="line-88"></a>
<a name="line-89"></a>The function requires an URL and a method name, and returns a function
<a name="line-90"></a>of type `Remote a => a`. Based on the instances defined for `Remote`,
<a name="line-91"></a>any function with zero or more parameters in the class `XmlRpcType`
<a name="line-92"></a>and a return type of `XmlRpcType r => IO r` will work, which means you
<a name="line-93"></a>can simply 'feed' `remote` additional arguments as required by the
<a name="line-94"></a>remote procedure, and as long as you make the call in an IO context,
<a name="line-95"></a>it will typecheck. `postIt` calls `metaWeblog.newPost` or
<a name="line-96"></a>`metaWeblog.editPost` (or simply prints the HTML to stdout) as
<a name="line-97"></a>appropriate:
<a name="line-98"></a>-}</span>
<a name="line-99"></a>
<a name="line-100"></a><a name="makePrisms"></a><span class='hs-definition'>makePrisms</span> <span class='hs-chr'>'</span><span class='hs-chr'>'</span><span class='hs-conid'>Value</span>
<a name="line-101"></a>
<a name="line-102"></a><a name="getPostURL"></a><span class='hs-comment'>-- | Get the URL for a given post.</span>
<a name="line-103"></a><span class='hs-definition'>getPostURL</span> <span class='hs-keyglyph'>::</span> <span class='hs-conid'>String</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>String</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>String</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>String</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>IO</span> <span class='hs-layout'>(</span><span class='hs-conid'>Maybe</span> <span class='hs-conid'>String</span><span class='hs-layout'>)</span>
<a name="line-104"></a><span class='hs-definition'>getPostURL</span> <span class='hs-varid'>url</span> <span class='hs-varid'>pid</span> <span class='hs-varid'>usr</span> <span class='hs-varid'>pwd</span> <span class='hs-keyglyph'>=</span> <span class='hs-keyword'>do</span>
<a name="line-105"></a> <span class='hs-varid'>v</span> <span class='hs-keyglyph'><-</span> <span class='hs-varid'>remote</span> <span class='hs-varid'>url</span> <span class='hs-str'>"metaWeblog.getPost"</span> <span class='hs-varid'>pid</span> <span class='hs-varid'>usr</span> <span class='hs-varid'>pwd</span>
<a name="line-106"></a> <span class='hs-varid'>return</span> <span class='hs-layout'>(</span><span class='hs-varid'>v</span> <span class='hs-varop'>^?</span> <span class='hs-sel'>_ValueStruct</span> <span class='hs-varop'>.</span> <span class='hs-varid'>to</span> <span class='hs-conid'>M</span><span class='hs-varop'>.</span><span class='hs-varid'>fromList</span> <span class='hs-varop'>.</span> <span class='hs-varid'>at</span> <span class='hs-str'>"link"</span> <span class='hs-varop'>.</span> <span class='hs-varid'>traverse</span> <span class='hs-varop'>.</span> <span class='hs-sel'>_ValueString</span><span class='hs-layout'>)</span>
<a name="line-107"></a>
<a name="line-108"></a><a name="postIt"></a><span class='hs-comment'>-- | Given a configuration and a formatted post, upload it to the server.</span>
<a name="line-109"></a><span class='hs-definition'>postIt</span> <span class='hs-keyglyph'>::</span> <span class='hs-conid'>BlogLiterately</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>String</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>IO</span> <span class='hs-conid'>()</span>
<a name="line-110"></a><span class='hs-definition'>postIt</span> <span class='hs-varid'>bl</span> <span class='hs-varid'>html</span> <span class='hs-keyglyph'>=</span>
<a name="line-111"></a> <span class='hs-keyword'>case</span> <span class='hs-layout'>(</span><span class='hs-varid'>bl</span><span class='hs-varop'>^.</span><span class='hs-varid'>blog</span><span class='hs-layout'>,</span> <span class='hs-varid'>bl</span><span class='hs-varop'>^.</span><span class='hs-varid'>htmlOnly</span><span class='hs-layout'>)</span> <span class='hs-keyword'>of</span>
<a name="line-112"></a> <span class='hs-layout'>(</span><span class='hs-conid'>Nothing</span> <span class='hs-layout'>,</span> <span class='hs-keyword'>_</span> <span class='hs-layout'>)</span> <span class='hs-keyglyph'>-></span> <span class='hs-varid'>putStr</span> <span class='hs-varid'>html</span>
<a name="line-113"></a> <span class='hs-layout'>(</span><span class='hs-keyword'>_</span> <span class='hs-layout'>,</span> <span class='hs-conid'>Just</span> <span class='hs-conid'>True</span> <span class='hs-layout'>)</span> <span class='hs-keyglyph'>-></span> <span class='hs-varid'>putStr</span> <span class='hs-varid'>html</span>
<a name="line-114"></a> <span class='hs-layout'>(</span><span class='hs-conid'>Just</span> <span class='hs-varid'>url</span> <span class='hs-layout'>,</span> <span class='hs-keyword'>_</span> <span class='hs-layout'>)</span> <span class='hs-keyglyph'>-></span> <span class='hs-keyword'>do</span>
<a name="line-115"></a> <span class='hs-keyword'>let</span> <span class='hs-varid'>pwd</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>password'</span> <span class='hs-varid'>bl</span>
<a name="line-116"></a> <span class='hs-keyword'>case</span> <span class='hs-varid'>bl</span><span class='hs-varop'>^.</span><span class='hs-varid'>postid</span> <span class='hs-keyword'>of</span>
<a name="line-117"></a> <span class='hs-conid'>Nothing</span> <span class='hs-keyglyph'>-></span> <span class='hs-keyword'>do</span>
<a name="line-118"></a> <span class='hs-varid'>pid</span> <span class='hs-keyglyph'><-</span> <span class='hs-varid'>remote</span> <span class='hs-varid'>url</span> <span class='hs-str'>"metaWeblog.newPost"</span>
<a name="line-119"></a> <span class='hs-layout'>(</span><span class='hs-varid'>blogid'</span> <span class='hs-varid'>bl</span><span class='hs-layout'>)</span>
<a name="line-120"></a> <span class='hs-layout'>(</span><span class='hs-varid'>user'</span> <span class='hs-varid'>bl</span><span class='hs-layout'>)</span>
<a name="line-121"></a> <span class='hs-varid'>pwd</span>
<a name="line-122"></a> <span class='hs-varid'>post</span>
<a name="line-123"></a> <span class='hs-layout'>(</span><span class='hs-varid'>publish'</span> <span class='hs-varid'>bl</span><span class='hs-layout'>)</span>
<a name="line-124"></a> <span class='hs-varid'>putStrLn</span> <span class='hs-varop'>$</span> <span class='hs-str'>"Post ID: "</span> <span class='hs-varop'>++</span> <span class='hs-varid'>pid</span>
<a name="line-125"></a> <span class='hs-varid'>getPostURL</span> <span class='hs-varid'>url</span> <span class='hs-varid'>pid</span> <span class='hs-layout'>(</span><span class='hs-varid'>user'</span> <span class='hs-varid'>bl</span><span class='hs-layout'>)</span> <span class='hs-varid'>pwd</span> <span class='hs-varop'>>>=</span> <span class='hs-varid'>maybe</span> <span class='hs-layout'>(</span><span class='hs-varid'>return</span> <span class='hs-conid'>()</span><span class='hs-layout'>)</span> <span class='hs-varid'>putStrLn</span>
<a name="line-126"></a> <span class='hs-conid'>Just</span> <span class='hs-varid'>pid</span> <span class='hs-keyglyph'>-></span> <span class='hs-keyword'>do</span>
<a name="line-127"></a> <span class='hs-varid'>success</span> <span class='hs-keyglyph'><-</span> <span class='hs-varid'>remote</span> <span class='hs-varid'>url</span> <span class='hs-str'>"metaWeblog.editPost"</span> <span class='hs-varid'>pid</span>
<a name="line-128"></a> <span class='hs-layout'>(</span><span class='hs-varid'>user'</span> <span class='hs-varid'>bl</span><span class='hs-layout'>)</span>
<a name="line-129"></a> <span class='hs-varid'>pwd</span>
<a name="line-130"></a> <span class='hs-varid'>post</span>
<a name="line-131"></a> <span class='hs-layout'>(</span><span class='hs-varid'>publish'</span> <span class='hs-varid'>bl</span><span class='hs-layout'>)</span>
<a name="line-132"></a> <span class='hs-keyword'>case</span> <span class='hs-varid'>success</span> <span class='hs-keyword'>of</span>
<a name="line-133"></a> <span class='hs-conid'>True</span> <span class='hs-keyglyph'>-></span> <span class='hs-varid'>getPostURL</span> <span class='hs-varid'>url</span> <span class='hs-varid'>pid</span> <span class='hs-layout'>(</span><span class='hs-varid'>user'</span> <span class='hs-varid'>bl</span><span class='hs-layout'>)</span> <span class='hs-varid'>pwd</span> <span class='hs-varop'>>>=</span> <span class='hs-varid'>maybe</span> <span class='hs-layout'>(</span><span class='hs-varid'>return</span> <span class='hs-conid'>()</span><span class='hs-layout'>)</span> <span class='hs-varid'>putStrLn</span>
<a name="line-134"></a> <span class='hs-conid'>False</span> <span class='hs-keyglyph'>-></span> <span class='hs-varid'>putStrLn</span> <span class='hs-str'>"Update failed!"</span>
<a name="line-135"></a> <span class='hs-keyword'>where</span>
<a name="line-136"></a> <span class='hs-varid'>post</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>mkPost</span>
<a name="line-137"></a> <span class='hs-layout'>(</span><span class='hs-varid'>title'</span> <span class='hs-varid'>bl</span><span class='hs-layout'>)</span>
<a name="line-138"></a> <span class='hs-varid'>html</span> <span class='hs-layout'>(</span><span class='hs-varid'>bl</span><span class='hs-varop'>^.</span><span class='hs-varid'>categories</span><span class='hs-layout'>)</span> <span class='hs-layout'>(</span><span class='hs-varid'>bl</span><span class='hs-varop'>^.</span><span class='hs-varid'>tags</span><span class='hs-layout'>)</span>
<a name="line-139"></a> <span class='hs-layout'>(</span><span class='hs-varid'>page'</span> <span class='hs-varid'>bl</span><span class='hs-layout'>)</span>
</pre></body>
</html>
|