diff --git a/Codemanic/Blogging.hs b/Codemanic/Blogging.hs new file mode 100644 --- /dev/null +++ b/Codemanic/Blogging.hs @@ -0,0 +1,76 @@ +-------------------------------------------------------------------- +-- | +-- Module : Codemanic.Blogging +-- Copyright : (c) Uwe Hoffmann 2009 +-- License : LGPL +-- +-- Maintainer: Uwe Hoffmann +-- 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 () + + diff --git a/Codemanic/NikeRuns.hs b/Codemanic/NikeRuns.hs new file mode 100644 --- /dev/null +++ b/Codemanic/NikeRuns.hs @@ -0,0 +1,234 @@ +{-# LANGUAGE Arrows, NoMonomorphismRestriction, DeriveDataTypeable #-} +-------------------------------------------------------------------- +-- | +-- Module : Codemanic.NikeRuns +-- Copyright : (c) Uwe Hoffmann 2009 +-- License : LGPL +-- +-- Maintainer: Uwe Hoffmann +-- 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 = "" + + diff --git a/Codemanic/NumericLists.hs b/Codemanic/NumericLists.hs new file mode 100644 --- /dev/null +++ b/Codemanic/NumericLists.hs @@ -0,0 +1,84 @@ +-------------------------------------------------------------------- +-- | +-- Module : Codemanic.NumericLists +-- Copyright : (c) Uwe Hoffmann 2009 +-- License : LGPL +-- +-- Maintainer: Uwe Hoffmann +-- 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 diff --git a/Codemanic/Util.hs b/Codemanic/Util.hs new file mode 100644 --- /dev/null +++ b/Codemanic/Util.hs @@ -0,0 +1,64 @@ +{-# LANGUAGE Arrows, NoMonomorphismRestriction, DeriveDataTypeable #-} +-------------------------------------------------------------------- +-- | +-- Module : Codemanic.Util +-- Copyright : (c) Uwe Hoffmann 2009 +-- License : LGPL +-- +-- Maintainer: Uwe Hoffmann +-- 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 + diff --git a/Codemanic/Weather.hs b/Codemanic/Weather.hs new file mode 100644 --- /dev/null +++ b/Codemanic/Weather.hs @@ -0,0 +1,72 @@ +{-# LANGUAGE Arrows, NoMonomorphismRestriction, DeriveDataTypeable #-} +-------------------------------------------------------------------- +-- | +-- Module : Codemanic.Weather +-- Copyright : (c) Uwe Hoffmann 2009 +-- License : LGPL +-- +-- Maintainer: Uwe Hoffmann +-- 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) diff --git a/nikepub.cabal b/nikepub.cabal --- a/nikepub.cabal +++ b/nikepub.cabal @@ -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,