feed2lj-0.0.3: Feed2Lj.hs

-- vim: ts=2 sw=2 expandtab si ai :

import LjPost

import System.Environment (getArgs)
import System.Directory (renameFile, doesFileExist)
import System (exitWith, ExitCode(..))
import Control.Monad (liftM, mapM,ap)
import Maybe (fromJust, fromMaybe, isNothing, isJust, maybe)
import List ((\\))
import Network.HTTP (urlEncode)

import Text.Regex.Posix ((=~))

import Network.Curl (curlGetString)
import Text.Feed.Import (parseFeedString)
import Text.Feed.Types (Feed, Item)
import Text.Feed.Query
import Text.HTML.TagSoup

import IO
import Codec.Binary.UTF8.String (encodeString)

--import Debug.Trace (trace)
--debug x = trace (show x) x

-- take first n sentences from string s
takeSentences n s
  | n > 0     = let (s',r) = takeSentence s
                in s' ++ takeSentences (n-1) r
  | otherwise = ""

takeSentence s =
  let ends = ".?!;"
      (first,rest) = break (`elem` ends) s
  in if not (null rest)
     then (first ++ [head rest],tail rest)
     else (first,[])

-- remove all html/xml tags, use tag text and replace images with their ALT text
eatTags :: String -> String
eatTags [] = []
eatTags s =
  let tags = parseTags s
      toString t =
        if (isTagOpenName "img" t)
          then (fromAttrib "alt" t)++" "
          else if isTagText t
            then fromTagText t
            else ""
  in  concat $ map toString tags

-- mini template engine
renderTemplate _ [] = []
renderTemplate alist s =
  let (b,t,a) = s =~ "%[a-z0-9]*%" :: (String,String,String)
      tagval t
         | t == "%%" = Just "%"
         | otherwise = let inner = take (length t - 2) $ drop 1 t
                       in  lookup inner alist
      val = tagval t
  in if isJust val
       then b ++ (fromJust val) ++ renderTemplate alist a
       else b ++ t ++ renderTemplate alist a

renderItem :: (Maybe Int) -> String -> Item -> String
renderItem n t i =
  let title = ( fromJust . getItemTitle ) i
      link = ( fromJust . getItemLink ) i
      guid = ( fromJust . getItemId ) i
      justFirst Nothing = id
      justFirst (Just n) = takeSentences n
      summary = ( justFirst n . eatTags . fromJust . getItemSummary) i
      tags = zip [ "title","link","text" ]
                 [ title, urlEncode link,summary ]
  in renderTemplate tags t

isNotSent sent i = ((snd . fromJust . getItemId) i) `notElem` sent

postItem u p t n i = do
  let message = renderItem n t i
  let subj = fromJust $ getItemTitle i
  r <- postToLj u p subj message
  if isSuccess r
    then putLjKey "url" r
    else putLjKey "errmsg" r

printItem t n i = do
  let message = renderItem n t i
  let subj = fromJust $ getItemTitle i
  putStrLn $ "Subject: " ++ subj
  putStrLn message
  putStrLn ""

readFileIfExists f = do
  t <- doesFileExist f
  if t then readFile f
       else return ""

readMaybeInt =  maybe Nothing (\s -> Just (read s::Int))

usage = "usage: feed2lj [--help] [--dry-run] http://example.com/rss.xml"

printUsageAndExitIf c status =
  if c
    then do { putStrLn usage ; exitWith status ; }
    else return ()

main = do
  args <- getArgs
  let opts = [ "--help", "--dry-run" ]
  let dryrun = "--dry-run" `elem` args
  printUsageAndExitIf ("--help" `elem` args) ExitSuccess

  let args' = args \\ opts
  printUsageAndExitIf (length args' == 0) $ ExitFailure 1

  let url= head $ args \\ opts
  (_,rawfeed) <- curlGetString url []

  ljuser <- return fromJust `ap` readLjSetting "username"
  ljpass <- return fromJust `ap` readLjSetting "password"
  sentfile <- return fromJust `ap` readLjSetting "sentfile"
  t <- return fromJust `ap` readLjSetting "template"
  nsentences <- return readMaybeInt `ap` readLjSetting "nsentences"
  sent_ids <- (return . lines) =<< readFileIfExists sentfile

  let feed = fromJust $ parseFeedString rawfeed
  let items = feedItems feed
  let newitems = reverse $ filter (isNotSent sent_ids) items
  let new_ids = map ( snd . fromJust . getItemId) newitems

  if not dryrun
    then do
      mapM_ (postItem ljuser ljpass t nsentences) newitems
      renameFile sentfile (sentfile ++ "~")
      writeFile sentfile $ unlines (sent_ids ++ new_ids)
    else do -- debug script and cross-post preview
      mapM_ (printItem t nsentences) newitems