HAppS-Server (empty) → 0.9.2
raw patch · 31 files changed
+5634/−0 lines, 31 filesdep +HAppS-Datadep +HAppS-IxSetdep +HAppS-Statesetup-changed
Dependencies added: HAppS-Data, HAppS-IxSet, HAppS-State, HAppS-Util, HTTP, HaXml, base, bytestring, containers, directory, hslogger, html, mtl, network, old-locale, old-time, parsec, random, regex-compat, template-haskell, unix, xhtml
Files
- HAppS-Server.cabal +50/−0
- Setup.hs +2/−0
- src/HAppS/Server.hs +21/−0
- src/HAppS/Server/Cookie.hs +199/−0
- src/HAppS/Server/Cron.hs +20/−0
- src/HAppS/Server/Facebook.hs +440/−0
- src/HAppS/Server/HTTP/Client.hs +81/−0
- src/HAppS/Server/HTTP/Clock.hs +30/−0
- src/HAppS/Server/HTTP/FileServe.hs +185/−0
- src/HAppS/Server/HTTP/Handler.hs +335/−0
- src/HAppS/Server/HTTP/LazyLiner.hs +41/−0
- src/HAppS/Server/HTTP/Listen.hs +48/−0
- src/HAppS/Server/HTTP/LowLevel.hs +28/−0
- src/HAppS/Server/HTTP/Multipart.hs +216/−0
- src/HAppS/Server/HTTP/RFC822Headers.hs +266/−0
- src/HAppS/Server/HTTP/Types.hs +244/−0
- src/HAppS/Server/HTTPClient/HTTP.hs +1048/−0
- src/HAppS/Server/HTTPClient/Stream.hs +173/−0
- src/HAppS/Server/HTTPClient/TCP.hs +191/−0
- src/HAppS/Server/JSON.hs +27/−0
- src/HAppS/Server/MessageWrap.hs +242/−0
- src/HAppS/Server/MinHaXML.hs +200/−0
- src/HAppS/Server/S3.hs +272/−0
- src/HAppS/Server/SURI.hs +65/−0
- src/HAppS/Server/SURI/ParseURI.hs +66/−0
- src/HAppS/Server/SimpleHTTP.hs +595/−0
- src/HAppS/Server/StdConfig.hs +54/−0
- src/HAppS/Server/XSLT.hs +141/−0
- src/HAppS/Store/FlashMsgs.hs +116/−0
- src/HAppS/Store/HelpReqs.hs +183/−0
- src/HAppS/Store/Util.hs +55/−0
+ HAppS-Server.cabal view
@@ -0,0 +1,50 @@+Name: HAppS-Server+Version: 0.9.2+Synopsis: Web related tools and services.+Description: Web framework+License: BSD3+Author: HAppS LLC+Maintainer: AlexJacobson@HAppS.org+Category: Web, Distributed Computing+Build-Depends: base, HaXml >= 1.13 && < 1.14, parsec, mtl, network,+ regex-compat, hslogger >= 1.0.2, HAppS-Data>=0.9.2, HAppS-Util>=0.9.2,+ HAppS-State>=0.9.2, HAppS-IxSet>=0.9.2, HTTP, template-haskell, xhtml, html,+ bytestring, random, containers, old-time, old-locale, directory, unix+Build-Type: Simple+hs-source-dirs: src+Exposed-modules:+ HAppS.Server,+ HAppS.Server.Cookie,+ HAppS.Server.HTTP.Client,+ HAppS.Server.HTTP.Types,+ HAppS.Server.HTTP.LowLevel,+ HAppS.Server.HTTP.FileServe,+ HAppS.Server.SimpleHTTP,+ HAppS.Server.JSON,+ HAppS.Server.MessageWrap,+ HAppS.Server.MinHaXML,+ HAppS.Server.SURI,+ HAppS.Server.XSLT,+ HAppS.Server.Facebook+ HAppS.Server.Cron+ HAppS.Server.StdConfig+ HAppS.Store.Util+ HAppS.Store.FlashMsgs+ HAppS.Store.HelpReqs+Other-modules: + HAppS.Server.S3,+ HAppS.Server.HTTPClient.HTTP,+ HAppS.Server.HTTPClient.Stream,+ HAppS.Server.HTTPClient.TCP,+ HAppS.Server.HTTP.Clock,+ HAppS.Server.HTTP.Handler,+ HAppS.Server.HTTP.LazyLiner,+ HAppS.Server.HTTP.Listen,+ HAppS.Server.HTTP.Multipart,+ HAppS.Server.HTTP.RFC822Headers,+ HAppS.Server.SURI.ParseURI+-- Should have ", DeriveDataTypeable, PatternSignatures" but Cabal complains+Extensions: CPP, UndecidableInstances+cpp-options: -DUNIX+ghc-options: -W -fno-warn-incomplete-patterns+GHC-Prof-Options: -auto-all
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMainWithHooks defaultUserHooks
+ src/HAppS/Server.hs view
@@ -0,0 +1,21 @@+module HAppS.Server +(+ module HAppS.State.Control+,module HAppS.Server.XSLT+,module HAppS.Server.SimpleHTTP+,module HAppS.Server.HTTP.Client+,module HAppS.Server.MessageWrap+,module HAppS.Server.HTTP.FileServe+,module HAppS.Server.StdConfig+,module HAppS.Store.Util++)+where+import HAppS.Server.HTTP.Client+import HAppS.Server.StdConfig+import HAppS.State.Control+import HAppS.Server.XSLT+import HAppS.Server.SimpleHTTP+import HAppS.Server.MessageWrap+import HAppS.Server.HTTP.FileServe+import HAppS.Store.Util
+ src/HAppS/Server/Cookie.hs view
@@ -0,0 +1,199 @@+{-# OPTIONS -fglasgow-exts #-}+-- http://tools.ietf.org/html/rfc2109+module HAppS.Server.Cookie+ ( Cookie(..), mkCookie, mkCookieHeader+ , getCookies, getCookie )+ where+{-+ (Cookie(..), setCookie, setCookieEx,+ sesCookie, delSesCookie, delSesCookie'+-- getCookies, getCookie, getCookieValue+ ) where+-}+import Control.Monad(when, zipWithM_)+import qualified Data.ByteString.Char8 as C+import Data.Char+import Data.List+import Data.Generics+import HAppS.Util.Common (Seconds)+--import HAppS.Server.HTTP.Types+--import HAppS.State+import Text.ParserCombinators.ReadP++data Cookie = Cookie+ { cookieVersion :: String+ , cookiePath :: String+ , cookieDomain :: String+ , cookieName :: String+ , cookieValue :: String+ } deriving(Show,Eq,Read,Typeable,Data)++mkCookie :: String -> String -> Cookie+mkCookie key val = Cookie "1" "/" "" key val++{-+-- | Set a cookie in the Result with empty path and domain.+-- See 'setCookieEx' for more details.+--setCookie :: Monad m => Seconds -> String -> String -> Result -> m Result+--setCookie sec key val = setCookieEx sec (Cookie "1" "" "" key val)++-- | Set a session cookie.+-- This should not live over browser restarts.+sesCookie :: Monad m => String -> String -> Result -> m Result+sesCookie key val = setCookieEx (-1) (Cookie "1" "/" "" key val)++-- | Delete a session cookie.+delSesCookie :: Monad m => String -> Result -> m Result+delSesCookie key = setCookieEx 0 (Cookie "1" "/" "" key "")++-}++-- | Set a Cookie in the Result.+-- The values are escaped as per RFC 2109, but some browsers may+-- have buggy support for cookies containing e.g. @\'\"\'@ or @\' \'@.+mkCookieHeader :: Seconds -> Cookie -> String+mkCookieHeader sec cookie =+ let l = [("Domain=",s cookieDomain)+ ,("Max-Age=",if sec < 0 then "" else show sec)+ ,("Path=", cookiePath cookie)+ ,("Version=", s cookieVersion)]+ s f | f cookie == "" = ""+ s f = '\"' : concatMap e (f cookie) ++ "\""+ e c | fctl c || c == '"' = ['\\',c]+ | otherwise = [c]+ in concat $ intersperse ";" ((cookieName cookie++"="++s cookieValue):[ (k++v) | (k,v) <- l, "" /= v ])++-- FIXME: validate at cookie creation.+validateCookie :: Monad m => Cookie -> m ()+validateCookie cookie+ = do when (null key || any (not . ftoken) key) $ fail ("Invalid cookie name: "++show key)+ let f n xs = when (any (not . fchar) xs) $ fail ("setCookieEx: "++n++": invalid character in value: "++show (xs))+ zipWithM_ f ["cookieValue","cookieDomain","cookieVersion"] $ map ($ cookie) [cookieValue, cookieDomain, cookieVersion]+ return ()+ where key = cookieName cookie++{-+-- | Deprecated. This will be deleted in future.+delSesCookie' :: (Monad m) => String -> m Result -> m Result+delSesCookie' key res = setCookieEx 0 (Cookie "1" "/" "" key "") =<< res+-}++{--setCookieEx' sec cook r0 = + let key = cookieName cook+ w = concat $ intersperse ";" ((key++"="++s cookieValue):[ (k++v) | (k,v) <- l, "" /= v ])+ l = [("Domain=",s cookieDomain)+ ,("Max-Age=",if sec < 0 then "" else show sec)+ ,("Path=", cookiePath cook)+ ,("Version=", s cookieVersion)]+ s f | f cook == "" = ""+ s f = '\"' : concatMap e (f cook) ++ "\""+ e c = case () of+ _ | fctl c || c == '"' -> ['\\',c]+ | otherwise -> [c]+ new = maybe w (\ss -> w++"\r\nSet-Cookie: "++C.unpack ss) $ getRsHeader "Set-Cookie" r0+ in + setHeader "Set-Cookie" new r0++delSesCookie' key = setCookieEx' 0 (Cookie "1" "/" "" key "")+--}+{- Cookie syntax:+ av-pairs = av-pair *(";" av-pair)+ av-pair = attr ["=" value] ; optional value+ attr = token+ value = word+ word = token | quoted-string+-}++gmany p = gmany1 p <++ return []+gmany1 p = do x <- p+ xs <- gmany1 p <++ return []+ return (x:xs)+gskipMany1 p = p >> (gskipMany p <++ return ())+gskipMany p = gskipMany1 p <++ return ()++fctl = \ch -> ch == chr 127 || ch <= chr 31+fseparator = \ch -> ch `elem` "()<>@,;:\\\"[]?={} \t" -- ignore '/' here+fchar = \ch -> ch <= chr 127+ftoken = \ch -> fchar ch && not (fctl ch || fseparator ch)+lws = ((char '\r' >> char '\n') <++ return ' ') >> gskipMany (satisfy (\ch -> ch == ' ' || ch == '\t'))+token = gmany $ satisfy ftoken+quotedString = do char '"' -- " stupid emacs syntax highlighting+ x <- many ((char '\\' >> satisfy fchar) <++ (satisfy $ \ch -> ch /= '"' && fchar ch && (ch == ' ' || ch == '\t' || not (fctl ch))))+ char '"' -- " stupid emacs syntax highlighting+ return x+word = quotedString <++ token++avPair = do+ k <- token+ lws >> char '=' >> lws+ v <- word+ return (low k,v)++sep = lws >> satisfy (\ch -> ch == ',' || ch == ';') >> lws++cookies :: ReadP [Cookie]+cookies = do+ let kpw n = do lws+ (k,v) <- avPair+ if k == n then return v else fail "Invalid key"+ ver <- ((kpw "$version" <~ sep) <++ return "")+ let ci = do (k,v) <- avPair+ p <- (sep >> kpw "$path") <++ return ""+ d <- (sep >> kpw "$domain") <++ return ""+ return $ Cookie ver p d k v+ x <- lws >> ci+ xs <- gmany (sep >> ci) <~ lws+ return (x:xs)++(<~) :: Monad m => m a -> m b -> m a+(<~) a b = do x <- a; b; return x++{- Debugging stuff+-- deb x = look >>= \s -> trace ("parse @ "++x++ ": "++show s) (return ())++t = mapM_ (\c -> putStrLn "" >> putStrLn c >> parse c >>= print) cs+q a b = C.putStrLn =<< getRsHeader "Set-Cookie" =<< setCookie 400 a b =<< sresult 200 "ok"+cs = ["$Version=\"1\"; Customer=\"WILE_E_COYOTE\"; $Path=\"/acme\""+ ,"$Version=\"1\"; Customer=\"WILE_E_COYOTE\"; $Path=\"/acme\"; Part_Number=\"Rocket_Launcher_0001\"; $Path=\"/acme\""+ ,"$Version=\"1\"; Customer=\"WILE_\"; $Path=\"/acme\"; Part_Number=\"Rocket_Launcher_0001\"; $Path=\"/acme\"; Shipping=\"FedEx\"; $Path=\"/acme\""+ ,"$Version=\"1\"; Part_Number=\"Riding_Rocket_0023\"; $Path=\"/acme/ammo\"; Part_Number=\"Rocket_Launcher_0001\"; $Path=\"/acme\""+ , "foo=bar"+ , "foo=\"bar\""+ , "foo=\"bar\\Zquote\""+ , "ses=; foo=\"bar\""+ , "foo=\"bar\"; ses="+ , "email=\"abcdefghi333@alexjacobson.com\"; session=427922315; ses=\"hii\""+ , "Path=/; ses=\"hii\"; session=427922315; email=\"abcdefghi333@alexjacobson.com\"; sessionId=\"552550384\""+ ]+-}+++parse :: Monad m => String -> m [Cookie]+parse i = case readP_to_S cookies i of+ [(res,"")] -> return res+ xs -> fail ("Invalid cookie syntax!: at position "++show (length i - length xs)++" input "++show i)++-- | Get all cookies from the HTTP request. The cookies are ordered per RFC from+-- the most specific to the least specific. Multiple cookies with the same+-- name are allowed to exist.+getCookies :: Monad m => C.ByteString -> m [Cookie]+getCookies header | C.null header = return []+ | otherwise = parse (C.unpack header)+++-- | Get the most specific cookie with the given name. Fails if there is no such+-- cookie or if the browser did not escape cookies in a proper fashion.+-- Browser support for escaping cookies properly is very diverse.+getCookie :: Monad m => String -> C.ByteString -> m Cookie+getCookie s h = do cs <- getCookies h+ case filter ((==) (low s) . cookieName) cs of+ [r] -> return r+ _ -> fail ("getCookie: " ++ show s)++low :: String -> String+low = map toLower+{-+-- | Get the value of the cookie that would be returned by 'getCookie'.+getCookieValue :: Monad m => String -> Request -> m String+getCookieValue s r = return . cookieValue =<< getCookie s r+-}
+ src/HAppS/Server/Cron.hs view
@@ -0,0 +1,20 @@+{-# OPTIONS -fglasgow-exts #-}+module HAppS.Server.Cron (cron)+-- (Seconds, CronEvent(..), everyNthSecond,runBackground)+ where++import Control.Concurrent+import Data.Typeable+import HAppS.State+import HAppS.Util.Concurrent+import Control.Monad+import System.Random++type Seconds = Int++cron :: Seconds -> IO () -> IO a+cron seconds action+ = loop+ where loop = do threadDelay (10^6 * seconds)+ action+ loop
+ src/HAppS/Server/Facebook.hs view
@@ -0,0 +1,440 @@+{-# OPTIONS -fcontext-stack=25 -fglasgow-exts -fth -fallow-overlapping-instances -fallow-undecidable-instances -cpp #-}+-- LANGUAGE TemplateHaskell, FlexibleInstances,+-- OverlappingInstances, UndecidableInstances +module HAppS.Server.Facebook where+import Control.Monad.Reader++import Data.Char+import Data.List+import Data.Maybe++import HAppS.Data+import HAppS.Data.Atom (Email(..))+import HAppS.Util.Common+import HAppS.Server.SURI+import HAppS.Server.SimpleHTTP hiding (escape,Method)++import HAppS.Crypto.MD5 ( md5, stringMD5)+import Text.Printf+import System.Directory++import Data.Generics++import qualified Network.Browser as Browser+import qualified Network.HTTP as HTTP+import Control.Monad.Identity++import HAppS.Server.XSLT+import HAppS.Server.HTTP.Types (Response,rsBody)+import qualified Data.ByteString.Lazy.Char8 as L+import System.Time+{--+Conceptually the demo app should expose functionality in website and facebook at once++1. facebook wrapper should take an fbconf and a require app added parameter+2. ServerParts that are depended on fb_Ses@(FB_Ses uid sessionId appadded)+ can we make them implicit parameters so the user doesn't have to see it?+3. if we get the parameters in a post then check valid and assign.+4. if we get parameters in a cookie then check valid and assign.+5. set cookie on initial login+6. calling API functions by typename before _response of returned XML+ Friends_get_response [uid] <- fb $ Fields fs .&. Title t++* make the response types be instances of HasArgs so fb can enforce+* define InCouple class that enforces that a type is inside the couple somewhere.+* enhance xml lib to allow matching if the constructor prefix matches. Then we get+ modify fb to drop _response in element name before converting.++ Friends_get_response [uid] <- fb $ Fields fs .&. Title t -- and it all typechecks!++also need to get pairs to drop the constructor names if present.+careful to only do so if they are present! e.g. UserName "alex" should become +userName=alex. But UserInfo (UserName "alex") should become userName=alex+++++uids fields title markup+uids1 uids2++so use heterogenous list of things that are convertible +--}+#ifndef __HADDOCK__+$(deriveAll [''Show,''Read,''Default, ''Eq, ''Ord]+ [d|+++ -- data FBSes = FBSes Uid SessionId AppAdded++ -- newtype SessionId = SessionId String+ -- newtype AppAdded = AppAdded Bool+ data Friends_getAppUsers_response = Friends_getAppUsers_response [Uid] + data Friends_get_response = Friends_get_response [Uid] ++ newtype Uid = Uid Integer+ newtype Friends = Friends [Integer]+ newtype Uids1 = Uids1 [Integer]+ newtype Uids2 = Uids2 [Integer]+ newtype Uids = Uids [Integer]++ -- used in array posted from multi-friend-input+ newtype Requested = Requested [Ids]+ newtype Ids = Ids Integer ++ newtype Fields = Fields [String]+ newtype Title = Title String+ newtype Method = Method String++++ data Fb_config = Fb_config Api_key Secret App_id Canvas_id Admins+ newtype Secret = Secret String+ newtype Api_key = Api_key String+ newtype App_id = App_id Int+ newtype Canvas_id = Canvas_id String+ newtype Admins = Admins [Uid]+ + + newtype Session_key=Session_key String + newtype Fb_sig_expires=Fb_sig_expires Int++ data FBSession = FBSession + Fb_sig_in_canvas + Fb_sig_added + Fb_sig_time+ Fb_sig_api_key + Fb_sig+ ---optional fields+ Fb_sig_user + Fb_sig_friends+ Fb_sig_session_key+ Fb_sig_expires+ Fb_sig_profile_update_time+ --stuff that is just carried here+ (Maybe (XSLTCmd,XSLPath))++ newtype Tbool = Tbool Bool+ newtype Tlist = Tlist [Int]+ data Friend_info = Friend_info Uid Uid Are_friends + newtype Are_friends = Are_friends Bool+ data Friends_areFriends_response = Friends_areFriends_response [Friend_info]+ newtype Users_getInfo_response = Users_getInfo_response [User]+ data Profile_setFBML_response = Profile_setFBML_response Bool+ data Profile_getFBML_response = Profile_getFBML_response String++ newtype Notifications_send_response = Notifications_send_response String+ newtype To_ids = To_ids [Integer]+ newtype Notification = Notification String+ data Error_response = Error_response Error_code+ newtype Error_code=Error_code Int+ --newtype Email = Email String+++ newtype Fb_sig_in_canvas = Fb_sig_in_canvas Bool + newtype Fb_sig_added = Fb_sig_added Bool+ newtype Fb_sig_time = Fb_sig_time Integer+ newtype Fb_sig_api_key = Fb_sig_api_key String+ newtype Fb_sig = Fb_sig String+ newtype Fb_sig_user = Fb_sig_user Integer+ newtype Fb_sig_friends = Fb_sig_friends [Integer] -- add automatic comma sep parse+ newtype Fb_sig_session_key= Fb_sig_session_key String+ newtype Fb_sig_profile_update_time = Fb_sig_profile_update_time Integer++ data User = User Uid (Maybe About_me) Affiliations -- we may need more lets see+ newtype About_me = About_me String+ newtype Affiliations = Affiliations [Affiliation]+ data Affiliation = Affiliation Nid Name Type Status Year+ newtype Nid = Nid Integer+ newtype Name = Name String+ newtype Type = Type String -- should be fixed later to enumeration+ newtype Status = Status String -- not sure what is here+ newtype Year = Year Int++ newtype AppUsers = AppUsers [Uid]+ data InviteInfo = InviteInfo Uid AppUsers BaseURL --- used for producing invites+ data NoFriends = NoFriends+ newtype InstallURL = InstallURL String+ newtype BaseURL = BaseURL String+ |]+ )++instance Version Uid+instance Version Element++$(deriveSerializeFor [ ''Uid+ , ''Element ])++#endif++a .$ b = b a+fb'::(?fb::Int)=>Int+fb' = ?fb+type FBInfo = (Api_key,Secret,FBSession)++friends_getAppUsers::(?fbSession::FBSession) => IO AppUsers+friends_getAppUsers = + do+ Friends_getAppUsers_response uids <- fb (?fbSession::FBSession) ()--(?fbInfo::FBInfo) ()+ return $ AppUsers $ gFind uids++users_getInfo uids fields = + do+ Users_getInfo_response users <- fb (?fbSession::FBSession) $ (Uids $ gFind uids) .&. (Fields fields)+ return users++--(networks::Maybe Affiliations) <- +getNetworks::(?fbSession::FBSession)=>IO (Maybe Affiliations)+getNetworks = return . gFind =<< users_getInfo [uid] ["affiliations"]+++--now we want to shift this so that the stuff is rendered in the present layer+notifications_send uids notifObj emailObj =+ do+ print "UIDS="+ print uids+ let (xsltcmd::XSLTCmd+ ,xslpath::XSLPath) = gFind' (?fbSession::FBSession)+ f x = do+ let els = toPublicXml x+ if null els then return "" else do+ let res = toResponse els+ xres <- doXslt xsltcmd xslpath res + (return . L.unpack . rsBody) xres+ + f :: (ToMessage a,Xml a)=> a -> IO String+ (notification::String) <- f notifObj+ (email::String) <- f emailObj+ Notifications_send_response confirm <-+ fb (?fbSession::FBSession) $ + (To_ids $ gFind uids) .&.+ (Notification notification) + -- .&. (Email email)+ .&. (if null email then Nothing else Just $ Email email)+ print "CONFIRM"+ print confirm+ --error "abc"+ return confirm+ ++--data Nofitications_send_response = Nofitications_send_response confirm ++profile_setFBML uid markup =+ do+ --can markup be passed as straight string of fbml?+ --how do we call out to xsl for this?+ Profile_setFBML_response x <- fb (?fbSession::FBSession) $ uid .&. markup+ return x++profile_getFBML uid =+ do+ Profile_getFBML_response markup <- fb (?fbSession::FBSession) $ uid+ --does this need decoding?+ return markup++friends_areFriends uids1 uids2 =+ do+ Friends_areFriends_response friendInfos <- + fb (?fbInfo::FBInfo) $ (Uids1 $ gFind uids1) .&. (Uids2 $ gFind uids2)+ return friendInfos+ +getMbUid () = return mbUid+getUid () = getMbUid () >>= return . fromJust+mbUid::(?fbSession::FBSession) => (Maybe Uid)+mbUid = fmap toUid $ gFind ?fbSession+uid::(?fbSession::FBSession) => (Uid)+uid = fromJust mbUid+friends::(?fbSession::FBSession) => (Friends)+friends = fromJust $ fmap toFriends $ gFind (?fbSession::FBSession)+numFriends::(?fbSession::FBSession) => Int+numFriends = let (Friends fs) = friends in length fs++--mbFriends = fmap toUid $ gFind ?fbSession+--time::(?fbSession::FBSession) => Integer+--time = let (Fb_sig_time t) = gFind' ?fbSession in t++getAppURLs = + do+ config <- getConfig+ let Api_key key = gFind' config+ Canvas_id cid = gFind' config+ installURL = InstallURL $ + "http://www.facebook.com/install.php?api_key="++key+ baseURL = BaseURL $ "http://apps.facebook/com/"++cid+ return (baseURL,installURL)++getInstallURL::(?fbSession::FBSession) => String -> IO InstallURL+getInstallURL (next) = + do+ config <- getConfig+ let Api_key key = gFind' config+ return $ InstallURL $ "http://www.facebook.com/install.php?api_key="++key+++ if null next then "" else "&next="++escape next++getBaseURL = do+ config <- getConfig+ let (Canvas_id cid) = gFind' config+ return $ BaseURL $ "http://apps.facebook/com/"++cid++"/"++--there is no invite info if all user's friends are app users+getInviteInfo::(?fbSession::FBSession) => IO (Maybe InviteInfo)+getInviteInfo = do+ appUsers@(AppUsers apps) <-friends_getAppUsers + -- let (Friends fs) = friends+ if numFriends == length apps then return Nothing else do+ return . Just . InviteInfo uid appUsers =<< getBaseURL+++ +++isAppAdded::(?fbSession::FBSession) => Bool+isAppAdded = maybe (error "no fb_sig_added") (const appAdded) mbAdded+ where + mbAdded = gFind ?fbSession + Fb_sig_added appAdded = fromJust mbAdded+--fakeEmail (Uid uid) = show uid ++ "@facebook.com"++getConfig = --yes reading a file is bad but roundtripping to fb sucks too+ do+ let path = "config/facebook.xml"+ fe <- doesFileExist path + when (not fe) $ error $ "you need a "++path++ "file of type fb_config"+ configData <- readFile path -- need error message if this fails+ print configData+ let (fb_config::Fb_config) = runIdentity $ fromString Flexible configData+ return fb_config+++getAdmins::IO [Uid]+getAdmins = getConfig >>= return . gFind++getIsAdmin::(?fbSession::FBSession) => IO Bool+getIsAdmin = getAdmins >>= return . elem uid+ ++fb fbSession a = + mdo+ fb_config <- getConfig+ TOD t _ <- getClockTime+ let req = makeReq t (fbSession,fb_config) a resp+ print "REQ="+ print req+ res <- spost fbserver req+ let body = HTTP.rspBody $ snd res+ print (body::String)+ print "body printed"+ let --mbResp = fromString Rigid body+ --resp = fromJust mbResp+ -- err = runIdentity $ fromString Flexible body+ resp = runIdentity $ fromString Flexible body+ -- Just (Error_code errCode) = gFind (err::Error_response)+ -- if errCode >0 then error $ show err else do+ --when (isNothing mbResp) $ error "BAD BODY" ++ body+ print resp+ print "resp returned"+ return resp++fbserver=suri $ fromJust $ parse "http://api.facebook.com/restserver.php"+++toUid (Fb_sig_user uid) = Uid uid+toFriends (Fb_sig_friends friends) = Friends friends+toSesKey (Fb_sig_session_key s) = Session_key s++makeReq t fbInfo a resp= req+ where+ [example,_] = [defaultValue,resp]+ cons = first toLower $ + show $ toConstr example+ fbCmd' = map (\x->if x=='_' then '.' else x) $ "facebook."++ cons+ method = Method $ if ".response" `isSuffixOf` fbCmd' + then take (length fbCmd'- (length "_response")) fbCmd'+ else fbCmd'+ sesKey = (fmap toSesKey (gFind fbInfo::Maybe Fb_sig_session_key))+ args = ("v","1.0"):("call_id",show t):+ (toPairs $ apikey .&. method .&. sesKey .&. a)+ s_args = sort args + Secret secret = fromJust $ gFind fbInfo+ (apikey::Api_key) = fromJust $ gFind fbInfo+ raw = concatMap (\(x,y)->x++'=':y) s_args ++ (secret)+ sig = stringMD5 (md5 (L.pack raw))+ req = s_args++[("sig",sig)]++{-+md5 = hex . map fromIntegral . MD5.hash . map (fromIntegral.fromEnum) +hex::[Integer]->String+hex = concatMap (printf "%02x") +-}++spost u q = Browser.browse $ Browser.request $ Browser.formToRequest $ + Browser.Form HTTP.POST u q+++consIf False x list = list+consIf _ x list = x:list++fbApp xslproc stylesheet app -- api_key secret app + = + xslt xslproc stylesheet [ withData fun]+ where+ fun (fbSes::FBSession) = app $ gSet (Just (xslproc,stylesheet)) fbSes+ --where+ --fbInfo = (api_key,secret,fbSes)::FBInfo ++onlyInstalled app = + if isAppAdded then app else + [uriRest $ \uri ->+ anyRequest $ fbSeeOther . gFind' =<< liftIO (getInstallURL uri)+ -- anyRequest $ fbSeeOther . gFind' =<< getInstallURL ""+ ]++postAdd :: Monad m => [ServerPartT m String]+postAdd = [uriRest $ \uri -> anyRequest $ fbSeeOther uri]+-- = ++fbSeeOther s = ok $ "<fb:redirect url=\""++s++"\"/>"++--ssh_forward host port = unsafePerformIO $ print "hello"+{--+fbapp fbconf handle =+ ReaderT $ \rq -> + do + + return "12"+--}++++--require args+-- fb (Session_key "abc" .&. Secret "abc") (Uid 123 .&. Title "abc")::IO Friends_get_response+-- Friends_get_response [Uid] <- fb fbInfo ()++--can make it typesafe. now we just need to deal with response+class HasArgs a b | a -> b +instance (HasT args Uid,HasT args Title) => HasArgs Friends_get_response args+f::(Default r,HasArgs r args) => args -> r+f a = defaultValue+Friends_get_response tf = f (Uid 123 .&. Title "abc" .&. Secret "abc")++{--+class HasTs targs args +instance HasTs Nil args+instance (HasTs targs args,HasT args t) =>HasTs (Couple t targs) args+--}++ --data FbInfo = FbInfo Fb_sig_in_canvas Fb_sig_user Fb_sig_session_key+{--+ newtype In_canvas=Fb_sig_in_canvas Bool+ newtype Time=Time Float+ newtype User=User Uid+ newtype Profile_update_time=Profile_update_time Integer++--}++{-- + newtype Fb_sig_friends=Fb_sig_friends [Uid]+ newtype Fb_sig_api_key=Fb_sig_api_key String+ newtype Fb_sig_added=Fb_sig_added Bool+ newtype Fb_sig=Fb_sig String+--}+
+ src/HAppS/Server/HTTP/Client.hs view
@@ -0,0 +1,81 @@+module HAppS.Server.HTTP.Client where+++import HAppS.Server.HTTP.Handler+import HAppS.Server.HTTP.Types+import Data.Maybe+import qualified Data.ByteString.Lazy.Char8 as L +--import HAppS.Server.AlternativeHTTP++import System.IO+import qualified Data.ByteString.Char8 as B +import Network++getResponse rq = withSocketsDo $ do+ let (hostName,port) = span (/=':') $ fromJust $ fmap B.unpack $ getHeader "host" rq + portInt = if null port then 80 else read $ tail port+ portId = PortNumber $ toEnum $ portInt+ h <- connectTo hostName portId + hSetBuffering h NoBuffering+ --print (hostName,portInt)+ --putRequest stdout rq+ --hFlush stdout++ putRequest h rq+ hFlush h++ inputStr <- L.hGetContents h+ --print $ L.take 200 inputStr+ return $ parseResponse inputStr++unproxify rq = rq {rqPaths = tail $ rqPaths rq,+ rqHeaders = + forwardedFor $ forwardedHost $ + setHeader "host" (head $ rqPaths rq) $+ rqHeaders rq}+ where+ appendInfo hdr val x = setHeader hdr (csv val $+ maybe "" B.unpack $+ getHeader hdr rq) x+ forwardedFor = appendInfo "X-Forwarded-For" (fst $ rqPeer rq)+ forwardedHost = appendInfo "X-Forwarded-Host" + (B.unpack $ fromJust $ getHeader "host" rq)+ --forwardedServer = appendInfo "X-Forwarded-Server" + -- how do we get server hostname? do we want this?+ csv v "" = v+ csv v x = x++", " ++ v++unrproxify defaultHost list rq = unproxify rq {rqPaths = host: rqPaths rq}+ where+ host::String+ host = maybe defaultHost (f .B.unpack) $+ getHeader "host" rq+ f = maybe defaultHost id . flip lookup list++++{-- setHeader forwardedForC (csv $ + maybe "" B.unpack $+ getHeader forwardedForC rq) x--}+{-- where cmd = "curl"++ args =["-L","-D","-"]++postFlag++[url]+ url = tail $ rqURL rq+ Body body = rqBody rq+ meth = rqMethod rq+ postFlag::[String]+ postFlag = if meth == GET then [] else ["--data-binary",L.unpack body]+ ctype = maybe [] ((\c->["-H","content-type: "++c]) . B.unpack) $ + getHeader "content-type" rq+ io = do+ (hIn,hOut,hErr,pi) <- runInteractiveProcess cmd args Nothing Nothing+ inputStr <- L.hGetContents hOut+ print inputStr+ return $ parseResponse inputStr+ --} ++ -- -H "host: abc" sends a header+ -- and we get back the header with+ -- post content-type and return content-type++
+ src/HAppS/Server/HTTP/Clock.hs view
@@ -0,0 +1,30 @@+{-# OPTIONS -fno-cse #-}+module HAppS.Server.HTTP.Clock(getApproximateTime) where++import Control.Concurrent+import Data.IORef+import System.IO.Unsafe+import System.Time+import System.Locale++import qualified Data.ByteString.Char8 as B++mkTime :: IO B.ByteString+mkTime = do now <- getClockTime+ return $ B.pack (formatCalendarTime defaultTimeLocale "%a, %d %b %Y %X GMT" (toUTCTime now))+++{-# NOINLINE clock #-}+clock :: IORef B.ByteString+clock = unsafePerformIO $ do+ ref <- newIORef =<< mkTime+ forkIO $ updater ref+ return ref++updater :: IORef B.ByteString -> IO ()+updater ref = do threadDelay (10^6 * 1) -- Every second+ writeIORef ref =<< mkTime+ updater ref++getApproximateTime :: IO B.ByteString+getApproximateTime = readIORef clock
+ src/HAppS/Server/HTTP/FileServe.hs view
@@ -0,0 +1,185 @@+{-# OPTIONS -fglasgow-exts #-}+module HAppS.Server.HTTP.FileServe+ (+ MimeMap,fileServe, mimeTypes,isDot, blockDotFiles,doIndex,errorwrapper+ ) where++import Control.Exception+import Control.Monad.Reader+import Control.Monad.Trans+import Data.List+import Data.Maybe+import HAppS.Server.SimpleHTTP+import System.Directory+import System.IO+import System.Locale(defaultTimeLocale)+import System.Log.Logger+import System.Time -- (formatCalendarTime, toUTCTime,TOD(..))+import qualified Data.ByteString.Char8 as P+import qualified Data.ByteString.Lazy.Char8 as L+import qualified Data.Map as Map+import qualified HAppS.Server.SimpleHTTP as SH++-- mapResult :: (IO Result -> IO Result) -> [ServerPart] -> ServerPart+-- mapResult fn parts = ReaderT $ \rq -> fmap fn (runReaderT (multi parts) rq++errorwrapper :: MonadIO m => String -> String -> ServerPartT m Response+errorwrapper binarylocation loglocation+ = require getErrorLog $ \errorLog ->+ --[method () $ SH.ok errorLog]+ [anyRequest $ liftIO $ return $ toResponse errorLog]+ where getErrorLog+ = liftIO $+ handleJust ioErrors (const (return Nothing)) $+ do bintime <- getModificationTime binarylocation+ logtime <- getModificationTime loglocation+ if (logtime > bintime)+ then fmap Just $ readFile loglocation -- fileServe [loglocation] [] "./"+ else return Nothing++type MimeMap = Map.Map String String++doIndex [] _mime _rq _fp = do setResponseCode 403+ return $ toResponse "Directory index forbidden"+doIndex (index:rest) mime rq fp =+ do+ let path = fp++'/':index+ --print path+ fe <- liftIO $ doesFileExist path+ if fe then retFile path else doIndex rest mime rq fp+ where retFile = returnFile mime rq+defaultIxFiles= ["index.html","index.xml","index.gif"]++fileServe :: MonadIO m => [FilePath] -> FilePath -> ServerPartT m Response+fileServe ixFiles localpath = + withRequest (fileServe' localpath (doIndex (ixFiles++defaultIxFiles)) mimeTypes)++-- | Serve files with a mime type map under a directory.+-- Uses the function to transform URIs to FilePaths.+fileServe' localpath fdir mime rq = do+ let fp2 = takeWhile (/=',') fp+ fp = filepath+ safepath = filter (\x->not (null x) && head x /= '.') (rqPaths rq)+ filepath = intercalate "/" (localpath:safepath)+ fp' = if null safepath then "" else last safepath+ if "TESTH" `isPrefixOf` fp'+ then renderResponse mime rq $ fakeFile $ read $ drop 5 $ fp' + else do+ fe <- liftIO $ doesFileExist fp+ fe2 <- liftIO $ doesFileExist fp2+ de <- liftIO $ doesDirectoryExist fp+ -- error $ "show ilepath: " ++show (fp,de)+ let status | de = "DIR"+ | fe = "file"+ | fe2 = "group"+ | True = "NOT FOUND"+ liftIO $ logM "HAppS.Server.HTTP.FileServe" INFO ("fileServe: "++show fp++" \t"++status)+ if de then fdir mime rq fp else do+ getFile mime fp >>= flip either (renderResponse mime rq) + (const $ returnGroup localpath mime rq safepath)++returnFile mime rq fp = + getFile mime fp >>= either fileNotFound (renderResponse mime rq)++--- #if fp has , separated then return concatenation with content-type of last+-- #and last modified of latest+tr a b list = map (\x->if x==a then b else x) list+ltrim = dropWhile (flip elem " \t\r") ++returnGroup localPath mime rq fp = do+ let fps0 = map ((:[]). ltrim) $ lines $ tr ',' '\n' $ last fp+ fps = map (intercalate "/" . ((localPath:init fp) ++)) fps0++ -- if (head $ head fps0)=="TEST" then renderResponse mime rq fakeFile else do++ mbFiles <- mapM (getFile mime) $ fps+ let notFounds = [x | Left x <- mbFiles]+ files = [x | Right x <- mbFiles]+ if not $ null notFounds + then fileNotFound $ drop (length localPath) $ head notFounds else do+ let totSize = sum $ map (snd . fst) files+ maxTime::ClockTime = maximum $ map (fst . fst) files++ renderResponse mime rq ((maxTime,totSize),(fst $ snd $ head files,+ L.concat $ map (snd . snd) files))++++fileNotFound fp = do setResponseCode 404 + return $ toResponse $ "File not found "++ fp+--fakeLen = 71* 1024+fakeFile fakeLen = ((TOD 0 0,L.length body),("text/javascript",body))+ where+ body = L.pack $ (("//"++(show len)++" ") ++ ) $ (take len $ repeat '0') ++ "\n"+ len = fromIntegral fakeLen++getFile mime fp = do+ let ct = Map.findWithDefault "text/plain" (getExt fp) mime+ fe <- liftIO $ doesFileExist fp+ if not fe then return $ Left fp else do+ + time <- liftIO $ getModificationTime fp+ h <- liftIO $ openBinaryFile fp ReadMode+ size <- liftIO $ hFileSize h+ lbs <- liftIO $ L.hGetContents h+ return $ Right ((time,size),(ct,lbs))++++renderResponse mime rq ((modtime,size),(ct,body)) = do++ let notmodified = getHeader "if-modified-since" rq == Just (P.pack $ repr)+ repr = formatCalendarTime defaultTimeLocale + "%a, %d %b %Y %X GMT" (toUTCTime modtime)+ -- "Mon, 07 Jan 2008 19:51:02 GMT"+ -- when (isJust $ getHeader "if-modified-since" rq) $ error $ show $ getHeader "if-modified-since" rq+ if notmodified then do setResponseCode 304 ; return $ toResponse "" else do+ let mod = getHeader "if-modified-since" rq+ modifyResponse (setHeader "HUH" $ show $ (fmap P.unpack mod == Just repr,mod,Just repr))+ modifyResponse (setHeader "Last-modified" repr)+ -- if %Z or UTC are in place of GMT below, wget complains that the last-modified header is invalid+ modifyResponse (setHeader "Content-Length" (show size))+ modifyResponse (setHeader "Content-Type" ct) + return $ resultBS 200 body++ +++getExt fPath = reverse $ takeWhile (/='.') $ reverse fPath++-- | Ready collection of common mime types.+mimeTypes :: MimeMap+mimeTypes = Map.fromList+ [("xml","application/xml")+ ,("xsl","application/xml")+ ,("js","text/javascript")+ ,("html","text/html")+ ,("css","text/css")+ ,("gif","image/gif")+ ,("jpg","image/jpeg")+ ,("png","image/png")+ ,("txt","text/plain")+ ,("doc","application/msword")+ ,("exe","application/octet-stream")+ ,("pdf","application/pdf")+ ,("zip","application/zip")+ ,("gz","application/x-gzip")+ ,("ps","application/postscript")+ ,("rtf","application/rtf")+ ,("wav","application/x-wav")+ ,("hs","text/plain")]++++blockDotFiles :: (Request -> IO Response) -> Request -> IO Response+blockDotFiles fn rq+ | isDot (intercalate "/" (rqPaths rq)) = return $ result 403 "Dot files not allowed."+ | otherwise = fn rq++isDot = isD . reverse+ where+ isD ('.':'/':_) = True+ isD ['.'] = True+ --isD ('/':_) = False+ isD (_:cs) = isD cs+ isD [] = False
+ src/HAppS/Server/HTTP/Handler.hs view
@@ -0,0 +1,335 @@+{-# OPTIONS -fglasgow-exts -cpp #-}+module HAppS.Server.HTTP.Handler(request-- version,required+ ,parseResponse,putRequest+-- ,unchunkBody,val,testChunk,pack+) where+-- ,fsepC,crlfC,pversion+import Control.Exception as E+import Control.Monad+import Data.List(foldl',unfoldr,elemIndex)+import Data.Char(toLower)+import Data.Maybe ( fromMaybe, fromJust )+import qualified Data.List as List+import qualified Data.ByteString.Char8 as P+import qualified Data.ByteString.Char8 as B+import qualified Data.ByteString.Lazy.Char8 as L+import qualified Data.ByteString.Unsafe as U+import qualified Data.Map as M+import System.IO+import System.Locale(defaultTimeLocale)+import System.Time+import Numeric+import Data.Maybe+import Data.Int (Int64)+import HAppS.Server.Cookie+import HAppS.Server.HTTP.Clock+import HAppS.Server.HTTP.LazyLiner+import HAppS.Server.HTTP.Types+import HAppS.Server.HTTP.Multipart+import HAppS.Server.HTTP.RFC822Headers+--import HAppS.Server.HTTP.RFC822HeadersBinary+import HAppS.Server.MessageWrap+import HAppS.Server.SURI(SURI(..),path,query)+import HAppS.Server.SURI.ParseURI+import HAppS.Util.ByteStringCompat+import HAppS.Util.TimeOut++import System.Log.Logger hiding (debugM)++pack = L.pack+logMH = logM "HAppS.Server.HTTP.Handler" DEBUG++request :: Conf -> Handle -> Host -> (Request -> IO Response) -> IO ()+request conf h host handler = rloop conf h host handler =<< L.hGetContents h++required :: String -> Maybe a -> Either String a+required err Nothing = Left err+required _ (Just a) = Right a++transferEncodingC = "transfer-encoding"+rloop conf h host handler inputStr+ | L.null inputStr = return ()+ | otherwise+ = join $ withTimeOut (30 * second) $+ do let parseRequest+ = do (topStr, restStr) <- required "failed to separate request" $ splitAtEmptyLine inputStr+ (rql, headerStr) <- required "failed to separate headers/body" $ splitAtCRLF topStr+ let (m,u,v) = requestLine rql+ headers' <- parseHeaders "host" (L.unpack headerStr)+-- headers' <- required "host" $ parseBHeaders headerStr+ let headers = mkHeaders headers'+-- let headers = M.fromList $ headers'+ let contentLength = fromMaybe 0 $ fmap fst (P.readInt =<< getHeaderUnsafe contentlengthC headers)+ (body, nextRequest) <- case () of+ () | contentLength < 0 -> fail "negative content-length"+ | isJust $ getHeader transferEncodingC headers ->+ return $ consumeChunks restStr+ | otherwise -> return (L.splitAt (fromIntegral contentLength) restStr)+ let cookies = [ (cookieName c, c) | cl <- fromMaybe [] (fmap getCookies (getHeader "Cookie" headers)), c <- cl ] -- Ugle+ rqTmp = Request m (pathEls (path u)) (query u) + [] cookies v headers (Body body) host+ rq = rqTmp{rqInputs = queryInput u ++ bodyInput rqTmp}+ return (rq, nextRequest)+ case parseRequest of+ Left err -> error $ "failed to parse HTTP request: " ++ err+ Right (req, rest)+ -> return $ -- logMH (show req) >>+ do let ioseq act = act >>= \x -> x `seq` return x+ res <- ioseq (handler req) `E.catch` \e -> return $ result 500 $ "Server error: " ++ show e+ putAugmentedResult h req res+ when (continueHTTP req res) $ rloop conf h host handler rest++parseResponse inputStr =+ do (topStr,restStr) <- required "failed to separate response" $ + splitAtEmptyLine inputStr+ (rsl,headerStr) <- required "failed to separate headers/body" $+ splitAtCRLF topStr+ let (v,code) = responseLine rsl+ headers' <- parseHeaders "host" (L.unpack headerStr)+ let headers = mkHeaders headers'+ let mbCL = fmap fst (B.readInt =<< getHeader "content-length" headers)+ rsFlags = RsFlags $ not $ isJust mbCL+ (body,nextResp) <-+ maybe (if (isNothing $ getHeader "transfer-encoding" headers) + then return (restStr,L.pack "") + else return $ consumeChunks restStr)+ (\cl->return (L.splitAt (fromIntegral cl) restStr))+ mbCL+ return $ Response {rsCode=code,rsHeaders=headers,rsBody=body,rsFlags=RsFlags True}+val = "71 \r\n\n<title> i2x.com </title>\n\n\n<H1> This is i2x.com </H1>\n\nContact <a href=\"mailto:contact20020212@i2x.com\">us.</a>\n\r\n0\r\n\r\n"++testChunk x = x == (L.unpack $ fst $ consumeChunks $ L.pack x)+-- http://www.w3.org/Protocols/rfc2616/rfc2616-sec3.html+-- note this does NOT handle extenions+consumeChunks::L.ByteString->(L.ByteString,L.ByteString)+consumeChunks str = let (parts,tr,rest) = consumeChunksImpl str in (L.concat . (++ [tr]) .map snd $ parts,rest)++consumeChunksImpl :: L.ByteString -> ([(Int64, L.ByteString)], L.ByteString, L.ByteString)+consumeChunksImpl str+ | L.null str = ([],L.empty,str)+ | chunkLen == 0 = let (last,rest') = L.splitAt lenLine1 str+ (tr,rest'') = getTrailer rest' + in ([(0,last)],tr,rest'')+ | otherwise = ((chunkLen,part):crest,tr,rest2)+ where+ line1 = head $ lazylines str + lenLine1 = (L.length line1) + 1 -- endchar+ chunkLen = (fst $ head $ readHex $ L.unpack line1)+ len = chunkLen + lenLine1 + 2+ (part,rest) = L.splitAt len str+ (crest,tr,rest2) = consumeChunksImpl rest+ getTrailer str = L.splitAt index str+ where index | crlfLC `L.isPrefixOf` str = 2+ | otherwise = let iscrlf = L.zipWith (\a b -> a == '\r' && b == '\n') str . L.tail $ str+ Just i = elemIndex True $ zipWith (&&) iscrlf (tail (tail iscrlf))+ in fromIntegral $ i+4+chunk :: Int64 -> L.ByteString -> L.ByteString+chunk n = L.concat . concatMap (\c -> [L.pack . flip showHex "" . L.length $ c,crlfLC,c,crlfLC]) . (++ [L.empty]) . splits n+ where + splits n = unfoldr (\xs -> if L.null xs then Nothing else Just (L.splitAt n xs))++unchunk :: L.ByteString -> (L.ByteString, L.ByteString -- ^ the trailer part, unparsed, plus the final \r\n+ ,L.ByteString)+unchunk bs = let (parts,tr,rest) = consumeChunksImpl bs+ in (L.concat . map clean $ parts,tr, rest)+ where clean (sz,bs) = L.take sz . L.drop 1 . snd . L.break (== '\n') $ bs+++crlfLC = L.pack "\r\n"++-- Properly lazy version of 'lines' for lazy bytestrings+lazylines :: L.ByteString -> [L.ByteString]+lazylines s+ | L.null s = []+ | otherwise =+ let (l,s') = L.break ((==) '\n') s+ in l : if L.null s' then []+ else lazylines (L.tail s') + ++++{-+presult :: Handle -> IO Result+presult h = do+ liner <- newLinerHandle h++ rls@(rql:hrl) <- headerLines liner+ let c = responseLine rql+ hh = combineHeaders $ headers hrl []++ let mread k = return (fmap fst (P.readInt =<< M.lookup k hh))+ cl <- mread contentlengthC+ body <- case cl of+ Nothing -> fmap toChunks $ getRest liner+ Just c | c < 0 -> fail "Negative content-length"+ | otherwise -> fmap toChunks $ getBytes liner c+ return $ Result c hh nullRsFlags body+-}++headers [] acc = acc+headers (line:rest) acc =+ let space = let x = P.head line in x == ' ' || x == '\t' in+ case () of+ _ | space && null acc -> error "Continuation header as first header"+ | space -> let ((k,v):r) = acc in headers rest ((k,P.append v line):r)+ | otherwise -> let (k,raw) = breakChar ':' line+ v = dropSpaceEnd $ dropSpace $ P.tail raw+ in headers rest ((k,v):acc)+ +requestLine l = case P.words ((P.concat . L.toChunks) l) of+ [rq,uri,ver] -> (method rq, SURI $ parseURIRef uri, version ver)+ [rq,uri] -> (method rq, SURI $ parseURIRef uri,Version 0 9)++--responseLine l = case P.words l of (v:c:_) -> version v `seq` fst (fromJust (P.readInt c))++responseLine l = case B.words ((B.concat . L.toChunks) l) of + (v:c:_) -> version v `seq` (v,fst (fromJust (B.readInt c)))+++method r = fj $ lookup r mtable+ where fj (Just x) = x+ fj Nothing = error "invalid request method"+ mtable = [(P.pack "GET", GET),+ (P.pack "HEAD", HEAD),+ (P.pack "POST", POST),+ (P.pack "PUT", PUT),+ (P.pack "DELETE", DELETE),+ (P.pack "TRACE", TRACE),+ (P.pack "OPTIONS", OPTIONS),+ (P.pack "CONNECT", CONNECT)]+++combineHeaders :: [(P.ByteString,P.ByteString)] -> M.Map P.ByteString P.ByteString+combineHeaders = foldl' w M.empty+ where w m (k,v) = M.insertWith (\n o -> P.concat [o, P.pack ", ", n])+ (P.map toLower k) v m++-- Result side++staticHeaders :: Headers+staticHeaders =+ foldr (uncurry setHeaderBS) (mkHeaders [])+ [ (serverC, happsC), (contentTypeC, textHtmlC) ]++putAugmentedResult :: Handle -> Request -> Response -> IO ()+putAugmentedResult h req res = do+ let ph (HeaderPair k vs) = map (\v -> P.concat [k, fsepC, v, crlfC]) vs+ raw <- getApproximateTime+ let cl = L.length $ rsBody res+ let put x = P.hPut h x+ -- TODO: Hoist static headers to the toplevel.+ let stdHeaders = staticHeaders `M.union`+ M.fromList ( [ (dateCLower, HeaderPair dateC [raw])+ , (connectionCLower, HeaderPair connectionC [if continueHTTP req res then keepAliveC else closeC])+ ] ++ if rsfContentLength (rsFlags res)+ then [(contentlengthC, HeaderPair contentLengthC [P.pack (show cl)])]+ else [] )+ allHeaders = rsHeaders res `M.union` stdHeaders -- 'union' prefers 'headers res' when duplicate keys are encountered.++ mapM_ put $ concat+ [ (pversion $ rqVersion req) -- Print HTTP version+ , [responseMessage $ rsCode res] -- Print responseCode+ , concatMap ph (M.elems allHeaders) -- Print all headers+ , [crlfC]+ ]+ when (rqMethod req /= HEAD) $ L.hPut h $ rsBody res+-- logMH "Flushing connection"+ hFlush h+++putRequest h rq = do + let put x = B.hPut h x+ ph (HeaderPair k vs) = map (\v -> B.concat [k, fsepC, v, crlfC]) vs+ sp = [B.pack " "]+ mapM_ put $ concat+ [[B.pack $ show $ rqMethod rq],sp+ ,[B.pack $ rqURL rq],sp+ ,(pversion $ rqVersion rq), [crlfC]+ ,concatMap ph (M.elems $ rqHeaders rq)+ ,[crlfC]+ ]+ let Body body = rqBody rq+ L.hPut h body+ hFlush h++++-- Version++pversion (Version 1 1) = [http11]+pversion (Version 1 0) = [http10]+pversion (Version x y) = [P.pack "HTTP/", P.pack (show x), P.pack ".", P.pack (show y)]++version x | x == http09 = Version 0 9+ | x == http10 = Version 1 0+ | x == http11 = Version 1 1+ | otherwise = error "Invalid HTTP version"++http09 = P.pack "HTTP/0.9"+http10 = P.pack "HTTP/1.0"+http11 = P.pack "HTTP/1.1"++-- Constants++connectionC = P.pack "Connection"+connectionCLower = P.map toLower connectionC+closeC = P.pack "close"+keepAliveC = P.pack "Keep-Alive"+--connectionCloseC = P.pack "Connection: close\r\n"+--connectionKeepC = P.pack "Connection: keep-alive\r\n"+crlfC = P.pack "\r\n"+fsepC = P.pack ": "+contentTypeC = P.pack "Content-Type"+contentLengthC = P.pack "Content-Length"+contentlengthC = P.pack "content-length"+dateC = P.pack "Date"+dateCLower = P.map toLower dateC+serverC = P.pack "Server"+happsC = P.pack "HAppS/0.8.4"+textHtmlC = P.pack "text/html; charset=utf-8"++-- Response code names++responseMessage 100 = P.pack " 100 Continue\r\n"+responseMessage 101 = P.pack " 101 Switching Protocols\r\n"+responseMessage 200 = P.pack " 200 OK\r\n"+responseMessage 201 = P.pack " 201 Created\r\n"+responseMessage 202 = P.pack " 202 Accepted\r\n"+responseMessage 203 = P.pack " 203 Non-Authoritative Information\r\n"+responseMessage 204 = P.pack " 204 No Content\r\n"+responseMessage 205 = P.pack " 205 Reset Content\r\n"+responseMessage 206 = P.pack " 206 Partial Content\r\n"+responseMessage 300 = P.pack " 300 Multiple Choices\r\n"+responseMessage 301 = P.pack " 301 Moved Permanently\r\n"+responseMessage 302 = P.pack " 302 Found\r\n"+responseMessage 303 = P.pack " 303 See Other\r\n"+responseMessage 304 = P.pack " 304 Not Modified\r\n"+responseMessage 305 = P.pack " 305 Use Proxy\r\n"+responseMessage 307 = P.pack " 307 Temporary Redirect\r\n"+responseMessage 400 = P.pack " 400 Bad Request\r\n"+responseMessage 401 = P.pack " 401 Unauthorized\r\n"+responseMessage 402 = P.pack " 402 Payment Required\r\n"+responseMessage 403 = P.pack " 403 Forbidden\r\n"+responseMessage 404 = P.pack " 404 Not Found\r\n"+responseMessage 405 = P.pack " 405 Method Not Allowed\r\n"+responseMessage 406 = P.pack " 406 Not Acceptable\r\n"+responseMessage 407 = P.pack " 407 Proxy Authentication Required\r\n"+responseMessage 408 = P.pack " 408 Request Time-out\r\n"+responseMessage 409 = P.pack " 409 Conflict\r\n"+responseMessage 410 = P.pack " 410 Gone\r\n"+responseMessage 411 = P.pack " 411 Length Required\r\n"+responseMessage 412 = P.pack " 412 Precondition Failed\r\n"+responseMessage 413 = P.pack " 413 Request Entity Too Large\r\n"+responseMessage 414 = P.pack " 414 Request-URI Too Large\r\n"+responseMessage 415 = P.pack " 415 Unsupported Media Type\r\n"+responseMessage 416 = P.pack " 416 Requested range not satisfiable\r\n"+responseMessage 417 = P.pack " 417 Expectation Failed\r\n"+responseMessage 500 = P.pack " 500 Internal Server Error\r\n"+responseMessage 501 = P.pack " 501 Not Implemented\r\n"+responseMessage 502 = P.pack " 502 Bad Gateway\r\n"+responseMessage 503 = P.pack " 503 Service Unavailable\r\n"+responseMessage 504 = P.pack " 504 Gateway Time-out\r\n"+responseMessage 505 = P.pack " 505 HTTP Version not supported\r\n"+responseMessage x = P.pack (show x ++ "\r\n")+
+ src/HAppS/Server/HTTP/LazyLiner.hs view
@@ -0,0 +1,41 @@+{-# OPTIONS -ffi #-}+module HAppS.Server.HTTP.LazyLiner+ (Lazy, newLinerHandle, headerLines, getBytes, getBytesStrict, getRest, L.toChunks+ ) where++import Control.Concurrent.MVar+import System.IO+import qualified Data.ByteString.Char8 as P+import qualified Data.ByteString.Lazy.Char8 as L++newtype Lazy = Lazy (MVar L.ByteString)++newLinerHandle :: Handle -> IO Lazy+newLinerHandle h = fmap Lazy (newMVar =<< L.hGetContents h)++headerLines :: Lazy -> IO [P.ByteString]+headerLines (Lazy mv) = modifyMVar mv $ \l -> do+ let loop acc r0 = let (h,r) = L.break ((==) ch) r0+ ph = toStrict h+ phl = P.length ph+ ph2 = if phl == 0 || P.last ph /= '\x0D' then ph else P.init ph+ ch = '\x0A'+ r' = if L.null r then r else L.tail r+ in if P.length ph2 == 0 then (r', reverse acc) else loop (ph2:acc) r'+ return $ loop [] l++getBytesStrict :: Lazy -> Int -> IO P.ByteString+getBytesStrict (Lazy mv) len = modifyMVar mv $ \l -> do+ let (h,p) = L.splitAt (fromIntegral len) l+ return (p, toStrict h)++getBytes :: Lazy -> Int -> IO L.ByteString+getBytes (Lazy mv) len = modifyMVar mv $ \l -> do+ let (h,p) = L.splitAt (fromIntegral len) l+ return (p, h)++getRest :: Lazy -> IO L.ByteString+getRest (Lazy mv) = modifyMVar mv $ \l -> return (L.empty, l)++toStrict :: L.ByteString -> P.ByteString+toStrict = P.concat . L.toChunks
+ src/HAppS/Server/HTTP/Listen.hs view
@@ -0,0 +1,48 @@+{-# OPTIONS -cpp #-}+module HAppS.Server.HTTP.Listen(listen) where++import System.Log.Logger++import HAppS.Server.HTTP.Types+import HAppS.Server.HTTP.Handler++import Control.Exception as E+import Control.Concurrent+import Network+import System.IO++import HAppS.Util.Exception++{-+#ifndef mingw32_HOST_OS+-}+import System.Posix.Signals+{-+#endif+-}++listen :: Conf -> (Request -> IO Response) -> IO ()+listen conf hand = do+{-+#ifndef mingw32_HOST_OS+-}+ installHandler openEndedPipe Ignore Nothing+{-+#endif+-}+ s <- listenOn $ PortNumber $ toEnum $ port conf+ let work (h,hn,p) = do -- hSetBuffering h NoBuffering+ let eh x = logM "HAppS.Server.HTTP.Listen" ERROR ("HTTP request failed with: "++show x)+ request conf h (hn,fromIntegral p) hand `E.catch` eh+ hClose h+ let msg = "\nIPV6 is not supported yet. \nLikely you made a localhost request \n"+++ "and your machine resolved localhost to an IPv6 address. \n"+++ "Use http://127.0.0.1:"++(show $ port conf)++"\n"+ loop = do accept s >>= forkIO . work+ loop+ -- let loop = accept s >>= forkIO . work >> loop+ let pe e = do logM "HAppS.Server.HTTP.Listen" ERROR ("ERROR in accept thread: "++show e)+ hPutStr stderr msg+ let infi = (loop `catchSome` pe) >> infi+ infi `finally` sClose s+
+ src/HAppS/Server/HTTP/LowLevel.hs view
@@ -0,0 +1,28 @@+module HAppS.Server.HTTP.LowLevel+ (-- * HTTP Implementation+ -- $impl++ -- * Problems+ -- $problems++ -- * API+ module HAppS.Server.HTTP.Handler,+ module HAppS.Server.HTTP.Listen,+ module HAppS.Server.HTTP.Types+ ) where++import HAppS.Server.HTTP.Handler+import HAppS.Server.HTTP.Listen+import HAppS.Server.HTTP.Types++-- $impl+-- The HAppS HTTP implementation supports HTTP 1.0 and 1.1.+-- Multiple request on a connection including pipelining is supported.++-- $problems+-- Currently if a client sends an invalid HTTP request the whole+-- connection is aborted and no further processing is done.+--+-- When the connection times out HAppS closes it. In future it could+-- send a 408 response but this may be problematic if the sending+-- of a response caused the problem.
+ src/HAppS/Server/HTTP/Multipart.hs view
@@ -0,0 +1,216 @@+-- #hide++-----------------------------------------------------------------------------+-- |+-- Module : HAppS.Server.HTTP.Multipart+-- Copyright : (c) Peter Thiemann 2001,2002+-- (c) Bjorn Bringert 2005-2006+-- (c) Lemmih 2007+-- License : BSD-style+--+-- Maintainer : lemmih@vo.com+-- Stability : experimental+-- Portability : xbnon-portable+--+-- Parsing of the multipart format from RFC2046.+-- Partly based on code from WASHMail.+--+-----------------------------------------------------------------------------+module HAppS.Server.HTTP.Multipart+ (+ -- * Multi-part messages+ MultiPart(..), BodyPart(..), Header+ , parseMultipartBody, hGetMultipartBody+ -- * Headers+ , ContentType(..), ContentTransferEncoding(..)+ , ContentDisposition(..)+ , parseContentType+ , parseContentTransferEncoding+ , parseContentDisposition+ , getContentType+ , getContentTransferEncoding+ , getContentDisposition++ , splitAtEmptyLine+ , splitAtCRLF+ ) where++import Control.Monad+import Data.Int (Int64)+import Data.Maybe+import System.IO (Handle)++import HAppS.Server.HTTP.RFC822Headers++import qualified Data.ByteString.Lazy.Char8 as BS+import Data.ByteString.Lazy.Char8 (ByteString)++--+-- * Multi-part stuff.+--++data MultiPart = MultiPart [BodyPart]+ deriving (Show, Read, Eq, Ord)++data BodyPart = BodyPart [Header] ByteString+ deriving (Show, Read, Eq, Ord)++-- | Read a multi-part message from a 'ByteString'.+parseMultipartBody :: String -- ^ Boundary+ -> ByteString -> Maybe MultiPart+parseMultipartBody b s = + do+ ps <- splitParts (BS.pack b) s+ liftM MultiPart $ mapM parseBodyPart ps++-- | Read a multi-part message from a 'Handle'.+-- Fails on parse errors.+hGetMultipartBody :: String -- ^ Boundary+ -> Handle+ -> IO MultiPart+hGetMultipartBody b h = + do+ s <- BS.hGetContents h+ case parseMultipartBody b s of+ Nothing -> fail "Error parsing multi-part message"+ Just m -> return m++++parseBodyPart :: ByteString -> Maybe BodyPart+parseBodyPart s =+ do+ (hdr,bdy) <- splitAtEmptyLine s+ hs <- parseM pHeaders "<input>" (BS.unpack hdr)+ return $ BodyPart hs bdy++--+-- * Splitting into multipart parts.+--++-- | Split a multipart message into the multipart parts.+splitParts :: ByteString -- ^ The boundary, without the initial dashes+ -> ByteString + -> Maybe [ByteString]+splitParts b s = dropPreamble b s >>= spl+ where+ spl x = case splitAtBoundary b x of+ Nothing -> Nothing+ Just (s1,d,s2) | isClose b d -> Just [s1]+ | otherwise -> spl s2 >>= Just . (s1:)++-- | Drop everything up to and including the first line starting +-- with the boundary. Returns 'Nothing' if there is no +-- line starting with a boundary.+dropPreamble :: ByteString -- ^ The boundary, without the initial dashes+ -> ByteString + -> Maybe ByteString+dropPreamble b s | isBoundary b s = fmap snd (splitAtCRLF s)+ | otherwise = dropLine s >>= dropPreamble b++-- | Split a string at the first boundary line.+splitAtBoundary :: ByteString -- ^ The boundary, without the initial dashes+ -> ByteString -- ^ String to split.+ -> Maybe (ByteString,ByteString,ByteString)+ -- ^ The part before the boundary, the boundary line,+ -- and the part after the boundary line. The CRLF+ -- before and the CRLF (if any) after the boundary line+ -- are not included in any of the strings returned.+ -- Returns 'Nothing' if there is no boundary.+splitAtBoundary b s = spl 0+ where+ spl i = case findCRLF (BS.drop i s) of+ Nothing -> Nothing+ Just (j,l) | isBoundary b s2 -> Just (s1,d,s3)+ | otherwise -> spl (i+j+l)+ where + s1 = BS.take (i+j) s+ s2 = BS.drop (i+j+l) s+ (d,s3) = splitAtCRLF_ s2++-- | Check whether a string starts with two dashes followed by+-- the given boundary string.+isBoundary :: ByteString -- ^ The boundary, without the initial dashes+ -> ByteString+ -> Bool+isBoundary b s = startsWithDashes s && b `BS.isPrefixOf` BS.drop 2 s++-- | Check whether a string for which 'isBoundary' returns true+-- has two dashes after the boudary string.+isClose :: ByteString -- ^ The boundary, without the initial dashes+ -> ByteString + -> Bool+isClose b s = startsWithDashes (BS.drop (2+BS.length b) s)++-- | Checks whether a string starts with two dashes.+startsWithDashes :: ByteString -> Bool+startsWithDashes s = BS.pack "--" `BS.isPrefixOf` s+++--+-- * RFC 2046 CRLF+--++-- | Drop everything up to and including the first CRLF.+dropLine :: ByteString -> Maybe ByteString+dropLine s = fmap snd (splitAtCRLF s)++-- | Split a string at the first empty line. The CRLF (if any) before the+-- empty line is included in the first result. The CRLF after the+-- empty line is not included in the result.+-- 'Nothing' is returned if there is no empty line.+splitAtEmptyLine :: ByteString -> Maybe (ByteString, ByteString)+splitAtEmptyLine s | startsWithCRLF s = Just (BS.empty, dropCRLF s)+ | otherwise = spl 0+ where+ spl i = case findCRLF (BS.drop i s) of+ Nothing -> Nothing+ Just (j,l) | startsWithCRLF s2 -> Just (s1, dropCRLF s2)+ | otherwise -> spl (i+j+l)+ where (s1,s2) = BS.splitAt (i+j+l) s++-- | Split a string at the first CRLF. The CRLF is not included+-- in any of the returned strings.+splitAtCRLF :: ByteString -- ^ String to split.+ -> Maybe (ByteString,ByteString)+ -- ^ Returns 'Nothing' if there is no CRLF.+splitAtCRLF s = case findCRLF s of+ Nothing -> Nothing+ Just (i,l) -> Just (s1, BS.drop l s2)+ where (s1,s2) = BS.splitAt i s++-- | Like 'splitAtCRLF', but if no CRLF is found, the first+-- result is the argument string, and the second result is empty.+splitAtCRLF_ :: ByteString -> (ByteString,ByteString)+splitAtCRLF_ s = fromMaybe (s,BS.empty) (splitAtCRLF s)++-- | Get the index and length of the first CRLF, if any.+findCRLF :: ByteString -- ^ String to split.+ -> Maybe (Int64,Int64)+findCRLF s = + case findCRorLF s of+ Nothing -> Nothing+ Just j | BS.null (BS.drop (j+1) s) -> Just (j,1)+ Just j -> case (BS.index s j, BS.index s (j+1)) of+ ('\n','\r') -> Just (j,2)+ ('\r','\n') -> Just (j,2)+ _ -> Just (j,1)++findCRorLF :: ByteString -> Maybe Int64+findCRorLF s = BS.findIndex (\c -> c == '\n' || c == '\r') s++startsWithCRLF :: ByteString -> Bool+startsWithCRLF s = not (BS.null s) && (c == '\n' || c == '\r')+ where c = BS.index s 0++-- | Drop an initial CRLF, if any. If the string is empty, +-- nothing is done. If the string does not start with CRLF,+-- the first character is dropped.+dropCRLF :: ByteString -> ByteString+dropCRLF s | BS.null s = BS.empty+ | BS.null (BS.drop 1 s) = BS.empty+ | c0 == '\n' && c1 == '\r' = BS.drop 2 s+ | c0 == '\r' && c1 == '\n' = BS.drop 2 s+ | otherwise = BS.drop 1 s+ where c0 = BS.index s 0+ c1 = BS.index s 1
+ src/HAppS/Server/HTTP/RFC822Headers.hs view
@@ -0,0 +1,266 @@+-- #hide++-----------------------------------------------------------------------------+-- |+-- Module : Network.CGI.RFC822Headers+-- Copyright : (c) Peter Thiemann 2001,2002+-- (c) Bjorn Bringert 2005-2006+-- (c) Lemmih 2007+-- License : BSD-style+--+-- Maintainer : lemmih@vo.com+-- Stability : experimental+-- Portability : portable+--+-- Parsing of RFC822-style headers (name, value pairs)+-- Partly based on code from WASHMail.+--+-----------------------------------------------------------------------------+module HAppS.Server.HTTP.RFC822Headers+ ( -- * Headers+ Header, + pHeader,+ pHeaders,+ parseHeaders,++ -- * Content-type+ ContentType(..), + getContentType,+ parseContentType,+ showContentType,++ -- * Content-transfer-encoding+ ContentTransferEncoding(..),+ getContentTransferEncoding,+ parseContentTransferEncoding,++ -- * Content-disposition+ ContentDisposition(..),+ getContentDisposition, + parseContentDisposition,+ + -- * Utilities+ parseM+ ) where++import Data.Char+import Data.List+import Text.ParserCombinators.Parsec++type Header = (String, String)++pHeaders :: Parser [Header]+pHeaders = many pHeader++parseHeaders :: Monad m => SourceName -> String -> m [Header]+parseHeaders s inp = parseM pHeaders s inp++pHeader :: Parser Header+pHeader = + do name <- many1 headerNameChar+ char ':'+ many ws1+ line <- lineString+ crLf+ extraLines <- many extraFieldLine+ return (map toLower name, concat (line:extraLines))++extraFieldLine :: Parser String+extraFieldLine = + do sp <- ws1+ line <- lineString+ crLf+ return (sp:line)++--+-- * Parameters (for Content-type etc.)+--++showParameters :: [(String,String)] -> String+showParameters = concatMap f+ where f (n,v) = "; " ++ n ++ "=\"" ++ concatMap esc v ++ "\""+ esc '\\' = "\\\\"+ esc '"' = "\\\""+ esc c | c `elem` ['\\','"'] = '\\':[c]+ | otherwise = [c]++p_parameter :: Parser (String,String)+p_parameter =+ do lexeme $ char ';'+ p_name <- lexeme $ p_token+ lexeme $ char '='+ -- Workaround for seemingly standardized web browser bug+ -- where nothing is escaped in the filename parameter+ -- of the content-disposition header in multipart/form-data+ let litStr = if p_name == "filename" + then buggyLiteralString+ else literalString+ p_value <- litStr <|> p_token+ return (map toLower p_name, p_value)+++-- +-- * Content type+--++-- | A MIME media type value.+-- The 'Show' instance is derived automatically.+-- Use 'showContentType' to obtain the standard+-- string representation.+-- See <http://www.ietf.org/rfc/rfc2046.txt> for more+-- information about MIME media types.+data ContentType = + ContentType {+ -- | The top-level media type, the general type+ -- of the data. Common examples are+ -- \"text\", \"image\", \"audio\", \"video\",+ -- \"multipart\", and \"application\".+ ctType :: String,+ -- | The media subtype, the specific data format.+ -- Examples include \"plain\", \"html\",+ -- \"jpeg\", \"form-data\", etc.+ ctSubtype :: String,+ -- | Media type parameters. On common example is+ -- the charset parameter for the \"text\" + -- top-level type, e.g. @(\"charset\",\"ISO-8859-1\")@.+ ctParameters :: [(String, String)]+ }+ deriving (Show, Read, Eq, Ord)++-- | Produce the standard string representation of a content-type,+-- e.g. \"text\/html; charset=ISO-8859-1\".+showContentType :: ContentType -> String+showContentType (ContentType x y ps) = x ++ "/" ++ y ++ showParameters ps++pContentType :: Parser ContentType+pContentType = + do many ws1+ c_type <- p_token+ lexeme $ char '/'+ c_subtype <- lexeme $ p_token+ c_parameters <- many p_parameter+ return $ ContentType (map toLower c_type) (map toLower c_subtype) c_parameters++-- | Parse the standard representation of a content-type.+-- If the input cannot be parsed, this function calls+-- 'fail' with a (hopefully) informative error message.+parseContentType :: Monad m => String -> m ContentType+parseContentType = parseM pContentType "Content-type"++getContentType :: Monad m => [Header] -> m ContentType+getContentType hs = lookupM "content-type" hs >>= parseContentType++--+-- * Content transfer encoding+--++data ContentTransferEncoding =+ ContentTransferEncoding String+ deriving (Show, Read, Eq, Ord)++pContentTransferEncoding :: Parser ContentTransferEncoding+pContentTransferEncoding =+ do many ws1+ c_cte <- p_token+ return $ ContentTransferEncoding (map toLower c_cte)++parseContentTransferEncoding :: Monad m => String -> m ContentTransferEncoding+parseContentTransferEncoding = + parseM pContentTransferEncoding "Content-transfer-encoding"++getContentTransferEncoding :: Monad m => [Header] -> m ContentTransferEncoding+getContentTransferEncoding hs = + lookupM "content-transfer-encoding" hs >>= parseContentTransferEncoding++--+-- * Content disposition+--++data ContentDisposition =+ ContentDisposition String [(String, String)]+ deriving (Show, Read, Eq, Ord)++pContentDisposition :: Parser ContentDisposition+pContentDisposition =+ do many ws1+ c_cd <- p_token+ c_parameters <- many p_parameter+ return $ ContentDisposition (map toLower c_cd) c_parameters++parseContentDisposition :: Monad m => String -> m ContentDisposition+parseContentDisposition = parseM pContentDisposition "Content-disposition"++getContentDisposition :: Monad m => [Header] -> m ContentDisposition+getContentDisposition hs = + lookupM "content-disposition" hs >>= parseContentDisposition++--+-- * Utilities+--++parseM :: Monad m => Parser a -> SourceName -> String -> m a+parseM p n inp =+ case parse p n inp of+ Left e -> fail (show e)+ Right x -> return x++lookupM :: (Monad m, Eq a, Show a) => a -> [(a,b)] -> m b+lookupM n = maybe (fail ("No such field: " ++ show n)) return . lookup n++-- +-- * Parsing utilities+--++-- | RFC 822 LWSP-char+ws1 :: Parser Char+ws1 = oneOf " \t"++lexeme :: Parser a -> Parser a+lexeme p = do x <- p; many ws1; return x++-- | RFC 822 CRLF (but more permissive)+crLf :: Parser String+crLf = try (string "\n\r" <|> string "\r\n") <|> string "\n" <|> string "\r"++-- | One line+lineString :: Parser String+lineString = many (noneOf "\n\r")++literalString :: Parser String+literalString = do char '\"'+ str <- many (noneOf "\"\\" <|> quoted_pair)+ char '\"'+ return str++-- No web browsers seem to implement RFC 2046 correctly,+-- since they do not escape double quotes and backslashes+-- in the filename parameter in multipart/form-data.+--+-- Note that this eats everything until the last double quote on the line.+buggyLiteralString :: Parser String+buggyLiteralString = + do char '\"'+ str <- manyTill anyChar (try lastQuote)+ return str+ where lastQuote = do char '\"' + notFollowedBy (try (many (noneOf "\"") >> char '\"'))++headerNameChar :: Parser Char+headerNameChar = noneOf "\n\r:"++especials, tokenchar :: [Char]+especials = "()<>@,;:\\\"/[]?.="+tokenchar = "!\"#$%&'()*+,-./0123456789:;<=>?@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\\]^_`abcdefghijklmnopqrstuvwxyz{|}~" \\ especials++p_token :: Parser String+p_token = many1 (oneOf tokenchar)++text_chars :: [Char]+text_chars = map chr ([1..9] ++ [11,12] ++ [14..127])++p_text :: Parser Char+p_text = oneOf text_chars++quoted_pair :: Parser Char+quoted_pair = do char '\\'+ p_text
+ src/HAppS/Server/HTTP/Types.hs view
@@ -0,0 +1,244 @@+{-# OPTIONS -fglasgow-exts #-}+module HAppS.Server.HTTP.Types+ (Request(..), Response(..), RqBody(..), Input(..), HeaderPair(..),+ rqURL, mkHeaders,+ getHeader, getHeaderBS, getHeaderUnsafe,+ hasHeader, hasHeaderBS, hasHeaderUnsafe,+ setHeader, setHeaderBS, setHeaderUnsafe,+ addHeader, addHeaderBS, addHeaderUnsafe,+ setRsCode, -- setCookie, setCookies,+ Conf(..), nullConf, result, resultBS,+ redirect, -- redirect_, redirect', redirect'_,+ RsFlags(..), nullRsFlags, noContentLength,+ Version(..), Method(..), Headers, continueHTTP,+ Host, ContentType(..)+ ) where+++import qualified Data.Map as M+import Data.Typeable(Typeable)+import Data.Maybe+import qualified Data.ByteString.Char8 as P+import Data.ByteString.Char8 (ByteString,pack)+import qualified Data.ByteString.Lazy.Char8 as L+import HAppS.Server.SURI+import Data.Char (toLower)+import Network.URI++import HAppS.Server.HTTP.Multipart ( ContentType(..) )+import HAppS.Server.Cookie+import HAppS.Util.Common (Seconds)+import Data.List++-- lowercase pack+--lpack = (P.map toLower) . P.pack++-- | HTTP version+data Version = Version Int Int+ deriving(Show,Read,Eq)++isHTTP1_1 rq = case rqVersion rq of Version 1 1 -> True; _ -> False+isHTTP1_0 rq = case rqVersion rq of Version 1 0 -> True; _ -> False++-- | Should the connection be used for further messages after this.+-- | isHTTP1_0 && hasKeepAlive || isHTTP1_1 && hasNotConnectionClose+continueHTTP :: Request -> Response -> Bool+--continueHTTP rq res = isHTTP1_1 rq && getHeader' connectionC rq /= Just closeC && rsfContentLength (rsFlags res)+continueHTTP rq res = (isHTTP1_0 rq && checkHeaderBS connectionC keepaliveC rq) ||+ (isHTTP1_1 rq && not (checkHeaderBS connectionC closeC rq)) && rsfContentLength (rsFlags res)++-- | HTTP configuration+data Conf = Conf { port :: Int -- ^ Port for the server to listen on.+ } deriving(Show)+nullConf = Conf { port = 8000+ }++++-- | HTTP request method+data Method = GET | HEAD | POST | PUT | DELETE | TRACE | OPTIONS | CONNECT+ deriving(Show,Read,Eq)++data HeaderPair = HeaderPair { hName :: ByteString, hValue :: [ByteString] } deriving (Read,Show)+-- | Combined headers.+type Headers = M.Map ByteString HeaderPair -- lowercased name -> (realname, value)++++-- | Result flags+data RsFlags = RsFlags + { rsfContentLength :: Bool -- ^ whether a content-length header will be added to the result.+ } deriving(Show,Read,Typeable)+nullRsFlags = RsFlags { rsfContentLength = True }+-- | Don't display a Content-Lenght field for the 'Result'.+noContentLength :: Response -> Response+noContentLength res = res { rsFlags = upd } where upd = (rsFlags res) { rsfContentLength = False }++data Input = Input+ { inputValue :: L.ByteString+ , inputFilename :: Maybe String+ , inputContentType :: ContentType+ } deriving (Show,Read,Typeable)++type Host = (String,Int)++--instance EventRelation Request Result++data Response = Response { rsCode :: Int,+ rsHeaders :: Headers,+ rsFlags :: RsFlags,+ rsBody :: L.ByteString+ } deriving(Show,Read,Typeable)+data Request = Request { rqMethod :: Method,+ rqPaths :: [String],+ rqQuery :: String,+ rqInputs :: [(String,Input)],+ rqCookies :: [(String,Cookie)],+ rqVersion :: Version,+ rqHeaders :: Headers,+ rqBody :: RqBody,+ rqPeer :: Host+ } deriving(Show,Read,Typeable)+++--rqURL=rq = '/':(concat $ intersperse "/" $ rqPaths rq) ++ rqQuery rq+rqURL rq = '/':intercalate "/" (rqPaths rq) ++ (rqQuery rq)+{-+instance Serialize Request where+ typeString _ = "HAppS.Server.HTTP.Request"+ encodeStringM = defaultEncodeStringM+ decodeStringM = defaultDecodeStringM+-}+{-+instance LogFormat Request where+ logFormat _ r = unwords [show $ rqMethod r, show $ rqURI r, show $ rqVersion r+ ,"\n\n"++unlines [unpack k ++ ": "++unpack v | (k,v) <- getHeadersBS r]+ ,show (rqBody r)]+-}++class HasHeaders a where + updateHeaders::(Headers->Headers)->a->a+ headers::a->Headers++instance HasHeaders Response where updateHeaders f rs = rs{rsHeaders=f $ rsHeaders rs}+ headers = rsHeaders+instance HasHeaders Request where updateHeaders f rq = rq{rqHeaders = f $ rqHeaders rq} + headers = rqHeaders++instance HasHeaders Headers where updateHeaders f hs = f hs+ headers = id++newtype RqBody = Body L.ByteString deriving (Read,Show,Typeable)+++setRsCode code rs = return rs {rsCode = code}++mkHeaders :: [(String,String)] -> Headers+mkHeaders hdrs+ = M.fromListWith join [ (P.pack (map toLower key), HeaderPair (P.pack key) [P.pack value]) | (key,value) <- hdrs ]+ where join (HeaderPair key vs1) (HeaderPair _ vs2) = HeaderPair key (vs1++vs2)++--------------------------------------------------------------+-- Retrieving header information+--------------------------------------------------------------++-- | Lookup header value. Key is case-insensitive.+getHeader :: HasHeaders r => String -> r -> Maybe ByteString+getHeader key = getHeaderBS (pack key)++-- | Lookup header value. Key is a case-insensitive bytestring.+getHeaderBS :: HasHeaders r => ByteString -> r -> Maybe ByteString+getHeaderBS key = getHeaderUnsafe (P.map toLower key)++-- | Lookup header value with a case-sensitive key. The key must be lowercase.+getHeaderUnsafe :: HasHeaders r => ByteString -> r -> Maybe ByteString+getHeaderUnsafe key var = listToMaybe =<< fmap hValue (getHeaderUnsafe' key var)++-- | Lookup header with a case-sensitive key. The key must be lowercase.+getHeaderUnsafe' :: HasHeaders r => ByteString -> r -> Maybe HeaderPair+getHeaderUnsafe' key r = M.lookup key (headers r)++getContentType x = getHeader "content-type" x+++--------------------------------------------------------------+-- Querying header status+--------------------------------------------------------------+++hasHeader :: HasHeaders r => String -> r -> Bool+hasHeader key r = isJust (getHeader key r)++hasHeaderBS :: HasHeaders r => ByteString -> r -> Bool+hasHeaderBS key r = isJust (getHeaderBS key r)++hasHeaderUnsafe :: HasHeaders r => ByteString -> r -> Bool+hasHeaderUnsafe key r = isJust (getHeaderUnsafe' key r)++-- Case-insensitive header comparison+checkHeader :: HasHeaders r => String -> String -> r -> Bool+checkHeader key val = checkHeaderBS (pack key) (pack val)++checkHeaderBS :: HasHeaders r => ByteString -> ByteString -> r -> Bool+checkHeaderBS key val = checkHeaderUnsafe (P.map toLower key) (P.map toLower val)++checkHeaderUnsafe :: HasHeaders r => ByteString -> ByteString -> r -> Bool+checkHeaderUnsafe key val r+ = case getHeaderUnsafe key r of+ Just val' | P.map toLower val' == val -> True+ _ -> False+++--------------------------------------------------------------+-- Setting header status+--------------------------------------------------------------++setHeader :: HasHeaders r => String -> String -> r -> r+setHeader key val = setHeaderBS (pack key) (pack val)++setHeaderBS :: HasHeaders r => ByteString -> ByteString -> r -> r+setHeaderBS key val = setHeaderUnsafe (P.map toLower key) (HeaderPair key [val])++setHeaderUnsafe :: HasHeaders r => ByteString -> HeaderPair -> r -> r+setHeaderUnsafe key val = updateHeaders (M.insert key val)++--------------------------------------------------------------+-- Adding headers+--------------------------------------------------------------++addHeader :: HasHeaders r => String -> String -> r -> r+addHeader key val = addHeaderBS (pack key) (pack val)++addHeaderBS :: HasHeaders r => ByteString -> ByteString -> r -> r+addHeaderBS key val = addHeaderUnsafe (P.map toLower key) (HeaderPair key [val])++addHeaderUnsafe :: HasHeaders r => ByteString -> HeaderPair -> r -> r+addHeaderUnsafe key val = updateHeaders (M.insertWith join key val)+ where join (HeaderPair key vs1) (HeaderPair _ vs2) = HeaderPair key (vs1++vs2)++++++result :: Int -> String -> Response+result code s = resultBS code (L.pack s)++resultBS :: Int -> L.ByteString -> Response+resultBS code s = Response code M.empty nullRsFlags s+++setLocationHeader :: ToSURI uri => uri -> Response -> Response+setLocationHeader uri = setHeaderBS locationC (pack (render (toSURI uri)))++redirect :: (ToSURI s) => Int -> s -> Response -> Response+redirect c s resp = setHeaderBS locationC (pack (render (toSURI s))) resp{rsCode = c}++++-- constants here+locationC = P.pack "Location"+commaSpaceC = P.pack ", "+closeC = P.pack "close"+connectionC = P.pack "Connection"+keepaliveC = P.pack "Keep-Alive"+
+ src/HAppS/Server/HTTPClient/HTTP.hs view
@@ -0,0 +1,1048 @@+-----------------------------------------------------------------------------+-- |+-- Module : HAppS.Server.HTTPClient.HTTP+-- Copyright : (c) Warrick Gray 2002, Bjorn Bringert 2003-2005+-- License : BSD+-- +-- Maintainer : bjorn@bringert.net+-- Stability : experimental+-- Portability : non-portable (not tested)+--+-- An easy HTTP interface enjoy.+--+-- * Changes by Simon Foster:+-- - Split module up into to sepearate Network.[Stream,TCP,HTTP] modules+-- - Created functions receiveHTTP and responseHTTP to allow server side interactions+-- (although 100-continue is unsupported and I haven't checked for standard compliancy).+-- - Pulled the transfer functions from sendHTTP to global scope to allow access by+-- above functions.+--+-- * Changes by Graham Klyne:+-- - export httpVersion+-- - use new URI module (similar to old, but uses revised URI datatype)+--+-- * Changes by Bjorn Bringert:+--+-- - handle URIs with a port number+-- - added debugging toggle+-- - disabled 100-continue transfers to get HTTP\/1.0 compatibility+-- - change 'ioError' to 'throw'+-- - Added simpleHTTP_, which takes a stream argument.+--+-- * Changes from 0.1+-- - change 'openHTTP' to 'openTCP', removed 'closeTCP' - use 'close' from 'Stream' class.+-- - added use of inet_addr to openHTTP, allowing use of IP "dot" notation addresses.+-- - reworking of the use of Stream, including alterations to make 'sendHTTP' generic+-- and the addition of a debugging stream.+-- - simplified error handling.+-- +-- * TODO+-- - request pipelining+-- - https upgrade (includes full TLS, i.e. SSL, implementation)+-- - use of Stream classes will pay off+-- - consider C implementation of encryption\/decryption+-- - comm timeouts+-- - MIME & entity stuff (happening in separate module)+-- - support \"*\" uri-request-string for OPTIONS request method+-- +-- +-- * Header notes:+--+-- [@Host@]+-- Required by HTTP\/1.1, if not supplied as part+-- of a request a default Host value is extracted+-- from the request-uri.+-- +-- [@Connection@] +-- If this header is present in any request or+-- response, and it's value is "close", then+-- the current request\/response is the last +-- to be allowed on that connection.+-- +-- [@Expect@]+-- Should a request contain a body, an Expect+-- header will be added to the request. The added+-- header has the value \"100-continue\". After+-- a 417 \"Expectation Failed\" response the request+-- is attempted again without this added Expect+-- header.+-- +-- [@TransferEncoding,ContentLength,...@]+-- if request is inconsistent with any of these+-- header values then you may not receive any response+-- or will generate an error response (probably 4xx).+--+--+-- * Response code notes+-- Some response codes induce special behaviour:+--+-- [@1xx@] \"100 Continue\" will cause any unsent request body to be sent.+-- \"101 Upgrade\" will be returned.+-- Other 1xx responses are ignored.+-- +-- [@417@] The reason for this code is \"Expectation failed\", indicating+-- that the server did not like the Expect \"100-continue\" header+-- added to a request. Receipt of 417 will induce another+-- request attempt (without Expect header), unless no Expect header+-- had been added (in which case 417 response is returned).+--+-----------------------------------------------------------------------------+module HAppS.Server.HTTPClient.HTTP (+ module HAppS.Server.HTTPClient.Stream,+ module HAppS.Server.HTTPClient.TCP,++ -- ** Constants+ httpVersion,+ + -- ** HTTP + Request(..),+ Response(..),+ RequestMethod(..),+ simpleHTTP, simpleHTTP_,+ sendHTTP,+ sendHTTPPipelined,+ receiveHTTP,+ respondHTTP,++ -- ** Header Functions+ HasHeaders,+ Header(..),+ HeaderName(..),+ insertHeader,+ insertHeaderIfMissing,+ insertHeaders,+ retrieveHeaders,+ replaceHeader,+ findHeader,++ -- ** URL Encoding+ urlEncode,+ urlDecode,+ urlEncodeVars,++ -- ** URI authority parsing+ URIAuthority(..),+ parseURIAuthority+) where++++-----------------------------------------------------------------+------------------ Imports --------------------------------------+-----------------------------------------------------------------++import Control.Exception as Exception++-- Networking+import Network.URI+import HAppS.Server.HTTPClient.Stream+import HAppS.Server.HTTPClient.TCP+++-- Util+import Data.Bits ((.&.))+import Data.Char+import Data.List (partition,elemIndex,intersperse)+import Data.Maybe+import Control.Monad (when,guard)+import Numeric (readHex)+import Text.ParserCombinators.ReadP+import Text.Read.Lex +import System.IO++++-- Turn on to enable HTTP traffic logging+debug :: Bool+debug = True -- False++-- File that HTTP traffic logs go to+httpLogFile :: String+httpLogFile = "http-debug.log"++-----------------------------------------------------------------+------------------ Misc -----------------------------------------+-----------------------------------------------------------------++-- remove leading and trailing whitespace.+trim :: String -> String+trim = let dropspace = dropWhile isSpace in+ reverse . dropspace . reverse . dropspace+++-- Split a list into two parts, the delimiter occurs+-- at the head of the second list. Nothing is returned+-- when no occurance of the delimiter is found.+split :: Eq a => a -> [a] -> Maybe ([a],[a])+split delim list = case delim `elemIndex` list of+ Nothing -> Nothing+ Just x -> Just $ splitAt x list+ +++crlf = "\r\n"+sp = " "++-----------------------------------------------------------------+------------------ URI Authority parsing ------------------------+-----------------------------------------------------------------++data URIAuthority = URIAuthority { user :: Maybe String, + password :: Maybe String,+ host :: String,+ port :: Maybe Int+ } deriving (Eq,Show)++-- | Parse the authority part of a URL.+--+-- > RFC 1732, section 3.1:+-- >+-- > //<user>:<password>@<host>:<port>/<url-path>+-- > Some or all of the parts "<user>:<password>@", ":<password>",+-- > ":<port>", and "/<url-path>" may be excluded.+parseURIAuthority :: String -> Maybe URIAuthority+parseURIAuthority s = listToMaybe (map fst (readP_to_S pURIAuthority s))+++pURIAuthority :: ReadP URIAuthority+pURIAuthority = do+ (u,pw) <- (pUserInfo `before` char '@') + <++ return (Nothing, Nothing)+ h <- munch (/=':')+ p <- orNothing (char ':' >> readDecP)+ look >>= guard . null + return URIAuthority{ user=u, password=pw, host=h, port=p }++pUserInfo :: ReadP (Maybe String, Maybe String)+pUserInfo = do+ u <- orNothing (munch (`notElem` ":@"))+ p <- orNothing (char ':' >> munch (/='@'))+ return (u,p)++before :: Monad m => m a -> m b -> m a+before a b = a >>= \x -> b >> return x++orNothing :: ReadP a -> ReadP (Maybe a)+orNothing p = fmap Just p <++ return Nothing++-----------------------------------------------------------------+------------------ Header Data ----------------------------------+-----------------------------------------------------------------+++-- | The Header data type pairs header names & values.+data Header = Header HeaderName String+++instance Show Header where+ show (Header key value) = show key ++ ": " ++ value ++ crlf+++-- | HTTP Header Name type:+-- Why include this at all? I have some reasons+-- 1) prevent spelling errors of header names,+-- 2) remind everyone of what headers are available,+-- 3) might speed up searches for specific headers.+--+-- Arguments against:+-- 1) makes customising header names laborious+-- 2) increases code volume.+--+data HeaderName = + -- Generic Headers --+ HdrCacheControl+ | HdrConnection+ | HdrDate+ | HdrPragma+ | HdrTransferEncoding + | HdrUpgrade + | HdrVia++ -- Request Headers --+ | HdrAccept+ | HdrAcceptCharset+ | HdrAcceptEncoding+ | HdrAcceptLanguage+ | HdrAuthorization+ | HdrCookie+ | HdrExpect+ | HdrFrom+ | HdrHost+ | HdrIfModifiedSince+ | HdrIfMatch+ | HdrIfNoneMatch+ | HdrIfRange+ | HdrIfUnmodifiedSince+ | HdrMaxForwards+ | HdrProxyAuthorization+ | HdrRange+ | HdrReferer+ | HdrUserAgent++ -- Response Headers+ | HdrAge+ | HdrLocation+ | HdrProxyAuthenticate+ | HdrPublic+ | HdrRetryAfter+ | HdrServer+ | HdrSetCookie+ | HdrVary+ | HdrWarning+ | HdrWWWAuthenticate++ -- Entity Headers+ | HdrAllow+ | HdrContentBase+ | HdrContentEncoding+ | HdrContentLanguage+ | HdrContentLength+ | HdrContentLocation+ | HdrContentMD5+ | HdrContentRange+ | HdrContentType+ | HdrETag+ | HdrExpires+ | HdrLastModified++ -- Mime entity headers (for sub-parts)+ | HdrContentTransferEncoding++ -- | Allows for unrecognised or experimental headers.+ | HdrCustom String -- not in header map below.+ deriving(Eq)+++-- Translation between header names and values,+-- good candidate for improvement.+headerMap :: [ (String,HeaderName) ]+headerMap + = [ ("Cache-Control" ,HdrCacheControl )+ , ("Connection" ,HdrConnection )+ , ("Date" ,HdrDate ) + , ("Pragma" ,HdrPragma )+ , ("Transfer-Encoding" ,HdrTransferEncoding ) + , ("Upgrade" ,HdrUpgrade ) + , ("Via" ,HdrVia )+ , ("Accept" ,HdrAccept )+ , ("Accept-Charset" ,HdrAcceptCharset )+ , ("Accept-Encoding" ,HdrAcceptEncoding )+ , ("Accept-Language" ,HdrAcceptLanguage )+ , ("Authorization" ,HdrAuthorization )+ , ("From" ,HdrFrom )+ , ("Host" ,HdrHost )+ , ("If-Modified-Since" ,HdrIfModifiedSince )+ , ("If-Match" ,HdrIfMatch )+ , ("If-None-Match" ,HdrIfNoneMatch )+ , ("If-Range" ,HdrIfRange ) + , ("If-Unmodified-Since" ,HdrIfUnmodifiedSince )+ , ("Max-Forwards" ,HdrMaxForwards )+ , ("Proxy-Authorization" ,HdrProxyAuthorization)+ , ("Range" ,HdrRange ) + , ("Referer" ,HdrReferer )+ , ("User-Agent" ,HdrUserAgent )+ , ("Age" ,HdrAge )+ , ("Location" ,HdrLocation )+ , ("Proxy-Authenticate" ,HdrProxyAuthenticate )+ , ("Public" ,HdrPublic )+ , ("Retry-After" ,HdrRetryAfter )+ , ("Server" ,HdrServer )+ , ("Vary" ,HdrVary )+ , ("Warning" ,HdrWarning )+ , ("WWW-Authenticate" ,HdrWWWAuthenticate )+ , ("Allow" ,HdrAllow )+ , ("Content-Base" ,HdrContentBase )+ , ("Content-Encoding" ,HdrContentEncoding )+ , ("Content-Language" ,HdrContentLanguage )+ , ("Content-Length" ,HdrContentLength )+ , ("Content-Location" ,HdrContentLocation )+ , ("Content-MD5" ,HdrContentMD5 )+ , ("Content-Range" ,HdrContentRange )+ , ("Content-Type" ,HdrContentType )+ , ("ETag" ,HdrETag )+ , ("Expires" ,HdrExpires )+ , ("Last-Modified" ,HdrLastModified )+ , ("Set-Cookie" ,HdrSetCookie )+ , ("Cookie" ,HdrCookie )+ , ("Expect" ,HdrExpect ) ]+++instance Show HeaderName where+ show (HdrCustom s) = s+ show x = case filter ((==x).snd) headerMap of+ [] -> error "headerMap incomplete"+ (h:_) -> fst h++++++-- | This class allows us to write generic header manipulation functions+-- for both 'Request' and 'Response' data types.+class HasHeaders x where+ getHeaders :: x -> [Header]+ setHeaders :: x -> [Header] -> x++++-- Header manipulation functions+insertHeader, replaceHeader, insertHeaderIfMissing+ :: HasHeaders a => HeaderName -> String -> a -> a+++-- | Inserts a header with the given name and value.+-- Allows duplicate header names.+insertHeader name value x = setHeaders x newHeaders+ where+ newHeaders = (Header name value) : getHeaders x+++-- | Adds the new header only if no previous header shares+-- the same name.+insertHeaderIfMissing name value x = setHeaders x (newHeaders $ getHeaders x)+ where+ newHeaders list@(h@(Header n _): rest)+ | n == name = list+ | otherwise = h : newHeaders rest+ newHeaders [] = [Header name value]++ ++-- | Removes old headers with duplicate name.+replaceHeader name value x = setHeaders x newHeaders+ where+ newHeaders = Header name value : [ x | x@(Header n v) <- getHeaders x, name /= n ]+ ++-- | Inserts multiple headers.+insertHeaders :: HasHeaders a => [Header] -> a -> a+insertHeaders hdrs x = setHeaders x (getHeaders x ++ hdrs)+++-- | Gets a list of headers with a particular 'HeaderName'.+retrieveHeaders :: HasHeaders a => HeaderName -> a -> [Header]+retrieveHeaders name x = filter matchname (getHeaders x)+ where+ matchname (Header n _) | n == name = True+ matchname _ = False+++-- | Lookup presence of specific HeaderName in a list of Headers+-- Returns the value from the first matching header.+findHeader :: HasHeaders a => HeaderName -> a -> Maybe String+findHeader n x = lookupHeader n (getHeaders x)++-- An anomally really:+lookupHeader :: HeaderName -> [Header] -> Maybe String+lookupHeader v (Header n s:t) | v == n = Just s+ | otherwise = lookupHeader v t+lookupHeader _ _ = Nothing+++++{-+instance HasHeaders [Header]+...requires -fglasgow-exts, and is not really necessary anyway...+-}++++-----------------------------------------------------------------+------------------ HTTP Messages --------------------------------+-----------------------------------------------------------------+++-- Protocol version+httpVersion :: String+httpVersion = "HTTP/1.1"+++-- | The HTTP request method, to be used in the 'Request' object.+-- We are missing a few of the stranger methods, but these are+-- not really necessary until we add full TLS.+data RequestMethod = HEAD | PUT | GET | POST | OPTIONS | TRACE | DELETE+ deriving(Show,Eq)++rqMethodMap = [("HEAD", HEAD),+ ("PUT", PUT),+ ("GET", GET),+ ("POST", POST),+ ("OPTIONS", OPTIONS),+ ("TRACE", TRACE),+ ("DELETE", DELETE)]++-- | An HTTP Request.+-- The 'Show' instance of this type is used for message serialisation,+-- which means no body data is output.+data Request =+ Request { rqURI :: URI -- ^ might need changing in future+ -- 1) to support '*' uri in OPTIONS request+ -- 2) transparent support for both relative+ -- & absolute uris, although this should+ -- already work (leave scheme & host parts empty).+ , rqMethod :: RequestMethod + , rqHeaders :: [Header]+ , rqBody :: String+ }+++++-- Notice that request body is not included,+-- this show function is used to serialise+-- a request for the transport link, we send+-- the body separately where possible.+instance Show Request where+ show (Request u m h _) =+ show m ++ sp ++ alt_uri ++ sp ++ httpVersion ++ crlf+ ++ foldr (++) [] (map show h) ++ crlf+ where+ alt_uri = show $ if null (uriPath u) || head (uriPath u) /= '/' + then u { uriPath = '/' : uriPath u } + else u+++instance HasHeaders Request where+ getHeaders = rqHeaders+ setHeaders rq hdrs = rq { rqHeaders=hdrs }+++++++type ResponseCode = (Int,Int,Int)+type ResponseData = (ResponseCode,String,[Header])+type RequestData = (RequestMethod,URI,[Header])++-- | An HTTP Response.+-- The 'Show' instance of this type is used for message serialisation,+-- which means no body data is output, additionally the output will+-- show an HTTP version of 1.1 instead of the actual version returned+-- by a server.+data Response =+ Response { rspCode :: ResponseCode+ , rspReason :: String+ , rspHeaders :: [Header]+ , rspBody :: String+ }+ +++-- This is an invalid representation of a received response, +-- since we have made the assumption that all responses are HTTP/1.1+instance Show Response where+ show (Response (a,b,c) reason headers _) =+ httpVersion ++ ' ' : map intToDigit [a,b,c] ++ ' ' : reason ++ crlf+ ++ foldr (++) [] (map show headers) ++ crlf++++instance HasHeaders Response where+ getHeaders = rspHeaders+ setHeaders rsp hdrs = rsp { rspHeaders=hdrs }++-----------------------------------------------------------------+------------------ Parsing --------------------------------------+-----------------------------------------------------------------++parseHeader :: String -> Result Header+parseHeader str =+ case split ':' str of+ Nothing -> Left (ErrorParse $ "Unable to parse header: " ++ str)+ Just (k,v) -> Right $ Header (fn k) (trim $ drop 1 v)+ where+ fn k = case map snd $ filter (match k . fst) headerMap of+ [] -> (HdrCustom k)+ (h:_) -> h++ match :: String -> String -> Bool+ match s1 s2 = map toLower s1 == map toLower s2+ ++parseHeaders :: [String] -> Result [Header]+parseHeaders = catRslts [] . map (parseHeader . clean) . joinExtended ""+ where+ -- Joins consecutive lines where the second line+ -- begins with ' ' or '\t'.+ joinExtended old (h : t)+ | not (null h) && (head h == ' ' || head h == '\t')+ = joinExtended (old ++ ' ' : tail h) t+ | otherwise = old : joinExtended h t+ joinExtended old [] = [old]++ clean [] = []+ clean (h:t) | h `elem` "\t\r\n" = ' ' : clean t+ | otherwise = h : clean t++ -- tollerant of errors? should parse+ -- errors here be reported or ignored?+ -- currently ignored.+ catRslts :: [a] -> [Result a] -> Result [a]+ catRslts list (h:t) = + case h of+ Left _ -> catRslts list t+ Right v -> catRslts (v:list) t+ catRslts list [] = Right $ reverse list + ++-- Parsing a request+parseRequestHead :: [String] -> Result RequestData+parseRequestHead [] = Left ErrorClosed+parseRequestHead (com:hdrs) =+ requestCommand com `bindE` \(version,rqm,uri) ->+ parseHeaders hdrs `bindE` \hdrs' ->+ Right (rqm,uri,hdrs')+ where+ requestCommand line+ = case words line of+ yes@(rqm:uri:version) -> case (parseURIReference uri, lookup rqm rqMethodMap) of+ (Just u, Just r) -> Right (version,r,u)+ _ -> Left (ErrorParse $ "Request command line parse failure: " ++ line)+ no -> if null line+ then Left ErrorClosed+ else Left (ErrorParse $ "Request command line parse failure: " ++ line) ++-- Parsing a response+parseResponseHead :: [String] -> Result ResponseData+parseResponseHead [] = Left ErrorClosed+parseResponseHead (sts:hdrs) = + responseStatus sts `bindE` \(version,code,reason) ->+ parseHeaders hdrs `bindE` \hdrs' ->+ Right (code,reason,hdrs')+ where++ responseStatus line+ = case words line of+ yes@(version:code:reason) -> Right (version,match code,concatMap (++" ") reason)+ no -> if null line + then Left ErrorClosed -- an assumption+ else Left (ErrorParse $ "Response status line parse failure: " ++ line)+++ match [a,b,c] = (digitToInt a,+ digitToInt b,+ digitToInt c)+ match _ = (-1,-1,-1) -- will create appropriate behaviour+++ ++-----------------------------------------------------------------+------------------ HTTP Send / Recv ----------------------------------+-----------------------------------------------------------------++data Behaviour = Continue+ | Retry+ | Done+ | ExpectEntity+ | DieHorribly String++++++matchResponse :: RequestMethod -> ResponseCode -> Behaviour+matchResponse rqst rsp =+ case rsp of+ (1,0,0) -> Continue+ (1,0,1) -> Done -- upgrade to TLS+ (1,_,_) -> Continue -- default+ (2,0,4) -> Done+ (2,0,5) -> Done+ (2,_,_) -> ans+ (3,0,4) -> Done+ (3,0,5) -> Done+ (3,_,_) -> ans+ (4,1,7) -> Retry -- Expectation failed+ (4,_,_) -> ans+ (5,_,_) -> ans+ (a,b,c) -> DieHorribly ("Response code " ++ map intToDigit [a,b,c] ++ " not recognised")+ where+ ans | rqst == HEAD = Done+ | otherwise = ExpectEntity+ ++-- | Simple way to get a resource across a non-persistant connection.+-- Headers that may be altered:+-- Host Altered only if no Host header is supplied, HTTP\/1.1+-- requires a Host header.+-- Connection Where no allowance is made for persistant connections+-- the Connection header will be set to "close"+simpleHTTP :: Request -> IO (Result Response)+simpleHTTP r = + do + auth <- getAuth r+ c <- openTCPPort (host auth) (fromMaybe 80 (port auth))+ simpleHTTP_ c r++-- | Like 'simpleHTTP', but acting on an already opened stream.+simpleHTTP_ :: Stream s => s -> Request -> IO (Result Response)+simpleHTTP_ s r =+ do + auth <- getAuth r+ let r' = fixReq auth r + rsp <- if debug then do+ s' <- debugStream httpLogFile s+ sendHTTP s' r'+ else+ sendHTTP s r'+ -- already done by sendHTTP because of "Connection: close" header+ --; close s + return rsp+ where+ {- RFC 2616, section 5.1.2:+ "The most common form of Request-URI is that used to identify a+ resource on an origin server or gateway. In this case the absolute+ path of the URI MUST be transmitted (see section 3.2.1, abs_path) as+ the Request-URI, and the network location of the URI (authority) MUST+ be transmitted in a Host header field." -}+ -- we assume that this is the case, so we take the host name from+ -- the Host header if there is one, otherwise from the request-URI.+ -- Then we make the request-URI an abs_path and make sure that there+ -- is a Host header.+ fixReq :: URIAuthority -> Request -> Request+ fixReq URIAuthority{host=h} r = + insertHeaderIfMissing HdrConnection "close" $+ insertHeaderIfMissing HdrHost h $+ r { rqURI = (rqURI r){ uriScheme = "", + uriAuthority = Nothing } } ++getAuth :: Monad m => Request -> m URIAuthority+getAuth r = case parseURIAuthority auth of+ Just x -> return x + Nothing -> fail $ "Error parsing URI authority '"+ ++ auth ++ "'"+ where auth = case findHeader HdrHost r of+ Just h -> h+ Nothing -> authority (rqURI r)++sendHTTP :: Stream s => s -> Request -> IO (Result Response)+sendHTTP conn rq+ = do rst <- sendHTTPPipelined conn [rq]+ case rst of+ ([response],_) -> return (Right response)+ (_,Just err) -> return (Left err)++sendHTTPPipelined :: Stream s => s -> [Request] -> IO ([Response],Maybe ConnError)+sendHTTPPipelined conn rqs = + do { (ok,rsp) <- Exception.catch (main (map fixHostHeader rqs))+ (\e -> do { close conn; throw e })+ ; let fn list = when (or $ map findConnClose list)+ (close conn)+ ; fn (map rqHeaders rqs ++ map rspHeaders ok)+ ; return (ok,rsp)+ }+ where +-- From RFC 2616, section 8.2.3:+-- 'Because of the presence of older implementations, the protocol allows+-- ambiguous situations in which a client may send "Expect: 100-+-- continue" without receiving either a 417 (Expectation Failed) status+-- or a 100 (Continue) status. Therefore, when a client sends this+-- header field to an origin server (possibly via a proxy) from which it+-- has never seen a 100 (Continue) status, the client SHOULD NOT wait+-- for an indefinite period before sending the request body.'+--+-- Since we would wait forever, I have disabled use of 100-continue for now.+ main :: [Request] -> IO ([Response], Maybe ConnError)+ main rqsts =+ do + --let str = if null (rqBody rqst)+ -- then show rqst+ -- else show (insertHeader HdrExpect "100-continue" rqst)+ -- write body immediately, don't wait for 100 CONTINUE+ writeBlock conn $ concat $ intersperse "\r\n" [ show rqst ++ rqBody rqst | rqst <- rqsts ]+ rets <- flip mapM rqsts $ \rqst ->+ do rsp <- getResponseHead+ switchResponse True True rsp rqst+ return (sequenceResponses rets)++ sequenceResponses :: [Result Response] -> ([Response], Maybe ConnError)+ sequenceResponses = worker []+ where worker acc [] = (reverse acc, Nothing)+ worker acc (Right x:xs) = worker (x:acc) xs+ worker acc (Left x:xs) = (reverse acc,Just x)++ -- reads and parses headers+ getResponseHead :: IO (Result ResponseData)+ getResponseHead =+ do { lor <- readTillEmpty1 conn+ ; return $ lor `bindE` parseResponseHead+ }++ -- Hmmm, this could go bad if we keep getting "100 Continue"+ -- responses... Except this should never happen according+ -- to the RFC.+ switchResponse :: Bool {- allow retry? -}+ -> Bool {- is body sent? -}+ -> Result ResponseData+ -> Request+ -> IO (Result Response)+ + switchResponse _ _ (Left e) _ = return (Left e)+ -- retry on connreset?+ -- if we attempt to use the same socket then there is an excellent+ -- chance that the socket is not in a completely closed state.++ switchResponse allow_retry bdy_sent (Right (cd,rn,hdrs)) rqst =+ case matchResponse (rqMethod rqst) cd of+ Continue+ | not bdy_sent -> {- Time to send the body -}+ do { val <- writeBlock conn (rqBody rqst)+ ; case val of+ Left e -> return (Left e)+ Right _ ->+ do { rsp <- getResponseHead+ ; switchResponse allow_retry True rsp rqst+ }+ }+ | otherwise -> {- keep waiting -}+ do { rsp <- getResponseHead+ ; switchResponse allow_retry bdy_sent rsp rqst + }++ Retry -> {- Request with "Expect" header failed.+ Trouble is the request contains Expects+ other than "100-Continue" -}+ do { writeBlock conn (show rqst ++ rqBody rqst)+ ; rsp <- getResponseHead+ ; switchResponse False bdy_sent rsp rqst+ } + + Done ->+ return (Right $ Response cd rn hdrs "")++ DieHorribly str ->+ return $ Left $ ErrorParse ("Invalid response: " ++ str)++ ExpectEntity ->+ let tc = lookupHeader HdrTransferEncoding hdrs+ cl = lookupHeader HdrContentLength hdrs+ in+ do { rslt <- case tc of+ Nothing -> + case cl of+ Just x -> linearTransfer conn (read x :: Int)+ Nothing -> hopefulTransfer conn ""+ Just x -> + case map toLower (trim x) of+ "chunked" -> chunkedTransfer conn+ _ -> uglyDeathTransfer conn+ ; return $ rslt `bindE` \(ftrs,bdy) -> Right (Response cd rn (hdrs++ftrs) bdy) + }++ + -- Adds a Host header if one is NOT ALREADY PRESENT+ fixHostHeader :: Request -> Request+ fixHostHeader rq =+ let uri = rqURI rq+ host = authority uri+ in insertHeaderIfMissing HdrHost host rq+ + -- Looks for a "Connection" header with the value "close".+ -- Returns True when this is found.+ findConnClose :: [Header] -> Bool+ findConnClose hdrs =+ case lookupHeader HdrConnection hdrs of+ Nothing -> False+ Just x -> map toLower (trim x) == "close"++-- | Receive and parse a HTTP request from the given Stream. Should be used +-- for server side interactions.+receiveHTTP :: Stream s => s -> IO (Result Request)+receiveHTTP conn = do rq <- getRequestHead+ processRequest rq + where+ -- reads and parses headers+ getRequestHead :: IO (Result RequestData)+ getRequestHead =+ do { lor <- readTillEmpty1 conn+ ; return $ lor `bindE` parseRequestHead+ }+ + processRequest (Left e) = return $ Left e+ processRequest (Right (rm,uri,hdrs)) = + do -- FIXME : Also handle 100-continue.+ let tc = lookupHeader HdrTransferEncoding hdrs+ cl = lookupHeader HdrContentLength hdrs+ rslt <- case tc of+ Nothing ->+ case cl of+ Just x -> linearTransfer conn (read x :: Int)+ Nothing -> return (Right ([], "")) -- hopefulTransfer ""+ Just x ->+ case map toLower (trim x) of+ "chunked" -> chunkedTransfer conn+ _ -> uglyDeathTransfer conn+ + return $ rslt `bindE` \(ftrs,bdy) -> Right (Request uri rm (hdrs++ftrs) bdy)+++-- | Very simple function, send a HTTP response over the given stream. This +-- could be improved on to use different transfer types.+respondHTTP :: Stream s => s -> Response -> IO ()+respondHTTP conn rsp = do writeBlock conn (show rsp)+ -- write body immediately, don't wait for 100 CONTINUE+ writeBlock conn (rspBody rsp)+ return ()++-- The following functions were in the where clause of sendHTTP, they have+-- been moved to global scope so other functions can access them. ++-- | Used when we know exactly how many bytes to expect.+linearTransfer :: Stream s => s -> Int -> IO (Result ([Header],String))+linearTransfer conn n+ = do info <- readBlock conn n+ return $ info `bindE` \str -> Right ([],str)++-- | Used when nothing about data is known,+-- Unfortunately waiting for a socket closure+-- causes bad behaviour. Here we just+-- take data once and give up the rest.+hopefulTransfer :: Stream s => s -> String -> IO (Result ([Header],String))+hopefulTransfer conn str+ = readLine conn >>= + either (\v -> return $ Left v)+ (\more -> if null more + then return (Right ([],str)) + else hopefulTransfer conn (str++more))+-- | A necessary feature of HTTP\/1.1+-- Also the only transfer variety likely to+-- return any footers.+chunkedTransfer :: Stream s => s -> IO (Result ([Header],String))+chunkedTransfer conn+ = chunkedTransferC conn 0 >>= \v ->+ return $ v `bindE` \(ftrs,count,info) ->+ let myftrs = Header HdrContentLength (show count) : ftrs + in Right (myftrs,info)++chunkedTransferC :: Stream s => s -> Int -> IO (Result ([Header],Int,String))+chunkedTransferC conn n+ = readLine conn >>= \v -> case v of+ Left e -> return (Left e)+ Right line ->+ let size = ( if null line || (head line) == '0'+ then 0+ else case readHex line of+ (n,_):_ -> n+ _ -> 0+ )+ in if size == 0+ then do { rs <- readTillEmpty2 conn []+ ; return $+ rs `bindE` \strs ->+ parseHeaders strs `bindE` \ftrs ->+ Right (ftrs,n,"")+ }+ else do { some <- readBlock conn size+ ; readLine conn+ ; more <- chunkedTransferC conn (n+size)+ ; return $ + some `bindE` \cdata ->+ more `bindE` \(ftrs,m,mdata) -> + Right (ftrs,m,cdata++mdata) + } ++-- | Maybe in the future we will have a sensible thing+-- to do here, at that time we might want to change+-- the name.+uglyDeathTransfer :: Stream s => s -> IO (Result ([Header],String))+uglyDeathTransfer conn+ = return $ Left $ ErrorParse "Unknown Transfer-Encoding"++-- | Remove leading crlfs then call readTillEmpty2 (not required by RFC)+readTillEmpty1 :: Stream s => s -> IO (Result [String])+readTillEmpty1 conn =+ do { line <- readLine conn+ ; case line of+ Left e -> return $ Left e+ Right s ->+ if s == crlf+ then readTillEmpty1 conn+ else readTillEmpty2 conn [s]+ }++-- | Read lines until an empty line (CRLF),+-- also accepts a connection close as end of+-- input, which is not an HTTP\/1.1 compliant+-- thing to do - so probably indicates an+-- error condition.+readTillEmpty2 :: Stream s => s -> [String] -> IO (Result [String])+readTillEmpty2 conn list =+ do { line <- readLine conn+ ; case line of+ Left e -> return $ Left e+ Right s ->+ if s == crlf || null s+ then return (Right $ reverse (s:list))+ else readTillEmpty2 conn (s:list)+ }++ +-----------------------------------------------------------------+------------------ A little friendly funtionality ---------------+-----------------------------------------------------------------+++{-+ I had a quick look around but couldn't find any RFC about+ the encoding of data on the query string. I did find an+ IETF memo, however, so this is how I justify the urlEncode+ and urlDecode methods.++ Doc name: draft-tiwari-appl-wxxx-forms-01.txt (look on www.ietf.org)++ Reserved chars: ";", "/", "?", ":", "@", "&", "=", "+", ",", and "$" are reserved.+ Unwise: "{" | "}" | "|" | "\" | "^" | "[" | "]" | "`"+ URI delims: "<" | ">" | "#" | "%" | <">+ Unallowed ASCII: <US-ASCII coded characters 00-1F and 7F hexadecimal>+ <US-ASCII coded character 20 hexadecimal>+ Also unallowed: any non-us-ascii character++ Escape method: char -> '%' a b where a, b :: Hex digits+-}++urlEncode, urlDecode :: String -> String++urlDecode ('%':a:b:rest) = chr (16 * digitToInt a + digitToInt b)+ : urlDecode rest+urlDecode (h:t) = h : urlDecode t+urlDecode [] = []++urlEncode (h:t) =+ let str = if reserved (ord h) then escape h else [h]+ in str ++ urlEncode t+ where+ reserved x+ | x >= ord 'a' && x <= ord 'z' = False+ | x >= ord 'A' && x <= ord 'Z' = False+ | x >= ord '0' && x <= ord '9' = False+ | x <= 0x20 || x >= 0x7F = True+ | otherwise = x `elem` map ord [';','/','?',':','@','&'+ ,'=','+',',','$','{','}'+ ,'|','\\','^','[',']','`'+ ,'<','>','#','%','"']+ -- wouldn't it be nice if the compiler+ -- optimised the above for us?++ escape x = + let y = ord x + in [ '%', intToDigit ((y `div` 16) .&. 0xf), intToDigit (y .&. 0xf) ]++urlEncode [] = []+ +++-- Encode form variables, useable in either the+-- query part of a URI, or the body of a POST request.+-- I have no source for this information except experience,+-- this sort of encoding worked fine in CGI programming.+urlEncodeVars :: [(String,String)] -> String+urlEncodeVars ((n,v):t) =+ let (same,diff) = partition ((==n) . fst) t+ in urlEncode n ++ '=' : foldl (\x y -> x ++ ',' : urlEncode y) (urlEncode $ v) (map snd same)+ ++ urlEncodeRest diff+ where urlEncodeRest [] = []+ urlEncodeRest diff = '&' : urlEncodeVars diff+urlEncodeVars [] = []
+ src/HAppS/Server/HTTPClient/Stream.hs view
@@ -0,0 +1,173 @@+-----------------------------------------------------------------------------+-- |+-- Module : HAppS.Server.HTTPClient.Stream+-- Copyright : (c) Warrick Gray 2002, Bjorn Bringert 2003-2004, Simon Foster 2004+-- License : BSD+--+-- Maintainer : bjorn@bringert.net+-- Stability : experimental+-- Portability : non-portable (not tested)+--+-- An library for creating abstract streams. Originally part of Gray's\/Bringert's+-- HTTP module.+--+-- * Changes by Simon Foster:+-- - Split module up into to sepearate Network.[Stream,TCP,HTTP] modules+-- +-----------------------------------------------------------------------------+module HAppS.Server.HTTPClient.Stream (+ -- ** Streams+ Debug,+ Stream(..),+ debugStream,+ + -- ** Errors+ ConnError(..),+ Result,+ handleSocketError,+ bindE,+ myrecv++) where++import Control.Exception as Exception+import System.IO.Error++-- Networking+import Network.Socket++import Control.Monad (liftM)+import System.IO++data ConnError = ErrorReset + | ErrorClosed+ | ErrorParse String+ | ErrorMisc String+ deriving(Show,Eq)++-- error propagating:+-- we could've used a monad, but that would lead us+-- into using the "-fglasgow-exts" compile flag.+bindE :: Either ConnError a -> (a -> Either ConnError b) -> Either ConnError b+bindE (Left e) _ = Left e+bindE (Right v) f = f v++-- | This is the type returned by many exported network functions.+type Result a = Either ConnError {- error -}+ a {- result -}++-----------------------------------------------------------------+------------------ Gentle Art of Socket Sucking -----------------+-----------------------------------------------------------------++-- | Streams should make layering of TLS protocol easier in future,+-- they allow reading/writing to files etc for debugging,+-- they allow use of protocols other than TCP/IP+-- and they allow customisation.+--+-- Instances of this class should not trim+-- the input in any way, e.g. leave LF on line+-- endings etc. Unless that is exactly the behaviour+-- you want from your twisted instances ;)+class Stream x where + readLine :: x -> IO (Result String)+ readBlock :: x -> Int -> IO (Result String)+ writeBlock :: x -> String -> IO (Result ())+ close :: x -> IO ()++++++-- Exception handler for socket operations+handleSocketError :: Socket -> Exception -> IO (Result a)+handleSocketError sk e =+ do { se <- getSocketOption sk SoError+ ; if se == 0+ then throw e+ else return $ if se == 10054 -- reset+ then Left ErrorReset+ else Left $ ErrorMisc $ show se+ }+++++instance Stream Socket where+ readBlock sk n = (liftM Right $ fn n) `Exception.catch` (handleSocketError sk)+ where+ fn x = do { str <- myrecv sk x+ ; let len = length str+ ; if len < x && len /= 0+ then ( fn (x-len) >>= \more -> return (str++more) ) + else return str+ }++ -- Use of the following function is discouraged.+ -- The function reads in one character at a time, + -- which causes many calls to the kernel recv()+ -- hence causes many context switches.+ readLine sk = (liftM Right $ fn "") `Exception.catch` (handleSocketError sk)+ where+ fn str =+ do { c <- myrecv sk 1 -- like eating through a straw.+ ; if null c || c == "\n"+ then return (reverse str++c)+ else fn (head c:str)+ }+ + writeBlock sk str = (liftM Right $ fn str) `Exception.catch` (handleSocketError sk)+ where+ fn [] = return ()+ fn x = send sk x >>= \i -> fn (drop i x)++ -- This slams closed the connection (which is considered rude for TCP\/IP)+ close sk = shutdown sk ShutdownBoth >> sClose sk++myrecv :: Socket -> Int -> IO String+myrecv sock len =+ let handler e = if isEOFError e then return [] else ioError e+ in System.IO.Error.catch (recv sock len) handler++-- | Allows stream logging.+-- Refer to 'debugStream' below.+data Debug x = Dbg Handle x+++instance (Stream x) => Stream (Debug x) where+ readBlock (Dbg h c) n =+ do { val <- readBlock c n+ ; hPutStrLn h ("readBlock " ++ show n ++ ' ' : show val)+ ; hFlush h+ ; return val+ }++ readLine (Dbg h c) =+ do { val <- readLine c+ ; hPutStrLn h ("readLine " ++ show val)+ ; return val+ }++ writeBlock (Dbg h c) str =+ do { val <- writeBlock c str+ ; hPutStrLn h ("writeBlock " ++ show val ++ ' ' : show str)+ ; return val+ }++ close (Dbg h c) =+ do { hPutStrLn h "closing..."+ ; hFlush h+ ; close c+ ; hPutStrLn h "...closed"+ ; hClose h+ }+++-- | Wraps a stream with logging I\/O, the first+-- argument is a filename which is opened in AppendMode.+debugStream :: (Stream a) => String -> a -> IO (Debug a)+debugStream file stm = + do { h <- openFile file AppendMode+ ; hPutStrLn h "File opened for appending."+ ; return (Dbg h stm)+ }
+ src/HAppS/Server/HTTPClient/TCP.hs view
@@ -0,0 +1,191 @@+-----------------------------------------------------------------------------+-- |+-- Module : HAppS.Server.HTTPClient.TCP+-- Copyright : (c) Warrick Gray 2002, Bjorn Bringert 2003-2004, Simon Foster 2004+-- License : BSD+--+-- Maintainer : bjorn@bringert.net+-- Stability : experimental+-- Portability : non-portable (not tested)+--+-- An easy access TCP library. Makes the use of TCP in Haskell much easier.+-- This was originally part of Gray's\/Bringert's HTTP module.+--+-- * Changes by Simon Foster:+-- - Split module up into to sepearate Network.[Stream,TCP,HTTP] modules+-- +-----------------------------------------------------------------------------+module HAppS.Server.HTTPClient.TCP (+ -- ** Connections+ Conn(..),+ Connection(..),+ openTCP,+ openTCPPort,+ isConnectedTo+) where++import Control.Exception as Exception++-- Networking+import Network.BSD+import Network.Socket+import HAppS.Server.HTTPClient.Stream++import Data.List (elemIndex)+import Data.Char+import Data.IORef+import System.IO++-----------------------------------------------------------------+------------------ TCP Connections ------------------------------+-----------------------------------------------------------------++-- | The 'Connection' newtype is a wrapper that allows us to make+-- connections an instance of the StreamIn\/Out classes, without ghc extensions.+-- While this looks sort of like a generic reference to the transport+-- layer it is actually TCP specific, which can be seen in the+-- implementation of the 'Stream Connection' instance.+newtype Connection = ConnRef {getRef :: IORef Conn}+++-- | The 'Conn' object allows input buffering, and maintenance of +-- some admin-type data.+data Conn = MkConn { connSock :: ! Socket+ , connAddr :: ! SockAddr + , connBffr :: ! String + , connHost :: String+ }+ | ConnClosed+ deriving(Eq)+++-- | Open a connection to port 80 on a remote host.+openTCP :: String -> IO Connection+openTCP host = openTCPPort host 80+++-- | This function establishes a connection to a remote+-- host, it uses "getHostByName" which interrogates the+-- DNS system, hence may trigger a network connection.+--+-- Add a "persistant" option? Current persistant is default.+-- Use "Result" type for synchronous exception reporting?+openTCPPort :: String -> Int -> IO Connection+openTCPPort uri port = + do { s <- socket AF_INET Stream 6+ ; setSocketOption s KeepAlive 1+ ; host <- Exception.catch (inet_addr uri) -- handles ascii IP numbers+ (\_ -> getHostByName uri >>= \host ->+ case hostAddresses host of+ [] -> return (error "no addresses in host entry")+ (h:_) -> return h)+ ; let a = SockAddrInet (toEnum port) host+ ; Exception.catch (connect s a) (\e -> sClose s >> throw e)+ ; v <- newIORef (MkConn s a [] uri)+ ; return (ConnRef v)+ }++instance Stream Connection where+ readBlock ref n = + readIORef (getRef ref) >>= \conn -> case conn of+ ConnClosed -> return (Left ErrorClosed)+ (MkConn sk addr bfr hst)+ | length bfr >= n ->+ do { modifyIORef (getRef ref) (\c -> c { connBffr=(drop n bfr) })+ ; return (Right $ take n bfr)+ }+ | otherwise ->+ do { modifyIORef (getRef ref) (\c -> c { connBffr=[] })+ ; more <- readBlock sk (n - length bfr)+ ; return $ case more of+ Left _ -> more+ Right s -> (Right $ bfr ++ s)+ }++ -- This function uses a buffer, at this time the buffer is just 1000 characters.+ -- (however many bytes this is is left to the user to decypher)+ readLine ref =+ readIORef (getRef ref) >>= \conn -> case conn of+ ConnClosed -> return (Left ErrorClosed)+ (MkConn sk addr bfr _)+ | null bfr -> {- read in buffer -}+ do { str <- myrecv sk 1000 -- DON'T use "readBlock sk 1000" !!+ -- ... since that call will loop.+ ; let len = length str+ ; if len == 0 {- indicates a closed connection -}+ then return (Right "")+ else modifyIORef (getRef ref) (\c -> c { connBffr=str })+ >> readLine ref -- recursion+ }+ | otherwise ->+ case elemIndex '\n' bfr of+ Nothing -> {- need recursion to finish line -}+ do { modifyIORef (getRef ref) (\c -> c { connBffr=[] })+ ; more <- readLine ref -- contains extra recursion + ; return $ more `bindE` \str -> Right (bfr++str)+ }+ Just i -> {- end of line found -}+ let (bgn,end) = splitAt i bfr in+ do { modifyIORef (getRef ref) (\c -> c { connBffr=(drop 1 end) })+ ; return (Right (bgn++['\n']))+ }++++ -- The 'Connection' object allows no outward buffering, + -- since in general messages are serialised in their entirety.+ writeBlock ref str =+ readIORef (getRef ref) >>= \conn -> case conn of+ ConnClosed -> return (Left ErrorClosed)+ (MkConn sk addr _ _) -> fn sk addr str `Exception.catch` (handleSocketError sk)+ where+ fn sk addr s+ | null s = return (Right ()) -- done+ | otherwise =+ getSocketOption sk SoError >>= \se ->+ if se == 0+ then sendTo sk s addr >>= \i -> fn sk addr (drop i s)+ else writeIORef (getRef ref) ConnClosed >>+ if se == 10054+ then return (Left ErrorReset)+ else return (Left $ ErrorMisc $ show se)+++ -- Closes a Connection. Connection will no longer+ -- allow any of the other Stream functions. Notice that a Connection may close+ -- at any time before a call to this function. This function is idempotent.+ -- (I think the behaviour here is TCP specific)+ close ref = + do { c <- readIORef (getRef ref)+ ; closeConn c `Exception.catch` (\_ -> return ())+ ; writeIORef (getRef ref) ConnClosed+ }+ where+ -- Be kind to peer & close gracefully.+ closeConn (ConnClosed) = return ()+ closeConn (MkConn sk addr [] _) =+ do { shutdown sk ShutdownSend+ ; suck ref+ ; shutdown sk ShutdownReceive+ ; sClose sk+ }++ suck :: Connection -> IO ()+ suck cn = readLine cn >>= + either (\_ -> return ()) -- catch errors & ignore+ (\x -> if null x then return () else suck cn)++-- | Checks both that the underlying Socket is connected+-- and that the connection peer matches the given+-- host name (which is recorded locally).+isConnectedTo :: Connection -> String -> IO Bool+isConnectedTo conn name =+ do { v <- readIORef (getRef conn)+ ; case v of+ ConnClosed -> return False+ (MkConn sk _ _ h) ->+ if (map toLower h == map toLower name)+ then sIsConnected sk+ else return False+ }+
+ src/HAppS/Server/JSON.hs view
@@ -0,0 +1,27 @@+module HAppS.Server.JSON where+import Data.Char+import Data.List++data JSON = JBool Bool | JString String | JInt Int | JFloat Float | + JObj [(String,JSON)] | JList [JSON] | JNull+++jInt = JInt . fromIntegral++class ToJSON a where+ toJSON::a->JSON+instance ToJSON JSON where toJSON=id++jsonToString (JBool bool) = map toLower $ show bool+jsonToString (JString string) = show string+jsonToString (JInt int) = show int+jsonToString (JFloat float) = show float+jsonToString (JObj pairs) = '{' : (concat $ (intersperse "," $ map impl pairs) )++"}"+ where+ impl (name,val) = concat [show name,":",jsonToString val]+jsonToString (JList list) = + '[':(concat $ (intersperse "," $ map jsonToString list)) ++"]"+jsonToString JNull = "null"+type CallBack=String++data JSONCall x = JCall CallBack x
+ src/HAppS/Server/MessageWrap.hs view
@@ -0,0 +1,242 @@+{-# OPTIONS -fglasgow-exts #-}+module HAppS.Server.MessageWrap where+{-+ (ToMessage(..), toMessage, FromMessage(..),+-- Index(..), + reqPath, pathEls, -- getPath,+ ReadString(..),+ look, lookS, lookM, lookMb,+ lookMbRead, mbRead, lookInput+ ,bodyToMap,bodyToList+ ) where+-}++import Control.Monad.Identity+import qualified Data.ByteString.Char8 as P+import qualified Data.ByteString.Lazy.Char8 as L+import qualified Data.List as List+import qualified Data.Map as M+import Data.Maybe+import HAppS.Server.HTTP.Types as H+import HAppS.Server.JSON+import HAppS.Server.MinHaXML+import HAppS.Server.HTTP.Multipart+import HAppS.Server.SURI as SURI+import HAppS.Util.Common+import qualified Text.XML.HaXml.Types as HaXml+import Data.Generics++{-+class ToMessage x where+ toMessageM :: Monad m => x -> m H.Result+ toMessageM x = do s <- toMessageBodyM x+ H.sresult' 200 [s]+ toMessageBodyM :: Monad m => x -> m P.ByteString+ toMessageBodyM x = (P.concat . H.rsBody) `liftM` toMessageM x++-- | Non-monadic variant of toMessageM, mostly for backwards support.+toMessage :: ToMessage x => x -> Result+toMessage x = runIdentity $ toMessageM x++class FromMessage x where+ fromMessage :: H.Request -> x+ fromMessage msg = x where Identity x = fromMessageM msg+ fromMessageM :: (Monad m,Functor m) => H.Request -> m x+ fromMessageM = return . fromMessage+++instance ToMessage H.Result where toMessageM = return+instance ToMessage String where toMessageM = H.sresult 200++instance ToMessage ([(String,String)],String) where + toMessageM (hdrs,val) = + do + msg <- toMessageM val+ return $ foldr (\ (n,v) res ->setHeader n v res) msg hdrs++++instance FromMessage () where fromMessage = const ()+instance FromMessage H.Request where fromMessage = id++instance (FromMessage m,FromMessage a) => FromMessage (m,a) where+ fromMessageM m = liftM2 (,) (fromMessageM m) (fromMessageM m)++instance FromMessage m => FromMessage (Maybe m) where+ fromMessageM m = return $ fromMessageM m++-}++{--instance (ToElement x)=>ToMessage (XML x) where + toMessageM (XML style obj) = liftM (addHeader "Content-Type" $ ctype el)+ (toMessageM doc)+ where+ doc = (if ctype el == "text/html" then simpleDoc' NoStyle+ else simpleDoc style) el+ el = HaXml.Elem "alksjd" [] []+ el' = toElement obj+ ctype (HaXml.Elem "html" _ _) = "text/html"+ ctype _ = "text/xxxxml"+ -- ctype (HaXml.Elem "html" _ _) = error "html!!!"+++instance (ToJSON x) => ToMessage (JSONCall x) where+ toMessageM (JCall cb x) = liftM (addHeader "Content-Type" "text/javascript")+ (toMessageM $ concat [cb,"(",jsonToString $ toJSON x,")"])+--}+++++{-+bodyToList :: Request -> [(String, String)]+bodyToList = map unInput . bodyToList'+ where unInput (name, input) = (name, P.unpack $ inputValue input)++bodyToList' :: Request -> [(String, Input)]+bodyToList' req = queryInput req ++ bodyInput req++bodyToMap :: Request -> M.Map String String+bodyToMap = M.fromList . bodyToList++bodyToMap' :: Request -> M.Map String Input+bodyToMap' = M.fromList . bodyToList'+-}++queryInput :: SURI -> [(String, Input)]+queryInput uri = formDecode (case SURI.query $ uri of+ '?':r -> r+ xs -> xs)++bodyInput :: Request -> [(String, Input)]+bodyInput req | rqMethod req /= POST = []+bodyInput req =+ let ctype = getHeader "content-type" req >>= parseContentType . P.unpack+ getBS (Body bs) = bs+ in decodeBody ctype (getBS $ rqBody req)+++-- Decodes application\/x-www-form-urlencoded inputs. +formDecode :: String -> [(String, Input)]+formDecode [] = []+formDecode qString = + if null pairString then rest else + (SURI.unEscape name,simpleInput $ SURI.unEscape val):rest+ where (pairString,qString')= split (=='&') qString+ (name,val)=split (=='=') pairString+ rest=if null qString' then [] else formDecode qString'++decodeBody :: Maybe ContentType+ -> L.ByteString+ -> [(String,Input)]+decodeBody ctype inp+ = case ctype of+ Just (ContentType "application" "x-www-form-urlencoded" _)+ -> formDecode (L.unpack inp)+ Just (ContentType "multipart" "form-data" ps)+ -> multipartDecode ps inp+ Just _ -> [] -- unknown content-type, the user will have to+ -- deal with it by looking at the raw content+ -- No content-type given, assume x-www-form-urlencoded+ Nothing -> formDecode (L.unpack inp)++-- | Decodes multipart\/form-data input.+multipartDecode :: [(String,String)] -- ^ Content-type parameters+ -> L.ByteString -- ^ Request body+ -> [(String,Input)] -- ^ Input variables and values.+multipartDecode ps inp =+ case lookup "boundary" ps of+ Just b -> case parseMultipartBody b inp of+ Just (MultiPart bs) -> map bodyPartToInput bs+ Nothing -> [] -- FIXME: report parse error+ Nothing -> [] -- FIXME: report that there was no boundary++bodyPartToInput :: BodyPart -> (String,Input)+bodyPartToInput (BodyPart hs b) =+ case getContentDisposition hs of+ Just (ContentDisposition "form-data" ps) ->+ (fromMaybe "" $ lookup "name" ps,+ Input { inputValue = b,+ inputFilename = lookup "filename" ps,+ inputContentType = ctype })+ _ -> ("ERROR",simpleInput "ERROR") -- FIXME: report error+ where ctype = fromMaybe defaultInputType (getContentType hs)+++simpleInput :: String -> Input+simpleInput v+ = Input { inputValue = L.pack v+ , inputFilename = Nothing+ , inputContentType = defaultInputType+ }++-- | The default content-type for variables.+defaultInputType :: ContentType+defaultInputType = ContentType "text" "plain" [] -- FIXME: use some default encoding?++++{-+-- | Get the path from a Request.+reqPath :: Request -> String+reqPath = SURI.path . rqURI+-}++-- | Get the path components from a String.+pathEls :: String -> [String]+pathEls = (drop 1) . map SURI.unEscape . splitList '/' +-- filter (not.null) $ map URI.unEscapeString $ splitList '/' path ++{-+-- | Get the path components from the Request.+getPath :: Request -> [String]+getPath req= pathEls $ reqPath req+-}+-- | Like 'Read' except Strings and Chars not quoted.+class (Read a)=>ReadString a where readString::String->a; readString =read ++instance ReadString Int +instance ReadString Double +instance ReadString Float +instance ReadString SURI.SURI where readString = read . show+instance ReadString [Char] where readString=id+instance ReadString Char where + readString s= if length t==1 then head t else read t where t=trim s ++{-+-- | Read the named field from the request and if it fails use the+-- given default value.+look :: (Read a) => Request -> String -> a -> a+look msg name other = maybe other id $ lookup name m >>= mbRead+ where m = bodyToList msg++-- | Get the named field from the request with a maximum length.+-- If the field is not defined return the empty String.+lookS :: Int -> Request -> String -> String+lookS maxLength msg name = take maxLength $ fromMaybe "" $ lookup name m+ where m = bodyToList msg+-- ml = if maxLength < 0 then 2^32 else maxLength++-- | Read a named field from the request. May fail if the field doens't exist.+lookM :: Monad m => Request -> String -> m String+lookM = lookMb return+++lookMb :: (Monad m) => (String -> m b) -> Request -> String -> m b+lookMb p msg name = M.lookup name m >>= p+ where m = bodyToMap msg++-- | Read the named field from the request.+--lookMbRead :: (Read a,Monad m) => Request -> String -> m a+lookMbRead msg = maybeM . lookMb mbRead msg+++lookInput :: Monad m => Request -> String -> m Input+lookInput req name+ = M.lookup name (bodyToMap' req)++-- | Read a value from a String.+mbRead :: (Read a) => String -> Maybe a+mbRead = msum . map (Just . fst) . readsPrec 5 +-}+
+ src/HAppS/Server/MinHaXML.hs view
@@ -0,0 +1,200 @@+{-# LANGUAGE TemplateHaskell, FlexibleInstances,+ OverlappingInstances, UndecidableInstances, TypeSynonymInstances #-}+++ +module HAppS.Server.MinHaXML where+-- Copyright (C) 2005 HAppS.org. All Rights Reserved.++import Text.XML.HaXml.Types as Types+import Text.XML.HaXml.Escape+import Text.XML.HaXml.Pretty as Pretty+import Text.XML.HaXml.Verbatim as Verbatim+import HAppS.Util.Common+import Data.Maybe+import System.Time++import HAppS.Data.Xml as Xml+import HAppS.Data.Xml.HaXml++type StyleURL=String+data StyleSheet = NoStyle+ | CSS {styleURL::StyleURL} + | XSL {styleURL::StyleURL} deriving (Read,Show)+hasStyleURL NoStyle = False+hasStyleURL _ = True +type Element = Types.Element++ ++isCSS (CSS _)=True+isCSS _ = False+isXSL = not.isCSS++t=textElem+l=listElem+e=emptyElem+(</<)=l+(<>)=t++++xmlElem f = \name attrs val -> xmlelem name attrs (f val)+ where + xmlelem name attrs = Types.Elem name (map (uncurry attr) attrs)+ attr name val= (name,AttValue [Left val])++textElem = xmlElem (return.CString True)+emptyElem = \n a->xmlElem id n a []+listElem = xmlElem $ map CElem++cdataElem = CString False++--simpleDoc xsl root = show $ document $ +-- Document (simpleProlog xsl) [] $ xmlEscape stdXmlEscaper root+simpleDocOld xsl = show . document . + flip (Document (simpleProlog xsl) []) [] . xmlStdEscape++simpleDoc style elem = ("<?xml version='1.0' encoding='UTF-8' ?>\n"+++ if hasStyleURL style then pi else "") +++ (verbatim $ xmlStdEscape elem)+ where typeText=if isCSS style then "text/css" else "text/xsl"+ pi= "<?xml-stylesheet type=\""++ typeText ++ + "\" href=\""++styleURL style++"\" ?>\n"+++simpleDoc' style elem = (if hasStyleURL style then pi else "") +++ (verbatim $ xmlStdEscape elem)+ where typeText=if isCSS style then "text/css" else "text/xsl"+ pi= "<?xml-stylesheet type=\""++ typeText ++ + "\" href=\""++styleURL style++"\" ?>\n"++++xmlEscaper=stdXmlEscaper+xmlStdEscape = xmlEscape stdXmlEscaper+verbim x =verbatim x++simpleProlog style = + Prolog + (Just (XMLDecl "1.0" + (Just $ EncodingDecl "UTF-8") + Nothing -- (Just True) -- standalone declaration+ ))+ [] Nothing -- (Just docType)+ (if url=="" then [] else [pi])+ where+ pi = PI ("xml-stylesheet", "type=\""++typeText++"\" href=\""++url++"\"")+ typeText = if isCSS style then "text/css" else "text/xsl"+ url=if hasStyleURL style then styleURL style else ""++nonEmpty name val = if val=="" then Nothing+ else Just $ textElem name [] val++getRoot (Document _ _ root _) = root++--toXML .< "App" attrs ./>+--toXML .< "App" attrs .> []+data XML a = XML StyleSheet a+--class HasStyle x where getStyle::x->StyleSheet+class ToElement x where toElement::x->Types.Element+ +{--+instance (ToElement x) => ToElement (Maybe x) where + toElement = maybe (emptyElem "Nothing" []) + (\x->listElem "Just" [] [toElement x])+--}++instance (ToElement x) => ToElement (Maybe x) where + toElement = maybe (emptyElem "Nothing" []) toElement++instance ToElement String where toElement s = textElem "String" [] s+instance ToElement Types.Element where toElement = id+instance ToElement CalendarTime where + toElement = recToEl "CalendarTime" + [attrFS "year" ctYear+ ,attrFS "month" (fromEnum.ctMonth)+ ,attrFS "day" ctDay+ ,attrFS "hour" ctHour+ ,attrFS "min" ctMin+ ,attrFS "sec" ctSec+ ,attrFS "time" time + ] []+ where time ct = epochPico ct++instance ToElement Int where toElement = toElement . show+instance ToElement Integer where toElement = toElement . show+instance ToElement Float where toElement = toElement . show+instance ToElement Double where toElement = toElement . show+++instance (Xml a) => ToElement a where+ toElement = un . head . map toHaXml . toXml+ where+ un (CElem el) = el+++--let TOD sec pico = toClockTime ct in sec*1000 +--class (Show x)=>ToAttr x where toAttr::x->String; toAttr=show++++wrapElem tag x= listElem tag [] [toElement x]+elF tag f = wrapElem tag.f +-- label !<=! field = wrapField label field+attrF name f rec = (name,quoteEsc $ f rec)+attrFS name f rec = (name,quoteEsc $ show $ f rec)+attrFMb r name f = maybe ("","") (\x->(name,quoteEsc $ r x)) . f ++--attrFMb r name f list= maybe list ((attrF name (r . fromJust . f)):list)++--(\x->(name,quoteEsc $ r x)) . f +--(name,quoteEsc $ show $ f rec)++quoteEsc [] = []+quoteEsc ('"':list) = """ ++ quoteEsc list+quoteEsc (x:xs) = x:quoteEsc xs++--hexToInt++--hexToAlphaNum [] = []+--hexToAlphaNum (x:xs) = ++--attrShowF name f rec = (name,show $ f rec)++--quotescape \\ and " \"++recToEl name attrs els rec = listElem name attrs' (revmap rec els)+ where+ attrs' = filter (\ (x,_)->not $ null x) (revmap rec attrs)+listToEl name attrs = listElem name attrs . map toElement ++--listToEl list = listElem "List" [] $ map toElement list+++--instance ToElement NELL where toElement s = e "x" []++--data NELL = NELL++toAttrs x = map (\ (s,f)->(s, f x)) ++{--+toElement rules:+1. if the attr is an instance of toElement then it is a child.+2. if it named and is type string then it is shown that way.+3. if it named and has non-string type then use show on the value.+4. if the attributes are not named then use the type as the label and+ make the text child be a show of the object.+--}+++newtype ElString = ElString {elString::String} deriving (Eq,Ord,Read,Show)+++{--+store thing as XML or do multiple parse passes?++--}+{--+elstring+--}
+ src/HAppS/Server/S3.hs view
@@ -0,0 +1,272 @@+module HAppS.Server.S3+ ( newS3 -- :: AccessKey -> SecretKey -> URI -> IO S3+ , closeS3 -- :: S3 -> IO ()+ , createBucket -- :: S3 -> BucketId -> IO ()+ , createObject -- :: S3 -> BucketId -> ObjectId -> String -> IO ()+ , getObject -- :: S3 -> BucketId -> ObjectId -> IO String+ , deleteBucket -- :: S3 -> BucketId -> IO ()+ , deleteObject -- :: S3 -> BucketId -> ObjectId -> IO ()+ , listObjects -- :: S3 -> BucketId -> IO [String]+ , sendRequest -- :: S3 -> Request -> IO String+ , sendRequest_ -- :: S3 -> Request -> IO ()+-- , sendRequests -- :: S3 -> [Request] -> IO ()+ , BucketId, ObjectId, AccessKey, SecretKey+ , amazonURI+ ) where++import HAppS.Crypto.HMAC ( hmacSHA1 )+import HAppS.Server.HTTPClient.HTTP+import qualified HAppS.Server.HTTPClient.Stream as Stream++import Network.URI+import Control.Concurrent ( newMVar, modifyMVar, swapMVar, forkIO+ , modifyMVar_, MVar )+import Data.Maybe ( fromJust, fromMaybe )+import Data.List ( intersperse )+import System.Time ( getClockTime, toCalendarTime+ , formatCalendarTime )+import System.Locale ( defaultTimeLocale, rfc822DateFormat )++import Text.XML.HaXml ( xmlParse, Document(..), Content(..) )+import Text.XML.HaXml.Xtract.Parse ( xtract )++type BucketId = String+type ObjectId = String+type AccessKey = String+type SecretKey = String++data S3+ = S3+ { s3AccessKey :: AccessKey+ , s3SecretKey :: SecretKey+ , s3URI :: URI+-- , s3KeepAliveTimeout :: Int+ , s3Conn :: MVar (Maybe Connection)+ }++{-+ Sign a request using the access key and secret key from the S3 data+ type.+-}+signRequest :: S3 -> Request -> IO Request+signRequest s3+ = let akey = s3AccessKey s3+ skey = s3SecretKey s3+ in signRequest' akey skey++{-+ Fill in necessary information (such as a date header) and then sign+ then request.+-}+signRequest' :: AccessKey -> SecretKey -> Request -> IO Request+signRequest' akey skey request+ = do now <- getClockTime+ cal <- toCalendarTime now+ let isoDate = formatCalendarTime defaultTimeLocale rfc822DateFormat cal+ auth = fromJust (parseURIAuthority (authority (rqURI request)))+-- authErr = error "S3.hs: internal error: failed to parse authority"+ let dat = concat $ intersperse "\n"+ [show (rqMethod request)+ ,lookupHeader HdrContentMD5+ ,lookupHeader HdrContentType+ ,isoDate+ ,uriPath (rqURI request)]+ authorization = Header HdrAuthorization $ "AWS " ++ akey ++ ":" ++ signature+ signature = hmacSHA1 skey dat+ lookupHeader hn = fromMaybe "" (findHeader hn request)+ dateHdr = Header HdrDate isoDate+ lengthHdr = Header HdrContentLength (show $ length (rqBody request))+ connHdr = Header HdrConnection "Keep-Alive"+ hostHdr = Header HdrHost (host auth)+ return $ request+ { rqHeaders = hostHdr:connHdr:lengthHdr:dateHdr:+ authorization:rqHeaders request+ , rqURI = (rqURI request) { uriScheme = ""+ , uriAuthority = Nothing}}++{-+ Return a connection to an S3 server. Will initiate a new+ connection if no previous was found.+-}+getConnection :: S3 -> IO Connection+getConnection s3+ = modifyMVar (s3Conn s3) $ \mbConn ->+ case mbConn of+ Just conn -> return (mbConn,conn)+ Nothing -> do print (host auth, port auth)+ c <- openTCPPort (host auth) (fromMaybe 80 (port auth))+ return (Just c,c)+ where auth = fromJust (parseURIAuthority (authority (s3URI s3)))++createRequest :: S3 -> RequestMethod -> String -> String -> Request+createRequest s3 method path body+ = Request uri method [] body+ where uri = localhost { uriPath = '/':escapeURIString isAllowedInURI path }++{-+ Send a single request to an S3 server returning the body+ of the result.+-}+sendRequest :: S3 -> Request -> IO String+sendRequest s3 request+ = loop =<< signRequest s3 request+ where loop request'+ = do c <- getConnection s3+ ret <- sendHTTP c request'+ case ret of+ Left ErrorClosed+ -> do putStrLn "Connection closed."+ swapMVar (s3Conn s3) Nothing+ loop request'+ Left err -> error ("Failed to connect: " ++ show err) -- FIXME+ Right res+ | (2,_,_) <- rspCode res -> return (rspBody res)+ | otherwise -> error ("Server error: " ++ rspReason res)++{-+ Same as 'sendRequest' except that it ignored the result.+-}+sendRequest_ :: S3 -> Request -> IO ()+sendRequest_ s3 request+ = do sendRequest s3 request+ return ()++{-+ Sign and send requests pipelined over a keep-alive connection.+-}+{-+ S3 imposes a quite severe limitation on pipelined requests.+ Sending too many requests or exceeding a size limit will+ result in a disconnect. The precise borders of these limits+ are hard-wired and unknown to the general public. At the time+ of this writing, sending three requests at a time seems optimal.++ Quote from Amazons web-forum:+ (http://developer.amazonwebservices.com/connect/thread.jspa?messageID=39883)+ "OK, we have located the cause of the behavior you are seeing.+ Your pipelined requests are being aborted because one of the+ network devices handling the connection has certain limitations+ on the amount of pipelined data it is willing to accept per+ connection, and that limit is being exceeded. Unfortunately, this+ limit is phrased in very low-level terms so it isn't possible to+ say in a platform or network independent way whether any given+ size, sequence or number of requests will exceed the limit and+ cause a disconnection or not. We have engaged with the device+ vendor and found out that this limit is hard-wired and that this+ behavior is not likely to change any time soon.++ In light of these facts, here is some guidance on pipelining HTTP+ requests to Amazon S3.+ 1) Be optimistic and pipeline a modest number of GET or HEAD+ requests, say two to four.+ 2) Handle asynchronous disconnects by re-connecting and re-sending+ unacknowledged requests left in your pipeline. (As Colin points+ out, correct HTTP clients must do this anyway)+ 3) If possible, try to minimize the number of TCP segments your+ pipelined requests generate. In particular, leave the TCP socket+ no delay option off and send as many requests per socket write call+ as is practical."+-}+{-+sendRequests :: S3 -> [Request] -> [IO ()] -> IO ()+sendRequests s3 [] io = return ()+sendRequests s3 rqsts io+ = do c <- getConnection s3+ rqsts' <- mapM (signRequest s3) rqsts+ let maxPipelineSize = 3+ loop c [] _ = return ()+ loop c rqs io =+ do (ok,rsps) <- sendHTTPPipelined c (take maxPipelineSize rqs)+ let nOk = length ok+ (okIO,io') = splitAt nOk io+ rqs' = drop nOk rqs+ sequence_ okIO+ -- forkIO $ sequence_ okIO -- FIXME: would it be OK to use forkIO here?+ case rsps of+ Just ErrorClosed+ -> do swapMVar (s3Conn s3) Nothing+ c <- getConnection s3+ loop c rqs' io'+ Just err -> do error ("Failed to send requests: " ++ show err)+ Nothing -> do loop c rqs' io'+ loop c rqsts' io+-}++{-+-- Testing utility+deleteAll :: BucketId -> IO ()+deleteAll bucket+ = do s3 <- newS3 akey skey localhost+ objs <- listObjects s3 bucket+ let rqs = flip map objs $ \obj -> (deleteObject s3 bucket obj)+ sendRequests s3 rqs []+ closeS3 s3+-}++--------------------------------------------------------------+-- Initiate+--------------------------------------------------------------++newS3 :: AccessKey -> SecretKey -> URI -> IO S3+newS3 akey skey uri+ = do conn <- newMVar Nothing+ return $ S3 { s3AccessKey = akey+ , s3SecretKey = skey+ , s3URI = uri+-- , s3KeepAliveTimeout :: Int+ , s3Conn = conn+ }++closeS3 :: S3 -> IO ()+closeS3 s3+ = modifyMVar_ (s3Conn s3) $ \mbConn ->+ case mbConn of+ Nothing -> return Nothing+ Just conn -> do Stream.close conn+ return Nothing+++--------------------------------------------------------------+-- Requests+--------------------------------------------------------------+++createBucket :: S3 -> BucketId -> Request+createBucket s3 bucket+ = createRequest s3 PUT bucket ""++createObject :: S3 -> BucketId -> ObjectId -> String -> Request+createObject s3 bucket object+ = createRequest s3 PUT (bucket ++ "/" ++ object)++getObject :: S3 -> BucketId -> ObjectId -> Request+getObject s3 bucket object+ = createRequest s3 GET (bucket ++ "/" ++ object) ""++deleteBucket :: S3 -> BucketId -> Request+deleteBucket s3 bucket+ = createRequest s3 DELETE bucket ""++deleteObject :: S3 -> BucketId -> ObjectId -> Request+deleteObject s3 bucket object+ = createRequest s3 DELETE (bucket ++ "/" ++ object) ""++--------------------------------------------------------------+-- Actions+--------------------------------------------------------------+++listObjects :: S3 -> BucketId -> IO [String]+listObjects s3 bucket+ = do lst <- sendRequest s3 (createRequest s3 GET bucket "")+ return $ ppContent . filter . getContent . xmlParse bucket $ lst+ where filter = xtract "*/Key/-"+ getContent (Document _ _ e _) = CElem e++ ppContent xs = [ s | CString _ s <- xs ]++++amazonURI = fromJust $ parseURI "http://s3.amazonaws.com/"+localhost = fromJust $ parseURI "http://localhost/"+
+ src/HAppS/Server/SURI.hs view
@@ -0,0 +1,65 @@+{-# OPTIONS -fglasgow-exts #-}+module HAppS.Server.SURI where+import Data.Maybe+import Data.Generics+import HAppS.Util.Common(mapFst)+import qualified Network.URI as URI++path, query, scheme :: SURI -> String+path = URI.uriPath . suri+query = URI.uriQuery . suri+scheme = URI.uriScheme . suri++u_scheme, u_path :: (String -> String) -> SURI -> SURI+u_scheme f (SURI u) = SURI (u {URI.uriScheme=f $ URI.uriScheme u})+u_path f (SURI u) = SURI $ u {URI.uriPath=f $ URI.uriPath u}+a_scheme, a_path :: String -> SURI -> SURI+a_scheme a (SURI u) = SURI $ u {URI.uriScheme=a}+a_path a (SURI u) = SURI $ u {URI.uriPath=a}++escape, unEscape :: String -> String+unEscape = URI.unEscapeString . map (\x->if x=='+' then ' ' else x)+escape = URI.escapeURIString URI.isAllowedInURI++isAbs :: SURI -> Bool+isAbs = not . null . URI.uriScheme . suri+--isAbs = maybe True ( mbParsed++newtype SURI = SURI {suri::URI.URI} deriving (Eq,Data,Typeable)+instance Show SURI where+ showsPrec d (SURI uri) = showsPrec d $ show uri+instance Read SURI where+ readsPrec d = mapFst fromJust . filter (isJust . fst) . mapFst parse . readsPrec d ++instance Ord SURI where+ compare a b = show a `compare` show b++--parse = fmap SURI . URI.parseURIReference ::String->Maybe SURI++-- | Render should be used for prettyprinting URIs.+render :: (ToSURI a) => a -> String+render x = (show . suri . toSURI) x+parse :: String -> Maybe SURI+parse = fmap SURI . URI.parseURIReference ++--mbParse::String->Maybe SURI+++--let x = readsPrec 5 s in if null x then Nothing +-- else Just $ fst $ head x++class ToSURI x where toSURI::x->SURI+--instance ToSURI (Maybe x) where toSURI =toSURI.fromJust+instance ToSURI SURI where toSURI=id+instance ToSURI URI.URI where toSURI=SURI+instance ToSURI String where + toSURI = maybe (SURI $ URI.URI "" Nothing "" "" "") id . parse++--class ToSURI x where toSURI::x->SURI+--instance ToSURI SURI where toSURI=id+--instance ToURI String where toURI=URI+--instance ToURI String +-- where toURI s = maybe (URI "" Nothing "" s "") id (parseURIReference s)++--handling obtaining things from URI paths+class FromPath x where fromPath::String->x
+ src/HAppS/Server/SURI/ParseURI.hs view
@@ -0,0 +1,66 @@+module HAppS.Server.SURI.ParseURI(parseURIRef) where++import qualified Data.ByteString.Internal as BB+import qualified Data.ByteString.Unsafe as BB+import Data.ByteString.Char8 as BC+import Prelude hiding(break,length,null,drop,splitAt)+import Network.URI++import HAppS.Util.ByteStringCompat++parseURIRef :: ByteString -> URI+parseURIRef fs =+ case break (\c -> ':' == c || '/' == c || '?' == c || '#' == c) fs of+ (initial,rest) ->+ let ui = unpack initial+ in case uncons rest of+ Nothing ->+ if null initial then nullURI -- empty uri+ else -- uri not containing either ':' or '/'+ nullURI { uriPath = ui }+ Just (c, rrest) ->+ case c of+ ':' -> pabsuri rrest $ URI (unpack initial)+ '/' -> puriref fs $ URI "" Nothing+ '?' -> pquery rrest $ URI "" Nothing ui+ '#' -> pfragment rrest $ URI "" Nothing ui ""+ _ -> error "parseURIRef: Can't happen"++pabsuri fs cont =+ if length fs >= 2 && unsafeHead fs == '/' && unsafeIndex fs 1 == '/'+ then pauthority (drop 2 fs) cont+ else puriref fs $ cont Nothing+pauthority fs cont =+ let (auth,rest) = breakChar '/' fs+ in puriref rest $! cont (Just $! pauthinner auth)+pauthinner fs =+ case breakChar '@' fs of+ (a,b) -> pauthport b $ URIAuth (unpack a)+pauthport fs cont =+ let spl idx = splitAt (idx+1) fs+ in case unsafeHead fs of+ _ | null fs -> cont "" ""+ '[' -> case fmap spl (elemIndexEnd ']' fs) of+ Just (a,b) | null b -> cont (unpack a) ""+ | unsafeHead b == ':' -> cont (unpack a) (unpack $ unsafeTail b)+ x -> error ("Parsing uri failed (pauthport):"++show x)+ _ -> case breakCharEnd ':' fs of+ (a,b) -> cont (unpack a) (unpack b)+puriref fs cont =+ let (u,r) = break (\c -> '#' == c || '?' == c) fs+ in case unsafeHead r of+ _ | null r -> cont (unpack u) "" ""+ '?' -> pquery (unsafeTail r) $ cont (unpack u)+ '#' -> pfragment (unsafeTail r) $ cont (unpack u) ""+pquery fs cont =+ case breakChar '#' fs of+ (a,b) -> cont ('?':unpack a) (unpack b)+pfragment fs cont =+ cont $ unpack fs++++unsafeTail = BB.unsafeTail+unsafeHead = BB.w2c . BB.unsafeHead+unsafeIndex s = BB.w2c . BB.unsafeIndex s+
+ src/HAppS/Server/SimpleHTTP.hs view
@@ -0,0 +1,595 @@+{-# OPTIONS_GHC -fglasgow-exts -fallow-undecidable-instances -fallow-overlapping-instances #-}+-----------------------------------------------------------------------------+-- |+-- Module : HAppS.Server.SimpleHTTP+-- Copyright : (c) HAppS Inc 2007+-- License : BSD-like+--+-- Maintainer : lemmih@vo.com+-- Stability : provisional+-- Portability : requires mtl+--+-- SimpleHTTP provides a back-end independent API for handling HTTP requests.+--+-- By default, the built-in HTTP server will be used. However, other back-ends+-- like CGI\/FastCGI can used if so desired.+-----------------------------------------------------------------------------+module HAppS.Server.SimpleHTTP+ ( module HAppS.Server.HTTP.Types+ , module HAppS.Server.Cookie+ , -- * SimpleHTTP+ simpleHTTP -- , simpleHTTP'+ , parseConfig+ , FromReqURI(..)+ , RqData+ , FromData(..)+ , ToMessage(..)+ , ServerPart+ , ServerPartT(..)+ , Web+ , WebT(..)+ , Result(..)+ , noHandle+ , escape+++ -- * ServerPart primitives.+ , webQuery+ , webUpdate+ , flatten+ , localContext+ , dir -- :: String -> [ServerPart] -> ServerPart+ , method -- :: MatchMethod m => m -> IO Result -> ServerPart+ , methodSP+-- , method' -- :: MatchMethod m => m -> IO (Maybe Result) -> ServerPart+ , path -- :: FromReqURI a => (a -> [ServerPart]) -> ServerPart+ , proxyServe+ , rproxyServe+-- , limProxyServe+ , uriRest + , anyPath+ , anyPath'+ , withData -- :: FromData a => (a -> [ServerPart]) -> ServerPart+ , withDataFn+-- , modXml+ , require -- :: IO (Maybe a) -> (a -> [ServerPart]) -> ServerPart+ , multi -- :: [ServerPart] -> ServerPart+ , withRequest -- :: (Request -> IO Result) -> ServerPart+ , debugFilter+ , anyRequest+ , applyRequest+ , modifyResponse+ , setResponseCode+ , basicAuth+ -- * Creating Results.+ , ok -- :: ToMessage a => a -> IO Result+-- , mbOk+ , badGateway+ , internalServerError+ , badRequest+ , unauthorized + , forbidden+ , notFound+ , seeOther+ , found+ , movedPermanently+ , tempRedirect+ , addCookie+ , addCookies+ -- * Parsing input and cookies+ , lookInput -- :: String -> Data Input+ , lookBS -- :: String -> Data B.ByteString+ , look -- :: String -> Data String+ , lookCookie -- :: String -> Data Cookie+ , lookCookieValue -- :: String -> Data String+ , readCookieValue -- :: Read a => String -> Data a+ , lookRead -- :: Read a => String -> Data a+ , lookPairs+ -- * XSLT+ , xslt ,doXslt+ ) where+import HAppS.Server.HTTP.Client+import HAppS.Data.Xml.HaXml+import qualified HAppS.Server.MinHaXML as H++import HAppS.Server.HTTP.Types hiding (Version(..))+import qualified HAppS.Server.HTTP.Types as Types+import HAppS.Server.HTTP.Listen+import HAppS.Server.XSLT+import HAppS.Server.SURI (ToSURI)+import HAppS.Util.Common+import HAppS.Server.Cookie+import HAppS.State (QueryEvent, UpdateEvent, query, update)+import HAppS.Data -- used by default implementation of fromData+import Control.Monad.Reader+import Control.Monad.State+--import Control.Concurrent+import Data.Maybe+import qualified Data.ByteString.Char8 as B+import qualified Data.ByteString.Lazy.Char8 as L+import qualified Data.Generics as G+import qualified Data.Map as M+import Text.Html (Html,renderHtml)+import qualified Text.XHtml as XHtml (Html,renderHtml)+import qualified HAppS.Crypto.Base64 as Base64+import Data.Char+import Data.List+import System.IO+import System.Environment+import System.Console.GetOpt+import System.Exit++type Web a = WebT IO a+type ServerPart a = ServerPartT IO a++newtype ServerPartT m a = ServerPartT { unServerPartT :: Request -> WebT m a }++instance (Monad m) => Monad (ServerPartT m) where+ f >>= g = ServerPartT $ \rq ->+ do a <- unServerPartT f rq+ unServerPartT (g a) rq+ return x = ServerPartT $ \_ -> return x++newtype WebT m a = WebT { unWebT :: m (Result a) }++data Result a = NoHandle+ | Ok (Response -> Response) a+ | Escape Response+ deriving Show+instance Show (a -> b) where+ show _ = "<func>"++instance Monad m => Monad (WebT m) where+ f >>= g = WebT $ do r <- unWebT f+ case r of+ NoHandle -> return NoHandle+ Escape resp -> return $ Escape resp+ Ok out a -> do r' <- unWebT (g a)+ case r' of+ NoHandle -> return NoHandle+ Escape resp -> return $ Escape resp+ Ok out' a' -> return $ Ok (out' . out) a'+ return x = WebT $ return (Ok id x)++instance MonadTrans WebT where+ lift m = WebT (liftM (Ok id) m)++instance MonadIO m => MonadIO (WebT m) where+ liftIO m = WebT (liftM (Ok id) $ liftIO m)++instance MonadReader r m => MonadReader r (WebT m) where+ ask = lift ask+ local fn m = WebT $ local fn (unWebT m)++instance MonadState st m => MonadState st (WebT m) where+ get = lift get+ put = lift . put+++noHandle :: Monad m => WebT m a+noHandle = WebT $ return NoHandle++escape :: (Monad m, ToMessage resp) => WebT m resp -> WebT m a+escape gen = WebT $ do res <- unWebT gen+ case res of+ NoHandle -> return NoHandle+ Escape resp -> return $ Escape resp+ Ok out a -> return $ Escape $ out $ toResponse a++ho :: [OptDescr (Conf -> Conf)]+ho = [Option [] ["http-port"] (ReqArg (\h c -> c { port = read h }) "port") "port to bind http server"]++parseConfig :: [String] -> Either [String] Conf+parseConfig args+ = case getOpt Permute ho args of+ (flags,_,[]) -> Right $ foldr ($) nullConf flags+ (_,_,errs) -> Left errs++-- | Use the built-in web-server to serve requests according to list of @ServerParts@.+simpleHTTP :: ToMessage a => Conf -> [ServerPartT IO a] -> IO ()+simpleHTTP conf hs+ = listen conf (simpleHTTP' hs)+++-- | Generate a result from a list of @ServerParts@ and a @Request@. This is mainly used+-- by CGI (and fast-cgi) wrappers.+simpleHTTP' :: (ToMessage a, Monad m) => [ServerPartT m a] -> Request -> m Response+simpleHTTP' hs req+ = do res <- unWebT (unServerPartT (multi hs) req)+ case res of+ NoHandle -> return $ result 404 "No suitable handler found"+ Escape resp -> return resp+ Ok out a -> return $ out $ toResponse a++class FromReqURI a where+ fromReqURI :: String -> Maybe a++++instance FromReqURI String where fromReqURI = Just+instance FromReqURI Int where fromReqURI = readM+instance FromReqURI Integer where fromReqURI = readM+instance FromReqURI Float where fromReqURI = readM+instance FromReqURI Double where fromReqURI = readM++type RqData a = ReaderT ([(String,Input)], [(String,Cookie)]) Maybe a++class FromData a where+ fromData :: RqData a++instance (Eq a,Show a,Xml a,G.Data a) => FromData a where+ fromData = do mbA <- lookPairs >>= return . normalize . fromPairs+ case mbA of+ Just a -> return a+ Nothing -> fail "FromData G.Data failure"+-- fromData = lookPairs >>= return . normalize . fromPairs++instance (FromData a, FromData b) => FromData (a,b) where+ fromData = liftM2 (,) fromData fromData+instance (FromData a, FromData b, FromData c) => FromData (a,b,c) where+ fromData = liftM3 (,,) fromData fromData fromData+instance (FromData a, FromData b, FromData c, FromData d) => FromData (a,b,c,d) where+ fromData = liftM4 (,,,) fromData fromData fromData fromData+instance FromData a => FromData (Maybe a) where+ fromData = fmap Just fromData `mplus` return Nothing++{- |+ Minimal definition: 'toMessage'+-}+++class ToMessage a where+ toContentType :: a -> B.ByteString+ toContentType _ = B.pack "text/plain"+ toMessage :: a -> L.ByteString+ toMessage = error "HAppS.Server.SimpleHTTP.ToMessage.toMessage: Not defined"+ toResponse:: a -> Response+ toResponse val =+ let bs = toMessage val+ result = Response 200 M.empty nullRsFlags bs+ in setHeaderBS (B.pack "Content-Type") (toContentType val)+ result++instance ToMessage [Element] where+ toContentType _ = B.pack "application/xml"+ toMessage [el] = L.pack $ H.simpleDoc H.NoStyle $ toHaXmlEl el -- !! OPTIMIZE+ toMessage x = error ("HAppS.Server.SimpleHTTP 'instance ToMessage [Element]' Can't handle " ++ show x)+++++instance ToMessage () where+ toContentType _ = B.pack "text/plain"+ toMessage () = L.empty+instance ToMessage String where+ toContentType _ = B.pack "text/plain"+ toMessage = L.pack+instance ToMessage Integer where+ toMessage = toMessage . show+instance ToMessage a => ToMessage (Maybe a) where+ toContentType _ = toContentType (undefined :: a)+ toMessage Nothing = toMessage "nothing"+ toMessage (Just x) = toMessage x+++instance ToMessage Html where+ toContentType _ = B.pack "text/html"+ toMessage = L.pack . renderHtml++instance ToMessage XHtml.Html where+ toContentType _ = B.pack "text/html"+ toMessage = L.pack . XHtml.renderHtml++instance ToMessage Response where+ toResponse = id++instance (Xml a)=>ToMessage a where+ toContentType = toContentType . toXml+ toMessage = toMessage . toPublicXml++-- toMessageM = toMessageM . toPublicXml+++class MatchMethod m where matchMethod :: m -> Method -> Bool+instance MatchMethod Method where matchMethod method = (== method) +instance MatchMethod [Method] where matchMethod methods = (`elem` methods)+instance MatchMethod (Method -> Bool) where matchMethod f = f +instance MatchMethod () where matchMethod () _ = True++webQuery :: (MonadIO m, QueryEvent ev res) => ev -> WebT m res+webQuery = liftIO . query++webUpdate :: (MonadIO m, UpdateEvent ev res) => ev -> WebT m res+webUpdate = liftIO . update++flatten :: (ToMessage a, Monad m) => ServerPartT m a -> ServerPartT m Response+flatten = liftM toResponse++localContext :: Monad m => (WebT m a -> WebT m' a) -> [ServerPartT m a] -> ServerPartT m' a+localContext fn hs+ = ServerPartT $ \rq -> fn (unServerPartT (multi hs) rq)+++-- | Pop a path element and run the @[ServerPart]@ if it matches the given string.+dir :: Monad m => String -> [ServerPartT m a] -> ServerPartT m a+dir staticPath handle+ = ServerPartT $ \rq -> case rqPaths rq of+ (path:xs) | path == staticPath -> + unServerPartT (multi handle) rq{rqPaths = xs}+ _ -> noHandle+++-- | Guard against the method. Note, this function also guards against any+-- remaining path segments. See 'anyRequest'.+methodSP :: (MatchMethod method, Monad m) => method -> ServerPartT m a -> ServerPartT m a+methodSP m handle+ = ServerPartT $ \rq -> if matchMethod m (rqMethod rq) && null (rqPaths rq)+ then unServerPartT handle rq+ else noHandle++-- | Guard against the method. Note, this function also guards against any+-- remaining path segments. See 'anyRequest'.+method :: (MatchMethod method, Monad m) => method -> WebT m a -> ServerPartT m a+method m handle = methodSP m (ServerPartT $ \_ -> handle)+++-- | Pop a path element and parse it.+path :: (FromReqURI a, Monad m) => (a -> [ServerPartT m r]) -> ServerPartT m r+path handle+ = ServerPartT $ \rq -> + case rqPaths rq of+ (path:xs) | Just a <- fromReqURI path+ -> unServerPartT (multi $ handle a) rq{rqPaths = xs}+ _ -> noHandle++uriRest :: Monad m => (String -> ServerPartT m a) -> ServerPartT m a+uriRest handle = withRequest $ \rq ->+ unServerPartT (handle (rqURL rq)) rq+++anyPath x = path $ (\(_::String) -> x)+anyPath' x = path $ (\(_::String) -> [x])++-- | Retrieve date from the input query or the cookies.+withData :: (FromData a, Monad m) => (a -> [ServerPartT m r]) -> ServerPartT m r+withData = withDataFn fromData++withDataFn :: Monad m => RqData a -> (a -> [ServerPartT m r]) -> ServerPartT m r+withDataFn fn handle+ = ServerPartT $ \rq -> case runReaderT fn (rqInputs rq,rqCookies rq) of+ Nothing -> noHandle+ Just a -> unServerPartT (multi $ handle a) rq+++proxyServe :: MonadIO m => [String] -> ServerPartT m Response+proxyServe allowed = withRequest $ \rq -> + if cond rq then proxyServe' rq else noHandle + where+ cond rq+ | "*" `elem` allowed = True+ | domain `elem` allowed = True+ | superdomain `elem` wildcards =True+ | otherwise = False+ where+ domain = head (rqPaths rq) + superdomain = tail $ snd $ break (=='.') domain+ wildcards = (map (drop 2) $ filter ("*." `isPrefixOf`) allowed) ++proxyServe' rq = liftIO (getResponse (unproxify rq)) >>=+ either (badGateway . toResponse . show) (escape . return)+++rproxyServe :: MonadIO m => String -> [(String, String)] -> ServerPartT m Response+rproxyServe defaultHost list = withRequest $ \rq ->+ liftIO (getResponse (unrproxify defaultHost list rq)) >>=+ either (badGateway . toResponse . show) (escape . return)+++{-+modXml:: (Monad m) => (Request -> Element -> m Element) -> [ServerPartT m a] -> + ServerPartT m a+modXml f handle + = Reader $ \rq -> + do res <- runReader (multi handle) rq + case res of + Nothing -> return Nothing+ Just res'@(Left _) -> return $ Just res'+ Just res'@(Right (s,el)) -> + (\el->return $ Just $ Right (s,el)) =<< f rq el+-}+++-- | Run an IO action and, if it returns @Just@, pass it to the second argument.+require :: MonadIO m => IO (Maybe a) -> (a -> [ServerPartT m r]) -> ServerPartT m r+require fn = requireM (liftIO fn)++requireM :: Monad m => m (Maybe a) -> (a -> [ServerPartT m r]) -> ServerPartT m r+requireM fn handle+ = ServerPartT $ \rq -> do mbVal <- lift fn+ case mbVal of+ Nothing -> noHandle+ Just a -> unServerPartT (multi $ handle a) rq++showRequest + = Reader $ \rq -> print (rq::Request)++-- FIXME: What to do with Escapes?+-- | Use @cmd@ to transform XML against @xslPath@.+-- This function only acts if the content-type is @application\/xml@.+xslt :: (MonadIO m, ToMessage r) =>+ XSLTCmd -- ^ XSLT preprocessor. Usually 'xsltproc' or 'saxon'.+ -> XSLPath -- ^ Path to xslt stylesheet.+ -> [ServerPartT m r] -- ^ Affected @ServerParts@.+ -> ServerPartT m Response+xslt cmd xslPath parts =+ withRequest $ \rq -> + do res <- unServerPartT (multi parts) rq+ if toContentType res == B.pack "application/xml"+ then liftM toResponse (doXslt cmd xslPath (toResponse res))+ else return (toResponse res)++doXslt cmd xslPath res = + do new <- liftIO $ procLBSIO cmd xslPath $ rsBody res+ liftIO $ print res + liftIO $ print "##########" + liftIO $ print new+ return $ setHeader "Content-Type" "text/html" $ + setHeader "Content-Length" (show $ L.length new) $+ res { rsBody = new }++++--io :: IO Result -> ServerPart+--io action = ReaderT $ \_ -> Just action+++modifyResponse :: Monad m => (Response -> Response) -> WebT m ()+modifyResponse modFn = WebT $ return $ Ok modFn ()++setResponseCode :: Monad m => Int -> WebT m ()+setResponseCode code+ = modifyResponse $ \resp -> resp{rsCode = code}++addCookie :: Monad m => Seconds -> Cookie -> WebT m ()+addCookie sec cookie+ = modifyResponse $ addHeader "Set-Cookie" (mkCookieHeader sec cookie)++addCookies :: Monad m => [(Seconds, Cookie)] -> WebT m ()+addCookies = mapM_ (uncurry addCookie)++{-+delCookie :: String -> WebT m ()+delCookie name = +-}+resp status val = setResponseCode status >> return val+{-- do bs <- toMessageM val+ liftM (setHeaderBS (B.pack "Content-Type") (toContentType val)) $ + sresult' status bs+--}+{-+mbOk :: ToMessage b => (a -> b) -> Maybe a -> IO Result -> IO Result+mbOk f val other = maybe other (ok . f) val+-}++-- | Respond with @200 OK@.+ok :: Monad m => a -> WebT m a+ok = resp 200++internalServerError::Monad m => a -> WebT m a+internalServerError = resp 500++badGateway::Monad m=> a-> WebT m a+badGateway = resp 502++-- | Respond with @400 Bad Request@.+badRequest :: Monad m => a -> WebT m a+badRequest = resp 400++-- | Respond with @401 Unauthorized@.+unauthorized :: Monad m => a -> WebT m a+unauthorized val = resp 401 val++-- | Respond with @403 Forbidden@.+forbidden :: Monad m => a -> WebT m a+forbidden val = resp 403 val++-- | Respond with @404 Not Found@.+notFound :: Monad m => a -> WebT m a+notFound val = resp 404 val++-- | Respond with @303 See Other@.+seeOther :: (Monad m, ToSURI uri) => uri -> res -> WebT m res+seeOther uri res = do modifyResponse $ redirect 303 uri+ return res++-- | Respond with @302 Found@.+found :: (Monad m, ToSURI uri) => uri -> res -> WebT m res+found uri res = do modifyResponse $ redirect 302 uri+ return res++-- | Respond with @301 Moved Permanently@.+movedPermanently :: (Monad m, ToSURI a) => a -> res -> WebT m res+movedPermanently uri res = do modifyResponse $ redirect 301 uri+ return res++-- | Respond with @307 Temporary Redirect@.+tempRedirect :: (Monad m, ToSURI a) => a -> res -> WebT m res+tempRedirect val res = do modifyResponse $ redirect 307 val+ return res+++multi :: Monad m => [ServerPartT m a] -> ServerPartT m a+multi ls = ServerPartT $ \rq -> foldr servPlus noHandle [ unServerPartT l rq | l <- ls ]+ where servPlus a b = WebT $+ do a' <- unWebT a+ case a' of+ NoHandle -> unWebT b+ _ -> return a'++withRequest :: (Request -> WebT m a) -> ServerPartT m a+withRequest fn = ServerPartT $ fn++debugFilter handle = [+ ServerPartT $ \rq -> WebT $ do+ resp <- unWebT (unServerPartT (multi handle) rq)+ liftIO $ print rq >> print resp+ return resp]++anyRequest :: Monad m => WebT m a -> ServerPartT m a+anyRequest x = withRequest $ \_ -> x+applyRequest hs = simpleHTTP' hs >>= return . Left++basicAuth :: (MonadIO m) => String -> M.Map String String -> [ServerPartT m a] -> ServerPartT m a+basicAuth realmName authMap xs = multi $ basicAuthImpl:xs+ where+ basicAuthImpl = withRequest $ \rq ->+ case getHeader "authorization" rq of+ Nothing -> err+ Just x -> case parseHeader x of + (name, ':':pass) | validLogin name pass -> noHandle+ _ -> err+ validLogin name pass = M.lookup name authMap == Just pass+ parseHeader = break (':'==) . Base64.decode . B.unpack . B.drop 6+ headerName = "WWW-Authenticate"+ headerValue = "Basic realm=\"" ++ realmName ++ "\""+ err = escape $+ do unauthorized "Not authorized"+++--------------------------------------------------------------+-- Query/Post data validating+--------------------------------------------------------------+++lookInput :: String -> RqData Input+lookInput name+ = do inputs <- asks fst+ case lookup name inputs of+ Nothing -> fail "input not found"+ Just i -> return i++lookBS :: String -> RqData L.ByteString+lookBS = fmap inputValue . lookInput++look :: String -> RqData String+look = fmap L.unpack . lookBS++lookCookie :: String -> RqData Cookie+lookCookie name+ = do cookies <- asks snd+ case lookup (map toLower name) cookies of -- keys are lowercased+ Nothing -> fail "cookie not found"+ Just c -> return c++lookCookieValue :: String -> RqData String+lookCookieValue = fmap cookieValue . lookCookie++readCookieValue :: Read a => String -> RqData a+readCookieValue name = readM =<< fmap cookieValue (lookCookie name)++lookRead :: Read a => String -> RqData a+lookRead name = readM =<< look name++lookPairs :: RqData [(String,String)]+lookPairs = asks fst >>= return . map (\(n,vbs)->(n,L.unpack $ inputValue vbs))+
+ src/HAppS/Server/StdConfig.hs view
@@ -0,0 +1,54 @@+{-# LANGUAGE ScopedTypeVariables #-}+module HAppS.Server.StdConfig where++import Control.Monad.Trans+import HAppS.Server.SimpleHTTP+import HAppS.Util.Daemonize+import HAppS.Server.HTTP.FileServe+import HAppS.State+--import HAppS.State.EventTH++{-+data StdConfig a = StdConfig {http::[ServerPart IO]+ ,everySecond::IO ()+ ,proxy :: Proxy a}++serverConfig :: StdConfig NoState+serverConfig = StdConfig {http=[]+ ,everySecond = return ()+ ,proxy = Proxy}++{-+class IsState st where+ getInterface :: st -> [Handler st]+-}++--data AsState a = AsState a+withState :: a -> StdConfig n -> StdConfig a+withState st s = s{proxy = Proxy}+++ ++start :: forall a. (SystemState a) => StdConfig a -> IO ()+start conf = daemonize binarylocation $ + stdMain $ simpleHTTP (errWrap:http conf) :*: cron 1 (everySecond conf)+ :*: (End :: StdPart a)++--main = daemonize binarylocation -- restart if binary changes+-- main'++{--+these locations are used so errorwrapper can serve out compiler+error messages when you modify the code rather than forcing you+to go to the shell and do it yourself. +--}+-}++binarylocation = "haskell/Main"+loglocation = "public/log"+++errWrap :: MonadIO m => ServerPartT m Response+errWrap = errorwrapper binarylocation loglocation+--stateFuns -- main actually has state so you can just import them
+ src/HAppS/Server/XSLT.hs view
@@ -0,0 +1,141 @@+{-# LANGUAGE TemplateHaskell, FlexibleInstances , UndecidableInstances,+ DeriveDataTypeable, MultiParamTypeClasses, CPP #-}+-- | Implement XSLT transformations using xsltproc+module HAppS.Server.XSLT+ (xsltFile, xsltString, xsltElem, xsltFPS, xsltFPSIO, XSLPath,+ xsltproc,saxon,procFPSIO,procLBSIO,XSLTCommand,XSLTCmd+ ) where+++import System.Log.Logger++import HAppS.Server.MinHaXML+import HAppS.Util.Common(runCommand)+import Control.Exception(bracket,try)+import qualified Data.ByteString.Char8 as P+import qualified Data.ByteString.Lazy.Char8 as L+import System.Directory(removeFile)+import System.Environment(getEnv)+import System.IO+import System.IO.Unsafe(unsafePerformIO)+import Text.XML.HaXml.Verbatim(verbatim)+import HAppS.Data hiding (Element)++logMX = logM "HAppS.Server.XSLT"++type XSLPath = FilePath+#ifndef __HADDOCK__+$(deriveAll [''Show,''Read,''Default, ''Eq, ''Ord]+ [d|+ data XSLTCmd = XSLTProc | Saxon + |]+ )+#endif+xsltCmd XSLTProc = xsltproc'+xsltCmd Saxon = saxon'++xsltElem :: XSLPath -> Element -> String+xsltElem xsl = xsltString xsl . verbatim+++procLBSIO xsltproc' xsl inp = + withTempFile "happs-src.xml" $ \sfp sh -> do+ withTempFile "happs-dst.xml" $ \dfp dh -> do+ let xsltproc = xsltCmd xsltproc'+ L.hPut sh inp+ hClose sh+ hClose dh+ xsltFileEx xsltproc xsl sfp dfp+ s <- L.readFile dfp+ logMX DEBUG (">>> XSLT: result: "++ show s)+ return s+++procFPSIO xsltproc xsl inp = + withTempFile "happs-src.xml" $ \sfp sh -> do+ withTempFile "happs-dst.xml" $ \dfp dh -> do+ mapM_ (P.hPut sh) inp+ hClose sh+ hClose dh+ xsltFileEx xsltproc xsl sfp dfp+ s <- P.readFile dfp+ logMX DEBUG (">>> XSLT: result: "++ show s)+ return [s]++xsltFPS :: XSLPath -> [P.ByteString] -> [P.ByteString]+xsltFPS xsl inp = unsafePerformIO $ xsltFPSIO xsl inp++xsltFPSIO xsl inp = + withTempFile "happs-src.xml" $ \sfp sh -> do+ withTempFile "happs-dst.xml" $ \dfp dh -> do+ mapM_ (P.hPut sh) inp+ hClose sh+ hClose dh+ xsltFile xsl sfp dfp+ s <- P.readFile dfp+ logMX DEBUG (">>> XSLT: result: "++ show s)+ return [s]++xsltString :: XSLPath -> String -> String+xsltString xsl inp = unsafePerformIO $+ withTempFile "happs-src.xml" $ \sfp sh -> do+ withTempFile "happs-dst.xml" $ \dfp dh -> do+ hPutStr sh inp+ hClose sh+ hClose dh+ xsltFile xsl sfp dfp+ s <- readFileStrict dfp+ logMX DEBUG (">>> XSLT: result: "++ show s)+ return s++-- | Note that the xsl file must have .xsl suffix.+xsltFile :: XSLPath -> FilePath -> FilePath -> IO ()+xsltFile = xsltFileEx xsltproc'++-- | Use @xsltproc@ to transform XML.+xsltproc' :: XSLTCommand+xsltproc' dst xsl src = ("xsltproc",["-o",dst,xsl,src])+xsltproc = XSLTProc++-- | Use @saxon@ to transform XML.+saxon = Saxon+saxon' :: XSLTCommand+saxon' dst xsl src = ("java -classpath /usr/share/java/saxon.jar",+ ["com.icl.saxon.StyleSheet"+ ,"-o",dst,src,xsl])+ +type XSLTCommand = XSLPath -> FilePath -> FilePath -> (FilePath,[String])+xsltFileEx :: XSLTCommand -> XSLPath -> FilePath -> FilePath -> IO ()+xsltFileEx xsltproc xsl src dst = do+ let msg = (">>> XSLT: Starting xsltproc " ++ unwords ["-o",dst,xsl,src])+ logMX DEBUG msg+ uncurry runCommand $ xsltproc dst xsl src+ logMX DEBUG (">>> XSLT: xsltproc done")++-- Utilities++withTempFile :: String -> (FilePath -> Handle -> IO a) -> IO a+withTempFile str hand = bracket (openTempFile tempDir str) (removeFile . fst) (uncurry hand)++readFileStrict :: FilePath -> IO String+readFileStrict fp = do+ let fseqM [] = return [] + fseqM xs = last xs `seq` return xs+ fseqM =<< readFile fp++{-+hGetContentsStrict :: Handle -> IO String+hGetContentsStrict h = flip finally (hClose h) $ do+ r <- hGetContents h+ let fseq [] = []; fseq xs = last xs `seq` xs+ return $! fseq r+-}++{-# NOINLINE tempDir #-}+tempDir :: FilePath+tempDir = unsafePerformIO $ tryAny [getEnv "TEMP",getEnv "TMP"] err+ where err = return "/tmp"++tryAny :: [IO a] -> IO a -> IO a+tryAny [] c = c+tryAny (x:xs) c = either (\_ -> tryAny xs c) return =<< try x
+ src/HAppS/Store/FlashMsgs.hs view
@@ -0,0 +1,116 @@+{-# LANGUAGE CPP, TemplateHaskell, FlexibleInstances, DeriveDataTypeable,+ MultiParamTypeClasses, TypeFamilies, TypeSynonymInstances #-}++{- LANGUAGE TemplateHaskell , FlexibleInstances, UndecidableInstances,+ OverlappingInstances, DeriveDataTypeable, PatternSignatures, MultiParamTypeClasses,+ TypeSynonymInstances, FlexibleContexts, CPP -}++-- MultiParamTypeClasses+module HAppS.Store.FlashMsgs where++import Control.Monad.State hiding (State)+import Control.Monad.Reader+-- import GHC.Conc++import HAppS.Data+import Data.Generics.Basics+import HAppS.Data.Atom+import HAppS.Data.IxSet+import HAppS.State+import HAppS.Server.Facebook as FB++++{--+ Use FashMsgs to send one off messages to the user. Think of it as single use sessions.+ Note: we don't have Sessions here yet because we need a nicer expose function+ that lets us have multiple sessions in state and parametrize by session value+ Also not sure that sessions are useful in this infrastructure++ It would also be nice to be able to parametrize on the Uid, but for now we treat the+ facebook Uid type as the universal Id++ 1. Put a FlashMsgs somewhere in your state+ 2. Make state an instance of class HasFlash++ instance HasFlash State where+ withFlashMsgs = State.withFlashMsgs+ flashMsgs = State.flashMsgs++ 3. put commmands in your getInterface function in State++ Now you can use insFlashMsg and extFlashMsg from your app.+ If we wanted a cleanup cycle we could add a periodic handler to stdMain+ stdMain () $ simpleHTTP impl $ periodic 10 impl $++Improvements:+ * get rid of HasFlash and use syb/generic haskell for this stuff+ * infer state getinterface rather than manual addition+--}+++--Types+#ifndef __HADDOCK__+$( deriveAll [''Read,''Show,''Default,''Eq,''Ord]+ [d|++ -- we are also going to want to issue flash msgs+ data FlashMsg msg = FlashMsg FB.Uid Published msg -- FlashContent+ newtype FlashContent = FlashContent [Element]++ |]+ )++instance Version (FlashMsg msg)+instance Version FlashContent++$(deriveSerialize ''FlashMsg)+$(deriveSerialize ''FlashContent)++$(inferIxSet "FlashMsgs" ''FlashMsg 'noCalcs [''FB.Uid,''Published])+#endif++--Command Functions+setFlashMsg :: (Ord msg,Data msg) => Uid -> msg -> Update (FlashMsgs msg) ()+setFlashMsg uid msg =+ do+ t <- getTime+ let f = FlashMsg uid (Published t) msg -- (FlashContent msg)+ modify (updateIx uid f)+ --delete old messages+ expired <-gets (toList . (@< (Updated $ t-maxAge)))+ mapM (modify . delete) expired+ return ()+ where maxAge = 3600+++getFlashMsg :: (Ord msg, Data msg) => Uid -> Query (FlashMsgs msg) (Maybe msg) -- FlashMsg)+getFlashMsg uid = +-- (return . maybe "" id . gFind . getOne . (@=uid) . flashMsgs) =<< ask+ (return . gFind . getOne . (@=uid)) =<< ask++delFlashMsg :: (Ord msg, Data msg) => Uid -> Proxy (FlashMsgs msg) -> Update (FlashMsgs msg) ()+delFlashMsg uid _ = do+ mbMsg <- gets (getOne . (@=uid) ) + maybe (return ()) (modify . delete) mbMsg++#ifndef __HADDOCK__+$(mkMethods ''FlashMsgs [ 'setFlashMsg+ , 'getFlashMsg+ , 'delFlashMsg ])++instance (Serialize (FlashMsgs a), Ord a, Data a) => Component (FlashMsgs a) where+ type Dependencies (FlashMsgs a) = End++#endif++-- Controls+--insFlashMsg:: Xml a => Uid -> a -> IO ()+insFlashMsg uid msg = update $ SetFlashMsg uid $ toXml msg+extFlashMsg uid = do+ msg <- query $ GetFlashMsg uid+ let mkProxy :: Maybe msg -> Proxy (FlashMsgs msg)+ mkProxy _ = Proxy+ update $ DelFlashMsg uid (mkProxy msg)+ return msg+
+ src/HAppS/Store/HelpReqs.hs view
@@ -0,0 +1,183 @@+{-# LANGUAGE TemplateHaskell, FlexibleInstances, DeriveDataTypeable,+ ImplicitParams, TypeSynonymInstances, TypeFamilies,+ MultiParamTypeClasses, TypeOperators #-}++{- LANGUAGE TemplateHaskell , FlexibleInstances, UndecidableInstances, OverlappingInstances, + DeriveDataTypeable, FlexibleContexts, ImplicitParams,+ MultiParamTypeClasses, TypeSynonymInstances, TypeFamilies -}++-- MultiParamTypeClasses+module HAppS.Store.HelpReqs where++import Control.Monad.State hiding (State)+import Control.Monad.Reader++import HAppS.Data+import HAppS.Data.Atom+import HAppS.Data.IxSet+import HAppS.State+import HAppS.Server.Facebook as FB + (Uid,uid,FBSession,fbSeeOther,getIsAdmin+ ,getAdmins,notifications_send )+import HAppS.Store.Util+import HAppS.Server.SimpleHTTP -- hiding (ok)+import HAppS.Store.FlashMsgs+import HAppS.Server.HTTP.Types (Response)+{--++ Use HelpReqs to track help requests on your app. The concept is that the+ user just fills out a form describing their needs and you get back to them.++ See FlashMsgs for the cannonical info, but..++--}+#ifndef __HADDOCK__+$( deriveAll [''Show,''Default,''Read,''Eq,''Ord]+ [d|+ -- the data for the help system+ data HelpReqForm = HelpReqForm --get the form+ data HelpReq = HelpReq FB.Uid Published Title HelpText Status--post the help+ newtype HelpText = HelpText String+ data Status = Open | Closed Published+ newtype HelpFeed = HelpFeed [HelpReq] -- provide a help feed+ data HelpMsgReceived = HelpMsgReceived+ --data Status = Open | Assigned FB.Uid Published | Closed FB.Uid Published+ |])++instance Version HelpReq+instance Version Status+instance Version HelpFeed+instance Version HelpText+instance Version HelpMsgReceived+$(deriveSerialize ''HelpReq)+$(deriveSerialize ''Status)+$(deriveSerialize ''HelpFeed)+$(deriveSerialize ''HelpText)+$(deriveSerialize ''HelpMsgReceived)++$(inferIxSet "HelpReqs" ''HelpReq 'noCalcs [''FB.Uid,''Published,''Status] )+#endif+{-+$(deriveAll [''Show,''Default,''Read]+ [d| data HelpReqs = HelpReqs {unHelpReqs :: HelpReqs_ } |]+ )+-}++--Command functions+addHelpReq :: HelpReq -> Update HelpReqs ()+addHelpReq helpReq+ = do seconds <- liftM (`div` 1000) getTime+ modify $ insert (gSet (Published seconds) helpReq)+ +getHelpReqs :: Query HelpReqs [HelpReq]+getHelpReqs = liftM byRevTime ask++#ifndef __HADDOCK__+$(mkMethods ''HelpReqs ['addHelpReq,'getHelpReqs])+instance Component HelpReqs where+ type Dependencies HelpReqs = FlashMsgs HelpMsgReceived :+: End+#endif++++-- http stuff +http::( ?fbSession::FBSession+ , MonadIO m+ ) => [ServerPartT m Response]+http = + [+ dir "help" [ method () $ ok $ toResponse HelpReqForm]++ ,dir "addHelp" + [withData $ \helpReq -> + [method () $ do+ webUpdate $ AddHelpReq helpReq+ liftIO $ insFlashMsg uid HelpMsgReceived+ admins <- liftIO $ getAdmins+ unless (null admins) $ + do+ conf <- liftIO $ notifications_send admins + (Title "helpreq")+ ()+ return ()+ liftM toResponse $ fbSeeOther "side-nav"+ ]]++ ,dir "helps" [method () $ do+ isAdmin <- liftIO $ getIsAdmin+ if not isAdmin then forbidden (toResponse "not admin!") else do+ flashMsg <- liftIO $ (extFlashMsg uid :: IO (Maybe HelpMsgReceived))+ helpReqs <- webQuery $ GetHelpReqs+ (ok . toResponse .+ insEl (Attr "context" "helpfeed") . + insEl flashMsg .+ HelpFeed . + take 1000) helpReqs + ]+ ]+++++++++++++++++++++++++++++++++++++++--controls+--addHelpReq = update . AddHelpReq'+{--++--addHelpReq' adr = update . adr ++controls::Q [Dec]+controls = return + [+-- fun0_1 "addHelpReq" "addHelpReq'" "AddHelpReq"+ fun0_1 "getHelpReqs" "query" "GetHelpReqs"+ ]+--} +-- $(return +-- [fun0_1 "addHelpReq" "addHelpReq'" "AddHelpReq"]) +++--OBSOLETE? ---+-- Control functions that need some help+{--+addHelpMsg help@(HelpMsg uid (Published t) msg) = + do+ TOD eTime _ <- getClockTime+ if t > eTime || t < eTime - 3600000 then return () else do+ update $ AddHelpMsg help++getHelpMsgs = query GetHelpMsgs+--}
+ src/HAppS/Store/Util.hs view
@@ -0,0 +1,55 @@+{-# LANGUAGE TemplateHaskell , FlexibleInstances, UndecidableInstances, CPP,+ OverlappingInstances, DeriveDataTypeable, MultiParamTypeClasses #-}++module HAppS.Store.Util +{-- (+ module Control.Monad.State+ ,module Control.Monad.Reader+ ,byTime,byRevTime,fun0_1,fun0_2+ +) --}+where+import HAppS.Data+import GHC.Conc+import HAppS.State+import Control.Monad.State+import HAppS.Data.IxSet+import HAppS.Data.Atom+import Language.Haskell.TH++import Control.Monad.State +import Control.Monad.Reader++++--interface with State+#ifndef __HADDOCK__+$( deriveAll [''Show,''Default,''Read,''Eq,''Ord]+ [d|+ newtype Context = Context String --this belongs elsewhere!+ newtype EpochTime = EpochTime Integer + data Wrap a = Wrap {unwrap::a}+ |])+#endif+type With st' st a = Ev (StateT st' STM) a -> Ev (StateT st STM) a+++byTime::(Typeable a) => IxSet a -> [a]+byTime = concat . map (\(Published t,es)->es) . groupBy+byRevTime = concat . map (\(Published t,es)->es) . rGroupBy+byRevTime::(Typeable a) => IxSet a -> [a]++fun0_1 name fun arg = + FunD (mkName name) + [Clause [] (NormalB (AppE (VarE $ mkName fun) + (ConE $ mkName arg))) + []+ ]+fun0_2 name fun arg1 arg2 = + FunD (mkName name) + [Clause [] (NormalB + (AppE (AppE (VarE $ mkName fun) + (ConE $ mkName arg1))+ (ConE $ mkName arg2)))+ []+ ]