packages feed

nikepub 1.1 → 1.1.1

raw patch · 6 files changed

+536/−1 lines, 6 files

Files

+ Codemanic/Blogging.hs view
@@ -0,0 +1,76 @@+--------------------------------------------------------------------+-- |+-- Module    : Codemanic.Blogging+-- Copyright : (c) Uwe Hoffmann 2009+-- License   : LGPL+--+-- Maintainer: Uwe Hoffmann <uwe@codemanic.com>+-- Stability : provisional+-- Portability: portable+--+-- Publishing to a blog supporting XML-RPC metaWeblog.newPost.+--+--------------------------------------------------------------------++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,+  draft :: Bool+} 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) (not $ draft blogEntry)+  putStrLn "done publishing to blog" +  return ()+  +
+ Codemanic/NikeRuns.hs view
@@ -0,0 +1,234 @@+{-# LANGUAGE Arrows, NoMonomorphismRestriction, DeriveDataTypeable #-}+--------------------------------------------------------------------+-- |+-- Module    : Codemanic.NikeRuns+-- Copyright : (c) Uwe Hoffmann 2009+-- License   : LGPL+--+-- Maintainer: Uwe Hoffmann <uwe@codemanic.com>+-- Stability : provisional+-- Portability: portable+--+-- Functions to fetch and process Nike+ run data.+--+--------------------------------------------------------------------++module Codemanic.NikeRuns +(+ chartNikeRun,+ NikeRun(..),+ getNikeRun,+ getMostRecentNikeRunId,+ renderNikeRun+)+where++import Codemanic.NumericLists+import Codemanic.Weather+import Codemanic.Util+import Graphics.Google.Chart+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 Text.Regex.Posix+import Text.JSON+import Text.JSON.String+import Text.JSON.Types+import Text.XML.HXT.Arrow+import Network.HTTP+import Network.URI+import Text.StringTemplate+import Data.Generics+import Data.Maybe+import System.FilePath++transformAndSmoothRunData :: [Double] -> [Double]+transformAndSmoothRunData  = +  flipInRange .+  (convolve (gaussianKernel 5)) .+  (correlate (movingAverageKernel 6)) .+  (map (\x -> (1.0 / (6.0 * x)))) . +  (filter (/=0)) . +  diff++transformAndAverageRunData :: [Double] -> [Double]+transformAndAverageRunData = +  flipInRange .+  (correlate (movingAverageKernel 6)) .+  (map (\x -> (1.0 / (6.0 * x)))) . +  (filter (/=0)) . +  diff++scaler :: [Double] -> Double -> (Double -> Double)+scaler xs y = (\x -> (x - minV) * y / d)+              where+                minV = minInList xs+                maxV = maxInList xs+                d = maxV - minV++encodeRunData :: [Double] -> ChartData+encodeRunData xs = encodeDataExtended [xs']+                   where+                     sc = scaler xs (fromIntegral 4095)+                     xs' = map (round . sc) xs :: [Int]++sampler :: Int -> Double -> Double -> [Double]+sampler n minV maxV = [(minV + d * (fromIntegral x) / (fromIntegral n)) | x <- [0..n]]+                      where+                        d = maxV - minV++yLabels :: Int -> [Double] -> [String]+yLabels n xs = map (\x -> printf "%.2f" x) (reverse (sampler n (minInList xs) (maxInList xs)))++xLabels :: Int -> [Double] -> [String]+xLabels n xs = map (\x -> printf "%.1f" x)  (sampler n 0.0 duration)+               where+                 duration = (fromIntegral $ length xs) / 6.0++suffix :: String -> (String -> String)+suffix s = (\x -> x ++ s) ++data NikeRun = NikeRun {+  userId :: Int,+  runId :: Int,+  extendedData :: [Double],+  calories :: Double,+  startTime :: UTCTime+} deriving (Eq,Show)++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) ++chartNikeRun :: Int -> Int -> NikeRun -> String+chartNikeRun 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++nikeRunURL :: Int -> Int -> String+nikeRunURL userId runId = +  "http://nikerunning.nike.com/nikeplus/v1/services/widget/get_public_run.jsp?userID=" ++ (show userId) +++  "&id=" ++ (show runId)++nikeRunIdsURL :: Int -> String+nikeRunIdsURL userId =+  "http://nikerunning.nike.com/nikeplus/v1/services/app/get_public_user_data.jsp?id=" ++ (show userId)  ++retrieveNikeRun :: Int -> Int -> IO String+retrieveNikeRun userId runId = do+  case parseURI (nikeRunURL userId runId) of+    Nothing  -> ioError . userError $ "Invalid URL"+    Just uri -> getHttpResponse uri++retrieveNikeRunIds :: Int -> IO String+retrieveNikeRunIds userId = do+  case parseURI (nikeRunIdsURL userId) of+    Nothing   -> ioError . userError $ "Invalid URL"+    Just uri  -> getHttpResponse uri++readDoubles :: String -> [Double]+readDoubles s = map (\y -> read y::Double) (splitRegex (mkRegex ",") s)++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 }++parseNikeRunId = atTag "mostRecentRun" >>>+  proc x -> do+    runId <- getAttrValue "id" -< x+    returnA -< (read runId)::Int++getNikeRun :: Int -> Int -> IO NikeRun+getNikeRun userId runId = do+  doc <- retrieveNikeRun userId runId+  let xml = parseXML doc+  nikeRuns <- runX (xml >>> (parseNikeRun userId runId))+  case nikeRuns of+    [] -> ioError . userError $ "Failed to parse nike run " ++ show runId+    nr:_ -> return nr++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++parseJSONChartSize :: String -> IO (Int, Int)+parseJSONChartSize jsonOptions =+  case runGetJSON readJSObject jsonOptions of+    Right x -> do+      let jo = fromJSONObject x+      return (getKey "width" jo, getKey "height" jo)+      where+        getKey k j = fromJSONRational $ fromJust $ lookup k j+    Left _ -> return (0, 0)++extractChartSize :: String -> String -> IO (Int, Int)+extractChartSize templates template = do+  let chartOptionsPattern = "\\$\\!chartOptions(\\{.+\\})\\!\\$"+  contents <- readFile (templates </> (addExtension template "st"))+  let (_, _, _, groups) = (contents =~ chartOptionsPattern :: (String, String, String, [String]))+  if ((length groups) > 0) +    then parseJSONChartSize $ head groups+    else return (0, 0)++renderNikeRun :: String -> String -> NikeRun -> String -> Maybe Weather -> IO String+renderNikeRun templates template nr message weather = do+  dirs <- directoryGroup templates+  (w, h) <- extractChartSize templates template+  let chart = chartNikeRun w h nr+  let tpl = fromJust $ getStringTemplate template dirs+  timeZone <- getCurrentTimeZone+  let localTime = utcToLocalTime timeZone (startTime nr)+  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 localTime) $+                    setAttribute "message" message $+                    setAttribute "userId" (userId nr) $+                    setAttribute "runId" (runId nr) $+                    setAttribute "weather" (renderWeather weather) tpl+  where+    renderDouble :: Double -> String+    renderDouble x = (printf "%.2f" x)::String+    renderTime :: LocalTime -> String+    renderTime t = formatTime defaultTimeLocale "%x, %r" t+    renderWeather :: Maybe Weather -> String+    renderWeather (Just weather) = "Temperature " ++ (temperature weather) ++ +         ", Wind " ++ (wind weather) ++ ", " ++ (humidity weather) ++ " humidity"+    renderWeather Nothing = ""++
+ Codemanic/NumericLists.hs view
@@ -0,0 +1,84 @@+--------------------------------------------------------------------+-- |+-- Module    : Codemanic.NumericLists+-- Copyright : (c) Uwe Hoffmann 2009+-- License   : LGPL+--+-- Maintainer: Uwe Hoffmann <uwe@codemanic.com>+-- Stability : provisional+-- Portability: portable+--+-- Provides useful functions for processing numeric lists.+--+--------------------------------------------------------------------++module Codemanic.NumericLists+(+ correlate,+ convolve,+ gaussianKernel,+ movingAverageKernel,+ scale,+ diff,+ minInList,+ maxInList,+ pad,+ padPeriodic,+ flipInRange+) +where++kernelOp :: (Num a) => [(a, a)] -> a+kernelOp = (foldr (+) 0) . (map (uncurry (*)))++correlate :: (Num a) => [a] -> [a] -> [a]+correlate ks xs | length xs < length ks  = []+correlate ks xs = kernelOp (zip ks xs) : correlate ks (tail xs)++convolve :: (Num a) => [a] -> [a] -> [a]+convolve ks xs = correlate (reverse ks) xs++gaussianKernel :: (Floating a) => Int -> [a]+gaussianKernel n = +  map (g . fromIntegral) [(-n)..n]+  where+     y = fromIntegral n+     g x = (exp (-(x^2) / (2 * y^2))) / ((y * sqrt (2 * pi)))++movingAverageKernel :: (Floating a) => Int -> [a]+movingAverageKernel n = take n (repeat (1.0 / (fromIntegral n)))++scale :: (Num a) => a -> [a] -> [a]+scale s xs = map (\x -> x * s) xs++diff :: (Num a) => [a] -> [a]+diff [] = []+diff xs = zipWith (-) (tail xs) xs++minInList :: (Ord a) => [a] -> a+minInList = foldr1 min++maxInList :: (Ord a) => [a] -> a+maxInList = foldr1 max++pad :: (Num a) => Int -> a -> [a] -> [a]+pad n p [] = take n (repeat p)+pad n p xs = xs ++ (take k (repeat p))+             where +               l = length xs+               k = (n - (l `mod` n)) `mod` n++padPeriodic :: (Num a) => Int -> [a] -> [a]+padPeriodic _ [] = []+padPeriodic n xs = xs ++ (take k (foldr (++) [] (take m (repeat xs))))+                   where+                     l = length xs+                     k = (n - (l `mod` n)) `mod` n+                     m = (k `div` l) + 1 ++flipInRange :: (Ord a, Num a) => [a] -> [a]+flipInRange [] = []+flipInRange xs = map (\x -> minV + maxV - x) xs+                 where+                   minV = minInList xs+                   maxV = maxInList xs
+ Codemanic/Util.hs view
@@ -0,0 +1,64 @@+{-# LANGUAGE Arrows, NoMonomorphismRestriction, DeriveDataTypeable #-}+--------------------------------------------------------------------+-- |+-- Module    : Codemanic.Util+-- Copyright : (c) Uwe Hoffmann 2009+-- License   : LGPL+--+-- Maintainer: Uwe Hoffmann <uwe@codemanic.com>+-- Stability : provisional+-- Portability: portable+--+-- Small utility functions shared between other modules of nikepub.+--+--------------------------------------------------------------------++module Codemanic.Util+(+ getHttpResponse,+ atTag,+ text,+ textAtTag,+ parseXML,+ fromJSONRational,+ fromJSONObject+)+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 Text.XML.HXT.Arrow+import Text.JSON+import Text.JSON.String+import Text.JSON.Types+import Network.HTTP+import Network.URI+import Data.Generics+import Data.Maybe++getHttpResponse :: URI -> IO String+getHttpResponse uri = do+  eresp <- simpleHTTP (Request uri GET [] "")+  case eresp of+    Left _    -> ioError . userError $ "Failed to get " ++ show uri+    Right res -> return $ rspBody res++atTag tag = deep (isElem >>> hasName tag)+text = getChildren >>> getText+textAtTag tag = atTag tag >>> text++parseXML doc = readString [(a_validate,v_0)] doc++fromJSONRational :: JSValue -> Int+fromJSONRational (JSRational _ n) = fromInteger . round $ n++fromJSONObject :: JSValue -> [(String,JSValue)]+fromJSONObject (JSObject o) = fromJSObject o+
+ Codemanic/Weather.hs view
@@ -0,0 +1,72 @@+{-# LANGUAGE Arrows, NoMonomorphismRestriction, DeriveDataTypeable #-}+--------------------------------------------------------------------+-- |+-- Module    : Codemanic.Weather+-- Copyright : (c) Uwe Hoffmann 2009+-- License   : LGPL+--+-- Maintainer: Uwe Hoffmann <uwe@codemanic.com>+-- Stability : provisional+-- Portability: portable+--+-- Function to fetch current weather given an airport code.+--+--------------------------------------------------------------------++module Codemanic.Weather+(+ Weather(..),+ getCurrentWeather+)+where++import Codemanic.Util+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 Text.XML.HXT.Arrow+import Network.HTTP+import Network.URI+import Data.Generics+import Data.Maybe++data Weather = Weather {+  temperature :: String,+  wind :: String,+  humidity :: String+} deriving (Eq,Show)++weatherURL :: String -> String+weatherURL airportCode = +  "http://api.wunderground.com/auto/wui/geo/WXCurrentObXML/index.xml?query=" ++ airportCode++retrieveWeather :: String -> IO String+retrieveWeather airportCode = do+  case parseURI (weatherURL airportCode) of+    Nothing  -> ioError . userError $ "Invalid URL"+    Just uri -> getHttpResponse uri++parseWeather = atTag "current_observation" >>>+  proc x -> do+    temp   <- textAtTag "temperature_string" -< x+    wnd <- textAtTag "wind_string" -< x+    hum <- textAtTag "relative_humidity" -< x+    returnA -< Weather {+        temperature = temp,+        wind = wnd,+        humidity = hum }++getCurrentWeather :: String -> IO (Maybe Weather)+getCurrentWeather airportCode = do+  doc <- retrieveWeather airportCode +  let xml = parseXML doc+  ws <- runX (xml >>> parseWeather)+  case ws of+    [] -> return Nothing+    w:_ -> return (Just w)
nikepub.cabal view
@@ -1,5 +1,5 @@ Name:                nikepub-Version:             1.1+Version:             1.1.1 Category:            Web Synopsis:            Command line utility publishes Nike+ runs on blogs and Twitter Description:         Simple commandline program that given a Nike+ user id will fetch the@@ -19,6 +19,11 @@                      templates/twitter_status.st Executable nikepub   Main-is:           nikepub.hs+  Other-Modules:     Codemanic.Util,+                     Codemanic.NumericLists,+                     Codemanic.Blogging,+                     Codemanic.Weather,+                     Codemanic.NikeRuns   Build-Depends:     haskell98,                      base >= 4.1.0.0 && < 5,                      containers >= 0.2.0.1,