{-# 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