diff --git a/CHANGES b/CHANGES new file mode 100644 --- /dev/null +++ b/CHANGES @@ -0,0 +1,3 @@ +Version 0.10: + + Initial release of PubSubHub Haskell package. diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,27 @@ +Copyright (c) Sigbjorn Finne, 2008. + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions +are met: +1. Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. +2. Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. +3. Neither the name of the author nor the names of his contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND +ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE +IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE +FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS +OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) +HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT +LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY +OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF +SUCH DAMAGE. diff --git a/Network/Connection.hs b/Network/Connection.hs new file mode 100644 --- /dev/null +++ b/Network/Connection.hs @@ -0,0 +1,252 @@ +-------------------------------------------------------------------- +-- | +-- Module : Network.Connection +-- Description : Networking, at a higher-level. +-- Copyright : (c) Sigbjorn Finne, 2009 +-- License : BSD3 +-- +-- Maintainer : Sigbjorn Finne +-- Stability : provisional +-- Portability : portable +-- +-- Taking care of the details of creating & tearing down network connections, +-- both client and server connections. +-- +-------------------------------------------------------------------- +module Network.Connection + ( ClientOptions(..) + , clientOpts + + , Connection(..) + , ConnectionOptions(..) + , defaultConnectionOptions + + , clientConnection + + , Server + , ServerOptions(..) + , serverOpts + + , newServer + + , acceptConnection + , closeConnection + , closeSession + + ) where + +import Network.Socket as S hiding ( connect ) +import qualified Network.Socket as S ( connect ) +import Network.BSD as BSD ( HostEntry, getHostByName, hostAddresses ) +import Control.Concurrent +import System.IO + +import Data.Maybe + +data Connection + = Connection + { coHandle :: Handle + , coSocket :: Socket + , coServer :: Maybe Server + } + +data ConnectionOptions + = ConnectionOptions + { connMode :: Bool -- False => connectionless. + , ioMode :: IOMode + , bufMode :: BufferMode + } + +defaultConnectionOptions :: ConnectionOptions +defaultConnectionOptions = ConnectionOptions + { connMode = True + , ioMode = ReadWriteMode + , bufMode = LineBuffering + } + +data ClientOptions + = ClientOptions + { host :: String + , port :: Maybe PortNumber + , cliProto :: Maybe ProtocolNumber + , localEnd :: Maybe PortNumber + , cliOpts :: ConnectionOptions + } + +clientOpts :: ClientOptions +clientOpts = ClientOptions + { host = "" + , port = Nothing + , cliProto = Nothing + , localEnd = Nothing + , cliOpts = defaultConnectionOptions + } + +-- | @clientConnection opts@ tries to open up a connection +-- as requested by the 'ClientOptions' @opts@. If successful, returns +-- a @Handle@ and its underlying @Socket@. The latter is only meant +-- to be used when doing orderly & draining shutdowns. All I/O is +-- expected to happen over the @Handle@. +clientConnection :: ClientOptions -> IO Connection +clientConnection opts = catch (do + s <- socket AF_INET (if connMode $ cliOpts opts then Stream else Datagram) + (fromMaybe S.defaultProtocol (cliProto opts)) + setSocketOption s KeepAlive 1{-on..-} + hst <- getHostAddr (host opts) + let srcAddr = SockAddrInet (fromMaybe S.aNY_PORT (localEnd opts)) + S.iNADDR_ANY + catch (S.bindSocket s srcAddr) (\ e -> sClose s >> ioError e) + resetSocketStatus s + let tgtAddr = SockAddrInet (fromMaybe S.aNY_PORT (port opts)) hst + catch (S.connect s tgtAddr) (\ e -> sClose s >> ioError e) + h <- socketToHandle s (ioMode $ cliOpts opts) + hSetBuffering h (bufMode $ cliOpts opts) + return (Connection{coHandle=h,coSocket=s,coServer=Nothing})) (errHandler opts) + where + errHandler o e = do + mapM_ (hPutStrLn stderr) + [ "clientConnection failed for: " + , show o + , "Details: " + , show e + ] + ioError e + +-- what a hack! +resetSocketStatus :: Socket -> IO () +resetSocketStatus (MkSocket _ _ _ _ s) = do + modifyMVar_ s $ \ status -> do + case status of + Bound -> return NotConnected + _ -> return status + + +data ServerOptions + = ServerOptions + { servInterface :: Maybe String + , servPort :: Maybe PortNumber + , servProto :: Maybe ProtocolNumber + , servOpts :: ConnectionOptions + } + +serverOpts :: ServerOptions +serverOpts = ServerOptions + { servInterface = Nothing + , servPort = Nothing + , servProto = Nothing + , servOpts = defaultConnectionOptions + } + +data Server + = Server + { servSocket :: Socket + , servOptions :: ConnectionOptions + , servSessions :: MVar [Connection] +-- , serv + } + +newServer :: ServerOptions -> IO Server +newServer opts = do + s <- socket AF_INET (if connMode $ servOpts opts then Stream else Datagram) + (fromMaybe S.defaultProtocol (servProto opts)) + setSocketOption s KeepAlive 1{-on..-} + setSocketOption s ReuseAddr 1{-on..-} + hst <- maybe (return iNADDR_ANY) getHostAddr (servInterface opts) + let srcAddr = SockAddrInet (fromMaybe S.aNY_PORT (servPort opts)) hst + catch (S.bindSocket s srcAddr) (\ e -> sClose s >> ioError e) + S.listen s 1024{-backlog-} + sessVar <- newMVar [] + return Server{ servSocket = s + , servOptions = servOpts opts + , servSessions = sessVar + } + +acceptConnection :: Server -> IO (Connection, SockAddr) +acceptConnection s = catch (do + (sc,sa) <- S.accept (servSocket s) + let opts = servOptions s + h <- socketToHandle sc (ioMode opts) + hSetBuffering h (bufMode opts) + let conn = + Connection{ coHandle=h + , coSocket=sc + , coServer=Just s + } + modifyMVar_ (servSessions s) (\ ls -> return (conn:ls)) + return (conn, sa)) + (errHandler (servOptions s)) + where + errHandler o e = do + mapM_ (hPutStrLn stderr) + [ "acceptConnection failed for: " + , show o + , "Details: " + , show e + ] + ioError e + +closeSession :: Connection -> Server -> IO () +closeSession co s = modifyMVar_ (servSessions s) $ \ ls -> + case break (\ c -> coSocket c == coSocket co) ls of + (_,[]) -> return ls + (as,_:bs) -> return (as++bs) + +closeServer :: Server -> IO () +closeServer s = do + ls <- readMVar (servSessions s) + mapM_ closeConnection ls + -- by this point the connections will have removed themselves...but just in case, stub out connections list. + _ls <- modifyMVar (servSessions s) (\ s -> return ([],s)) + let sock = servSocket s + shutdown sock ShutdownSend + shutdown sock ShutdownReceive + sClose sock + return () + +closeConnection :: Connection -> IO () +closeConnection co = do + let h = coHandle co + let s = coSocket co + hFlush h + shutdown s ShutdownSend + catch (hClose h) (\ _ -> return ()) + shutdown s ShutdownReceive + sClose s + maybe (return ()) (closeSession co) (coServer co) + return () + +getHostAddr :: String -> IO HostAddress +getHostAddr h = do + catch (inet_addr h) -- handles ascii IP numbers + (\ _ -> do + hst <- getHostByName_safe h + case hostAddresses hst of + [] -> fail ("getHostAddr: no addresses in host entry for " ++ show h) + (ha:_) -> return ha) + +getHostByName_safe :: HostName -> IO BSD.HostEntry +getHostByName_safe h = + catch (getHostByName h) + (\ _ -> fail ("Redis.connect: host lookup failure for " ++ show h)) + + + +-- Instances: + +instance Show ClientOptions where + show x = + unlines [ "ClientOptions: " + , " hostName = " ++ host x + , " portNumber = " ++ show (port x) + , " connection-oriented = " ++ show (connMode $ cliOpts x) + , " direction = " ++ show (ioMode $ cliOpts x) + , " buffering = " ++ show (bufMode $ cliOpts x) + ] + +instance Show ConnectionOptions where + show x = + unlines [ "ConnectionOptions: " + , " connection-oriented = " ++ show (connMode x) + , " direction = " ++ show (ioMode x) + , " buffering = " ++ show (bufMode x) + ] diff --git a/README b/README new file mode 100644 --- /dev/null +++ b/README @@ -0,0 +1,44 @@ +== Intro == + +This package is an early-release of the webhooks / publish-subscribe +protocol that http://pubsubhubbub.googlecode.com/ is working and +rapidly deploying for various Google services. + +The protocol itself isn't tied or limited to a Google service; a +number of hubs have been created and deployed already (see the +above URL for list.) + +This Haskell package adds support for working with these +HTTP-based publish-subscribe hub servers, i.e., you may +subscribe to notification to URLs ('topics') from a hub and it +will push updates down as they occur (rather than you polling.) + +== Getting started == + +The protocol is dependent on having some callback/endpoints +to forward 'topic' updates to you locally. There's a number of +ways of providing this in Haskell...for testing purposes, I've +included a 'fastcgi' proxy/relaying script that handles this; +see examples/Main.hs It operates by forwarding incoming requests +to a local server for processing -- the thinking being that +it provides a robust web front-end, leaving your basic Haskell +code to do the interesting bits of proccessing the pubsub +notifications. An example of how this could be done is provided +in examples/Feeder.hs which uses the pubsubhub service that +superfeedr.com provides. + +To use, you need to: + + * build the cabal package..(!) + * Make the fastcgi script pubsub.fcgi available on + 'web-visible' URL. + * Adjust the settings at the top of examples/Feeder.hs + to match your local settings for the script's URL + + settle on a hub to use. + +For actual code / documentation on the bits that implement the +very-straightforward PubSubHub protocol, see Web/PubSub.hs + + +enjoy +--sigbjorn 09/08/2009 diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,8 @@ +module Main(main) where + +import Distribution.Simple + +main :: IO () +main = defaultMain + + diff --git a/Utils/Data/List.hs b/Utils/Data/List.hs new file mode 100644 --- /dev/null +++ b/Utils/Data/List.hs @@ -0,0 +1,29 @@ +-------------------------------------------------------------------- +-- | +-- Module : Utils.Data.List +-- Copyright : (c) Sigbjorn Finne, 2009 +-- License : BSD3 +-- +-- Maintainer: Sigbjorn Finne +-- Stability : provisional +-- Portability: +-- +-------------------------------------------------------------------- +module Utils.Data.List + ( matchPrefix -- :: Eq a => [a] -> [a] -> Maybe [a] + , transElem -- :: Eq a => a -> a -> a -> a + + ) where + + +matchPrefix :: Eq a => [a] -> [a] -> Maybe [a] +matchPrefix [] xs = Just xs +matchPrefix (x:xs) (y:ys) + | x == y = matchPrefix xs ys + | otherwise = Nothing + +transElem :: Eq a => a -> a -> a -> a +transElem t f x + | t == x = f + | otherwise = x + diff --git a/Utils/Data/String.hs b/Utils/Data/String.hs new file mode 100644 --- /dev/null +++ b/Utils/Data/String.hs @@ -0,0 +1,30 @@ +-------------------------------------------------------------------- +-- | +-- Module : Utils.Data.String +-- Copyright : (c) Sigbjorn Finne, 2009 +-- License : BSD3 +-- +-- Maintainer: Sigbjorn Finne +-- Stability : provisional +-- Portability: +-- +-------------------------------------------------------------------- +module Utils.Data.String + ( capitalize -- :: String -> String + , unwordsWith -- :: String -> [String] -> String + ) where + + +import Data.Char + +capitalize :: String -> String +capitalize "" = "" +capitalize ls@(x:xs) + | isAlpha x && isLower x = toUpper x : xs + | otherwise = ls + +unwordsWith :: String -> [String] -> String +unwordsWith sep [] = "" +unwordsWith sep [x] = x +unwordsWith sep (x:y:xs) = x ++ sep ++ unwordsWith sep (y:xs) + diff --git a/Web/Codec/Percent.hs b/Web/Codec/Percent.hs new file mode 100644 --- /dev/null +++ b/Web/Codec/Percent.hs @@ -0,0 +1,57 @@ +{- | + + Module : Web.Codec.Percent + Copyright : (c) 2008, Sigbjorn Finne + + Maintainer : sof@forkIO.com + + License : See the file LICENSE + + Status : Coded + + Codec for de/encoding URI strings via percent encodings + (cf. RFC 3986.) +-} +module Web.Codec.Percent where + +import Data.Char ( chr, isAlphaNum, isAscii ) +import Numeric ( readHex, showHex ) + +getEncodedString :: String -> String +getEncodedString "" = "" +getEncodedString (x:xs) = + case getEncodedChar x of + Nothing -> x : getEncodedString xs + Just ss -> ss ++ getEncodedString xs + +getDecodedString :: String -> String +getDecodedString "" = "" +getDecodedString ls@(x:xs) = + case getDecodedChar ls of + Nothing -> x : getDecodedString xs + Just (ch,xs1) -> ch : getDecodedString xs1 + +getEncodedChar :: Char -> Maybe String +getEncodedChar x + | (isAlphaNum x && isAscii x) || + x `elem` "-_.~" = Nothing + | xi < 0xff = Just ('%':showHex (xi `div` 16) (showHex (xi `mod` 16) "")) + | otherwise = -- ToDo: import utf8 lib + error "getEncodedChar: can only handle 8-bit chars right now." + where + xi :: Int + xi = fromEnum x + +getDecodedChar :: String -> Maybe (Char, String) +getDecodedChar str = + case str of + "" -> Nothing + (x:xs) + | x /= '%' -> Nothing + | otherwise -> do + case xs of + (b1:b2:bs) -> + case readHex [b1,b2] of + ((v,_):_) -> Just (Data.Char.chr v, bs) + _ -> Nothing + _ -> Nothing diff --git a/Web/Codec/URLEncoder.hs b/Web/Codec/URLEncoder.hs new file mode 100644 --- /dev/null +++ b/Web/Codec/URLEncoder.hs @@ -0,0 +1,104 @@ +{- | + + Module : Web.Codec.URLEncoder + Copyright : (c) 2008, Sigbjorn Finne + + Maintainer : sof@forkIO.com + + License : See the file LICENSE + + Status : Coded + + Codec for de/encoding form data shipped in URL query strings + or in POST request bodies. (application/x-www-form-urlencoded) + (cf. RFC 3986.) +-} +module Web.Codec.URLEncoder + ( encodeString + , decodeString + + , isUTF8Encoded + , utf8Encode + ) where + +import qualified Codec.Binary.UTF8.String as UTF8 ( encodeString ) +import Web.Codec.Percent ( getEncodedChar, getDecodedChar ) + +-- for isUTF8Encoded +import Data.Bits +import Data.Word ( Word32 ) + +utf8Encode :: String -> String +utf8Encode str + | isUTF8Encoded str = str + | otherwise = UTF8.encodeString str + +encodeString :: String -> String +encodeString str = go (utf8Encode str) + where + go "" = "" + go (' ':xs) = '+':go xs + go ('\r':'\n':xs) = '%':'0':'D':'%':'0':'A':go xs + go ('\r':xs) = go ('\r':'\n':xs) + go ('\n':xs) = go ('\r':'\n':xs) + go (x:xs) = + case getEncodedChar x of + Nothing -> x : go xs + Just ss -> ss ++ go xs + +decodeString :: String -> String +decodeString "" = "" +decodeString ('+':xs) = ' ':decodeString xs +decodeString ls@(x:xs) = + case getDecodedChar ls of + Nothing -> x : decodeString xs + Just (ch,xs1) -> ch : decodeString xs1 + + +-- | @isUTF8Encoded str@ tries to recognize input string as being in UTF-8 form. +-- Will soon migrate to @utf8-string@. +isUTF8Encoded :: String -> Bool +isUTF8Encoded [] = True +isUTF8Encoded (x:xs) = + case ox of + _ | ox < 0x80 -> isUTF8Encoded xs + | ox > 0xff -> False + | ox < 0xc0 -> False + | ox < 0xe0 -> check1 + | ox < 0xf0 -> check_byte 2 0xf 0 + | ox < 0xf8 -> check_byte 3 0x7 0x10000 + | ox < 0xfc -> check_byte 4 0x3 0x200000 + | ox < 0xfe -> check_byte 5 0x1 0x4000000 + | otherwise -> False + where + ox = toW32 x + + toW32 :: Char -> Word32 + toW32 ch = fromIntegral (fromEnum ch) + + check1 = + case xs of + [] -> False + c1 : ds + | oc .&. 0xc0 /= 0x80 || d < 0x000080 -> False + | otherwise -> isUTF8Encoded ds + where + oc = toW32 c1 + d = ((ox .&. 0x1f) `shiftL` 6) .|. (oc .&. 0x3f) + + check_byte :: Int -> Word32 -> Word32 -> Bool + check_byte i mask overlong = aux i xs (ox .&. mask) + where + aux 0 rs acc + | overlong <= acc && + acc <= 0x10ffff && + (acc < 0xd800 || 0xdfff < acc) && + (acc < 0xfffe || 0xffff < acc) = isUTF8Encoded rs + | otherwise = False + + aux n (r:rs) acc + | toW32 r .&. 0xc0 == 0x80 = + aux (n-1) rs (acc `shiftL` 6 .|. (toW32 r .&. 0x3f)) + + aux _ _ _ = False + diff --git a/Web/PubSub.hs b/Web/PubSub.hs new file mode 100644 --- /dev/null +++ b/Web/PubSub.hs @@ -0,0 +1,200 @@ +-------------------------------------------------------------------- +-- | +-- Module : Web.PubSub +-- Copyright : (c) Sigbjorn Finne, 2009 +-- License : BSD3 +-- +-- Maintainer: Sigbjorn Finne +-- 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 + _ | " processIt + _ -> return ( resp, Nothing) + _ -> + case lookup "hub.url" (reqVars req) of + Just u -> getContent u Nothing >>= \ v -> return (sresp,v) + _ | " 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] + diff --git a/Web/PubSub/Types.hs b/Web/PubSub/Types.hs new file mode 100644 --- /dev/null +++ b/Web/PubSub/Types.hs @@ -0,0 +1,36 @@ +-------------------------------------------------------------------- +-- | +-- Module : Web.PubSub.Types +-- Copyright : (c) Sigbjorn Finne, 2009 +-- License : BSD3 +-- +-- Maintainer: Sigbjorn Finne +-- Stability : provisional +-- Portability: so-so +-- +-- Basic types and defs behind the PubSubHub protocol. +-- +module Web.PubSub.Types where + +import Web.Types + +data HubLink + = HubLink + { linkURL :: URLString + } deriving ( Show ) + +-- | @Subscribe@ represents both subscribe and subscribe requests. +-- +data Subscribe + = Subscribe + { subMode :: Bool -- True => subscribe; False => ... + , subCallback :: URLString -- the local endpoint + , subTopic :: URLString -- the URL you are subscribing to. + , subVerify :: [VerifyMode] + , subVerifyToken :: Maybe VerifyToken + , subLeaseSecs :: Maybe Integer + } + +data VerifyMode = VerifySync Bool -- False => async. + +type VerifyToken = String diff --git a/Web/Types.hs b/Web/Types.hs new file mode 100644 --- /dev/null +++ b/Web/Types.hs @@ -0,0 +1,19 @@ +-------------------------------------------------------------------- +-- | +-- Module : Web.Types +-- Copyright : (c) Sigbjorn Finne, 2009 +-- License : BSD3 +-- +-- Maintainer: Sigbjorn Finne +-- 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.Types where + +-- the ubiq.. +type URLString = String diff --git a/Web/Utils/Fetch.hs b/Web/Utils/Fetch.hs new file mode 100644 --- /dev/null +++ b/Web/Utils/Fetch.hs @@ -0,0 +1,187 @@ +-------------------------------------------------------------------- +-- | +-- Module : Web.Utils.Fetch +-- Copyright : (c) Sigbjorn Finne, 2009 +-- License : BSD3 +-- +-- Maintainer: Sigbjorn Finne +-- Stability : provisional +-- Portability: so-so +-- +-- Simple GET\/de-ref of URLs; abstracting out networking backend\/package. +-- +module Web.Utils.Fetch + ( readContentsURL + , readUserContentsURL + + , postContentsURL + + , AuthUser(..) + , nullAuthUser + + , Cookie + + , addDefaultHeaders + ) where + +--import Network.Curl +import Network.Browser +import Network.HTTP +import Network.URI + +import Web.Types ( URLString ) + +data AuthUser + = AuthUser { authUserName :: String + , authUserPass :: String + } + +nullAuthUser :: AuthUser +nullAuthUser = AuthUser + { authUserName = "" + , authUserPass = "" + } + +readContentsURL :: URLString -> IO String +readContentsURL u = do + req <- + case parseURI u of + Nothing -> fail ("ill-formed URL: " ++ u) + Just ur -> return (defaultGETRequest ur) + -- don't like doing this, but HTTP is awfully chatty re: cookie handling.. + let nullHandler _ = return () + (_u, resp) <- browse $ setOutHandler nullHandler >> request req + case rspCode resp of + (2,_,_) -> return (rspBody resp) + _ -> fail ("Failed reading URL " ++ show u ++ " code: " ++ show (rspCode resp)) + +{- Curl version: +readContentsURL :: URLString -> IO String +readContentsURL u = do + let opts = [ CurlFollowLocation True + ] + (_,xs) <- curlGetString u opts + return xs +-} + +readUserContentsURL :: Maybe AuthUser + -> Bool + -> Bool + -> URLString + -> [(String,String)] + -> IO ([(String,String)], String) +readUserContentsURL mbU doRedir isHead us hdrs = do -- readContentsURL u + let hs = + case parseHeaders $ map (\ (x,y) -> x++": " ++ y) (addDefaultHeaders 0 hdrs) of + Left{} -> [] + Right xs -> xs + req0 <- + case parseURI us of + Nothing -> fail ("ill-formed URL: " ++ us) + Just ur -> return (defaultGETRequest ur) + -- don't like doing this, but HTTP is awfully chatty re: cookie handling.. + let req = insertHeaderIfMissing HdrHost (authority (rqURI req0)) $ + req0{ rqMethod=if isHead then HEAD else GET + , rqHeaders= hs + , rqURI = (rqURI req0){uriScheme="",uriAuthority=Nothing} + } + let nullHandler _ = return () + (u, resp) <- browse $ do + setOutHandler nullHandler + case mbU of + Nothing -> return () + Just usr -> do + setAllowRedirects doRedir + setAllowBasicAuth True + setAuthorityGen (\ _ _ -> return (Just (authUserName usr,authUserPass usr))) + +-- setAllowBasicAuth True +-- setAuthorityGen (\ _ _ -> return (Just (authUserName usr,authUserPass usr))) +{- + addAuthority AuthBasic{ auUsername = userName usr + , auPassword = userPass usr + , auRealm = "" + , auSite = nullURI{uriPath="/"} + } +-} + request req + case rspCode resp of + (2,_,_) -> return (map toP (rspHeaders resp), rspBody resp) + (3,_,_) | not doRedir -> return (map toP (rspHeaders resp), rspBody resp) + _ -> fail ("Failed reading URL " ++ show u ++ " code: " ++ show (rspCode resp)) + + +postContentsURL :: Maybe AuthUser + -> URLString + -> [(String,String)] + -> [Cookie] + -> String + -> IO ([Cookie],[(String,String)], String) +postContentsURL mbU u hdrs csIn body = do + let hs = + case parseHeaders $ map (\ (x,y) -> x++": " ++ y) (addDefaultHeaders (length body) hdrs) of + Left{} -> [] + Right xs -> xs + req0 <- + case parseURI u of + Nothing -> fail ("ill-formed URL: " ++ u) + Just ur -> return (defaultGETRequest ur) + let req = insertHeaderIfMissing HdrHost (authority (rqURI req0)) $ + req0{ rqMethod=POST + , rqBody=body + , rqHeaders= hs + , rqURI = (rqURI req0){uriScheme="",uriAuthority=Nothing} + } +-- print req -- ,body) + let nullHandler _ = return () + ((_,rsp),cs) <- browse $ do + setOutHandler nullHandler + setAllowRedirects True + setCookies csIn + case mbU of + Nothing -> return () + Just usr -> do + setAllowBasicAuth True + setAuthorityGen (\ _ _ -> return (Just (authUserName usr,authUserPass usr))) + + v <- request req + ls <- getCookies + return (v,ls) + case rspCode rsp of + (2,_,_) -> return (cs,map toP (rspHeaders rsp), rspBody rsp) + x -> fail ("POST failed - code: " ++ show x ++ ", URL: " ++ u ++ show (rspBody rsp)) + +toP (Header k v) = (show k, v) + +addDefaultHeaders :: Int -> [(String,String)] -> [(String,String)] +addDefaultHeaders clen hs = + addIfMiss "User-Agent" "hs-lib" $ + addIfMiss "Content-Length" (show clen) hs + where + addIfMiss f v xs = maybe ((f,v):xs) (const xs) (lookup f xs) + +{- Curl versions: +readUserContentsURL :: User -> URLString -> IO String +readUserContentsURL u url = do + let opts = [ CurlHttpAuth [HttpAuthAny] + , CurlUserPwd (authUserName u ++ + case userPass u of {"" -> ""; p -> ':':p }) + , CurlFollowLocation True + ] + (_,xs) <- curlGetString url opts + return xs + +postContentsURL :: URLString -> [(String,String)] -> String -> IO String +postContentsURL u hdrs body = do + let opts = [ CurlCustomRequest "POST" + , CurlFollowLocation True + , CurlPost True + , CurlPostFields [body] + , CurlHttpTransferDecoding False + ] ++ [CurlHttpHeaders (map ( \ (x,y) -> (x ++ ':':y)) hdrs)] + rsp <- curlGetResponse u opts + case respStatus rsp `div` 100 of + 2 -> return (respBody rsp) + x -> fail ("POST failed - code: " ++ show x ++ ", URL: " ++ u) + +-} diff --git a/Web/Utils/HTTP.hs b/Web/Utils/HTTP.hs new file mode 100644 --- /dev/null +++ b/Web/Utils/HTTP.hs @@ -0,0 +1,150 @@ +-------------------------------------------------------------------- +-- | +-- Module : Web.Utils.HTTP +-- Copyright : (c) Sigbjorn Finne, 2009 +-- License : BSD3 +-- +-- Maintainer: Sigbjorn Finne +-- Stability : provisional +-- Portability: so-so +-- +-- Ad-hoc, one-off, but convenient untyped representation of +-- HTTP requests and responses. Includes instances for serializing +-- both via JSON. +-- +module Web.Utils.HTTP where + +import Web.Types +import Data.Maybe +import Text.JSON + +-- +-- basic representation of requests and responses; minimal +-- typing used, i.e., at the other end of the spectrum from +-- the HTTP package's representation of the same objects. +-- +data Request + = Request + { reqMethod :: String + , reqURL :: URLString + , reqHeaders :: [(String,String)] + , reqVars :: [(String,String)] + , reqBody :: String + } + +data Response + = Response + { respStatus :: Integer + , respHeaders :: [(String,String)] + , respBody :: String + } deriving ( Show, Read ) + + +jsonRequest :: String -> Maybe Request +jsonRequest s = + case decode s of + Ok v -> Just v + _ -> Nothing + +jsonResponse :: Response -> String +jsonResponse r = encode r + +instance JSON Request where + readJSON r = readRequest r + showJSON r = showRequest r + +instance JSON Response where + readJSON r = readResponse r + showJSON r = showResponse r + +readRequest :: JSValue -> Result Request +readRequest (JSObject o) = do + m <- valFromObj "method" o + u <- valFromObj "url" o + hs <- valFromObj "headers" o + vs <- valFromObj "vars" o + bo <- valFromObj "body" o + return Request{ reqMethod = m + , reqURL = u + , reqHeaders = hs + , reqVars = vs + , reqBody = bo + } +readRequest _ = Error ("unable to decode Request object") + +showRequest :: Request -> JSValue +showRequest r = makeObj + [ ("method", showJSON (reqMethod r)) + , ("url", showJSON (reqURL r)) + , ("headers", showJSON (reqHeaders r)) + , ("vars", showJSON (reqVars r)) + , ("body", showJSON (reqBody r)) + ] + +readResponse :: JSValue -> Result Response +readResponse (JSObject o) = do + s <- valFromObj "status" o + hs <- valFromObj "headers" o + bo <- valFromObj "body" o + return Response{ respStatus = s + , respHeaders = hs + , respBody = bo + } +readResponse _ = Error ("unable to decode response object") + +showResponse :: Response -> JSValue +showResponse r = makeObj + [ ("status", showJSON (respStatus r)) + , ("headers", showJSON (respHeaders r)) + , ("body", showJSON (respBody r)) + ] + +toStatusString :: Integer -> String +toStatusString x = fromMaybe "" (lookup x statusMap) + + +statusMap :: [(Integer, String)] +statusMap = + [ 100 -=> "Continue" + , 101 -=> "Switching Protocols" + , 200 -=> "OK" + , 201 -=> "Created" + , 202 -=> "Accepted" + , 203 -=> "Non-Authoritative Information" + , 204 -=> "No Content" + , 205 -=> "Reset Content" + , 206 -=> "Partial Content" + , 300 -=> "Multiple Choices" + , 301 -=> "Moved Permanently" + , 302 -=> "Found" + , 303 -=> "See Other" + , 304 -=> "Not Modified" + , 305 -=> "Use Proxy" + , 307 -=> "Temporary Redirect" + , 400 -=> "Bad Request" + , 401 -=> "Unauthorized" + , 402 -=> "Payment Required" + , 403 -=> "Forbidden" + , 404 -=> "Not Found" + , 405 -=> "Method Not Allowed" + , 406 -=> "Not Acceptable" + , 407 -=> "Proxy Authentication Required" + , 408 -=> "Request Time-out" + , 409 -=> "Conflict" + , 410 -=> "Gone" + , 411 -=> "Length Required" + , 412 -=> "Precondition Failed" + , 413 -=> "Request Entity Too Large" + , 414 -=> "Request-URI Too Large" + , 415 -=> "Unsupported Media Type" + , 416 -=> "Requested range not satisfiable" + , 417 -=> "Expectation Failed" + , 500 -=> "Internal Server Error" + , 501 -=> "Not Implemented" + , 502 -=> "Bad Gateway" + , 503 -=> "Service Unavailable" + , 504 -=> "Gateway Time-out" + , 505 -=> "HTTP Version not supported" + ] + where + (-=>) a b = (a,b) diff --git a/Web/Utils/MIME.hs b/Web/Utils/MIME.hs new file mode 100644 --- /dev/null +++ b/Web/Utils/MIME.hs @@ -0,0 +1,129 @@ +-------------------------------------------------------------------- +-- | +-- Module : Web.Utils.MIME +-- Copyright : (c) Sigbjorn Finne, 2009 +-- License : BSD3 +-- +-- Maintainer: Sigbjorn Finne +-- Stability : provisional +-- Portability: so-so +-- +-- Working with MIME content; missing bits. +-- +module Web.Utils.MIME where + +import System.IO +import System.Random +import Numeric ( showHex ) +import Data.List ( intercalate ) + +import Codec.MIME.Type as MIME + +uploadFileType :: String -> MIME.Type +uploadFileType bou = MIME.Type + { mimeType = Multipart FormData + , mimeParams = [("boundary", bou)] + } + +mixedType :: IO (MIMEValue, String) +mixedType = do + let low = (2^(32::Integer)-1) :: Integer + x <- randomRIO (low,low*low) + let boundary = replicate 30 '-' ++ showHex x "" + return (nullMIMEValue + { mime_val_type = MIME.Type { mimeType = Multipart Mixed + , mimeParams = [("boundary", boundary)] + } + }, boundary) + +uploadFile :: String -> FilePath -> IO MIMEValue +uploadFile nm fp = do +{- + let low = (2^(32::Integer)-1) :: Integer + x <- randomRIO (low,low*low) + let boundary = replicate 30 '-' ++ showHex x "" +-} + let file_disp = + Disposition + { dispType = DispFormData + , dispParams = [ Name nm, Filename fp ] + } + h <- openBinaryFile fp ReadMode + ls <- hGetContents h + let fileValue = + nullMIMEValue + { mime_val_type = Type{mimeType=Text "plain", mimeParams=[]} + , mime_val_disp = Just file_disp + , mime_val_content = Single ls + , mime_val_headers = [ ("Content-Transfer-Encoding", "binary") + , ("Content-Length", show (length ls)) + ] + , mime_val_inc_type = True + } + return fileValue -- MIMEValue +{- + { mime_val_type = uploadFileType boundary + , mime_val_disp = Nothing + , mime_val_content = Multi [fileValue] + } +-} +showMIMEValue :: String -> MIMEValue -> ([(String,String)], String) +showMIMEValue m mv = + let marker = + case mimeType (mime_val_type mv) of + Multipart{} -> + case lookup "boundary" (mimeParams (mime_val_type mv)) of + Just x -> crnl ++ '-':'-':x + _ -> m + _ -> m + in + ( withType $ withDisp (mime_val_headers mv) + , (if True || null m then (crnl++) else (\x -> m ++ crnl ++ x)) + (showMIMEContent marker (mime_val_content mv)) + ) + where + withType + | mime_val_inc_type mv = (("Content-Type", showType (mime_val_type mv)):) + | otherwise = id + + withDisp = + case mime_val_disp mv of + Nothing -> id + Just d -> (("Content-Disposition", showDisposition d):) + +showMIMEContent :: String -> MIMEContent -> String +showMIMEContent _marker (Single s) = s +showMIMEContent marker (Multi ms) = + concat (map (s.(showMIMEValue marker)) ms) ++ marker ++ "--" + where + s (hs,v) = marker ++ crnl ++ + intercalate crnl (map (\ (a,b) -> (a ++ ':':' ':b)) hs) ++ crnl ++ v + +crnl :: String +crnl = "\r\n" + +showDisposition :: Disposition -> String +showDisposition d = + showDispType (dispType d) ++ + (concat $ map showDispParam (dispParams d)) + +showDispType :: DispType -> String +showDispType dt = + case dt of + DispInline -> "inline" + DispAttachment -> "attachment" + DispFormData -> "form-data" + DispOther x -> x + +showDispParam :: DispParam -> String +showDispParam dp = ';':' ': + case dp of + Name x -> "name="++show x + Filename x -> "filename=" ++ show x + CreationDate s -> "creation-date=" ++ show s + ModDate s -> "modification-date=" ++ show s + ReadDate s -> "read-date=" ++ show s + MIME.Size x -> "size=" ++ show x + OtherParam a b -> a ++ '=':show b + + diff --git a/Web/Utils/Post.hs b/Web/Utils/Post.hs new file mode 100644 --- /dev/null +++ b/Web/Utils/Post.hs @@ -0,0 +1,218 @@ +-------------------------------------------------------------------- +-- | +-- Module : Web.Utils.Post +-- Copyright : (c) Sigbjorn Finne, 2009 +-- License : BSD3 +-- +-- Maintainer: Sigbjorn Finne +-- Stability : provisional +-- Portability: so-so +-- +-- Working with POSTed form payloads. +-- +module Web.Utils.Post where + +import Codec.MIME.Type as MIME +import Codec.MIME.Parse as MIME +import Web.Utils.MIME +import Web.Codec.URLEncoder + +import Data.List +import System.Random +import Numeric + +-- ease the working with POST requests and their +-- outgoing payloads. + +data PostReq + = PostReq + { prName :: String + , prVals :: [PostParam] + } + +data PostKind + = PostQuery + | PostWWWForm + | PostFormData + +newPostRequest :: String -> PostReq +newPostRequest s = PostReq{prName=s,prVals=[]} + +testRequest :: PostReq + -> Maybe PostKind + -> IO () +testRequest a b = do + (as,bs,cs) <- toRequest a b + putStrLn ("URL query portion: " ++ as) + putStrLn (unlines $ map (\ (k,v) -> k ++ ':':' ':v) bs) + putStrLn "" + putStrLn cs + + +toRequest :: PostReq + -> Maybe PostKind + -> IO (String, [(String,String)], String) +toRequest pr mbKind = + case mbKind of + Nothing -> + case filter isPostFile (prVals pr) of + (_:_) -> toRequest pr (Just PostFormData) + _ -> toRequest pr (Just PostWWWForm) + Just PostQuery -> + case partition isPostFile (prVals pr) of + (ls@(_:_),bs) -> do + putStrLn ("toRequest: POST request contains " ++ + shows (length ls) (" files; unable to represent as query string")) + putStrLn ("Defaulting to multiform/form-data instead") + toRequest pr{prVals=bs++ls} (Just PostFormData) + _ -> + let + (body_enc, xs) = partition mustBeBody (prVals pr) + body + | null body_enc = "" + | otherwise = toAmpString body_enc + in + return ( toAmpString xs + , ("Content-Length", show (length body)) : + if null body_enc + then [] + else [ ("Content-Type", "application/x-www-form-urlencoded") ] + , body + ) + Just PostWWWForm -> + case partition isPostFile (prVals pr) of + (ls@(_:_),bs) -> do + putStrLn ("toRequest: POST request contains " ++ + shows (length ls) (" files; unable to represent as application/x-www-form-urlencoded")) + putStrLn ("Defaulting to multiform/form-data instead") + toRequest pr{prVals=bs++ls} (Just PostFormData) + _ -> do + let + (qs, xs) = partition mustBeQuery (prVals pr) + body = toAmpString xs + return ( toAmpString qs + , [ ("Content-Type", "application/x-www-form-urlencoded") + , ("Content-Length", show (length body)) + ] + , body + ) + Just PostFormData -> do + let (qs, xs) = partition mustBeQuery (prVals pr) + mv <- toMIMEValue xs + let (hs,bod) = showMIMEValue "" mv + putStrLn bod + return ( toAmpString qs + , ("Content-Length", show (length bod)):hs + , bod + ) + +toAmpString :: [PostParam] -> String +toAmpString xs = + intercalate "&" $ + map (\ (PostNameValue n v _) -> encodeString n ++ '=':encodeString v) xs + +mustBeBody :: PostParam -> Bool +mustBeBody (PostNameValue _ _ (Just True)) = True +mustBeBody _ = False + +mustBeQuery :: PostParam -> Bool +mustBeQuery (PostNameValue _ _ (Just False)) = True +mustBeQuery _ = False + +-- | @addNameValue nm val req@ augments the request @req@ with a binding +-- for @(nm,val)@. Neither @nm@ nor @val@ are assumed encoded. It leaves it +-- until the serialization phase to fix on how to communicate the binding +-- for the POST request (i.e., via the query portion or in the request's body.) +addNameValue :: String -> String -> PostReq -> PostReq +addNameValue n v pr = pr{prVals=(PostNameValue n v Nothing):prVals pr} + +-- | @addQueryNameValue nm val req@ performs same function as @addNameValue@, +-- but adds the constraint that the binding must be transmitted as part of the query +-- portion of the URL it ends up going out via. +addQueryNameValue :: String -> String -> PostReq -> PostReq +addQueryNameValue n v pr = pr{prVals=(PostNameValue n v (Just False)):prVals pr} + +-- | @addQueryNameValue nm val req@ performs same function as @addNameValue@, +-- but adds the constraint that the binding must be transmitted as part of the +-- body of the POST request, forcing the payload to be of MIME type @application/x-www-form-urlencoded@ +addBodyNameValue :: String -> String -> PostReq -> PostReq +addBodyNameValue n v pr = pr{prVals=(PostNameValue n v (Just True)):prVals pr} + +-- | @addNameFile nm fb mbMimeType req@ augments the request @req@ with a binding +-- of name @nm@ to the local file @fb@. It will be slurped in and included in the +-- POST request, as part of a multi-part payload. +addNameFile :: String -> FilePath -> Maybe String -> PostReq -> PostReq +addNameFile nm fp mbTy pr = pr{prVals=(PostFile nm fp mbTy):prVals pr} + +data PostParam + = PostNameValue String -- name + String -- value (assume: un-encoded) + (Maybe Bool) -- Just True => must be in query; Just False => must be in body; Nothing => either way. + | PostFile String -- name + FilePath -- local file to post + (Maybe String) -- Just ty => use 'ty' as content-type + +isPostFile :: PostParam -> Bool +isPostFile PostFile{} = True +isPostFile _ = False + +toMIMEValue :: [PostParam] -> IO MIMEValue +toMIMEValue ps = do + let low = (2^(32::Integer)-1) :: Integer + x <- randomRIO (low,low*low) + let boundary = replicate 30 '-' ++ showHex x "" + let (fs,ns) = + case partition isPostFile ps of + ([_],_) -> ([],ps) + xs -> xs + + fns <- mapM (fromPostParam boundary) ns + (mi,b) <- mixedType + ffs <- mapM (fromPostParam b) fs + let addM [] = [] + addM xs = [mi{mime_val_content=Multi xs}] + + return MIMEValue + { mime_val_type = MIME.Type{ mimeType = Multipart FormData + , mimeParams = [("boundary", boundary)] + } + , mime_val_disp = Nothing + , mime_val_content = Multi (fns ++ addM ffs) + , mime_val_inc_type = True + , mime_val_headers = [] + } + +fromPostParam :: String -> PostParam -> IO MIMEValue +fromPostParam _boundary (PostNameValue n v _mbQ) = + return MIMEValue + { mime_val_type = MIME.Type + { mimeType = Application "x-www-form-urlencoded" + , mimeParams=[] + } + , mime_val_disp = Just $ + Disposition { dispType = DispFormData + , dispParams = [Name n] + } + , mime_val_content = Single v -- (encodeString v) + , mime_val_headers = [] + , mime_val_inc_type = False + } +fromPostParam _boundary (PostFile nm fp mbTy) = do + ty <- + case mbTy of + Nothing -> getMIMEType fp + Just ty -> toMIMEType ty + mv <- uploadFile nm fp + return mv{mime_val_type=ty} + +toMIMEType :: String -> IO Type +toMIMEType tyStr = + case parseMIMEType tyStr of + Just t -> return t + _ -> return MIME.Type{mimeType=Text "plain",mimeParams=[]} + +getMIMEType :: String -> IO Type +getMIMEType x = + case parseMIMEType x of + Just t -> return t + _ -> return MIME.Type{mimeType=Application "octet-stream",mimeParams=[]} diff --git a/examples/Feeder.hs b/examples/Feeder.hs new file mode 100644 --- /dev/null +++ b/examples/Feeder.hs @@ -0,0 +1,168 @@ +-------------------------------------------------------------------- +-- | +-- Module : Feeder +-- Copyright : (c) Sigbjorn Finne, 2009 +-- License : BSD3 +-- +-- Maintainer: Sigbjorn Finne +-- 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 " + 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 = "" + } diff --git a/examples/Main.hs b/examples/Main.hs new file mode 100644 --- /dev/null +++ b/examples/Main.hs @@ -0,0 +1,103 @@ +-------------------------------------------------------------------- +-- | +-- Module : PubSub +-- Copyright : (c) Sigbjorn Finne, 2009 +-- License : BSD3 +-- +-- Maintainer: Sigbjorn Finne +-- Stability : provisional +-- Portability: +-- +-- FastCGI wrapper for forwarding incoming request to local network +-- server for processing. For fun, serialize the requests and responses +-- via JSON. +-- +-------------------------------------------------------------------- +module Main(main) where + +import Control.Concurrent +import Network.FastCGI + +import Data.Char +import Data.Maybe +import Web.Utils.HTTP +import Web.Utils.Fetch ( addDefaultHeaders ) + +-- local +import Utils.Data.List +import Utils.Data.String + + +import System.IO ( hPutStrLn, hGetLine ) +import Network.Connection +import Text.JSON + +clientConn :: ClientOptions +clientConn = clientOpts{host="localhost",port=Just 8080} + +processRequest :: Request -> CGI CGIResult +processRequest req = do + conn <- liftIO $ clientConnection clientConn + liftIO $ hPutStrLn (coHandle conn) (encode req) + v <- liftIO $ hGetLine (coHandle conn) +-- logIt ("incoming: " ++ v) +-- liftIO $ closeConnection conn + case decode v of + Error s -> outputNotFound s + Ok re -> fromResponse re + +action :: CGI CGIResult +action = do + req <- mkRequest + res <- processRequest req + return res + +main :: IO () +main = runFastCGIConcurrent' forkIO 10 action + +-- going from an incoming CGI context to a @Request@ value; +-- some magic and a bit brittle (cf. derivation of HTTP headers.) +mkRequest :: CGI Request +mkRequest = do + m <- requestMethod + u <- requestURI + body <- getBody + ls <- getInputs + vs <- getVars +-- logIt (show (m,u,ls,vs,body)) + let hdrs = mapMaybe toHeader vs + return Request { reqMethod = m + , reqURL = show u + , reqHeaders = hdrs + , reqBody = body + , reqVars = ls + } + +toHeader :: (String,String) -> Maybe (String,String) +toHeader (a,b) = + case matchPrefix "HTTP_" a of + Just a' -> Just (toHeaderName a', b) + _ -> Nothing + where + toHeaderName ls = + unwordsWith "-" $ + map capitalize $ + words $ map (transElem '_' ' ') $ map toLower ls + + +fromResponse :: Response -> CGI CGIResult +fromResponse r = do +-- setStatus (fromIntegral (respStatus r)) (toStatusString (respStatus r)) + let hdrs = addDefaultHeaders (length (respBody r)) (respHeaders r) +-- mapM_ (\ (a,b) -> setHeader a b) hdrs + output (respBody r) + + +logFile :: FilePath +logFile = "hs-pubsub.log" + -- you want to make this writable by the account running your CGI scripts + -- (plus possibly make the path absolute..) + +logIt :: String -> CGI () +logIt s = liftIO (appendFile logFile (s++"\n")) + diff --git a/pubsub.cabal b/pubsub.cabal new file mode 100644 --- /dev/null +++ b/pubsub.cabal @@ -0,0 +1,56 @@ +Name: pubsub +Version: 0.10 +Cabal-Version: >= 1.2 +Build-type: Simple +License: BSD3 +License-file: LICENSE +Copyright: + Copyright (c) 2009, Sigbjorn Finne +Author: Sigbjorn Finne +Maintainer: Sigbjorn Finne +Homepage: http://projects.haskell.org/pubsub/ +Category: Web +Synopsis: A library for Google/SixApart pubsub hub interaction +Description: + + A package for setting up, sending and receiving PubSub requests to pubsub hubs, + + . + Git repository available at + +Extra-Source-Files: CHANGES README + +Flag old-base + description: Old, monolithic base + default: False + +Library + Exposed-modules: + Web.Types, + Web.PubSub, + Web.PubSub.Types, + Web.Codec.Percent, + Web.Codec.URLEncoder, + Web.Utils.HTTP, + Web.Utils.MIME, + Web.Utils.Post, + Web.Utils.Fetch, + Network.Connection + Other-modules: Utils.Data.List, + Utils.Data.String + GHC-options: -fwarn-missing-signatures -Wall + Build-depends: base >= 2 && <4, network, feed, xml, mime, utf8-string, json, random, HTTP >= 4000 + if flag(old-base) + Build-depends: base < 3 + else + Build-depends: base >= 3 + +executable pubsub.fcgi { + main-is: examples/Main.hs + ghc-options: -threaded + build-depends: fastcgi +} + +executable feeder { + main-is: examples/Feeder.hs +}