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

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

-- Fetch several ticker quotes and report them.
tickerCmd :: String -> Cmd Ticker ()
tickerCmd :: String -> Cmd (ModuleT () LB) ()
tickerCmd []        = String -> Cmd (ModuleT () LB) ()
forall (m :: * -> *). Monad m => String -> Cmd m ()
say String
"Empty ticker."
tickerCmd String
tickers = do
    [String]
quotes <- String -> Cmd (ModuleT () LB) [String]
forall (m :: * -> *). MonadLB m => String -> m [String]
getPage (String -> Cmd (ModuleT () LB) [String])
-> String -> Cmd (ModuleT () LB) [String]
forall a b. (a -> b) -> a -> b
$ [String] -> String
tickerUrl ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ String -> [String]
words String
tickers
    case [String
x | Just String
x <- (String -> Maybe String) -> [String] -> [Maybe String]
forall a b. (a -> b) -> [a] -> [b]
map String -> Maybe String
extractQuote [String]
quotes] of
      []       -> String -> Cmd (ModuleT () LB) ()
forall (m :: * -> *). Monad m => String -> Cmd m ()
say String
"No Result Found."
      [String]
xs       -> (String -> Cmd (ModuleT () LB) ())
-> [String] -> Cmd (ModuleT () LB) ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ String -> Cmd (ModuleT () LB) ()
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=" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
ts
    where ts :: String
ts = String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
"+" ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ (String -> String) -> [String] -> [String]
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 = [String] -> Maybe String
forall a. PrintfType a => [String] -> Maybe a
getQuote ([String] -> Maybe String)
-> (String -> [String]) -> String -> Maybe String
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] =
            a -> Maybe a
forall a. a -> Maybe a
Just (a -> Maybe a) -> a -> Maybe a
forall a b. (a -> b) -> a -> b
$ String -> String -> String -> String -> String -> String -> a
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 String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" (" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
pch String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
") "
                              [String]
_            -> String
""
        getQuote [String]
_ = Maybe a
forall a. Maybe a
Nothing

-- Fetch quotes for tickers and sum their bid/ask prices.
bidsCmd :: String -> Cmd Ticker ()
bidsCmd :: String -> Cmd (ModuleT () LB) ()
bidsCmd String
tickers =
    case String -> [String]
words String
tickers of
        [] -> String -> Cmd (ModuleT () LB) ()
forall (m :: * -> *). Monad m => String -> Cmd m ()
say (String -> String -> String
forall r. PrintfType r => String -> r
printf String
"Invalid argument '%s'" String
tickers)
        [String]
xs -> [String] -> Cmd (ModuleT () LB) String
forall (m :: * -> *). MonadLB m => [String] -> m String
calcBids [String]
xs Cmd (ModuleT () LB) String
-> (String -> Cmd (ModuleT () LB) ()) -> Cmd (ModuleT () LB) ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= String -> Cmd (ModuleT () LB) ()
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=" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
ts
    where ts :: String
ts = String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
"+" ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ (String -> String) -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map String -> String
urlEncode [String]
tickers

getBidAsks :: MonadLB m => [String] -> m [Maybe (Float, Float)]
getBidAsks :: [String] -> m [Maybe (Float, Float)]
getBidAsks [String]
tickers = do
    [String]
xs <- String -> m [String]
forall (m :: * -> *). MonadLB m => String -> m [String]
getPage (String -> m [String]) -> String -> m [String]
forall a b. (a -> b) -> a -> b
$ [String] -> String
bidsUrl [String]
tickers
    [Maybe (Float, Float)] -> m [Maybe (Float, Float)]
forall (m :: * -> *) a. Monad m => a -> m a
return ([Maybe (Float, Float)] -> m [Maybe (Float, Float)])
-> [Maybe (Float, Float)] -> m [Maybe (Float, Float)]
forall a b. (a -> b) -> a -> b
$ (String -> Maybe (Float, Float))
-> [String] -> [Maybe (Float, Float)]
forall a b. (a -> b) -> [a] -> [b]
map ([String] -> Maybe (Float, Float)
extractPrice([String] -> Maybe (Float, Float))
-> (String -> [String]) -> String -> Maybe (Float, Float)
forall 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] = (Float -> Float -> (Float, Float))
-> Maybe Float -> Maybe Float -> Maybe (Float, Float)
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 (,) (String -> Maybe Float
forall a. Read a => String -> Maybe a
readMaybe String
bid) (String -> Maybe Float
forall a. Read a => String -> Maybe a
readMaybe String
ask)
        extractPrice [String]
