diff --git a/HAppS-Server.cabal b/HAppS-Server.cabal new file mode 100644 --- /dev/null +++ b/HAppS-Server.cabal @@ -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 diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMainWithHooks defaultUserHooks diff --git a/src/HAppS/Server.hs b/src/HAppS/Server.hs new file mode 100644 --- /dev/null +++ b/src/HAppS/Server.hs @@ -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 diff --git a/src/HAppS/Server/Cookie.hs b/src/HAppS/Server/Cookie.hs new file mode 100644 --- /dev/null +++ b/src/HAppS/Server/Cookie.hs @@ -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 +-} diff --git a/src/HAppS/Server/Cron.hs b/src/HAppS/Server/Cron.hs new file mode 100644 --- /dev/null +++ b/src/HAppS/Server/Cron.hs @@ -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 diff --git a/src/HAppS/Server/Facebook.hs b/src/HAppS/Server/Facebook.hs new file mode 100644 --- /dev/null +++ b/src/HAppS/Server/Facebook.hs @@ -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 $ "" + +--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 +--} + diff --git a/src/HAppS/Server/HTTP/Client.hs b/src/HAppS/Server/HTTP/Client.hs new file mode 100644 --- /dev/null +++ b/src/HAppS/Server/HTTP/Client.hs @@ -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 + + diff --git a/src/HAppS/Server/HTTP/Clock.hs b/src/HAppS/Server/HTTP/Clock.hs new file mode 100644 --- /dev/null +++ b/src/HAppS/Server/HTTP/Clock.hs @@ -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 diff --git a/src/HAppS/Server/HTTP/FileServe.hs b/src/HAppS/Server/HTTP/FileServe.hs new file mode 100644 --- /dev/null +++ b/src/HAppS/Server/HTTP/FileServe.hs @@ -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 diff --git a/src/HAppS/Server/HTTP/Handler.hs b/src/HAppS/Server/HTTP/Handler.hs new file mode 100644 --- /dev/null +++ b/src/HAppS/Server/HTTP/Handler.hs @@ -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 i2x.com \n\n\n

This is i2x.com

\n\nContact us.\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") + diff --git a/src/HAppS/Server/HTTP/LazyLiner.hs b/src/HAppS/Server/HTTP/LazyLiner.hs new file mode 100644 --- /dev/null +++ b/src/HAppS/Server/HTTP/LazyLiner.hs @@ -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 diff --git a/src/HAppS/Server/HTTP/Listen.hs b/src/HAppS/Server/HTTP/Listen.hs new file mode 100644 --- /dev/null +++ b/src/HAppS/Server/HTTP/Listen.hs @@ -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 + diff --git a/src/HAppS/Server/HTTP/LowLevel.hs b/src/HAppS/Server/HTTP/LowLevel.hs new file mode 100644 --- /dev/null +++ b/src/HAppS/Server/HTTP/LowLevel.hs @@ -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. diff --git a/src/HAppS/Server/HTTP/Multipart.hs b/src/HAppS/Server/HTTP/Multipart.hs new file mode 100644 --- /dev/null +++ b/src/HAppS/Server/HTTP/Multipart.hs @@ -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 "" (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 diff --git a/src/HAppS/Server/HTTP/RFC822Headers.hs b/src/HAppS/Server/HTTP/RFC822Headers.hs new file mode 100644 --- /dev/null +++ b/src/HAppS/Server/HTTP/RFC822Headers.hs @@ -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 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 diff --git a/src/HAppS/Server/HTTP/Types.hs b/src/HAppS/Server/HTTP/Types.hs new file mode 100644 --- /dev/null +++ b/src/HAppS/Server/HTTP/Types.hs @@ -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" + diff --git a/src/HAppS/Server/HTTPClient/HTTP.hs b/src/HAppS/Server/HTTPClient/HTTP.hs new file mode 100644 --- /dev/null +++ b/src/HAppS/Server/HTTPClient/HTTP.hs @@ -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: +-- > +-- > //:@:/ +-- > Some or all of the parts ":@", ":", +-- > ":", and "/" 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: + + 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 [] = [] diff --git a/src/HAppS/Server/HTTPClient/Stream.hs b/src/HAppS/Server/HTTPClient/Stream.hs new file mode 100644 --- /dev/null +++ b/src/HAppS/Server/HTTPClient/Stream.hs @@ -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) + } diff --git a/src/HAppS/Server/HTTPClient/TCP.hs b/src/HAppS/Server/HTTPClient/TCP.hs new file mode 100644 --- /dev/null +++ b/src/HAppS/Server/HTTPClient/TCP.hs @@ -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 + } + diff --git a/src/HAppS/Server/JSON.hs b/src/HAppS/Server/JSON.hs new file mode 100644 --- /dev/null +++ b/src/HAppS/Server/JSON.hs @@ -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 diff --git a/src/HAppS/Server/MessageWrap.hs b/src/HAppS/Server/MessageWrap.hs new file mode 100644 --- /dev/null +++ b/src/HAppS/Server/MessageWrap.hs @@ -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 +-} + diff --git a/src/HAppS/Server/MinHaXML.hs b/src/HAppS/Server/MinHaXML.hs new file mode 100644 --- /dev/null +++ b/src/HAppS/Server/MinHaXML.hs @@ -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 +()=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 = ("\n"++ + if hasStyleURL style then pi else "") ++ + (verbatim $ xmlStdEscape elem) + where typeText=if isCSS style then "text/css" else "text/xsl" + pi= "\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= "\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 +--} diff --git a/src/HAppS/Server/S3.hs b/src/HAppS/Server/S3.hs new file mode 100644 --- /dev/null +++ b/src/HAppS/Server/S3.hs @@ -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/" + diff --git a/src/HAppS/Server/SURI.hs b/src/HAppS/Server/SURI.hs new file mode 100644 --- /dev/null +++ b/src/HAppS/Server/SURI.hs @@ -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 diff --git a/src/HAppS/Server/SURI/ParseURI.hs b/src/HAppS/Server/SURI/ParseURI.hs new file mode 100644 --- /dev/null +++ b/src/HAppS/Server/SURI/ParseURI.hs @@ -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 + diff --git a/src/HAppS/Server/SimpleHTTP.hs b/src/HAppS/Server/SimpleHTTP.hs new file mode 100644 --- /dev/null +++ b/src/HAppS/Server/SimpleHTTP.hs @@ -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 _ = "" + +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)) + diff --git a/src/HAppS/Server/StdConfig.hs b/src/HAppS/Server/StdConfig.hs new file mode 100644 --- /dev/null +++ b/src/HAppS/Server/StdConfig.hs @@ -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 diff --git a/src/HAppS/Server/XSLT.hs b/src/HAppS/Server/XSLT.hs new file mode 100644 --- /dev/null +++ b/src/HAppS/Server/XSLT.hs @@ -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 diff --git a/src/HAppS/Store/FlashMsgs.hs b/src/HAppS/Store/FlashMsgs.hs new file mode 100644 --- /dev/null +++ b/src/HAppS/Store/FlashMsgs.hs @@ -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 + diff --git a/src/HAppS/Store/HelpReqs.hs b/src/HAppS/Store/HelpReqs.hs new file mode 100644 --- /dev/null +++ b/src/HAppS/Store/HelpReqs.hs @@ -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 +--} diff --git a/src/HAppS/Store/Util.hs b/src/HAppS/Store/Util.hs new file mode 100644 --- /dev/null +++ b/src/HAppS/Store/Util.hs @@ -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))) + [] + ]