Recently in haskell Category

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

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.

This entry will try to describe a little haskell gem I learned while reading the getOpt docs for the next part in the series.

In one of the example usages of getOpt was this innocent looking expression: foldl (flip id) v fs. The types are v :: A and fs :: [A -> A] for some type A (in the getOpt example A was some type about options). This expression applies the functions in fs one by one starting with the first one and using the accumulator of foldl as the argument to the functions. The output of one function is the input to the next. It's a processing pipeline that send the initial value v through the first function in fs, the result of that to the next function in fs and so on.

I got that quickly. What baffled me was the fact that haskell didn't complain about feeding id to flip. Because looking with ghci at types we have:

Prelude> :t flip
flip :: (a -> b -> c) -> b -> a -> c

Prelude> :t id
id :: a -> a

This shows that flip's first argument is a binary function and id is a unary function. Of course in haskell all functions are unary through currying, so the nice folks on the #haskell irc.freenode.net channel clued me in on how this works in this case and how this expression is typed correctly. (btw, the #haskell channel is highly recommended, the coolest, most patient experts hang out there, answering anything beginners like me throw at them).

The expression flip id is valid if the types of id and a -> b -> c can be unified. What I missed is that they easily can.

a -> b -> c is a -> (b -> c). If we feed (b -> c) to id it will return (b -> c). So in this case id :: (b -> c) -> (b -> c). The a from a -> (b -> c) can be anything, so it can be (b -> c) also. Done, expression has valid type.

Let's also look why the expression foldl (flip id) v fs does what we claimed it does, namely send v through the list of functions fs, applying the next function to the result of the previous.

If we wanted to implement this behavior ourselves, we would recognize quickly that foldl is what we want because it eats through the list from left to right. In our case the list is a list of functions and the accumulator in foldl is the argument we want to give to the functions on each application. The complication comes from the fact that the accumulator in foldl is on the left, so it's the first argument. Therefore we cannot directly combine it with functions in fs expecting function application. We have to reverse (flip) the arguments first.

We could therefore write something like this expression: foldl (\x f -> f x) v fs.

Looking closer at the lambda expression there, it takes the value as first parameter and then the function that we want to apply to the value (this is the order in which foldl gives it to us). The lambda expression flips it and does the application. Aha, flips it. Maybe we can use flip. But flip alone won't do it (foldl flip v fs doesn't even have valid type). Well, flip takes 3 arguments, the first of which is a function. Function application is left-associative. So this first argument is a function that will end up being applied to the function f that comes out of fs. The result of that will be applied to the accumulator. In the end we want f applied to the accumulator. Which function when applied to f will return f again, id of course.

Voila, we have foldl (\x f -> f x) v fs be the same as foldl (flip id) v fs.

First we bulk up the NikeRun data:

data NikeRun = NikeRun {
  userId :: Int,
  runId :: Int,
  extendedData :: [Double],
  calories :: Double,
  startTime :: UTCTime
} deriving (Eq,Show)

We also define some functions to derive more data from NikeRun:

duration :: NikeRun -> Double
duration nr = 
  (10.0 * (fromIntegral (length (extendedData nr)))) / 60.0

distance :: NikeRun -> Double
distance nr = last (extendedData nr)

pace :: NikeRun -> Double
pace nr = (duration nr) / (distance nr) 

and we modify the xml data processing function parseNikeRun to extract the start time of the run too:

parseNikeRun uId rId = atTag "sportsData" >>>
  proc x -> do
    cs   <- textAtTag "calories" -< x
    exds <- textAtTag "extendedData" -< x
    sts <- textAtTag "startTime" -< x
    returnA -< NikeRun {
        userId = uId,
        runId = rId,
        extendedData = readDoubles exds,
        startTime = readTime defaultTimeLocale "%Y-%m-%dT%H:%M:%S%z" sts,
        calories = read cs }

