~singpolyma/xmpp-blog-utils

xmpp-blog-utils/pubsub-entry-publish.hs -rw-r--r-- 5.4 KiB
9591d1a0Stephen Paul Weber Some fixes 3 months ago
                                                                                
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
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DeriveAnyClass #-}
module Main (main) where

import Prelude ()
import BasicPrelude

import Data.Default (def)
import Text.Blaze ((!), customAttribute)
import Data.Time (getZonedTime, ZonedTime)
import Data.Time.Format.ISO8601 (iso8601ParseM, iso8601Show)
import Control.Monad.Error.Class (throwError)
import qualified Text.Blaze as Blaze
import qualified Text.Blaze.Internal as Blaze
import qualified Text.Blaze.Renderer.Text as Blaze
import qualified Dhall
import qualified Text.Pandoc as Pandoc
import qualified Data.Text as T
import qualified Data.Text.Lazy as TL
import qualified Data.Text.Lazy.IO as TL

s :: (IsString s) => String -> s
s = fromString

data PandocSource = PandocSource {
	source :: Text,
	reader :: String
} deriving (Dhall.Generic, Dhall.FromDhall, Show)

data Author = Author {
	name :: Text,
	uri :: Text
} deriving (Dhall.Generic, Dhall.FromDhall, Show)

instance Blaze.ToMarkup Author where
	toMarkup theAuthor = Blaze.customParent (s"author") $ do
		Blaze.customParent (s"name") (Blaze.text $ name theAuthor)
		Blaze.customParent (s"uri") (Blaze.text $ uri theAuthor)

data Time = Now | At Text deriving (Dhall.Generic, Dhall.FromDhall, Show)

zonedTime :: Time -> IO ZonedTime
zonedTime Now = getZonedTime
zonedTime (At time) = iso8601ParseM (textToString time)

data Enclosure = Enclosure {
	type_ :: Text,
	href_ :: Text,
	title_ :: Text
} deriving (Dhall.Generic, Show)

instance Dhall.FromDhall Enclosure where
  autoWith _ =
    Dhall.genericAutoWith Dhall.defaultInterpretOptions
      { Dhall.fieldModifier = T.dropWhileEnd (=='_') }

instance Blaze.ToMarkup Enclosure where
	toMarkup (Enclosure ty h ti) =
		Blaze.customLeaf (s"link") True
			! customAttribute (s"rel") (s"enclosure")
			! customAttribute (s"type") (Blaze.toValue ty)
			! customAttribute (s"title") (Blaze.toValue ti)
			! customAttribute (s"href") (Blaze.toValue h)

data Config = Config {
	id :: Text,
	httpUri :: Maybe Text,
	title :: Text,
	author :: Author,
	contentText :: Maybe Text,
	contentXHTML :: Maybe PandocSource,
	comments :: Bool,
	published :: Time,
	updated :: Time,
	category :: [Text],
	enclosures :: [Enclosure]
} deriving (Dhall.Generic, Dhall.FromDhall, Show)

pandocReader :: (Pandoc.PandocMonad m) =>
	   String
	-> Text
	-> m Pandoc.Pandoc
pandocReader readerSpec txt = do
	(theReader, theExtensions) <- Pandoc.getReader (fromString readerSpec)
	case theReader of
		Pandoc.ByteStringReader _ -> throwError $
			Pandoc.PandocAppError $ s"No support for binary formats"
		Pandoc.TextReader r ->
			r (def { Pandoc.readerExtensions = theExtensions }) txt

main :: IO ()
main = do
	[service, node] <- getArgs
	config <- getContents >>= Dhall.input Dhall.auto . TL.toStrict

	xhtml <- case contentXHTML config of
		Just content -> do
			pandoc <- Pandoc.runIOorExplode (pandocReader (reader content) (source content))
			xhtml <- Pandoc.runIOorExplode (Pandoc.writeHtml5 def pandoc)
			return $ Just (xhtml, pandoc)
		Nothing -> return Nothing

	text <- case (contentText config, xhtml) of
		(Just t, _) -> return $ Just t
		(Nothing, Just (_, pandoc)) -> Just <$> Pandoc.runIOorExplode (Pandoc.writePlain def pandoc)
		_ -> return Nothing

	publishedZT <- zonedTime (published config)
	updatedZT <- zonedTime (updated config)

	let itemUri = s"xmpp:" ++ service ++ s"?;node=" ++ node ++ s";item=" ++ Main.id config
	let commentUri = s"xmpp:" ++ service ++ s"?;node=" ++ node ++ s":comments/" ++ Main.id config

	let entry =
		Blaze.customParent (s"entry") ! customAttribute (s"xmlns") (s"http://www.w3.org/2005/Atom") $ do
			Blaze.customParent (s"id")
				$ Blaze.text itemUri
			Blaze.customParent (s"title")
				! customAttribute (s"type") (s"text")
				$ Blaze.text $ title config
			Blaze.toMarkup (author config)
			Blaze.customLeaf (s"link") True
				! customAttribute (s"rel") (s"alternate")
				! customAttribute (s"href") (Blaze.toValue itemUri)
			forM_ (httpUri config) $ \http ->
				Blaze.customLeaf (s"link") True
					! customAttribute (s"rel") (s"alternate")
					! customAttribute (s"type") (s"text/html")
					! customAttribute (s"href") (Blaze.toValue http)
			when (comments config) $
				Blaze.customLeaf (s"link") True
					! customAttribute (s"title") (s"comments")
					! customAttribute (s"rel") (s"replies")
					! customAttribute (s"href") (Blaze.toValue commentUri)
			forM_ (enclosures config) Blaze.toMarkup

			forM_ text $ \txt ->
				Blaze.customParent (s"content")
					! customAttribute (s"type") (s"text")
					$ Blaze.text txt

			forM_ xhtml $ \(markup, _) ->
				Blaze.customParent (s"content")
					! customAttribute (s"type") (s"xhtml")
					$ Blaze.customParent (s"div")
						! customAttribute (s"xmlns") (s"http://www.w3.org/1999/xhtml")
						$ markup

			Blaze.customParent (s"published")
				$ Blaze.string $ iso8601Show publishedZT
			Blaze.customParent (s"updated")
				$ Blaze.string $ iso8601Show updatedZT

			forM_ (category config) $ \cat ->
				Blaze.customLeaf (s"category") True
					! customAttribute (s"term") (Blaze.toValue cat)

	TL.putStrLn $ Blaze.renderMarkup $
		Blaze.customParent (s"iq")
			! customAttribute (s"to") (Blaze.toValue service)
			! customAttribute (s"type") (s"set")
			! customAttribute (s"id") (s"publishing")
			$ Blaze.customParent (s"pubsub")
				! customAttribute (s"xmlns") (s"http://jabber.org/protocol/pubsub")
				$ Blaze.customParent (s"publish")
					! customAttribute (s"node") (Blaze.toValue node)
					$ Blaze.customParent (s"item")
						! customAttribute (s"id") (Blaze.toValue $ Main.id config)
						$ entry