pubsub (empty) → 0.10
raw patch · 19 files changed
+1820/−0 lines, 19 filesdep +HTTPdep +basedep +fastcgisetup-changed
Dependencies added: HTTP, base, fastcgi, feed, json, mime, network, random, utf8-string, xml
Files
- CHANGES +3/−0
- LICENSE +27/−0
- Network/Connection.hs +252/−0
- README +44/−0
- Setup.hs +8/−0
- Utils/Data/List.hs +29/−0
- Utils/Data/String.hs +30/−0
- Web/Codec/Percent.hs +57/−0
- Web/Codec/URLEncoder.hs +104/−0
- Web/PubSub.hs +200/−0
- Web/PubSub/Types.hs +36/−0
- Web/Types.hs +19/−0
- Web/Utils/Fetch.hs +187/−0
- Web/Utils/HTTP.hs +150/−0
- Web/Utils/MIME.hs +129/−0
- Web/Utils/Post.hs +218/−0
- examples/Feeder.hs +168/−0
- examples/Main.hs +103/−0
- pubsub.cabal +56/−0
+ CHANGES view
@@ -0,0 +1,3 @@+Version 0.10:++ Initial release of PubSubHub Haskell package.
+ LICENSE view
@@ -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.
+ Network/Connection.hs view
@@ -0,0 +1,252 @@+-------------------------------------------------------------------- +-- | +-- Module : Network.Connection +-- Description : Networking, at a higher-level. +-- Copyright : (c) Sigbjorn Finne, 2009 +-- License : BSD3 +-- +-- Maintainer : Sigbjorn Finne <sof@forkIO.com> +-- 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) + ]
+ README view
@@ -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
+ Setup.hs view
@@ -0,0 +1,8 @@+module Main(main) where + +import Distribution.Simple + +main :: IO () +main = defaultMain + +
+ Utils/Data/List.hs view
@@ -0,0 +1,29 @@+--------------------------------------------------------------------+-- |+-- Module : Utils.Data.List+-- Copyright : (c) Sigbjorn Finne, 2009+-- License : BSD3+--+-- Maintainer: Sigbjorn Finne <sof@forkIO.com>+-- 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+
+ Utils/Data/String.hs view
@@ -0,0 +1,30 @@+--------------------------------------------------------------------+-- |+-- Module : Utils.Data.String+-- Copyright : (c) Sigbjorn Finne, 2009+-- License : BSD3+--+-- Maintainer: Sigbjorn Finne <sof@forkIO.com>+-- 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)+
+ Web/Codec/Percent.hs view
@@ -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
+ Web/Codec/URLEncoder.hs view
@@ -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+
+ Web/PubSub.hs view
@@ -0,0 +1,200 @@+--------------------------------------------------------------------+-- |+-- 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]+
+ Web/PubSub/Types.hs view
@@ -0,0 +1,36 @@+--------------------------------------------------------------------+-- |+-- Module : Web.PubSub.Types+-- Copyright : (c) Sigbjorn Finne, 2009+-- License : BSD3+--+-- Maintainer: Sigbjorn Finne <sof@forkIO.com>+-- 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
+ Web/Types.hs view
@@ -0,0 +1,19 @@+--------------------------------------------------------------------+-- |+-- Module : Web.Types+-- 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.Types where++-- the ubiq..+type URLString = String
+ Web/Utils/Fetch.hs view
@@ -0,0 +1,187 @@+-------------------------------------------------------------------- +-- | +-- Module : Web.Utils.Fetch +-- Copyright : (c) Sigbjorn Finne, 2009 +-- License : BSD3 +-- +-- Maintainer: Sigbjorn Finne <sof@forkIO.com> +-- 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) + +-}
+ Web/Utils/HTTP.hs view
@@ -0,0 +1,150 @@+--------------------------------------------------------------------+-- |+-- Module : Web.Utils.HTTP+-- Copyright : (c) Sigbjorn Finne, 2009+-- License : BSD3+--+-- Maintainer: Sigbjorn Finne <sof@forkIO.com>+-- 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)
+ Web/Utils/MIME.hs view
@@ -0,0 +1,129 @@+-------------------------------------------------------------------- +-- | +-- Module : Web.Utils.MIME +-- Copyright : (c) Sigbjorn Finne, 2009 +-- License : BSD3 +-- +-- Maintainer: Sigbjorn Finne <sof@forkIO.com> +-- 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 + +
+ Web/Utils/Post.hs view
@@ -0,0 +1,218 @@+-------------------------------------------------------------------- +-- | +-- Module : Web.Utils.Post +-- Copyright : (c) Sigbjorn Finne, 2009 +-- License : BSD3 +-- +-- Maintainer: Sigbjorn Finne <sof@forkIO.com> +-- 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=[]}
+ examples/Feeder.hs view
@@ -0,0 +1,168 @@+--------------------------------------------------------------------+-- |+-- 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 = ""+ }
+ examples/Main.hs view
@@ -0,0 +1,103 @@+--------------------------------------------------------------------+-- |+-- Module : PubSub+-- Copyright : (c) Sigbjorn Finne, 2009+-- License : BSD3+--+-- Maintainer: Sigbjorn Finne <sof@forkIO.com>+-- 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"))+
+ pubsub.cabal view
@@ -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 <sigbjorn.finne@gmail.com>+Maintainer: Sigbjorn Finne <sigbjorn.finne@gmail.com>+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,+ <http://pubsubhubbub.googlecode.com/svn/trunk/pubsubhubbub-core-0.1.html>+ .+ Git repository available at <git://coming.soon/>++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+}