module Web.PubSub
( getHubLink
, discover
, subscribe
, getContent
, notifyPublish
, 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
True
False
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
[]
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
False
topic
[("X-Hub-Subscribers", show (fromMaybe 1 mbSubs))]
return (parseXMLDoc bo >>= elementFeed)
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
[]
bod
return ()
where
req =
addBodyNameValue "hub.mode" "publish" $
addBodyNameValue "hub.url" topic $
newPostRequest ""
handleVerify :: Subscribe
-> Request
-> Response
handleVerify subVer req
| Just (if subMode subVer then "subscribe" else "unsubscribe") == hub_mode &&
isJust hub_chal &&
hub_tok == subVerifyToken subVer = resp{respStatus=200,respBody=fromMaybe "" 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 = []
, respBody = ""
}
trim :: String -> String
trim xs = trimR (trimL xs)
trimL :: String -> String
trimL xs = dropWhile isSpace xs
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]