-- LjPost: Send Markdown-formatted blog posts to Livejournal
-- Copyright (C) 2007  Dougal Stanton
-- 
-- This program is free software; you can redistribute it and/or modify
-- it under the terms of the GNU General Public License as published by
-- the Free Software Foundation; either version 2 of the License, or
-- (at your option) any later version.
-- 
-- This program is distributed in the hope that it will be useful,
-- but WITHOUT ANY WARRANTY; without even the implied warranty of
-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
-- GNU General Public License for more details.
-- 
-- You should have received a copy of the GNU General Public License along
-- with this program; if not, write to the Free Software Foundation, Inc.,
-- 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.


module Main where

-- Reading and writing various types
-- of marked-up text.
import Text.Pandoc.Readers.Markdown
import Text.Pandoc.Writers.HTML
import Text.Pandoc.Shared

import System.Process       (runCommand, runInteractiveProcess, runProcess, waitForProcess)
import System.Directory     (getTemporaryDirectory, removeFile, renameFile)
import System.Environment   (getArgs)
import System.Exit
import System.IO
import Control.Concurrent   (forkIO)
import Control.Monad        (when)
import Control.Exception    (bracket)
import Data.List            (isSuffixOf)
import Text.Printf          (printf)
import Text.Regex

data Post = Post
    { content :: String
    , subject :: String
    , music   :: Maybe String }

main = do
    (cmd, inputfile, options) <- parseArguments
    case cmd of
        "post" -> makePost inputfile >>= flip postentry options >> chfilename inputfile
        "show" -> makePost inputfile >>= showentry
        "help" -> putStrLn usage
        s      -> putStrLn ("Unknown command: " ++ s) >> putStrLn usage
  where chfilename i = if "todo" `isSuffixOf` i
                        then renameFile i $ take (length i-4) i ++ "done"
                        else return ()

parseArguments = do
    argv <- getArgs
    case argv of
        []       -> return ("help", "", [])
        [cmd]    -> return (cmd, "" ,[])
        (c:f:as) -> return (c, f, as)

makePost mkdfile = do
    mkd <- readFile mkdfile
    let (topline:rest) = lines mkd
        blogbody = educate $ unlines $ rest ++ [""]
        blogtitle = removeTrailingSpace $ educate topline
    muso <- getMusic
    return $ Post { content = blogbody, subject = blogtitle, music = muso }

showentry :: Post -> IO ()
showentry post = do
    bracket
      (getTemporaryDirectory >>= flip openTempFile "ljpost-entry.html")
      (\(f,_) -> removeFile f) $ \(filename, handle) -> do
        hPutStr handle ("<h1>" ++ subject post ++ "</h1>\n")
        hPutStr handle (ljusers $ content post)
        hPutStr handle $ maybe "" ("<hr /> " ++) $ music post
        hClose handle
        openInTextBrowser filename

postentry :: Post -> [String] -> IO ()
postentry post args = do
    (pc, err) <- runcmd "charm" arguments (ljcut $ content post)
    ec <- waitForProcess pc
    case ec of
        ExitSuccess -> putStrLn "Posted."
        e           -> error $ "Couldn't post to blog\n" ++ show e
  where arguments = ["--quick"
                    ,"--autoformat=off"
                    ,"--subject", subject post
                    ] ++ addmusic args
        -- has the user supplied their own music info?
        explicit = "--music" `elem` args || "-M" `elem` args
        currentsong = maybe id (\s -> (++) ("--music":s:[])) (music post)
        addmusic = if explicit then id else currentsong

runcmd cmd args content = do
    (hin, hout, herr, pc) <- runInteractiveProcess cmd args Nothing Nothing
    forkIO $ hPutStr hin content >> hClose hin
    out <- hGetContents hout
    return (pc, out)



--
-- Get name of currently playing song (if any)
-- from external script.

queryCurrentMusic = do
    (hin,hout,herr,ph) <- runInteractiveProcess "nowplaying" [] Nothing Nothing
    result <- hGetContents hout
    return (result, ph)

getMusic = do
    (proc, content) <- runcmd "nowplaying" [] ""
    case content of
        "" -> waitForProcess proc >> return Nothing
        _  -> do let music = head . lines $ content
                 waitForProcess proc
                 return $ Just music

--
-- Preparing marked-up text files for preview or
-- posting. There are several stages.
--
-- 1. Converting Markdown-formatted text to HTML
-- with fancy typography (smart quotes etc.).
--
-- 2. Display LJ usernames as bold text for local
-- previews.
--
-- 3. Turn quotes inside HTML comments into LJ cuts
-- for posting only.

ljcut input = subRegex ljcutintro input "<lj-cut text=\"\\1\" />"
    where ljcutintro = mkRegex "<!-- \"(.*)\" -->"
ljusers inp = subRegex ljusername inp "<b>\\2</b>"
    where ljusername = mkRegex "<lj (user|community)=\"(.*)\" />"


educate = writeHtml writeOpts . readMarkdown readOpts
  where writeOpts = WriterOptions   { writerStandalone     = False
                                    , writerHeader         = ""
                                    , writerTitlePrefix    = ""
                                    , writerTabStop        = 4
                                    , writerNotes          = []
                                    , writerS5             = False
                                    , writerIncremental    = False
                                    , writerNumberSections = False
                                    , writerIncludeBefore  = ""
                                    , writerIncludeAfter   = ""
                                    , writerStrictMarkdown = False }
        readOpts = defaultParserState { stateSmart = True
                                      , stateParseRaw = True }

--
-- Open HTML files in browser to preview
-- the blog post. Previews also contain
-- extra info like subjects on the page
-- for context.

openInTextBrowser html = do
    rc <- runCommand browser >>= waitForProcess
    case rc of
        ExitSuccess -> return ()
        _           -> error $ "Couldn't open in text browser"
  where browser = printf "links %s" html

cmds = ["text", "show", "post"]
usage = unlines $
    ["Usage:"
    ,"  ljpost <show|post> <blogpost> [optargs]"
    ,"  ljpost help"]