publishing nike runs, part 5: blogging and twitter

This is the fifth and final part of the series of entries about publishing nike runs.

In the first part we defined functions operating on numeric lists, in the second part we used those functions and Google Charts to create charts of our NikeRuns. In the third part we fetched the xml data from the Nike+ http servers and processed it into NikeRuns. In the fourth part we used HStringTemplate to compose text renderings from the NikeRuns.

In this fifth part we will publish the text renderings to our blog (and to twitter too, my vanity is boundless).

First we create a new module Codemanic.Blogging in file Blogging.hs with the blog publishing code. We define two data types describing a blog and a blog entry:

data Blog = Blog {
  url :: String,
  user :: String,
  password :: String,
  blogId :: Int
} deriving (Eq,Show)

data BlogEntry = BlogEntry {
  title :: String,
  body :: String,
  keywords :: [String],
  publishTime :: UTCTime
} deriving (Eq,Show)

The url in Blog needs to point to the xml rpc api of our blog. We will use HaXR to make the metaWeblog.newPost xml rpc call for us. (Small tip for MovableType bloggers: the xml rpc api password is different from your regular blog password, you can get it from System Overview > Authors > Your Name, scroll to the bottom of the page and look for the "API Password" field).

HaXR is very easy to use. We define a function that takes the server url as its first argument followed by the same arguments as metaWeblog.newPost, only mapped to haskell types:

publishMT :: String -> Int -> String -> String -> [(String, Value)] -> Bool -> IO Value
publishMT url = remote url "metaWeblog.newPost"

We need another function that builds that list of key-value pairs from a BlogEntry. It uses HaXR value types:

blogPost :: BlogEntry -> TimeZone -> [(String, Value)]
blogPost blogEntry timeZone =
  ("title", ValueString $ title blogEntry) :
  ("description", ValueString $ body blogEntry) :
  ("dateCreated", ValueDateTime (utcToLocalTime timeZone (publishTime blogEntry))) :
  ("mt_allow_comments", ValueBool False) :
  ("mt_allow_pings", ValueBool False) :
  ("mt_convert_breaks", ValueBool True) :
  ("mt_keywords", ValueString (foldl1 (\x y -> x ++ "," ++ y) (keywords blogEntry))) :
  ("categories", ValueArray (map ValueString (keywords blogEntry))) : []   

The following publish function (which this module will export) wraps all this into a convenient call:

publish :: Blog -> BlogEntry -> IO ()
publish blog blogEntry = do
  timeZone <- getCurrentTimeZone
  putStrLn $ "publishing blog entry " ++ (show blogEntry)
  rv <- publishMT (url blog) (blogId blog) (user blog) (password blog) (blogPost blogEntry timeZone) True
  putStrLn "done publishing to blog" 
  return ()

Let's turn our attention to the main module nikepub.hs. What's left to do there is parsing command line options. We will closely follow this recipe.

First we define our Options data type and the default options:

data Options = Options {
  nikeId :: Int,
  templateDir :: String,
  chartWidth :: Int,
  chartHeight :: Int,
  mtUser :: Maybe String,
  mtPassword :: Maybe FilePath,
  mtUrl :: Maybe String,
  twitterUser :: Maybe String,
  twitterPassword :: Maybe FilePath,
  message :: Maybe String
} deriving (Eq, Show)

defaultOptions :: Options
defaultOptions = Options {
  nikeId = 0,
  templateDir = "",
  chartWidth = 600,
  chartHeight = 200,
  mtUser = Nothing,
  mtPassword = Nothing,
  mtUrl = Nothing,
  twitterUser = Nothing,
  twitterPassword = Nothing,
  message = Nothing
}

Then we define the list of option descriptions:

options :: [ OptDescr (Options -> IO Options) ]
options = 
  [ Option "" ["templates"]
        (ReqArg
            (\arg opt -> return opt { templateDir = arg })
            "DIR")
        "template directory"
 
    , Option "u" ["id"]
        (ReqArg
            (\arg opt -> return opt { nikeId = (read arg) })
            "INT")
        "nike+ user id"

    , Option "" ["mtUser"]
        (ReqArg
            (\arg opt -> return opt { mtUser = Just arg })
            "STRING")
        "mt user"

    , Option "" ["mtPassword"]
        (ReqArg
            (\arg opt -> return opt { mtPassword = Just arg })
            "FILEPATH")
        "mt password file"

    , Option "" ["mtUrl"]
        (ReqArg
            (\arg opt -> return opt { mtUrl = Just arg })
            "STRING")
        "mt url"

    , Option "" ["twitterUser"]
        (ReqArg
            (\arg opt -> return opt { twitterUser = Just arg })
            "STRING")
        "twitter user"

    , Option "" ["twitterPassword"]
        (ReqArg
            (\arg opt -> return opt { twitterPassword = Just arg })
            "FILEPATH")
        "twitter password file"

    , Option "m" ["message"]
        (ReqArg
            (\arg opt -> return opt { message = Just arg })
            "STRING")
        "message"
 
    , Option [] ["chartWidth"]
        (ReqArg
            (\arg opt -> return opt { chartWidth = read arg })
            "INT")
        "chart width"

    , Option [] ["chartHeight"]
        (ReqArg
            (\arg opt -> return opt { chartHeight = read arg })
            "INT")
        "chart height"

    , Option "v" ["version"]
        (NoArg
            (\_ -> do
                hPutStrLn stderr "Version 1.00"
                exitWith ExitSuccess))
        "Print version"
 
    , Option "h" ["help"]
        (NoArg
            (\_ -> do
    	        prg <- getProgName
                hPutStrLn stderr (usageInfo prg options)
                exitWith ExitSuccess))
        "Show help"
    ]

