--------------------------------------------------------------------
-- |
-- Module    : Web.PubSub
-- Copyright : (c) Sigbjorn Finne, 2009
-- License   : BSD3
--
-- Maintainer: Sigbjorn Finne <sof@forkIO.com>
-- Stability : provisional
-- Portability:
--
-- Interacting with hubs implementing the PubSubHub protocol
-- for publish-subscribing to URL change notifications over HTTP.
-- Nice and simple (the protocol, that is :-) )
--
--------------------------------------------------------------------
module Web.PubSub
       ( getHubLink
       , discover
       , subscribe
       , getContent
       , notifyPublish

           -- callbacks / incoming requests from hub:
       , notifyContent
       , handleVerify

       ) where

import Text.Atom.Feed
import Text.Atom.Feed.Import
import Web.PubSub.Types

import Text.XML.Light
import Web.Utils.Fetch
import Web.Utils.Post
import Web.Types
import Web.Utils.HTTP

import Data.Char
import Data.Maybe
import Data.List ( isPrefixOf )

getHubLink :: Feed -> Maybe HubLink
getHubLink f =
  case filter isHub (feedLinks f) of
    [] -> Nothing
    (l:_) -> Just HubLink{ linkURL = show (linkHref l) }
 where
  isHub Link{linkRel=Just (Right "hub")} = True
  isHub Link{linkRel=Just (Left "hub")} = True
  isHub _ = False

discover :: URLString -> IO (Maybe Feed)
discover u = do
  (_,bo) <- readUserContentsURL Nothing{-no auth-}
                                True{-do redir-}
				False{-is GET-}
				u
				[]
  case parseXMLDoc bo >>= elementFeed of
    Nothing -> return Nothing
    Just f  -> return (Just f)

  
subscribe :: Maybe AuthUser
          -> URLString
          -> Subscribe
	  -> IO ()
subscribe mbUser hub s = do
  (_q,hs,bod) <- toRequest req (Just PostWWWForm)
  postContentsURL mbUser
                  hub
		  hs
		  [{-no cookies either-}]
		  bod
  return ()
 where
  req =
   foldr (\ (x,y) acc -> addBodyNameValue x y acc) (newPostRequest "") vals
  
  vals =
     [ ("hub.mode", if subMode s then "subscribe" else "unsubscribe")
     , ("hub.callback", subCallback s)
     , ("hub.topic", subTopic s)
     ] ++ map (\ (VerifySync v) -> ("hub.verify", if v then "sync" else "async")) (subVerify s)
     ++ fromMaybe [] (fmap (\ t -> [("hub.token", t)]) (subVerifyToken s))
     ++ fromMaybe [] (fmap (\ t -> [("hub.lease_seconds", show t)]) (subLeaseSecs s))

getContent :: URLString
           -> Maybe Integer
	   -> IO (Maybe Feed)
getContent topic mbSubs = do
  (hs,bo) <- readUserContentsURL Nothing
                                 True{-do redir-}
                                 False{-is GET-}
				 topic
				 [("X-Hub-Subscribers", show (fromMaybe 1 mbSubs))]
  return (parseXMLDoc bo >>= elementFeed)

-- | Handle incoming POST notification of updated topic content. Checks to
-- see that the MIME type is indeed @atom@. Returns the feed along with
-- status code (and headers) to respond with. A result of @Nothing@ should
-- be interpreted as an error and responded to accordingly.
notifyContent :: Request
	      -> IO (Response, Maybe Feed)
notifyContent req =
  let
   hdrs = reqHeaders req
   body = reqBody req
   processIt = do
    let mbf = parseXMLDoc body >>= elementFeed
    return ( resp{respStatus  = if isJust mbf then 200 else 404}, mbf)
  in
  case filter isContentType hdrs of
    ((_,y):_) | not (null body) ->
      case trim y of
        "application/atom+xml" -> processIt
	_ | "<?xml" `isPrefixOf` body -> processIt
	_ -> return ( resp, Nothing)
    _ ->
      case lookup "hub.url" (reqVars req) of
         Just u -> getContent u Nothing >>= \ v -> return (sresp,v)
	 _ | "<?xml" `isPrefixOf` body -> processIt
	 _ -> return (resp, Nothing)

 where
   sresp = resp{respStatus=200}
   resp = Response{ respStatus  = 404
	          , respHeaders = [("X-Hub-On-Behalf-Of", "10")]
		  , respBody    = ""
		  }
   isContentType (x,_) = map toLower x == "content-type"

notifyPublish :: Maybe AuthUser -> URLString -> URLString -> IO ()
notifyPublish mbUser hub topic = do
  (_q,hs,bod) <- toRequest req (Just PostWWWForm)
  postContentsURL mbUser
                  hub
		  hs
		  [{-no cookies either-}]
		  bod
  return ()
 where
  req =
   addBodyNameValue "hub.mode" "publish" $
    addBodyNameValue "hub.url" topic $
      newPostRequest ""

-- | In response to a (un)subscription POST request, a hub will
-- do a POSTback to verify the request. The 'Subscribe' argument
-- is the same as the one used to issue the original (un)subscription
-- request.
handleVerify :: Subscribe
             -> Request
             -> Response
handleVerify subVer req
 | Just (if subMode subVer then "subscribe" else "unsubscribe") == hub_mode &&
--   Just (subTopic subVer) == hub_topic &&
   isJust hub_chal &&
   hub_tok == subVerifyToken subVer = resp{respStatus=200,respBody=fromMaybe "" hub_chal}
       -- (fmap (\ x -> ("hub.challenge="++x)) hub_chal)}
 | otherwise = resp
 where
  vars      = reqVars req
  hub_mode  = getField "hub.mode"
  hub_topic = getField "hub.topic"
  hub_chal  = getField "hub.challenge"
  hub_leas  = getField "hub.lease_seconds"
  hub_tok   = getField "hub.verify_token"

  getField x
   = case filter ((x==).fst) vars of { [] -> Nothing; ((_,y):_) -> Just y}

  resp = Response{ respStatus  = 404
	         , respHeaders = [] -- ("Content-Type", "text/plain")]
		 , respBody    = ""
		 }


-- yeah, doesn't belong here.

-- | @trim str@ removes leading and trailing whitespace from @str@.
trim :: String -> String
trim xs = trimR (trimL xs)
   
-- | @trimL str@ removes leading whitespace (as defined by 'Data.Char.isSpace')
-- from @str@.
trimL :: String -> String
trimL xs = dropWhile isSpace xs

-- | @trimL str@ removes trailing whitespace (as defined by 'Data.Char.isSpace')
-- from @str@.
trimR :: String -> String
trimR str = fromMaybe "" $ foldr trimIt Nothing str
 where
  trimIt x (Just xs) = Just (x:xs)
  trimIt x Nothing   
   | isSpace x = Nothing
   | otherwise = Just [x]