-- | Pull quotes down from yahoo.
module Lambdabot.Plugin.Reference.Ticker (tickerPlugin) where

import Lambdabot.Plugin
import Lambdabot.Util.Browser

import Control.Applicative
import Data.List
import Network.Browser (request)
import Network.HTTP
import Text.Printf

type Ticker = ModuleT () LB

tickerPlugin :: Module ()
tickerPlugin :: Module ()
tickerPlugin = forall st. Module st
newModule
    { moduleCmds :: ModuleT () LB [Command Ticker]
moduleCmds = forall (m :: * -> *) a. Monad m => a -> m a
return
        [ (String -> Command Identity
command String
"ticker")
            { help :: Cmd Ticker ()
help = forall (m :: * -> *). Monad m => String -> Cmd m ()
say String
"ticker symbols.  Look up quotes for symbols"
            , process :: String -> Cmd Ticker ()
process = String -> Cmd Ticker ()
tickerCmd
            }
        , (String -> Command Identity
command String
"bid")
            { help :: Cmd Ticker ()
help = forall (m :: * -> *). Monad m => String -> Cmd m ()
say String
"bid symbols.  Sum up the bid and ask prices for symbols."
            , process :: String -> Cmd Ticker ()
process = String -> Cmd Ticker ()
bidsCmd
            }
        ]
    }

------------------------------------------------------------------------

-- Fetch several ticker quotes and report them.
tickerCmd :: String -> Cmd Ticker ()
tickerCmd :: String -> Cmd Ticker ()
tickerCmd []        = forall (m :: * -> *). Monad m => String -> Cmd m ()
say String
"Empty ticker."
tickerCmd String
tickers = do
    [String]
quotes <- forall (m :: * -> *). MonadLB m => String -> m [String]
getPage forall a b. (a -> b) -> a -> b
$ [String] -> String
tickerUrl forall a b. (a -> b) -> a -> b
$ String -> [String]
words String
tickers
    case [String
x | Just String
x <- forall a b. (a -> b) -> [a] -> [b]
map String -> Maybe String
extractQuote [String]
quotes] of
      []       -> forall (m :: * -> *). Monad m => String -> Cmd m ()
say String
"No Result Found."
      [String]
xs       -> forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ forall (m :: * -> *). Monad m => String -> Cmd m ()
say [String]
xs

-- fetch: s symbol, l1 price, c change with percent, d1 date, t1 time.
tickerUrl :: [String] -> String
tickerUrl :: [String] -> String
tickerUrl [String]
tickers =  String
"http://download.finance.yahoo.com/d/quotes.csv?f=sl1cd1t1&e=.csv&s=" forall a. [a] -> [a] -> [a]
++ String
ts
    where ts :: String
ts = forall a. [a] -> [[a]] -> [a]
intercalate String
"+" forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map String -> String
urlEncode [String]
tickers

-- $ curl "http://download.finance.yahoo.com/d/quotes.csv?f=sl1cd1t1&e=.csv&s=C"
-- "C",23.19,"-0.45 - -1.90%","5/13/2008","1:32pm"
-- "GBPUSD=X",1.9478,"N/A - N/A","5/13/2008","1:52pm"
extractQuote :: String -> Maybe String
extractQuote :: String -> Maybe String
extractQuote = forall {a}. PrintfType a => [String] -> Maybe a
getQuote forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [String]
csv
    where
        getQuote :: [String] -> Maybe a
getQuote [String
sym, String
price, String
change, String
date, String
time] =
            forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall r. PrintfType r => String -> r
printf String
"%s: %s %s@ %s %s" String
sym String
price String
change' String
date String
time
            where change' :: String
change' = case String -> [String]
words String
change of
                              (String
"N/A":[String]
_)    -> String
""
                              [String
ch, String
_, String
pch] -> String
ch forall a. [a] -> [a] -> [a]
++ String
" (" forall a. [a] -> [a] -> [a]
++ String
pch forall a. [a] -> [a] -> [a]
++ String
") "
                              [String]