A function will thread the Options record through all the functions described in the OptDescr list, creating modified Options records as it goes:

nikepubOpts :: [String] -> IO Options
nikepubOpts args = do
    case getOpt RequireOrder options args of
      (o,n,[]  ) -> foldl (>>=) (return defaultOptions) o
      (_,_,errs) -> ioError (userError (concat errs ++ usageInfo header options))
  where header = "Usage: nikepub [OPTION...]"

That's it, we use it in the new main function:

main :: IO ()
main = do
  args <- getArgs
  opts <- nikepubOpts args
  let userId = (nikeId opts)
  putStrLn $ "fetching most recent run for nike user " ++ (show userId)
  runId <- getMostRecentNikeRunId userId
  putStrLn $ "fetching run " ++ (show runId)
  nr <- getNikeRun userId runId
  blog nr opts
  tweet nr opts

Oh, we still need to define the tweeting function. For this we use hs-twitter and define the tweet function:

tweet :: NikeRun -> Options -> IO ()
tweet nr opts = do
  let cw = chartWidth opts
  let ch = chartHeight opts
  case (twitterUser opts) of
    Just twu -> do
      twitterMsg <- renderNikeRun cw ch (templateDir opts) "twitter_status" nr ""
      twitterPswd <- readFile (fromJust $ twitterPassword opts)
      putStrLn $ "tweeting update " ++ twitterMsg
      runTM (AuthUser twu twitterPswd)
        $ postMethod
        $ restCall "update.json" (arg "status" twitterMsg [])
      putStrLn "done tweeting"
      return ()
    Nothing -> return ()

Now we're really done. This blog entry for example was created with the program we just finished. I'll follow up with an addendum entry on using cabal and making a hackage and I'll post the whole code somewhere for download. In the meantime here are today's two modules.

module Codemanic.Blogging
(
 Blog(..),
 BlogEntry(..),
 publish
)
where

import Data.Time
import Data.Time.LocalTime
import Data.Time.Clock
import Data.Time.Clock.POSIX
import Data.Time.Format
import System.Locale
import System.Time
import Text.Printf
import Text.Regex
import Data.Maybe
import Data.Map (Map)
import qualified Data.Map as Map
import Network.XmlRpc.Client
import Network.XmlRpc.Internals

data Blog = Blog {
  url :: String,
  user :: String,
  password :: String,
  blogId :: Int
} deriving (Eq,Show)

data BlogEntry = BlogEntry {
  title :: String,
  body :: String,
  keywords :: [String],
  publishTime :: UTCTime
} deriving (Eq,Show)

publishMT :: String -> Int -> String -> String -> [(String, Value)] -> Bool -> IO Value
publishMT url = remote url "metaWeblog.newPost"

blogPost :: BlogEntry -> TimeZone -> [(String, Value)]
blogPost blogEntry timeZone =
  ("title", ValueString $ title blogEntry) :
  ("description", ValueString $ body blogEntry) :
  ("dateCreated", ValueDateTime (utcToLocalTime timeZone (publishTime blogEntry))) :
  ("mt_allow_comments", ValueBool False) :
  ("mt_allow_pings", ValueBool False) :
  ("mt_convert_breaks", ValueBool True) :
  ("mt_keywords", ValueString (foldl1 (\x y -> x ++ "," ++ y) (keywords blogEntry))) :
  ("categories", ValueArray (map ValueString (keywords blogEntry))) : []   

publish :: Blog -> BlogEntry -> IO ()
publish blog blogEntry = do
  timeZone <- getCurrentTimeZone
  putStrLn $ "publishing blog entry " ++ (show blogEntry)
  rv <- publishMT (url blog) (blogId blog) (user blog) (password blog) (blogPost blogEntry timeZone) True
  putStrLn "done publishing to blog" 
  return ()

module Main (main)
where

import Codemanic.NikeRuns
import Codemanic.Blogging
import System.Console.GetOpt
import System
import IO
import Control.Monad
import Data.Maybe
import Web.Twitter.Fetch
import Web.Twitter.Monad
import System.Environment