_         = Maybe (Float, Float)
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) = String -> AccumVal
forall a b. a -> Either a b
Left (String -> AccumVal) -> String -> AccumVal
forall a b. (a -> b) -> a -> b
$ String -> String -> String
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')) = (Float, Float) -> AccumVal
forall a b. b -> Either a b
Right (Float
aFloat -> Float -> Float
forall a. Num a => a -> a -> a
-Float
b', Float
bFloat -> Float -> Float
forall a. Num a => a -> a -> a
-Float
a')
accumOption (Right (Float
a,Float
b)) (String
_, Just (Float
a',Float
b')) = (Float, Float) -> AccumVal
forall a b. b -> Either a b
Right (Float
aFloat -> Float -> Float
forall a. Num a => a -> a -> a
+Float
a', Float
bFloat -> Float -> Float
forall 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 :: [String] -> m String
calcBids [String]
ticks = do
    [Maybe (Float, Float)]
xs <- [String] -> m [Maybe (Float, Float)]
forall (m :: * -> *).
MonadLB m =>
[String] -> m [Maybe (Float, Float)]
getBidAsks ([String] -> m [Maybe (Float, Float)])
-> [String] -> m [Maybe (Float, Float)]
forall a b. (a -> b) -> a -> b
$ (String -> String) -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map String -> String
noPrefix [String]
ticks
    String -> m String
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> m String) -> String -> m String
forall a b. (a -> b) -> a -> b
$ case (AccumVal -> (String, Maybe (Float, Float)) -> AccumVal)
-> AccumVal -> [(String, Maybe (Float, Float))] -> AccumVal
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl AccumVal -> (String, Maybe (Float, Float)) -> AccumVal
accumOption ((Float, Float) -> AccumVal
forall a b. b -> Either a b
Right (Float
0,Float
0)) ([String]
-> [Maybe (Float, Float)] -> [(String, Maybe (Float, Float))]
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)) -> String -> String -> Float -> Float -> String
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 :: String -> m [String]
getPage String
url = do
    let cleanup :: String -> [String]
cleanup = ((String -> String) -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map ((Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
filter (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'\r'))) ([String] -> [String])
-> (String -> [String]) -> String -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [String]
lines
    
    BrowserAction (HandleStream String) [String] -> m [String]
forall (m :: * -> *) conn a.
MonadLB m =>
BrowserAction conn a -> m a
browseLB (BrowserAction (HandleStream String) [String] -> m [String])
-> BrowserAction (HandleStream String) [String] -> m [String]
forall a b. (a -> b) -> a -> b
$ do
        (URI
_, Response String
result) <- Request String
-> BrowserAction (HandleStream String) (URI, Response String)
forall ty.
HStream ty =>
Request ty -> BrowserAction (HandleStream ty) (URI, Response ty)
request (String -> Request String
getRequest String
url)
        case Response String -> ResponseCode
forall a. Response a -> ResponseCode
rspCode Response String
result of
          (Int
2,Int
0,Int
0) -> [String] -> BrowserAction (HandleStream String) [String]
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> [String]
cleanup (Response String -> String
forall a. Response a -> a
rspBody Response String
result))
          (Int
x,Int
y,Int
z) -> [String] -> BrowserAction (HandleStream String) [String]
forall (m :: * -> *) a. Monad m => a -> m a
return [String
"Connection error: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ ([Int
x,Int
y,Int
z] [Int] -> (Int -> String) -> String
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Int -> String
forall a. Show a => a -> String
show) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
forall a. Show a => a -> String
show (Response String -> String
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 (Char -> Bool) -> String -> (String, String)
forall a. (a -> Bool) -> [a] -> ([a], [a])
span (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'"') String
xs of
                  (String
word, Char
'"':Char
',':String
rest) -> String
word String -> [String] -> [String]
forall a. a -> [a] -> [a]
: String -> [String]
csv String
rest
                  (String
word, Char
'"':[])       -> String
word String -> [String] -> [String]
forall a. a -> [a] -> [a]
: []
                  (String, String)
_                    -> String -> [String]
forall a. HasCallStack => String -> a
error String
"invalid CSV"
csv String
xs = case (Char -> Bool) -> String -> (String, String)
forall a. (a -> Bool) -> [a] -> ([a], [a])
span (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
',') String
xs of
             (String
word, Char
',':String
rest) -> String
word String -> [String] -> [String]
forall a. a -> [a] -> [a]
: String -> [String]
csv String
rest
             ([], [])         -> []
             (String
word, [])       -> [String
word]
             (String, String)
_                -> 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 :: String -> Maybe a
readMaybe String
x = case Int -> ReadS a
forall a. Read a => Int -> ReadS a
readsPrec Int
0 String
x of
                [(a
y,String
"")] -> a -> Maybe a
forall a. a -> Maybe a
Just a
y
                [(a, String)]
_        -> Maybe a
forall a. Maybe a
Nothing