_            -> String
""
        getQuote [String]
_ = forall a. Maybe a
Nothing

-- Fetch quotes for tickers and sum their bid/ask prices.
bidsCmd :: String -> Cmd Ticker ()
bidsCmd :: String -> Cmd Ticker ()
bidsCmd String
tickers =
    case String -> [String]
words String
tickers of
        [] -> forall (m :: * -> *). Monad m => String -> Cmd m ()
say (forall r. PrintfType r => String -> r
printf String
"Invalid argument '%s'" String
tickers)
        [String]
xs -> forall (m :: * -> *). MonadLB m => [String] -> m String
calcBids [String]
xs forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (m :: * -> *). Monad m => String -> Cmd m ()
say

-- fetch: b bid, a ask
bidsUrl :: [String] -> String
bidsUrl :: [String] -> String
bidsUrl [String]
tickers = String
"http://download.finance.yahoo.com/d/quotes.csv?f=ba&e=.csv&s=" forall a. [a] -> [a] -> [a]
++ String
ts
    where ts :: String
ts = forall a. [a] -> [[a]] -> [a]
intercalate String
"+" forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map String -> String
urlEncode [String]
tickers

getBidAsks :: MonadLB m => [String] -> m [Maybe (Float, Float)]
getBidAsks :: forall (m :: * -> *).
MonadLB m =>
[String] -> m [Maybe (Float, Float)]
getBidAsks [String]
tickers = do
    [String]
xs <- forall (m :: * -> *). MonadLB m => String -> m [String]
getPage forall a b. (a -> b) -> a -> b
$ [String] -> String
bidsUrl [String]
tickers
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map ([String] -> Maybe (Float, Float)
extractPriceforall b c a. (b -> c) -> (a -> b) -> a -> c
.String -> [String]
csv) [String]
xs
    where
        extractPrice :: [String] -> Maybe (Float, Float)
        extractPrice :: [String] -> Maybe (Float, Float)
extractPrice [String
bid,String
ask] = forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 (,) (forall a. Read a => String -> Maybe a
readMaybe String
bid) (forall a. Read a => String -> Maybe a
readMaybe String
ask)
        extractPrice [String]
_         = forall a. Maybe a
Nothing

type AccumVal = Either String (Float, Float)