data Options = Options {
  nikeId :: Int,
  templateDir :: String,
  chartWidth :: Int,
  chartHeight :: Int,
  mtUser :: Maybe String,
  mtPassword :: Maybe FilePath,
  mtUrl :: Maybe String,
  twitterUser :: Maybe String,
  twitterPassword :: Maybe FilePath,
  message :: Maybe String
} deriving (Eq, Show)

defaultOptions :: Options
defaultOptions = Options {
  nikeId = 0,
  templateDir = "",
  chartWidth = 600,
  chartHeight = 200,
  mtUser = Nothing,
  mtPassword = Nothing,
  mtUrl = Nothing,
  twitterUser = Nothing,
  twitterPassword = Nothing,
  message = Nothing
}

options :: [ OptDescr (Options -> IO Options) ]
options = 
  [ Option "" ["templates"]
        (ReqArg
            (\arg opt -> return opt { templateDir = arg })
            "DIR")
        "template directory"
 
    , Option "u" ["id"]
        (ReqArg
            (\arg opt -> return opt { nikeId = (read arg) })
            "INT")
        "nike+ user id"

    , Option "" ["mtUser"]
        (ReqArg
            (\arg opt -> return opt { mtUser = Just arg })
            "STRING")
        "mt user"

    , Option "" ["mtPassword"]
        (ReqArg
            (\arg opt -> return opt { mtPassword = Just arg })
            "FILEPATH")
        "mt password file"

    , Option "" ["mtUrl"]
        (ReqArg
            (\arg opt -> return opt { mtUrl = Just arg })
            "STRING")
        "mt url"

    , Option "" ["twitterUser"]
        (ReqArg
            (\arg opt -> return opt { twitterUser = Just arg })
            "STRING")
        "twitter user"

    , Option "" ["twitterPassword"]
        (ReqArg
            (\arg opt -> return opt { twitterPassword = Just arg })
            "FILEPATH")
        "twitter password file"

    , Option "m" ["message"]
        (ReqArg
            (\arg opt -> return opt { message = Just arg })
            "STRING")
        "message"
 
    , Option [] ["chartWidth"]
        (ReqArg
            (\arg opt -> return opt { chartWidth = read arg })
            "INT")
        "chart width"

    , Option [] ["chartHeight"]
        (ReqArg
            (\arg opt -> return opt { chartHeight = read arg })
            "INT")
        "chart height"

    , Option "v" ["version"]
        (NoArg
            (\_ -> do
                hPutStrLn stderr "Version 1.00"
                exitWith ExitSuccess))
        "Print version"
 
    , Option "h" ["help"]
        (NoArg
            (\_ -> do
    	        prg <- getProgName
                hPutStrLn stderr (usageInfo prg options)
                exitWith ExitSuccess))
        "Show help"
    ]

nikepubOpts :: [String] -> IO Options
nikepubOpts args = do
    case getOpt RequireOrder options args of
      (o,n,[]  ) -> foldl (>>=) (return defaultOptions) o
      (_,_,errs) -> ioError (userError (concat errs ++ usageInfo header options))
  where header = "Usage: nikepub [OPTION...]"

tweet :: NikeRun -> Options -> IO ()
tweet nr opts = do
  let cw = chartWidth opts
  let ch = chartHeight opts
  case (twitterUser opts) of
    Just twu -> do
      twitterMsg <- renderNikeRun cw ch (templateDir opts) "twitter_status" nr ""
      twitterPswd <- readFile (fromJust $ twitterPassword opts)
      putStrLn $ "tweeting update " ++ twitterMsg
      runTM (AuthUser twu twitterPswd)
        $ postMethod
        $ restCall "update.json" (arg "status" twitterMsg [])
      putStrLn "done tweeting"
      return ()
    Nothing -> return ()
 
blog :: NikeRun -> Options -> IO ()
blog nr opts = do
  let cw = chartWidth opts
  let ch = chartHeight opts
  case (mtUrl opts) of 
    Just u -> do
      mtTitle <- renderNikeRun cw ch (templateDir opts) "mt_title" nr ""
      mtBody  <- renderNikeRun cw ch (templateDir opts) "mt_body" nr (fromMaybe "" (message opts))
      mtPswd <- readFile (fromJust $ mtPassword opts)
      let blogEntry = BlogEntry {
         title = mtTitle,
         body = mtBody,
         keywords = ["running"],
         publishTime = (startTime nr) }
      let blog = Blog {
         url = u,
         user = (fromJust $ mtUser opts),
         password = mtPswd,         
         blogId = 1}
      publish blog blogEntry
    Nothing  -> return ()
  
main :: IO ()
main = do
  args <- getArgs
  opts <- nikepubOpts args
  let userId = (nikeId opts)
  putStrLn $ "fetching most recent run for nike user " ++ (show userId)
  runId <- getMostRecentNikeRunId userId
  putStrLn $ "fetching run " ++ (show runId)
  nr <- getNikeRun userId runId
  blog nr opts
  tweet nr opts