renderNikeRun :: Int -> Int -> String -> NikeRun -> IO String
renderNikeRun w h templates nr = do
  dirs <- directoryGroup templates
  let chart = chartNikeRun w h nr
  let tpl = fromJust $ getStringTemplate "nikerun" dirs
  return $ render $ setAttribute "chart" chart $
                    setAttribute "calories" (calories nr) $
                    setAttribute "duration" (renderDouble (duration nr)) $
                    setAttribute "distance" (renderDouble (distance nr)) $
                    setAttribute "pace" (renderDouble (pace nr)) $
                    setAttribute "startTime" (renderTime (startTime nr)) $
                    setAttribute "userId" (userId nr) $
                    setAttribute "runId" (runId nr) tpl
  where
    renderDouble :: Double -> String
    renderDouble x = (printf "%.2f" x)::String
    renderTime :: UTCTime -> String
    renderTime t = formatTime defaultTimeLocale "%x, %r" t

For our convenience we want to provide a function to get the runId of the most recent run. We do it similar to the fetching and xml processing in part 3, this time with a different URL to fetch run summaries and extract runIds:

nikeRunIdsURL :: Int -> String
nikeRunIdsURL userId =
  "http://nikeplus.nike.com/nikeplus/v1/" ++
  "services/app/get_public_user_data.jsp?id=" ++ (show userId)  

retrieveNikeRunIds :: Int -> IO String
retrieveNikeRunIds userId = do
  case parseURI (nikeRunIdsURL userId) of
    Nothing   -> ioError . userError $ "Invalid URL"
    Just uri  -> get uri

parseNikeRunId = atTag "mostRecentRun" >>>
  proc x -> do
    runId <- getAttrValue "id" -< x
    returnA -< (read runId)::Int

getMostRecentNikeRunId :: Int -> IO Int
getMostRecentNikeRunId userId = do
  doc <- retrieveNikeRunIds userId
  let xml = parseXML doc
  nikeRunIds <- runX (xml >>> parseNikeRunId)
  case nikeRunIds of
    [] -> ioError . userError $ 
        "Failed to parse most recent nike run id " ++ show userId
    id:_ -> return id

That's it. To test this we write our first main module in file nikepub.hs. We will expand that later wih command line argument parsing:

module Main (main) 
where

import Codemanic.NikeRuns

main :: IO ()
main = do
  let userId = 617307368
  runId <- getMostRecentNikeRunId userId
  nr <- getNikeRun userId runId
  rendered <- renderNikeRun 600 200 "/Users/uwe/moonlight/haskell/templates" nr
  putStrLn rendered

We create a templates directory and define the following template file nikerun.st in there:

chart = $chart$
duration = $duration$ min
distance = $distance$ km
pace = $pace$ min/km
calories = $calories$
startTime = $startTime$
userId = $userId$
runId = $runId$

We run nikepub.hs with runhaskell because I haven't started reading the cabal user guide yet:

runhaskell nikepub.hs
chart = http://chart.apis.google.com/chart?chxp=0,0,25,50,75,100|1,50|2,0,25,50,75,100|3,50&chxl=0:|6.05|5.64|5.22|4.81|4.40|1:|pace+(min%2fkm)|2:|0.0|15.2|30.3|45.5|60.7|3:|time+(min)&chxt=y,y,x,x&chs=600x200&chd=e:WdWbW-WMWuV-V-WAVUVPTtTYSOQSPeOFNeMZMJMALdLeLeLdMAM3NQNwOUO6PgQfRTRWR-R0RGQXPfPOOQN8M.MvMnMqM0NHOFO.PNQDQKQIP-P2PvN3M7L-KSIhGsF-FlErEvEbGgIPJiMPOOQvQdQRQZO7NzLzKPJpIwI5IvKcMGMVNANVOFL8KSJUHuG7GWHJI.LHOMQ-UyYZaidBedezegeHdrcnbAavZ9YJWwVPUPRwPKNpKjIAEwCUA6AAAhBnElHTJXNOQ2TZUDVZVJSdQRONNHMSLvMQNCOfPOPLP7PnOaMYK4KJJEJAJ8KNLNMHM6NgOhQbQIP0QPPeO7OGOFOCNSNLLsMINZOSQFSjVpXIYlZzavbhbZbIaJZyZhW8VlTZSVP1NQMXKVJ2JDIrKILANROQPzR4SPT4UHUPURULT.SZSERsQuQhPwPyP3QuRAQiRxSVS9S6SxTRSiSWRgSISWRVRnQWPlPGPCQQPrQKQPQ9SXSETWVEWNUlSwSeP7NuLLI8HjGXF9E8FuHLHXIbJjLOL2MhN-M1MrMPLoK5J6KAJxJzKHKzLnMFMLMALnK5JiIbILIOH.I5KWLwMfNGOJOMO4O6OSOTONODNONEOVNSNZM6MaMfLEL7LCKyKjJOKUJoKXL2NjQuRyU3XQY5bAcMdweWe3fefmhekRpKt1zq6N..&cht=lc&chg=25.0,25.0,3,2
duration = 60.67 min
distance = 10.92 km
pace = 5.56 min/km
calories = 1078.0
startTime = 06/03/09, 11:06:55 PM
userId = 617307368
runId = 672740334

