pubsub-0.10: examples/Feeder.hs

--------------------------------------------------------------------
-- |
-- Module    : Feeder
-- Copyright : (c) Sigbjorn Finne, 2009
-- License   : BSD3
--
-- Maintainer: Sigbjorn Finne <sof@forkIO.com>
-- Stability : provisional
-- Portability:
--
--------------------------------------------------------------------
module Main(main) where

import Network.Connection
import Web.Utils.HTTP

import Web.Types
import Web.PubSub.Types
import Web.PubSub

import System.IO
import System.Environment
import System.Exit
import Control.Concurrent

import Web.Utils.Fetch
import Text.Atom.Feed

-- where we will be listening for incoming pubsub events; sub and
-- feed updates.
-- [If you are using the fastcgi proxy script pubsub.fcgi,
--  it needs to be changed also if you modify the location below.]
servOptions :: ServerOptions
servOptions =
  Network.Connection.serverOpts{servInterface=Just "localhost"
                               ,servPort=Just 8080
			       }


-- where the PubSubHub protocol will callback:
endpoint="http://hs-pubsub.example.com/pubsub.fcgi"

-- I _think_ you can leave out the 'method' bit...
sub_callback = endpoint++"?method=notify"

-- if you need to authenticate with the hub, config this
-- (superfeedr requires it.)
authUser :: Maybe AuthUser
authUser = Nothing
--authUser = Just nullAuthUser{authUserName="bobo", authUserPass="alice"}



-- URL of hub to use
sub_hub :: URLString
--sub_hub = "http://pubsubhubbub.appspot.com/"
sub_hub = "http://superfeedr.com/hubbub"


type Handler = Request -> IO Response

type MethodTable = [(String, Handler)]

createServer :: IO Server
createServer = do
  serv <- newServer servOptions
  return serv

startServer :: Bool -> MethodTable -> Server -> IO ()
startServer oneShot tab serv 
 | oneShot   = forkIO (acceptor serv) >> return ()
 | otherwise = acceptor serv
 where
   acceptor s = do
     (c,_) <- acceptConnection s
     forkIO (handleConnection tab c)
     if oneShot
      then return ()
      else acceptor s

handleConnection :: MethodTable -> Connection -> IO ()
handleConnection tab c = do
  ls <- hGetLine (coHandle c)
  case jsonRequest ls of
    Nothing -> do
      hPutStrLn (coHandle c) (jsonResponse errorResponse)
    Just req ->
      case lookup "method" (reqVars req) >>= \ m -> lookup m tab of
        Nothing -> do
	  case tab of
	    ((_,r):_) -> do
	      rsp <- r req
    	      hPutStrLn (coHandle c) (jsonResponse rsp)
	    _ -> hPutStrLn (coHandle c) (jsonResponse errorResponse)
	Just hdlr -> do
	  rsp <- hdlr req
	  hPutStrLn (coHandle c) (jsonResponse rsp)
  finishSession c

finishSession :: Connection -> IO ()
finishSession c = Prelude.catch (closeConnection c) (\ _ -> return ())

main :: IO ()
main = do
  ls <- getArgs
  top <-
    case ls of
      (t:_) -> return t
      _ -> do
        putStrLn "Usage: feeder <topic URL>"
	putStrLn "(foo$ feeder 'http://search.twitter.com/search.atom?q=opera' )"
	putStrLn "[Hence, not adding new subs but listening to existing ones..]"
	return ""
  serv <- createServer
  (subStart, tab) <- setupSubscription top
  startServer True tab serv
  Prelude.catch subStart (\ e -> print e >> hFlush stdout >> return ())
  startServer False tab serv

setupSubscription :: String -> IO (IO (), MethodTable)
setupSubscription top = do
  let sub = Subscribe{ subMode     = True
                     , subCallback = sub_callback
		     , subTopic    = top
		     , subVerify   = [VerifySync True]
		     , subVerifyToken = Nothing
		     , subLeaseSecs  = Nothing
		     }
  return (if null top then return () else subscribe authUser sub_hub sub, 
    [ ("notify", handleCalls sub)
    ])

handleCalls :: Subscribe -> Handler
handleCalls s req = do
   case lookup "hub.mode" (reqVars req) of
    Just "subscribe" -> do
--       hPutStrLn stdout "subscribe-verify.."
--       hPutStrLn stdout (show $ reqVars req)
       let r = handleVerify s req
--       hPutStrLn stdout (respBody r)
       return r
    Just "publish"   -> handleNewContent req
    _ -> do
      case lookup "method" (reqVars req) of
        Just "notify" | reqMethod req == "POST" -> handleNewContent req
	_ -> do
	  case lookup "Referer" (reqHeaders req) of
	    Just "superfeedr.com" -> return superfeedrResp
	    _ -> handleNewContent req
 where
  handleNewContent req = do
    (r, mbf) <- notifyContent req
    case mbf of
      Just f -> do
       putStrLn ("new entries - " ++ feedId f)
       mapM_ (\ e -> putStrLn (txtToString $ entryTitle e)) (feedEntries f)
      _ -> return ()
    return r

superfeedrResp :: Response
superfeedrResp = errorResponse{respStatus=200,respBody="736f66333639"}

errorResponse :: Response
errorResponse =
  Response{  respStatus  = 404
          ,  respHeaders = []
	  ,  respBody    = ""
	  }