-- If we have a new bid/ask pair, accumulate it (normally add, but
-- if the ticker starts with '-' then subtract).  If there is no
-- value, make a note that it is an error.
accumOption :: AccumVal -> (String, Maybe (Float, Float)) -> AccumVal
accumOption :: AccumVal -> (String, Maybe (Float, Float)) -> AccumVal
accumOption err :: AccumVal
err@(Left String
_) (String, Maybe (Float, Float))
_ = AccumVal
err
accumOption (Right (Float, Float)
_) (String
ticker, Maybe (Float, Float)
Nothing) = forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ forall r. PrintfType r => String -> r
printf String
"Can't find '%s'" String
ticker
accumOption (Right (Float
a,Float
b)) ((Char
'-':String
_), Just (Float
a',Float
b')) = forall a b. b -> Either a b
Right (Float
aforall a. Num a => a -> a -> a
-Float
b', Float
bforall a. Num a => a -> a -> a
-Float
a')
accumOption (Right (Float
a,Float
b)) (String
_, Just (Float
a',Float
b')) = forall a b. b -> Either a b
Right (Float
aforall a. Num a => a -> a -> a
+Float
a', Float
bforall a. Num a => a -> a -> a
+Float
b')

-- Take a list of tickers which are optionally prefixed with '+' or '-'
-- and add up (or subtract) the bid/ask prices on the based on the prefix.
calcBids :: MonadLB m => [String] -> m String
calcBids :: forall (m :: * -> *). MonadLB m => [String] -> m String
calcBids [String]
ticks = do
    [Maybe (Float, Float)]
xs <- forall (m :: * -> *).
MonadLB m =>
[String] -> m [Maybe (Float, Float)]
getBidAsks forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map String -> String
noPrefix [String]
ticks
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ case forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl AccumVal -> (String, Maybe (Float, Float)) -> AccumVal
accumOption (forall a b. b -> Either a b
Right (Float
0,Float
0)) (forall a b. [a] -> [b] -> [(a, b)]
zip [String]
ticks [Maybe (Float, Float)]
xs) of
        (Left String
err)        -> String
err
        (Right (Float
bid,Float
ask)) -> forall r. PrintfType r => String -> r
printf String
"%s: bid $%.02f, ask $%.02f" String
s Float
bid Float
ask
    where
        s :: String
s = [String] -> String
unwords [String]
ticks
        noPrefix :: String -> String
noPrefix (Char
'+':String
xs) = String
xs
        noPrefix (Char
'-':String
xs) = String
xs
        noPrefix String
xs = String
xs

-- | Fetch a page via HTTP and return its body as a list of lines.
getPage :: MonadLB m => String -> m [String]
getPage :: forall (m :: * -> *). MonadLB m => String -> m [String]
getPage String
url = do
    let cleanup :: String -> [String]
cleanup = (forall a b. (a -> b) -> [a] -> [b]
map (forall a. (a -> Bool) -> [a] -> [a]
filter (forall a. Eq a => a -> a -> Bool
/= Char
'\r'))) forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [String]
lines
    
    forall (m :: * -> *) conn a.
MonadLB m =>
BrowserAction conn a -> m a
browseLB forall a b. (a -> b) -> a -> b
$ do
        (URI
_, Response String
result) <- forall ty.
HStream ty =>
Request ty -> BrowserAction (HandleStream ty) (URI, Response ty)
request (String -> Request_String
getRequest String
url)
        case forall a. Response a -> ResponseCode
rspCode Response String
result of
          (Int
2,Int
0,Int
0) -> forall (m :: * -> *) a. Monad m => a -> m a
return (String -> [String]
cleanup (forall a. Response a -> a
rspBody Response String
result))
          (Int
x,Int
y,Int
z) -> forall (m :: * -> *) a. Monad m => a -> m a
return [String
"Connection error: " forall a. [a] -> [a] -> [a]
++ ([Int
x,Int
y,Int
z] forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall a. Show a => a -> String
show) forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show (forall a. Response a -> String
rspReason Response String
result)]

-- | Return a list of comma-separated values.
-- Quotes allowed in CSV if it's the first character of a field.
csv :: String -> [String]
csv :: String -> [String]
csv (Char
'"':String
xs) = case forall a. (a -> Bool) -> [a] -> ([a], [a])
span (forall a. Eq a => a -> a -> Bool
/= Char
'"') String
xs of
                  (String
word, Char
'"':Char
',':String
rest) -> String
word forall a. a -> [a] -> [a]
: String -> [String]
csv String
rest
                  (String
word, Char
'"':[])       -> String
word forall a. a -> [a] -> [a]
: []
                  (String, String)
_                    -> forall a. HasCallStack => String -> a
error String
"invalid CSV"
csv String
xs = case forall a. (a -> Bool) -> [a] -> ([a], [a])
span (forall a. Eq a => a -> a -> Bool
/= Char
',') String
xs of
             (String
word, Char
',':String
rest) -> String
word forall a. a -> [a] -> [a]
: String -> [String]
csv String
rest
             ([], [])         -> []
             (String
word, [])       -> [String
word]
             (String, String)
_                -> forall a. HasCallStack => String -> a
error String
"shouldn't happen"

-- | Read a value from a string.
readMaybe :: Read a => String -> Maybe a
readMaybe :: forall a. Read a => String -> Maybe a
readMaybe String
x = case forall a. Read a => Int -> ReadS a
readsPrec Int
0 String
x of
                [(a
y,String
"")] -> forall a. a -> Maybe a
Just a
y
                [(a, String)]
_        -> forall a. Maybe a
Nothing