First let's define the NikeRun data:

data NikeRun = NikeRun { 
  extendedData :: [Double],
  calories :: Double
} deriving (Eq,Show)

Later we will add more fields to the definition of NikeRun. Let's also change the charting function chartRun to take a NikeRun instead of [Double]:

chartRun :: Int -> Int -> NikeRun -> String
chartRun w h NikeRun {extendedData = xs, calories = c} = 
  suffix "&chg=25.0,25.0,3,2" $
  chartURL $
  setAxisLabelPositions [[0, 25, 50, 75, 100], [50], [0, 25, 50, 75, 100], [50]] $
  setAxisLabels [(yLabels 4 ylxs), ["pace (min/km)"], 
                          (xLabels 4 xs), ["time (min)"]] $
  setAxisTypes [AxisLeft, AxisLeft, AxisBottom, AxisBottom] $
  setSize w h $
  setData (encodeRunData txs) $
  newLineChart
  where
    ylxs = transformAndAverageRunData xs
    txs = transformAndSmoothRunData xs

Now it's time to fetch the xml and parse it which means using Arrows and the IO monad. We will steal most of the following code from this example.

The utility function nikeRunURL returns the URL of a run given the user ID and the run ID:

nikeRunURL :: Int -> Int -> String
nikeRunURL userId runId = 
   "http://nikeplus.nike.com/nikeplus/" ++
   "v1/services/widget/get_public_run.jsp?userID=" ++ (show userId) ++
   "&id=" ++ (show runId)

and the helper function get does an http get and returns the body of the response as a string. This is an IO operation so the return type is IO String:

get :: URI -> IO String
get uri = do
  eresp <- simpleHTTP (Request uri GET [] "")
  case eresp of
    Left _    -> ioError . userError $ "Failed to get " ++ show uri
    Right res -> return $ rspBody res

Armed with these two helper functions we define retrieveNikeRun:

retrieveNikeRun :: Int -> Int -> IO String
retrieveNikeRun userId runId = do
  case parseURI (nikeRunURL userId runId) of
    Nothing  -> ioError . userError $ "Invalid URL"
    Just uri -> get uri

At this point the fetched data is still in the form of a string. We know we will need a helper function that given a string of comma-separated numbers returns a list of doubles:

readDoubles :: String -> [Double]
readDoubles s = 
  map (\y -> read y::Double) (splitRegex (mkRegex ",") s)

A couple more helpers for dealing with xml:

atTag tag = deep (isElem >>> hasName tag)
text = getChildren >>> getText
textAtTag tag = atTag tag >>> text
parseXML doc = readString [(a_validate,v_0)] doc

The next code section uses the {-# LANGUAGE Arrows, NoMonomorphismRestriction #-} extensions:

parseNikeRun = atTag "sportsData" >>>
  proc x -> do
    cs   <- textAtTag "calories" -< x
    exds <- textAtTag "extendedData" -< x
    returnA -< NikeRun { 
        extendedData = readDoubles exds,
        calories = read cs }

It builds NikeRun data out of xml using the proc and -< syntax sugar.

Finally we collect all this in the getNikeRun function:

getNikeRun :: Int -> Int -> IO NikeRun
getNikeRun userId runId = do
  doc <- retrieveNikeRun userId runId
  let xml = parseXML doc
  nikeRuns <- runX (xml >>> parseNikeRun)
  case nikeRuns of
    [] -> ioError . userError $ "Failed to parse nike run " ++ show runId
    nr:_ -> return nr

Let's try it out in ghci:

do {
   nr <- getNikeRun 617307368 1947965371; 
   return $ chartRun 600 200 nr}