happstack-server 0.1 → 0.2.1
raw patch · 57 files changed
+5604/−4782 lines, 57 filesdep +MaybeTdep +timedep +zlibdep −happstack-ixsetdep −happstack-statedep ~happstack-datadep ~happstack-util
Dependencies added: MaybeT, time, zlib
Dependencies removed: happstack-ixset, happstack-state
Dependency ranges changed: happstack-data, happstack-util
Files
- happstack-server.cabal +55/−37
- src/HAppS/Server.hs +0/−21
- src/HAppS/Server/Cookie.hs +0/−132
- src/HAppS/Server/Cron.hs +0/−12
- src/HAppS/Server/HTTP/Client.hs +0/−50
- src/HAppS/Server/HTTP/Clock.hs +0/−30
- src/HAppS/Server/HTTP/FileServe.hs +0/−215
- src/HAppS/Server/HTTP/Handler.hs +0/−304
- src/HAppS/Server/HTTP/LazyLiner.hs +0/−41
- src/HAppS/Server/HTTP/Listen.hs +0/−67
- src/HAppS/Server/HTTP/LowLevel.hs +0/−28
- src/HAppS/Server/HTTP/Multipart.hs +0/−216
- src/HAppS/Server/HTTP/RFC822Headers.hs +0/−266
- src/HAppS/Server/HTTP/Types.hs +0/−227
- src/HAppS/Server/HTTPClient/HTTP.hs +0/−1045
- src/HAppS/Server/HTTPClient/Stream.hs +0/−173
- src/HAppS/Server/HTTPClient/TCP.hs +0/−193
- src/HAppS/Server/JSON.hs +0/−29
- src/HAppS/Server/MessageWrap.hs +0/−99
- src/HAppS/Server/MinHaXML.hs +0/−215
- src/HAppS/Server/S3.hs +0/−240
- src/HAppS/Server/SURI.hs +0/−55
- src/HAppS/Server/SURI/ParseURI.hs +0/−81
- src/HAppS/Server/SimpleHTTP.hs +0/−780
- src/HAppS/Server/StdConfig.hs +0/−16
- src/HAppS/Server/XSLT.hs +0/−147
- src/HAppS/Store/Util.hs +0/−50
- src/Happstack/Server.hs +15/−0
- src/Happstack/Server/Cookie.hs +138/−0
- src/Happstack/Server/HTTP/Client.hs +50/−0
- src/Happstack/Server/HTTP/Clock.hs +30/−0
- src/Happstack/Server/HTTP/FileServe.hs +215/−0
- src/Happstack/Server/HTTP/Handler.hs +322/−0
- src/Happstack/Server/HTTP/LazyLiner.hs +41/−0
- src/Happstack/Server/HTTP/Listen.hs +58/−0
- src/Happstack/Server/HTTP/LowLevel.hs +28/−0
- src/Happstack/Server/HTTP/Multipart.hs +216/−0
- src/Happstack/Server/HTTP/RFC822Headers.hs +266/−0
- src/Happstack/Server/HTTP/Socket.hs +52/−0
- src/Happstack/Server/HTTP/SocketTH.hs +16/−0
- src/Happstack/Server/HTTP/Types.hs +252/−0
- src/Happstack/Server/HTTPClient/HTTP.hs +1019/−0
- src/Happstack/Server/HTTPClient/Stream.hs +173/−0
- src/Happstack/Server/HTTPClient/TCP.hs +193/−0
- src/Happstack/Server/JSON.hs +29/−0
- src/Happstack/Server/MessageWrap.hs +99/−0
- src/Happstack/Server/MinHaXML.hs +215/−0
- src/Happstack/Server/Parts.hs +153/−0
- src/Happstack/Server/S3.hs +240/−0
- src/Happstack/Server/SURI.hs +72/−0
- src/Happstack/Server/SURI/ParseURI.hs +81/−0
- src/Happstack/Server/SimpleHTTP.hs +1355/−0
- src/Happstack/Server/StdConfig.hs +22/−0
- src/Happstack/Server/XSLT.hs +157/−0
- tests/HAppS/Server/Tests.hs +0/−12
- tests/Happstack/Server/Tests.hs +41/−0
- tests/Test.hs +1/−1
happstack-server.cabal view
@@ -1,5 +1,5 @@ Name: happstack-server-Version: 0.1+Version: 0.2.1 Synopsis: Web related tools and services. Description: Web framework License: BSD3@@ -9,54 +9,73 @@ homepage: http://happstack.com Category: Web, Distributed Computing Build-Type: Simple-Cabal-Version: >= 1.2.3+Cabal-Version: >= 1.4 Flag base4 Description: Choose the even newer, even smaller, split-up base package. Flag tests Description: Build the testsuite, and include the tests in the library- Default: True+ Default: False Library 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.Cron,- HAppS.Server.StdConfig,- HAppS.Store.Util+ Happstack.Server+ Happstack.Server.Cookie+ Happstack.Server.HTTP.Client+ Happstack.Server.HTTP.Types+ Happstack.Server.HTTP.LowLevel+ Happstack.Server.HTTP.FileServe+ Happstack.Server.SimpleHTTP+ Happstack.Server.JSON+ Happstack.Server.MessageWrap+ Happstack.Server.MinHaXML+ Happstack.Server.SURI+ Happstack.Server.XSLT+ Happstack.Server.StdConfig+ Happstack.Server.Parts if flag(tests) Exposed-modules: - HAppS.Server.Tests+ Happstack.Server.Tests 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+ Happstack.Server.S3+ Happstack.Server.HTTPClient.HTTP+ Happstack.Server.HTTPClient.Stream+ Happstack.Server.HTTPClient.TCP+ Happstack.Server.HTTP.Clock+ Happstack.Server.HTTP.Handler+ Happstack.Server.HTTP.LazyLiner+ Happstack.Server.HTTP.Listen+ Happstack.Server.HTTP.Multipart+ Happstack.Server.HTTP.RFC822Headers+ Happstack.Server.HTTP.Socket+ Happstack.Server.HTTP.SocketTH+ Happstack.Server.SURI.ParseURI+ Paths_happstack_server - Build-Depends: base, HaXml >= 1.13 && < 1.14, parsec<3, mtl, network,- hslogger >= 1.0.2, happstack-data, happstack-util,- happstack-state, happstack-ixset, template-haskell, xhtml, html,- bytestring, containers, old-time, old-locale, directory, - process, extensible-exceptions+ Build-Depends: base,+ bytestring,+ containers,+ directory,+ extensible-exceptions,+ HaXml >= 1.13 && < 1.14,+ hslogger >= 1.0.2,+ happstack-data >= 0.2.1 && < 0.3,+ happstack-util >= 0.2.1 && < 0.3,+ html,+ MaybeT,+ mtl,+ network,+ old-locale,+ old-time,+ parsec < 3,+ process,+ template-haskell,+ time,+ xhtml,+ zlib+ hs-source-dirs: src if flag(tests) hs-source-dirs: tests@@ -70,11 +89,10 @@ if flag(tests) Build-Depends: HUnit - -- Should have ", DeriveDataTypeable, PatternSignatures" but Cabal complains Extensions: TemplateHaskell, DeriveDataTypeable, MultiParamTypeClasses, TypeFamilies, FlexibleContexts, OverlappingInstances, FlexibleInstances, UndecidableInstances, ScopedTypeVariables,- TypeSynonymInstances, PatternGuards, PatternSignatures,+ TypeSynonymInstances, PatternGuards CPP, ForeignFunctionInterface ghc-options: -Wall GHC-Prof-Options: -auto-all
− src/HAppS/Server.hs
@@ -1,21 +0,0 @@-module HAppS.Server -(- module HAppS.State.Control-,module HAppS.Server.XSLT-,module HAppS.Server.SimpleHTTP-,module HAppS.Server.HTTP.Client-,module HAppS.Server.MessageWrap-,module HAppS.Server.HTTP.FileServe-,module HAppS.Server.StdConfig-,module HAppS.Store.Util--)-where-import HAppS.Server.HTTP.Client-import HAppS.Server.StdConfig-import HAppS.State.Control-import HAppS.Server.XSLT-import HAppS.Server.SimpleHTTP-import HAppS.Server.MessageWrap-import HAppS.Server.HTTP.FileServe-import HAppS.Store.Util
− src/HAppS/Server/Cookie.hs
@@ -1,132 +0,0 @@-{-# LANGUAGE DeriveDataTypeable #-}---- http://tools.ietf.org/html/rfc2109-module HAppS.Server.Cookie- ( Cookie(..), mkCookie, mkCookieHeader- , getCookies, getCookie )- where--import qualified Data.ByteString.Char8 as C-import Data.Char-import Data.List-import Data.Generics-import HAppS.Util.Common (Seconds)-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.--- 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 ])---{- Cookie syntax:- av-pairs = av-pair *(";" av-pair)- av-pair = attr ["=" value] ; optional value- attr = token- value = word- word = token | quoted-string--}--gmany :: ReadP a -> ReadP [a]-gmany p = gmany1 p <++ return []-gmany1 :: ReadP a -> ReadP [a]-gmany1 p = do x <- p- xs <- gmany1 p <++ return []- return (x:xs)-gskipMany1 :: ReadP a -> ReadP ()-gskipMany1 p = p >> (gskipMany p <++ return ())-gskipMany :: ReadP a -> ReadP ()-gskipMany p = gskipMany1 p <++ return ()--fctl :: Char -> Bool-fctl = \ch -> ch == chr 127 || ch <= chr 31-fseparator :: Char -> Bool-fseparator = \ch -> ch `elem` "()<>@,;:\\\"[]?={} \t" -- ignore '/' here-fchar :: Char -> Bool-fchar = \ch -> ch <= chr 127-ftoken :: Char -> Bool-ftoken = \ch -> fchar ch && not (fctl ch || fseparator ch)-lws :: ReadP ()-lws = ((char '\r' >> char '\n') <++ return ' ') >> gskipMany (satisfy (\ch -> ch == ' ' || ch == '\t'))-token :: ReadP [Char]-token = gmany $ satisfy ftoken-quotedString :: ReadP [Char]-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 :: ReadP [Char]-word = quotedString <++ token--avPair :: ReadP (String, [Char])-avPair = do- k <- token- lws >> char '=' >> lws- v <- word- return (low k,v)--sep :: ReadP ()-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--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
− src/HAppS/Server/Cron.hs
@@ -1,12 +0,0 @@-module HAppS.Server.Cron (cron) where--import Control.Concurrent (threadDelay)--type Seconds = Int--cron :: Seconds -> IO () -> IO a-cron seconds action- = loop- where loop = do threadDelay (10^(6 :: Int) * seconds)- action- loop
− src/HAppS/Server/HTTP/Client.hs
@@ -1,50 +0,0 @@-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 System.IO-import qualified Data.ByteString.Char8 as B -import Network--getResponse :: Request -> IO (Either String Response)-getResponse rq = withSocketsDo $ do- let (hostName,p) = span (/=':') $ fromJust $ fmap B.unpack $ getHeader "host" rq - portInt = if null p then 80 else read $ tail p- portId = PortNumber $ toEnum $ portInt- h <- connectTo hostName portId - hSetBuffering h NoBuffering-- putRequest h rq- hFlush h-- inputStr <- L.hGetContents h- return $ parseResponse inputStr--unproxify :: Request -> Request-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)- csv v "" = v- csv v x = x++", " ++ v--unrproxify :: String -> [(String, String)] -> Request -> Request-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-
− src/HAppS/Server/HTTP/Clock.hs
@@ -1,30 +0,0 @@-{-# 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 :: Int) * 1) -- Every second- writeIORef ref =<< mkTime- updater ref--getApproximateTime :: IO B.ByteString-getApproximateTime = readIORef clock
− src/HAppS/Server/HTTP/FileServe.hs
@@ -1,215 +0,0 @@-module HAppS.Server.HTTP.FileServe- (- MimeMap,fileServe, mimeTypes,isDot, blockDotFiles,doIndex,errorwrapper- ) where--import Control.Exception.Extensible--import Control.Monad.Reader-import Control.Monad.Trans-import Data.List-import Data.Maybe-import Data.Int-import HAppS.Server.SimpleHTTP hiding (path)-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--ioErrors :: SomeException -> Maybe IOException-ioErrors = fromException--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 :: (MonadIO m) =>- [String] -> Map.Map String String -> Request -> String -> WebT m Response-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 :: [String]-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' :: (MonadIO m) =>- String- -> (Map.Map String String -> Request -> String -> WebT m Response)- -> Map.Map String String- -> Request- -> WebT m Response-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' :: Integer)- 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 :: (MonadIO m) =>- Map.Map String String -> Request -> String -> WebT m Response-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 :: (Eq a) => a -> a -> [a] -> [a]-tr a b list = map (\x->if x==a then b else x) list-ltrim :: String -> String-ltrim = dropWhile (flip elem " \t\r") --returnGroup :: (MonadIO m) =>- String -> Map.Map String String -> Request -> [String] -> WebT m Response-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 = maximum $ map (fst . fst) files :: ClockTime-- renderResponse mime rq ((maxTime,totSize),(fst $ snd $ head files,- L.concat $ map (snd . snd) files))----fileNotFound :: (Monad m) => String -> WebT m Response-fileNotFound fp = do setResponseCode 404 - return $ toResponse $ "File not found "++ fp---fakeLen = 71* 1024-fakeFile :: (Integral a) =>- a -> ((ClockTime, Int64), (String, L.ByteString))-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 :: (MonadIO m) =>- Map.Map String String- -> String- -> m (Either String ((ClockTime, Integer), (String, L.ByteString)))-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 :: (Monad m,- Show t1) =>- t- -> Request- -> ((ClockTime, t1), (String, L.ByteString))- -> WebT m Response-renderResponse _ 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- -- 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 :: String -> String-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 :: String -> Bool-isDot = isD . reverse- where- isD ('.':'/':_) = True- isD ['.'] = True- --isD ('/':_) = False- isD (_:cs) = isD cs- isD [] = False
− src/HAppS/Server/HTTP/Handler.hs
@@ -1,304 +0,0 @@-{-# LANGUAGE ScopedTypeVariables, PatternSignatures #-}--module HAppS.Server.HTTP.Handler(request-- version,required- ,parseResponse,putRequest--- ,unchunkBody,val,testChunk,pack-) where--- ,fsepC,crlfC,pversion-import Control.Exception.Extensible as E-import Control.Monad-import Data.List(elemIndex)-import Data.Char(toLower)-import Data.Maybe ( fromMaybe, fromJust, isJust, isNothing )-import Prelude hiding (last)-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.Map as M-import System.IO-import Numeric-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.MessageWrap-import HAppS.Server.SURI(SURI(..),path,query)-import HAppS.Server.SURI.ParseURI-import HAppS.Util.TimeOut---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 :: [Char]-transferEncodingC = "transfer-encoding"-rloop :: t- -> Handle- -> Host- -> (Request -> IO Response)- -> L.ByteString- -> IO ()-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)- let headers = mkHeaders 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)) (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 $- do let ioseq act = act >>= \x -> x `seq` return x- res <- ioseq (handler req) `E.catch` \(e::E.SomeException) -> return $ result 500 $ "Server error: " ++ show e- putAugmentedResult h req res- when (continueHTTP req res) $ rloop conf h host handler rest--parseResponse :: L.ByteString -> Either String Response-parseResponse inputStr =- do (topStr,restStr) <- required "failed to separate response" $ - splitAtEmptyLine inputStr- (rsl,headerStr) <- required "failed to separate headers/body" $- splitAtCRLF topStr- let (_,code) = responseLine rsl- headers' <- parseHeaders "host" (L.unpack headerStr)- let headers = mkHeaders headers'- let mbCL = fmap fst (B.readInt =<< getHeader "content-length" headers)- (body,_) <-- 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,rsValidator=Nothing}---- 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 s = L.splitAt index s- where index | crlfLC `L.isPrefixOf` s = 2- | otherwise = let iscrlf = L.zipWith (\a b -> a == '\r' && b == '\n') s . L.tail $ s- Just i = elemIndex True $ zipWith (&&) iscrlf (tail (tail iscrlf))- in fromIntegral $ i+4--crlfLC :: L.ByteString-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')--requestLine :: L.ByteString -> (Method, SURI, Version)-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)- x -> error $ "requestLine cannot handle input: " ++ (show x)--responseLine :: L.ByteString -> (B.ByteString, Int)-responseLine l = case B.words ((B.concat . L.toChunks) l) of - (v:c:_) -> version v `seq` (v,fst (fromJust (B.readInt c)))- x -> error $ "responseLine cannot handle input: " ++ (show x)---method :: B.ByteString -> Method-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)]---- 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- hFlush h---putRequest :: Handle -> Request -> IO ()-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 -> [B.ByteString]-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 :: B.ByteString -> Version-version x | x == http09 = Version 0 9- | x == http10 = Version 1 0- | x == http11 = Version 1 1- | otherwise = error "Invalid HTTP version"--http09 :: B.ByteString-http09 = P.pack "HTTP/0.9"-http10 :: B.ByteString-http10 = P.pack "HTTP/1.0"-http11 :: B.ByteString-http11 = P.pack "HTTP/1.1"---- Constants--connectionC :: B.ByteString-connectionC = P.pack "Connection"-connectionCLower :: B.ByteString-connectionCLower = P.map toLower connectionC-closeC :: B.ByteString-closeC = P.pack "close"-keepAliveC :: B.ByteString-keepAliveC = P.pack "Keep-Alive"-crlfC :: B.ByteString-crlfC = P.pack "\r\n"-fsepC :: B.ByteString-fsepC = P.pack ": "-contentTypeC :: B.ByteString-contentTypeC = P.pack "Content-Type"-contentLengthC :: B.ByteString-contentLengthC = P.pack "Content-Length"-contentlengthC :: B.ByteString-contentlengthC = P.pack "content-length"-dateC :: B.ByteString-dateC = P.pack "Date"-dateCLower :: B.ByteString-dateCLower = P.map toLower dateC-serverC :: B.ByteString-serverC = P.pack "Server"-happsC :: B.ByteString-happsC = P.pack "HAppS/0.9.2"-textHtmlC :: B.ByteString-textHtmlC = P.pack "text/html; charset=utf-8"---- Response code names--responseMessage :: (Num t) => t -> B.ByteString-responseMessage 100 = P.pack " 100 Continue\r\n"-responseMessage 101 = P.pack " 101 Switching Protocols\r\n"-responseMessage 200 = P.pack " 200 OK\r\n"-responseMessage 201 = P.pack " 201 Created\r\n"-responseMessage 202 = P.pack " 202 Accepted\r\n"-responseMessage 203 = P.pack " 203 Non-Authoritative Information\r\n"-responseMessage 204 = P.pack " 204 No Content\r\n"-responseMessage 205 = P.pack " 205 Reset Content\r\n"-responseMessage 206 = P.pack " 206 Partial Content\r\n"-responseMessage 300 = P.pack " 300 Multiple Choices\r\n"-responseMessage 301 = P.pack " 301 Moved Permanently\r\n"-responseMessage 302 = P.pack " 302 Found\r\n"-responseMessage 303 = P.pack " 303 See Other\r\n"-responseMessage 304 = P.pack " 304 Not Modified\r\n"-responseMessage 305 = P.pack " 305 Use Proxy\r\n"-responseMessage 307 = P.pack " 307 Temporary Redirect\r\n"-responseMessage 400 = P.pack " 400 Bad Request\r\n"-responseMessage 401 = P.pack " 401 Unauthorized\r\n"-responseMessage 402 = P.pack " 402 Payment Required\r\n"-responseMessage 403 = P.pack " 403 Forbidden\r\n"-responseMessage 404 = P.pack " 404 Not Found\r\n"-responseMessage 405 = P.pack " 405 Method Not Allowed\r\n"-responseMessage 406 = P.pack " 406 Not Acceptable\r\n"-responseMessage 407 = P.pack " 407 Proxy Authentication Required\r\n"-responseMessage 408 = P.pack " 408 Request Time-out\r\n"-responseMessage 409 = P.pack " 409 Conflict\r\n"-responseMessage 410 = P.pack " 410 Gone\r\n"-responseMessage 411 = P.pack " 411 Length Required\r\n"-responseMessage 412 = P.pack " 412 Precondition Failed\r\n"-responseMessage 413 = P.pack " 413 Request Entity Too Large\r\n"-responseMessage 414 = P.pack " 414 Request-URI Too Large\r\n"-responseMessage 415 = P.pack " 415 Unsupported Media Type\r\n"-responseMessage 416 = P.pack " 416 Requested range not satisfiable\r\n"-responseMessage 417 = P.pack " 417 Expectation Failed\r\n"-responseMessage 500 = P.pack " 500 Internal Server Error\r\n"-responseMessage 501 = P.pack " 501 Not Implemented\r\n"-responseMessage 502 = P.pack " 502 Bad Gateway\r\n"-responseMessage 503 = P.pack " 503 Service Unavailable\r\n"-responseMessage 504 = P.pack " 504 Gateway Time-out\r\n"-responseMessage 505 = P.pack " 505 HTTP Version not supported\r\n"-responseMessage x = P.pack (show x ++ "\r\n")-
− src/HAppS/Server/HTTP/LazyLiner.hs
@@ -1,41 +0,0 @@-{-# LANGUAGE ForeignFunctionInterface #-}-module HAppS.Server.HTTP.LazyLiner- (Lazy, newLinerHandle, headerLines, getBytes, getBytesStrict, getRest, L.toChunks- ) where--import Control.Concurrent.MVar-import System.IO-import qualified Data.ByteString.Char8 as P-import qualified Data.ByteString.Lazy.Char8 as L--newtype Lazy = Lazy (MVar L.ByteString)--newLinerHandle :: Handle -> IO Lazy-newLinerHandle h = fmap Lazy (newMVar =<< L.hGetContents h)--headerLines :: Lazy -> IO [P.ByteString]-headerLines (Lazy mv) = modifyMVar mv $ \l -> do- let loop acc r0 = let (h,r) = L.break ((==) ch) r0- ph = toStrict h- phl = P.length ph- ph2 = if phl == 0 || P.last ph /= '\x0D' then ph else P.init ph- ch = '\x0A'- r' = if L.null r then r else L.tail r- in if P.length ph2 == 0 then (r', reverse acc) else loop (ph2:acc) r'- return $ loop [] l--getBytesStrict :: Lazy -> Int -> IO P.ByteString-getBytesStrict (Lazy mv) len = modifyMVar mv $ \l -> do- let (h,p) = L.splitAt (fromIntegral len) l- return (p, toStrict h)--getBytes :: Lazy -> Int -> IO L.ByteString-getBytes (Lazy mv) len = modifyMVar mv $ \l -> do- let (h,p) = L.splitAt (fromIntegral len) l- return (p, h)--getRest :: Lazy -> IO L.ByteString-getRest (Lazy mv) = modifyMVar mv $ \l -> return (L.empty, l)--toStrict :: L.ByteString -> P.ByteString-toStrict = P.concat . L.toChunks
− src/HAppS/Server/HTTP/Listen.hs
@@ -1,67 +0,0 @@-{-# LANGUAGE CPP, ScopedTypeVariables, PatternSignatures #-}-module HAppS.Server.HTTP.Listen(listen) where--import System.Log.Logger--import HAppS.Server.HTTP.Types-import HAppS.Server.HTTP.Handler--import Control.Exception.Extensible as E-import Control.Concurrent-import Network-import Network.Socket as Socket hiding (listen)-import System.IO--{--#ifndef mingw32_HOST_OS--}-import System.Posix.Signals-{--#endif--}---- alternative implementation of accept to work around EAI_AGAIN errors-acceptLite :: Socket -> IO (Handle, HostName, Socket.PortNumber)-acceptLite sock = do- (sock', addr) <- Socket.accept sock- (Just peer, _) <- getNameInfo [NI_NUMERICHOST] True False addr- h <- socketToHandle sock' ReadWriteMode- (PortNumber p) <- Network.socketPort sock'- return (h, peer, p)----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::SomeException) = 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 loop = do acceptLite s >>= forkIO . work- loop- let pe e = logM "HAppS.Server.HTTP.Listen" ERROR ("ERROR in accept thread: "++- show e)- let infi = loop `catchSome` pe >> infi -- loop `E.catch` pe >> infi- infi `finally` sClose s-{---#ifndef mingw32_HOST_OS--}- installHandler openEndedPipe Ignore Nothing- return ()-{--#endif--}- where -- why are these handlers needed?-- catchSome op h = op `E.catches` [- Handler $ \(e :: ArithException) -> h (toException e),- Handler $ \(e :: ArrayException) -> h (toException e)- ]
− src/HAppS/Server/HTTP/LowLevel.hs
@@ -1,28 +0,0 @@-module HAppS.Server.HTTP.LowLevel- (-- * HTTP Implementation- -- $impl-- -- * Problems- -- $problems-- -- * API- module HAppS.Server.HTTP.Handler,- module HAppS.Server.HTTP.Listen,- module HAppS.Server.HTTP.Types- ) where--import HAppS.Server.HTTP.Handler-import HAppS.Server.HTTP.Listen-import HAppS.Server.HTTP.Types---- $impl--- The HAppS HTTP implementation supports HTTP 1.0 and 1.1.--- Multiple request on a connection including pipelining is supported.---- $problems--- Currently if a client sends an invalid HTTP request the whole--- connection is aborted and no further processing is done.------ When the connection times out HAppS closes it. In future it could--- send a 408 response but this may be problematic if the sending--- of a response caused the problem.
− src/HAppS/Server/HTTP/Multipart.hs
@@ -1,216 +0,0 @@--- #hide---------------------------------------------------------------------------------- |--- Module : HAppS.Server.HTTP.Multipart--- Copyright : (c) Peter Thiemann 2001,2002--- (c) Bjorn Bringert 2005-2006--- (c) Lemmih 2007--- License : BSD-style------ Maintainer : lemmih@vo.com--- Stability : experimental--- Portability : xbnon-portable------ Parsing of the multipart format from RFC2046.--- Partly based on code from WASHMail.----------------------------------------------------------------------------------module HAppS.Server.HTTP.Multipart- (- -- * Multi-part messages- MultiPart(..), BodyPart(..), Header- , parseMultipartBody, hGetMultipartBody- -- * Headers- , ContentType(..), ContentTransferEncoding(..)- , ContentDisposition(..)- , parseContentType- , parseContentTransferEncoding- , parseContentDisposition- , getContentType- , getContentTransferEncoding- , getContentDisposition-- , splitAtEmptyLine- , splitAtCRLF- ) where--import Control.Monad-import Data.Int (Int64)-import Data.Maybe-import System.IO (Handle)--import HAppS.Server.HTTP.RFC822Headers--import qualified Data.ByteString.Lazy.Char8 as BS-import Data.ByteString.Lazy.Char8 (ByteString)------- * Multi-part stuff.-----data MultiPart = MultiPart [BodyPart]- deriving (Show, Read, Eq, Ord)--data BodyPart = BodyPart [Header] ByteString- deriving (Show, Read, Eq, Ord)---- | Read a multi-part message from a 'ByteString'.-parseMultipartBody :: String -- ^ Boundary- -> ByteString -> Maybe MultiPart-parseMultipartBody b s = - do- ps <- splitParts (BS.pack b) s- liftM MultiPart $ mapM parseBodyPart ps---- | Read a multi-part message from a 'Handle'.--- Fails on parse errors.-hGetMultipartBody :: String -- ^ Boundary- -> Handle- -> IO MultiPart-hGetMultipartBody b h = - do- s <- BS.hGetContents h- case parseMultipartBody b s of- Nothing -> fail "Error parsing multi-part message"- Just m -> return m----parseBodyPart :: ByteString -> Maybe BodyPart-parseBodyPart s =- do- (hdr,bdy) <- splitAtEmptyLine s- hs <- parseM pHeaders "<input>" (BS.unpack hdr)- return $ BodyPart hs bdy------- * Splitting into multipart parts.------- | Split a multipart message into the multipart parts.-splitParts :: ByteString -- ^ The boundary, without the initial dashes- -> ByteString - -> Maybe [ByteString]-splitParts b s = dropPreamble b s >>= spl- where- spl x = case splitAtBoundary b x of- Nothing -> Nothing- Just (s1,d,s2) | isClose b d -> Just [s1]- | otherwise -> spl s2 >>= Just . (s1:)---- | Drop everything up to and including the first line starting --- with the boundary. Returns 'Nothing' if there is no --- line starting with a boundary.-dropPreamble :: ByteString -- ^ The boundary, without the initial dashes- -> ByteString - -> Maybe ByteString-dropPreamble b s | isBoundary b s = fmap snd (splitAtCRLF s)- | otherwise = dropLine s >>= dropPreamble b---- | Split a string at the first boundary line.-splitAtBoundary :: ByteString -- ^ The boundary, without the initial dashes- -> ByteString -- ^ String to split.- -> Maybe (ByteString,ByteString,ByteString)- -- ^ The part before the boundary, the boundary line,- -- and the part after the boundary line. The CRLF- -- before and the CRLF (if any) after the boundary line- -- are not included in any of the strings returned.- -- Returns 'Nothing' if there is no boundary.-splitAtBoundary b s = spl 0- where- spl i = case findCRLF (BS.drop i s) of- Nothing -> Nothing- Just (j,l) | isBoundary b s2 -> Just (s1,d,s3)- | otherwise -> spl (i+j+l)- where - s1 = BS.take (i+j) s- s2 = BS.drop (i+j+l) s- (d,s3) = splitAtCRLF_ s2---- | Check whether a string starts with two dashes followed by--- the given boundary string.-isBoundary :: ByteString -- ^ The boundary, without the initial dashes- -> ByteString- -> Bool-isBoundary b s = startsWithDashes s && b `BS.isPrefixOf` BS.drop 2 s---- | Check whether a string for which 'isBoundary' returns true--- has two dashes after the boudary string.-isClose :: ByteString -- ^ The boundary, without the initial dashes- -> ByteString - -> Bool-isClose b s = startsWithDashes (BS.drop (2+BS.length b) s)---- | Checks whether a string starts with two dashes.-startsWithDashes :: ByteString -> Bool-startsWithDashes s = BS.pack "--" `BS.isPrefixOf` s-------- * RFC 2046 CRLF------- | Drop everything up to and including the first CRLF.-dropLine :: ByteString -> Maybe ByteString-dropLine s = fmap snd (splitAtCRLF s)---- | Split a string at the first empty line. The CRLF (if any) before the--- empty line is included in the first result. The CRLF after the--- empty line is not included in the result.--- 'Nothing' is returned if there is no empty line.-splitAtEmptyLine :: ByteString -> Maybe (ByteString, ByteString)-splitAtEmptyLine s | startsWithCRLF s = Just (BS.empty, dropCRLF s)- | otherwise = spl 0- where- spl i = case findCRLF (BS.drop i s) of- Nothing -> Nothing- Just (j,l) | startsWithCRLF s2 -> Just (s1, dropCRLF s2)- | otherwise -> spl (i+j+l)- where (s1,s2) = BS.splitAt (i+j+l) s---- | Split a string at the first CRLF. The CRLF is not included--- in any of the returned strings.-splitAtCRLF :: ByteString -- ^ String to split.- -> Maybe (ByteString,ByteString)- -- ^ Returns 'Nothing' if there is no CRLF.-splitAtCRLF s = case findCRLF s of- Nothing -> Nothing- Just (i,l) -> Just (s1, BS.drop l s2)- where (s1,s2) = BS.splitAt i s---- | Like 'splitAtCRLF', but if no CRLF is found, the first--- result is the argument string, and the second result is empty.-splitAtCRLF_ :: ByteString -> (ByteString,ByteString)-splitAtCRLF_ s = fromMaybe (s,BS.empty) (splitAtCRLF s)---- | Get the index and length of the first CRLF, if any.-findCRLF :: ByteString -- ^ String to split.- -> Maybe (Int64,Int64)-findCRLF s = - case findCRorLF s of- Nothing -> Nothing- Just j | BS.null (BS.drop (j+1) s) -> Just (j,1)- Just j -> case (BS.index s j, BS.index s (j+1)) of- ('\n','\r') -> Just (j,2)- ('\r','\n') -> Just (j,2)- _ -> Just (j,1)--findCRorLF :: ByteString -> Maybe Int64-findCRorLF s = BS.findIndex (\c -> c == '\n' || c == '\r') s--startsWithCRLF :: ByteString -> Bool-startsWithCRLF s = not (BS.null s) && (c == '\n' || c == '\r')- where c = BS.index s 0---- | Drop an initial CRLF, if any. If the string is empty, --- nothing is done. If the string does not start with CRLF,--- the first character is dropped.-dropCRLF :: ByteString -> ByteString-dropCRLF s | BS.null s = BS.empty- | BS.null (BS.drop 1 s) = BS.empty- | c0 == '\n' && c1 == '\r' = BS.drop 2 s- | c0 == '\r' && c1 == '\n' = BS.drop 2 s- | otherwise = BS.drop 1 s- where c0 = BS.index s 0- c1 = BS.index s 1
− src/HAppS/Server/HTTP/RFC822Headers.hs
@@ -1,266 +0,0 @@--- #hide---------------------------------------------------------------------------------- |--- Module : Network.CGI.RFC822Headers--- Copyright : (c) Peter Thiemann 2001,2002--- (c) Bjorn Bringert 2005-2006--- (c) Lemmih 2007--- License : BSD-style------ Maintainer : lemmih@vo.com--- Stability : experimental--- Portability : portable------ Parsing of RFC822-style headers (name, value pairs)--- Partly based on code from WASHMail.----------------------------------------------------------------------------------module HAppS.Server.HTTP.RFC822Headers- ( -- * Headers- Header, - pHeader,- pHeaders,- parseHeaders,-- -- * Content-type- ContentType(..), - getContentType,- parseContentType,- showContentType,-- -- * Content-transfer-encoding- ContentTransferEncoding(..),- getContentTransferEncoding,- parseContentTransferEncoding,-- -- * Content-disposition- ContentDisposition(..),- getContentDisposition, - parseContentDisposition,- - -- * Utilities- parseM- ) where--import Data.Char-import Data.List-import Text.ParserCombinators.Parsec--type Header = (String, String)--pHeaders :: Parser [Header]-pHeaders = many pHeader--parseHeaders :: Monad m => SourceName -> String -> m [Header]-parseHeaders s inp = parseM pHeaders s inp--pHeader :: Parser Header-pHeader = - do name <- many1 headerNameChar- char ':'- many ws1- line <- lineString- crLf- extraLines <- many extraFieldLine- return (map toLower name, concat (line:extraLines))--extraFieldLine :: Parser String-extraFieldLine = - do sp <- ws1- line <- lineString- crLf- return (sp:line)------- * Parameters (for Content-type etc.)-----showParameters :: [(String,String)] -> String-showParameters = concatMap f- where f (n,v) = "; " ++ n ++ "=\"" ++ concatMap esc v ++ "\""- esc '\\' = "\\\\"- esc '"' = "\\\""- esc c | c `elem` ['\\','"'] = '\\':[c]- | otherwise = [c]--p_parameter :: Parser (String,String)-p_parameter =- do lexeme $ char ';'- p_name <- lexeme $ p_token- lexeme $ char '='- -- Workaround for seemingly standardized web browser bug- -- where nothing is escaped in the filename parameter- -- of the content-disposition header in multipart/form-data- let litStr = if p_name == "filename" - then buggyLiteralString- else literalString- p_value <- litStr <|> p_token- return (map toLower p_name, p_value)----- --- * Content type------- | A MIME media type value.--- The 'Show' instance is derived automatically.--- Use 'showContentType' to obtain the standard--- string representation.--- See <http://www.ietf.org/rfc/rfc2046.txt> for more--- information about MIME media types.-data ContentType = - ContentType {- -- | The top-level media type, the general type- -- of the data. Common examples are- -- \"text\", \"image\", \"audio\", \"video\",- -- \"multipart\", and \"application\".- ctType :: String,- -- | The media subtype, the specific data format.- -- Examples include \"plain\", \"html\",- -- \"jpeg\", \"form-data\", etc.- ctSubtype :: String,- -- | Media type parameters. On common example is- -- the charset parameter for the \"text\" - -- top-level type, e.g. @(\"charset\",\"ISO-8859-1\")@.- ctParameters :: [(String, String)]- }- deriving (Show, Read, Eq, Ord)---- | Produce the standard string representation of a content-type,--- e.g. \"text\/html; charset=ISO-8859-1\".-showContentType :: ContentType -> String-showContentType (ContentType x y ps) = x ++ "/" ++ y ++ showParameters ps--pContentType :: Parser ContentType-pContentType = - do many ws1- c_type <- p_token- lexeme $ char '/'- c_subtype <- lexeme $ p_token- c_parameters <- many p_parameter- return $ ContentType (map toLower c_type) (map toLower c_subtype) c_parameters---- | Parse the standard representation of a content-type.--- If the input cannot be parsed, this function calls--- 'fail' with a (hopefully) informative error message.-parseContentType :: Monad m => String -> m ContentType-parseContentType = parseM pContentType "Content-type"--getContentType :: Monad m => [Header] -> m ContentType-getContentType hs = lookupM "content-type" hs >>= parseContentType------- * Content transfer encoding-----data ContentTransferEncoding =- ContentTransferEncoding String- deriving (Show, Read, Eq, Ord)--pContentTransferEncoding :: Parser ContentTransferEncoding-pContentTransferEncoding =- do many ws1- c_cte <- p_token- return $ ContentTransferEncoding (map toLower c_cte)--parseContentTransferEncoding :: Monad m => String -> m ContentTransferEncoding-parseContentTransferEncoding = - parseM pContentTransferEncoding "Content-transfer-encoding"--getContentTransferEncoding :: Monad m => [Header] -> m ContentTransferEncoding-getContentTransferEncoding hs = - lookupM "content-transfer-encoding" hs >>= parseContentTransferEncoding------- * Content disposition-----data ContentDisposition =- ContentDisposition String [(String, String)]- deriving (Show, Read, Eq, Ord)--pContentDisposition :: Parser ContentDisposition-pContentDisposition =- do many ws1- c_cd <- p_token- c_parameters <- many p_parameter- return $ ContentDisposition (map toLower c_cd) c_parameters--parseContentDisposition :: Monad m => String -> m ContentDisposition-parseContentDisposition = parseM pContentDisposition "Content-disposition"--getContentDisposition :: Monad m => [Header] -> m ContentDisposition-getContentDisposition hs = - lookupM "content-disposition" hs >>= parseContentDisposition------- * Utilities-----parseM :: Monad m => Parser a -> SourceName -> String -> m a-parseM p n inp =- case parse p n inp of- Left e -> fail (show e)- Right x -> return x--lookupM :: (Monad m, Eq a, Show a) => a -> [(a,b)] -> m b-lookupM n = maybe (fail ("No such field: " ++ show n)) return . lookup n---- --- * Parsing utilities------- | RFC 822 LWSP-char-ws1 :: Parser Char-ws1 = oneOf " \t"--lexeme :: Parser a -> Parser a-lexeme p = do x <- p; many ws1; return x---- | RFC 822 CRLF (but more permissive)-crLf :: Parser String-crLf = try (string "\n\r" <|> string "\r\n") <|> string "\n" <|> string "\r"---- | One line-lineString :: Parser String-lineString = many (noneOf "\n\r")--literalString :: Parser String-literalString = do char '\"'- str <- many (noneOf "\"\\" <|> quoted_pair)- char '\"'- return str---- No web browsers seem to implement RFC 2046 correctly,--- since they do not escape double quotes and backslashes--- in the filename parameter in multipart/form-data.------ Note that this eats everything until the last double quote on the line.-buggyLiteralString :: Parser String-buggyLiteralString = - do char '\"'- str <- manyTill anyChar (try lastQuote)- return str- where lastQuote = do char '\"' - notFollowedBy (try (many (noneOf "\"") >> char '\"'))--headerNameChar :: Parser Char-headerNameChar = noneOf "\n\r:"--especials, tokenchar :: [Char]-especials = "()<>@,;:\\\"/[]?.="-tokenchar = "!\"#$%&'()*+,-./0123456789:;<=>?@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\\]^_`abcdefghijklmnopqrstuvwxyz{|}~" \\ especials--p_token :: Parser String-p_token = many1 (oneOf tokenchar)--text_chars :: [Char]-text_chars = map chr ([1..9] ++ [11,12] ++ [14..127])--p_text :: Parser Char-p_text = oneOf text_chars--quoted_pair :: Parser Char-quoted_pair = do char '\\'- p_text
− src/HAppS/Server/HTTP/Types.hs
@@ -1,227 +0,0 @@-{-# LANGUAGE TypeSynonymInstances, DeriveDataTypeable #-}--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 HAppS.Server.HTTP.Multipart ( ContentType(..) )-import HAppS.Server.Cookie-import Data.List-import Text.Show.Functions ()---- | HTTP version-data Version = Version Int Int- deriving(Show,Read,Eq)--isHTTP1_1 :: Request -> Bool-isHTTP1_1 rq = case rqVersion rq of Version 1 1 -> True; _ -> False-isHTTP1_0 :: Request -> Bool-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.- , validator :: Maybe (Response -> IO Response)- } -nullConf :: Conf-nullConf = Conf { port = 8000- , validator = Nothing- }------ | 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-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)--data Response = Response { rsCode :: Int,- rsHeaders :: Headers,- rsFlags :: RsFlags,- rsBody :: L.ByteString,- rsValidator:: Maybe (Response -> IO Response)- } deriving (Show,Typeable) --data Request = Request { rqMethod :: Method,- rqPaths :: [String],- rqUri :: String,- rqQuery :: String,- rqInputs :: [(String,Input)],- rqCookies :: [(String,Cookie)],- rqVersion :: Version,- rqHeaders :: Headers,- rqBody :: RqBody,- rqPeer :: Host- } deriving(Show,Read,Typeable)----rqURL :: Request -> String-rqURL rq = '/':intercalate "/" (rqPaths rq) ++ (rqQuery rq)--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 :: (Monad m) => Int -> Response -> m Response-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)------------------------------------------------------------------- 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)--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 k vs1) (HeaderPair _ vs2) = HeaderPair k (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 Nothing--redirect :: (ToSURI s) => Int -> s -> Response -> Response-redirect c s resp = setHeaderBS locationC (pack (render (toSURI s))) resp{rsCode = c}------ constants here-locationC :: ByteString-locationC = P.pack "Location"-closeC :: ByteString-closeC = P.pack "close"-connectionC :: ByteString-connectionC = P.pack "Connection"-keepaliveC :: ByteString-keepaliveC = P.pack "Keep-Alive"-
− src/HAppS/Server/HTTPClient/HTTP.hs
@@ -1,1045 +0,0 @@-{-# LANGUAGE ScopedTypeVariables, PatternSignatures #-}--------------------------------------------------------------------------------- |--- 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.Extensible 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 :: String-crlf = "\r\n"-sp :: String-sp = " "-------------------------------------------------------------------------------------- URI Authority parsing --------------------------------------------------------------------------------------------data URIAuthority = URIAuthority { user :: Maybe String, - password :: Maybe String,- host :: String,- port :: Maybe Int- } deriving (Eq,Show)---- | Parse the authority part of a URL.------ > RFC 1732, section 3.1:--- >--- > //<user>:<password>@<host>:<port>/<url-path>--- > Some or all of the parts "<user>:<password>@", ":<password>",--- > ":<port>", and "/<url-path>" may be excluded.-parseURIAuthority :: String -> Maybe URIAuthority-parseURIAuthority s = listToMaybe (map fst (readP_to_S pURIAuthority s))---pURIAuthority :: ReadP URIAuthority-pURIAuthority = do- (u,pw) <- (pUserInfo `before` char '@') - <++ return (Nothing, Nothing)- h <- munch (/=':')- p <- orNothing (char ':' >> readDecP)- look >>= guard . null - return URIAuthority{ user=u, password=pw, host=h, port=p }--pUserInfo :: ReadP (Maybe String, Maybe String)-pUserInfo = do- u <- orNothing (munch (`notElem` ":@"))- p <- orNothing (char ':' >> munch (/='@'))- return (u,p)--before :: Monad m => m a -> m b -> m a-before a b = a >>= \x -> b >> return x--orNothing :: ReadP a -> ReadP (Maybe a)-orNothing p = fmap Just p <++ return Nothing-------------------------------------------------------------------------------------- Header Data --------------------------------------------------------------------------------------------------------- | The Header data type pairs header names & values.-data Header = Header HeaderName String---instance Show Header where- show (Header key value) = show key ++ ": " ++ value ++ crlf----- | HTTP Header Name type:--- Why include this at all? I have some reasons--- 1) prevent spelling errors of header names,--- 2) remind everyone of what headers are available,--- 3) might speed up searches for specific headers.------ Arguments against:--- 1) makes customising header names laborious--- 2) increases code volume.----data HeaderName = - -- Generic Headers --- HdrCacheControl- | HdrConnection- | HdrDate- | HdrPragma- | HdrTransferEncoding - | HdrUpgrade - | HdrVia-- -- Request Headers --- | HdrAccept- | HdrAcceptCharset- | HdrAcceptEncoding- | HdrAcceptLanguage- | HdrAuthorization- | HdrCookie- | HdrExpect- | HdrFrom- | HdrHost- | HdrIfModifiedSince- | HdrIfMatch- | HdrIfNoneMatch- | HdrIfRange- | HdrIfUnmodifiedSince- | HdrMaxForwards- | HdrProxyAuthorization- | HdrRange- | HdrReferer- | HdrUserAgent-- -- Response Headers- | HdrAge- | HdrLocation- | HdrProxyAuthenticate- | HdrPublic- | HdrRetryAfter- | HdrServer- | HdrSetCookie- | HdrVary- | HdrWarning- | HdrWWWAuthenticate-- -- Entity Headers- | HdrAllow- | HdrContentBase- | HdrContentEncoding- | HdrContentLanguage- | HdrContentLength- | HdrContentLocation- | HdrContentMD5- | HdrContentRange- | HdrContentType- | HdrETag- | HdrExpires- | HdrLastModified-- -- Mime entity headers (for sub-parts)- | HdrContentTransferEncoding-- -- | Allows for unrecognised or experimental headers.- | HdrCustom String -- not in header map below.- deriving(Eq)----- Translation between header names and values,--- good candidate for improvement.-headerMap :: [ (String,HeaderName) ]-headerMap - = [ ("Cache-Control" ,HdrCacheControl )- , ("Connection" ,HdrConnection )- , ("Date" ,HdrDate ) - , ("Pragma" ,HdrPragma )- , ("Transfer-Encoding" ,HdrTransferEncoding ) - , ("Upgrade" ,HdrUpgrade ) - , ("Via" ,HdrVia )- , ("Accept" ,HdrAccept )- , ("Accept-Charset" ,HdrAcceptCharset )- , ("Accept-Encoding" ,HdrAcceptEncoding )- , ("Accept-Language" ,HdrAcceptLanguage )- , ("Authorization" ,HdrAuthorization )- , ("From" ,HdrFrom )- , ("Host" ,HdrHost )- , ("If-Modified-Since" ,HdrIfModifiedSince )- , ("If-Match" ,HdrIfMatch )- , ("If-None-Match" ,HdrIfNoneMatch )- , ("If-Range" ,HdrIfRange ) - , ("If-Unmodified-Since" ,HdrIfUnmodifiedSince )- , ("Max-Forwards" ,HdrMaxForwards )- , ("Proxy-Authorization" ,HdrProxyAuthorization)- , ("Range" ,HdrRange ) - , ("Referer" ,HdrReferer )- , ("User-Agent" ,HdrUserAgent )- , ("Age" ,HdrAge )- , ("Location" ,HdrLocation )- , ("Proxy-Authenticate" ,HdrProxyAuthenticate )- , ("Public" ,HdrPublic )- , ("Retry-After" ,HdrRetryAfter )- , ("Server" ,HdrServer )- , ("Vary" ,HdrVary )- , ("Warning" ,HdrWarning )- , ("WWW-Authenticate" ,HdrWWWAuthenticate )- , ("Allow" ,HdrAllow )- , ("Content-Base" ,HdrContentBase )- , ("Content-Encoding" ,HdrContentEncoding )- , ("Content-Language" ,HdrContentLanguage )- , ("Content-Length" ,HdrContentLength )- , ("Content-Location" ,HdrContentLocation )- , ("Content-MD5" ,HdrContentMD5 )- , ("Content-Range" ,HdrContentRange )- , ("Content-Type" ,HdrContentType )- , ("ETag" ,HdrETag )- , ("Expires" ,HdrExpires )- , ("Last-Modified" ,HdrLastModified )- , ("Set-Cookie" ,HdrSetCookie )- , ("Cookie" ,HdrCookie )- , ("Expect" ,HdrExpect ) ]---instance Show HeaderName where- show (HdrCustom s) = s- show x = case filter ((==x).snd) headerMap of- [] -> error "headerMap incomplete"- (h:_) -> fst h-------- | This class allows us to write generic header manipulation functions--- for both 'Request' and 'Response' data types.-class HasHeaders x where- getHeaders :: x -> [Header]- setHeaders :: x -> [Header] -> x------ Header manipulation functions-insertHeader, replaceHeader, insertHeaderIfMissing- :: HasHeaders a => HeaderName -> String -> a -> a----- | Inserts a header with the given name and value.--- Allows duplicate header names.-insertHeader name value x = setHeaders x newHeaders- where- newHeaders = (Header name value) : getHeaders x----- | Adds the new header only if no previous header shares--- the same name.-insertHeaderIfMissing name value x = setHeaders x (newHeaders $ getHeaders x)- where- newHeaders list@(h@(Header n _): rest)- | n == name = list- | otherwise = h : newHeaders rest- newHeaders [] = [Header name value]-- ---- | Removes old headers with duplicate name.-replaceHeader name value x = setHeaders x newHeaders- where- newHeaders = Header name value : [ h | h@(Header n _) <- 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---------------------------------------------------------------------------------------- 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 :: [(String, RequestMethod)]-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} req = - insertHeaderIfMissing HdrConnection "close" $- insertHeaderIfMissing HdrHost h $- req { rqURI = (rqURI req){ 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)- (_,_) -> error "Case not supported in sendHTTP"--sendHTTPPipelined :: Stream s => s -> [Request] -> IO ([Response],Maybe ConnError)-sendHTTPPipelined conn rqs = - do { (ok,rsp) <- Exception.catch (main (map fixHostHeader rqs))- (\(e::SomeException) -> 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:_) = (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- h = authority uri- in insertHeaderIfMissing HdrHost h 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,c,info) ->- let myftrs = Header HdrContentLength (show c) : 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 _- = return $ Left $ ErrorParse "Unknown Transfer-Encoding"---- | Remove leading crlfs then call readTillEmpty2 (not required by RFC)-readTillEmpty1 :: Stream s => s -> IO (Result [String])-readTillEmpty1 conn =- do { line <- readLine conn- ; case line of- Left e -> return $ Left e- Right s ->- if s == crlf- then readTillEmpty1 conn- else readTillEmpty2 conn [s]- }---- | Read lines until an empty line (CRLF),--- also accepts a connection close as end of--- input, which is not an HTTP\/1.1 compliant--- thing to do - so probably indicates an--- error condition.-readTillEmpty2 :: Stream s => s -> [String] -> IO (Result [String])-readTillEmpty2 conn list =- do { line <- readLine conn- ; case line of- Left e -> return $ Left e- Right s ->- if s == crlf || null s- then return (Right $ reverse (s:list))- else readTillEmpty2 conn (s:list)- }-- ------------------------------------------------------------------------------------- A little friendly funtionality ------------------------------------------------------------------------------------{-- I had a quick look around but couldn't find any RFC about- the encoding of data on the query string. I did find an- IETF memo, however, so this is how I justify the urlEncode- and urlDecode methods.-- Doc name: draft-tiwari-appl-wxxx-forms-01.txt (look on www.ietf.org)-- Reserved chars: ";", "/", "?", ":", "@", "&", "=", "+", ",", and "$" are reserved.- Unwise: "{" | "}" | "|" | "\" | "^" | "[" | "]" | "`"- URI delims: "<" | ">" | "#" | "%" | <">- Unallowed ASCII: <US-ASCII coded characters 00-1F and 7F hexadecimal>- <US-ASCII coded character 20 hexadecimal>- Also unallowed: any non-us-ascii character-- Escape method: char -> '%' a b where a, b :: Hex digits--}--urlEncode, urlDecode :: String -> String--urlDecode ('%':a:b:rest) = chr (16 * digitToInt a + digitToInt b)- : urlDecode rest-urlDecode (h:t) = h : urlDecode t-urlDecode [] = []--urlEncode (h:t) =- let str = if reserved_ (ord h) then escape h else [h]- in str ++ urlEncode t- where- reserved_ x- | x >= ord 'a' && x <= ord 'z' = False- | x >= ord 'A' && x <= ord 'Z' = False- | x >= ord '0' && x <= ord '9' = False- | x <= 0x20 || x >= 0x7F = True- | otherwise = x `elem` map ord [';','/','?',':','@','&'- ,'=','+',',','$','{','}'- ,'|','\\','^','[',']','`'- ,'<','>','#','%','"']- -- wouldn't it be nice if the compiler- -- optimised the above for us?-- escape x = - let y = ord x - in [ '%', intToDigit ((y `div` 16) .&. 0xf), intToDigit (y .&. 0xf) ]--urlEncode [] = []- ----- Encode form variables, useable in either the--- query part of a URI, or the body of a POST request.--- I have no source for this information except experience,--- this sort of encoding worked fine in CGI programming.-urlEncodeVars :: [(String,String)] -> String-urlEncodeVars ((n,v):t) =- let (same,diff) = partition ((==n) . fst) t- in urlEncode n ++ '=' : foldl (\x y -> x ++ ',' : urlEncode y) (urlEncode $ v) (map snd same)- ++ urlEncodeRest diff- where urlEncodeRest [] = []- urlEncodeRest diff = '&' : urlEncodeVars diff-urlEncodeVars [] = []
− src/HAppS/Server/HTTPClient/Stream.hs
@@ -1,173 +0,0 @@--------------------------------------------------------------------------------- |--- 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.Extensible 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.SomeException -> IO (Result a)-handleSocketError sk e =- do { se <- getSocketOption sk SoError- ; if se == 0- then throw e- else return $ if se == 10054 -- reset- then Left ErrorReset- else Left $ ErrorMisc $ show se- }-----instance Stream Socket where- readBlock sk n = (liftM Right $ fn n) `Exception.catch` (handleSocketError sk)- where- fn x = do { str <- myrecv sk x- ; let len = length str- ; if len < x && len /= 0- then ( fn (x-len) >>= \more -> return (str++more) ) - else return str- }-- -- Use of the following function is discouraged.- -- The function reads in one character at a time, - -- which causes many calls to the kernel recv()- -- hence causes many context switches.- readLine sk = (liftM Right $ fn "") `Exception.catch` (handleSocketError sk)- where- fn str =- do { c <- myrecv sk 1 -- like eating through a straw.- ; if null c || c == "\n"- then return (reverse str++c)- else fn (head c:str)- }- - writeBlock sk str = (liftM Right $ fn str) `Exception.catch` (handleSocketError sk)- where- fn [] = return ()- fn x = send sk x >>= \i -> fn (drop i x)-- -- This slams closed the connection (which is considered rude for TCP\/IP)- close sk = shutdown sk ShutdownBoth >> sClose sk--myrecv :: Socket -> Int -> IO String-myrecv sock len =- let handler e = if isEOFError e then return [] else ioError e- in System.IO.Error.catch (recv sock len) handler---- | Allows stream logging.--- Refer to 'debugStream' below.-data Debug x = Dbg Handle x---instance (Stream x) => Stream (Debug x) where- readBlock (Dbg h c) n =- do { val <- readBlock c n- ; hPutStrLn h ("readBlock " ++ show n ++ ' ' : show val)- ; hFlush h- ; return val- }-- readLine (Dbg h c) =- do { val <- readLine c- ; hPutStrLn h ("readLine " ++ show val)- ; return val- }-- writeBlock (Dbg h c) str =- do { val <- writeBlock c str- ; hPutStrLn h ("writeBlock " ++ show val ++ ' ' : show str)- ; return val- }-- close (Dbg h c) =- do { hPutStrLn h "closing..."- ; hFlush h- ; close c- ; hPutStrLn h "...closed"- ; hClose h- }----- | Wraps a stream with logging I\/O, the first--- argument is a filename which is opened in AppendMode.-debugStream :: (Stream a) => String -> a -> IO (Debug a)-debugStream file stm = - do { h <- openFile file AppendMode- ; hPutStrLn h "File opened for appending."- ; return (Dbg h stm)- }
− src/HAppS/Server/HTTPClient/TCP.hs
@@ -1,193 +0,0 @@-{-# LANGUAGE ScopedTypeVariables, PatternSignatures #-}--------------------------------------------------------------------------------- |--- 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.Extensible 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- (\(_::SomeException) -> getHostByName uri >>= \host -> -- _shrug_ this will catch _any_ exception FIXME- 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::SomeException) -> 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` (\(_::SomeException) -> return ()) -- FIXME see above- ; 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- }- closeConn (MkConn _ _ _ _) = error "Case in closeConn not supported"-- suck :: Connection -> IO ()- suck cn = readLine cn >>= - either (\_ -> return ()) -- catch errors & ignore- (\x -> if null x then return () else suck cn)---- | Checks both that the underlying Socket is connected--- and that the connection peer matches the given--- host name (which is recorded locally).-isConnectedTo :: Connection -> String -> IO Bool-isConnectedTo conn name =- do { v <- readIORef (getRef conn)- ; case v of- ConnClosed -> return False- (MkConn sk _ _ h) ->- if (map toLower h == map toLower name)- then sIsConnected sk- else return False- }-
− src/HAppS/Server/JSON.hs
@@ -1,29 +0,0 @@-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 :: Integral a => a -> JSON-jInt = JInt . fromIntegral--class ToJSON a where- toJSON::a->JSON-instance ToJSON JSON where toJSON=id--jsonToString :: JSON -> String-jsonToString (JBool bool) = map toLower $ show bool-jsonToString (JString string) = show string-jsonToString (JInt int) = show int-jsonToString (JFloat float) = show float-jsonToString (JObj pairs) = '{' : (concat $ (intersperse "," $ map impl pairs) )++"}"- where- impl (name,val) = concat [show name,":",jsonToString val]-jsonToString (JList list) = - '[':(concat $ (intersperse "," $ map jsonToString list)) ++"]"-jsonToString JNull = "null"-type CallBack=String--data JSONCall x = JCall CallBack x
− src/HAppS/Server/MessageWrap.hs
@@ -1,99 +0,0 @@-{-# LANGUAGE FlexibleInstances #-}--module HAppS.Server.MessageWrap 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 Data.Maybe-import HAppS.Server.HTTP.Types as H-import HAppS.Server.HTTP.Multipart-import HAppS.Server.SURI as SURI-import HAppS.Util.Common--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 components from a String.-pathEls :: String -> [String]-pathEls = (drop 1) . map SURI.unEscape . splitList '/' ---- | 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
− src/HAppS/Server/MinHaXML.hs
@@ -1,215 +0,0 @@-{-# LANGUAGE TemplateHaskell, FlexibleInstances,- OverlappingInstances, UndecidableInstances, TypeSynonymInstances #-}--- -module HAppS.Server.MinHaXML where--- Copyright (C) 2005 HAppS.org. All Rights Reserved.--import Prelude hiding (elem, pi)--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 :: StyleSheet -> Bool-hasStyleURL NoStyle = False-hasStyleURL _ = True -type Element = Types.Element-- --isCSS :: StyleSheet -> Bool-isCSS (CSS _)=True-isCSS _ = False-isXSL :: StyleSheet -> Bool-isXSL = not.isCSS--t :: Name -> [(Name, String)] -> CharData -> Types.Element-t=textElem-l :: Name -> [(Name, String)] -> [Types.Element] -> Types.Element-l=listElem-e :: Name -> [(Name, String)] -> Types.Element-e=emptyElem-(</<) :: Name- -> [(Name, String)]- -> [Types.Element]- -> Types.Element-(</<)=l-(<>) :: Name -> [(Name, String)] -> CharData -> Types.Element-(<>)=t----xmlElem :: (t -> [Content])- -> Name- -> [(Name, String)]- -> t- -> Types.Element-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 :: Name -> [(Name, String)] -> CharData -> Types.Element-textElem = xmlElem (return.CString True)-emptyElem :: Name -> [(Name, String)] -> Types.Element-emptyElem = \n a->xmlElem id n a []-listElem :: Name- -> [(Name, String)]- -> [Types.Element]- -> Types.Element-listElem = xmlElem $ map CElem--cdataElem :: CharData -> Content-cdataElem = CString False---- Document (simpleProlog xsl) [] $ xmlEscape stdXmlEscaper root-simpleDocOld :: StyleSheet -> Types.Element -> String-simpleDocOld xsl = show . document . - flip (Document (simpleProlog xsl) []) [] . xmlStdEscape--simpleDoc :: StyleSheet -> Types.Element -> String-simpleDoc style elem = ("<?xml version='1.0' encoding='UTF-8' ?>\n"++- if hasStyleURL style then pi else "") ++- (verbatim $ xmlStdEscape elem)- where typeText=if isCSS style then "text/css" else "text/xsl"- pi= "<?xml-stylesheet type=\""++ typeText ++ - "\" href=\""++styleURL style++"\" ?>\n"---simpleDoc' :: StyleSheet -> Types.Element -> String-simpleDoc' style elem = (if hasStyleURL style then pi else "") ++- (verbatim $ xmlStdEscape elem)- where typeText=if isCSS style then "text/css" else "text/xsl"- pi= "<?xml-stylesheet type=\""++ typeText ++ - "\" href=\""++styleURL style++"\" ?>\n"----xmlEscaper :: XmlEscaper-xmlEscaper=stdXmlEscaper-xmlStdEscape :: Types.Element -> Types.Element-xmlStdEscape = xmlEscape stdXmlEscaper-verbim :: (Verbatim a) => a -> String-verbim x =verbatim x--simpleProlog :: StyleSheet -> Prolog-simpleProlog style = - Prolog - (Just (XMLDecl "1.0" - (Just $ EncodingDecl "UTF-8") - Nothing -- standalone declaration- ))- [] Nothing- (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 -> String -> Maybe Types.Element-nonEmpty name val = if val=="" then Nothing- else Just $ textElem name [] val--getRoot :: Document -> Types.Element-getRoot (Document _ _ root _) = root----toXML .< "App" attrs ./>---toXML .< "App" attrs .> []-data XML a = XML StyleSheet a--class ToElement x where toElement::x->Types.Element- -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- un _ = error "Case not handled in Xml toElement instance"--wrapElem :: (ToElement x) => Name -> x -> Types.Element-wrapElem tag x= listElem tag [] [toElement x]-elF :: (ToElement b) => Name -> (a -> b) -> a -> Types.Element-elF tag f = wrapElem tag.f --- label !<=! field = wrapField label field-attrF :: t1 -> (t -> String) -> t -> (t1, String)-attrF name f rec = (name,quoteEsc $ f rec)-attrFS :: (Show a) => t1 -> (t -> a) -> t -> (t1, String)-attrFS name f rec = (name,quoteEsc $ show $ f rec)-attrFMb :: (a -> String)- -> String- -> (a1 -> Maybe a)- -> a1- -> (String, String)-attrFMb r name f = maybe ("","") (\x->(name,quoteEsc $ r x)) . f ----(\x->(name,quoteEsc $ r x)) . f ---(name,quoteEsc $ show $ f rec)--quoteEsc :: String -> String-quoteEsc [] = []-quoteEsc ('"':list) = """ ++ quoteEsc list-quoteEsc (x:xs) = x:quoteEsc xs----quotescape \\ and " \"--recToEl :: Name- -> [a -> (String, String)]- -> [a -> Types.Element]- -> a- -> Types.Element-recToEl name attrs els rec = listElem name attrs' (revmap rec els)- where- attrs' = filter (\ (x,_)->not $ null x) (revmap rec attrs)-listToEl :: (ToElement a) =>- Name -> [(Name, String)] -> [a] -> Types.Element-listToEl name attrs = listElem name attrs . map toElement --toAttrs :: t -> [(t1, t -> t2)] -> [(t1, t2)]-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)
− src/HAppS/Server/S3.hs
@@ -1,240 +0,0 @@-{-# LANGUAGE PatternGuards #-}-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 hiding (path)-import Control.Concurrent ( newMVar, modifyMVar, swapMVar- , 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."--}------------------------------------------------------------------- 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 . auxFilter . getContent . xmlParse bucket $ lst- where auxFilter = xtract "*/Key/-"- getContent (Document _ _ e _) = CElem e-- ppContent xs = [ s | CString _ s <- xs ]----amazonURI :: URI-amazonURI = fromJust $ parseURI "http://s3.amazonaws.com/"-localhost :: URI-localhost = fromJust $ parseURI "http://localhost/"-
− src/HAppS/Server/SURI.hs
@@ -1,55 +0,0 @@-{-# LANGUAGE TypeSynonymInstances, DeriveDataTypeable #-}--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 ---class ToSURI x where toSURI::x->SURI-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-----handling obtaining things from URI paths-class FromPath x where fromPath::String->x
− src/HAppS/Server/SURI/ParseURI.hs
@@ -1,81 +0,0 @@-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 :: ByteString- -> (Maybe URIAuth -> String -> String -> String -> b)- -> b-pabsuri fs cont =- if length fs >= 2 && unsafeHead fs == '/' && unsafeIndex fs 1 == '/'- then pauthority (drop 2 fs) cont- else puriref fs $ cont Nothing-pauthority :: ByteString- -> (Maybe URIAuth -> String -> String -> String -> b)- -> b-pauthority fs cont =- let (auth,rest) = breakChar '/' fs- in puriref rest $! cont (Just $! pauthinner auth)-pauthinner :: ByteString -> URIAuth-pauthinner fs =- case breakChar '@' fs of- (a,b) -> pauthport b $ URIAuth (unpack a)-pauthport :: ByteString -> (String -> String -> t) -> t-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 :: ByteString -> (String -> String -> String -> b) -> 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) ""- _ -> error "unexpected match"-pquery :: ByteString -> (String -> String -> t) -> t-pquery fs cont =- case breakChar '#' fs of- (a,b) -> cont ('?':unpack a) (unpack b)-pfragment :: ByteString -> (String -> b) -> b-pfragment fs cont =- cont $ unpack fs----unsafeTail :: ByteString -> ByteString-unsafeTail = BB.unsafeTail-unsafeHead :: ByteString -> Char-unsafeHead = BB.w2c . BB.unsafeHead-unsafeIndex :: ByteString -> Int -> Char-unsafeIndex s = BB.w2c . BB.unsafeIndex s-
− src/HAppS/Server/SimpleHTTP.hs
@@ -1,780 +0,0 @@-{-# LANGUAGE UndecidableInstances, OverlappingInstances, ScopedTypeVariables, FlexibleInstances, TypeSynonymInstances,- MultiParamTypeClasses, PatternGuards, PatternSignatures #-}---------------------------------------------------------------------------------- |--- 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- -- * Error Handlng- , errorHandlerSP- , simpleErrorHandler- -- * Output Validation- , setValidator- , setValidatorSP- , validateConf- , runValidator- , wdgHTMLValidator- , noopValidator- , lazyProcValidator- ) 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.Applicative-import Control.Concurrent (forkIO)-import Control.Exception (evaluate)-import Control.Monad.Reader-import Control.Monad.State-import Control.Monad.Error-import Data.Maybe-import Data.Monoid-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.Console.GetOpt-import System.Process (runInteractiveProcess, waitForProcess)-import System.Exit-import Text.Show.Functions ()--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--instance (MonadIO m) => MonadIO (ServerPartT m) where- liftIO m = ServerPartT $ const (liftIO m)--newtype WebT m a = WebT { unWebT :: m (Result a) }--data Result a = NoHandle- | Ok (Response -> Response) a- | Escape Response- deriving Show--instance Functor Result where- fmap _ NoHandle = NoHandle- fmap fn (Ok out a) = Ok out (fn a)- fmap _ (Escape r) = Escape r--instance Monad m => Monad (WebT m) where- f >>= g = WebT $ do r <- unWebT f- case r of- NoHandle -> return NoHandle- Escape res -> return $ Escape res- Ok out a -> do r' <- unWebT (g a)- case r' of- NoHandle -> return NoHandle- Escape res -> return $ Escape res- Ok out' a' -> return $ Ok (out' . out) a'- return x = WebT $ return (Ok id x)--instance (Monad m) => Monoid (ServerPartT m a)- where mempty = ServerPartT $ \_ -> noHandle- mappend a b = ServerPartT $ \rq -> (unServerPartT a rq)- `mappend` (unServerPartT b rq)--instance (Monad m) => Monoid (WebT m a) where- mempty = noHandle- mappend a b = WebT $ do a' <- unWebT a- case a' of- NoHandle -> unWebT b- _ -> return a'--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 Functor m => Functor (WebT m) where- fmap fn (WebT m) = WebT $ fmap (fmap fn) m--instance Functor m => Functor (ServerPartT m) where- fmap fn (ServerPartT m) = ServerPartT $ fmap (fmap fn) m--instance (Monad m, Functor m) => Applicative (ServerPartT m) where- pure = return- (<*>) = ap--instance (Monad m, Functor m) => Applicative (WebT m) where- pure = return- (<*>) = ap--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--instance MonadError e m => MonadError e (WebT m) where- throwError err = WebT $ throwError err- catchError action handler = WebT $ catchError (unWebT action) (unWebT . handler)---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 r -> return $ Escape r- 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 (\req -> runValidator (fromMaybe return (validator conf)) =<< simpleHTTP' hs req)----- | 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 r -> return r- 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- res = Response 200 M.empty nullRsFlags bs Nothing- in setHeaderBS (B.pack "Content-Type") (toContentType val)- res--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 m = (== m) -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- (p:xs) | p == 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- (p:xs) | Just a <- fromReqURI p- -> 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 :: (Monad m) => [ServerPartT m r] -> ServerPartT m r-anyPath x = path $ (\(_::String) -> x)-anyPath' :: (Monad m) => ServerPartT m r -> ServerPartT m r-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' :: (MonadIO m) => Request -> WebT m Response-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)---- | 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---- 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 :: (MonadIO m) =>- XSLTCmd -> XSLPath -> Response -> m Response-doXslt cmd xslPath res = - do new <- liftIO $ procLBSIO cmd xslPath $ rsBody res- 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 $ \r -> r{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)--resp :: (Monad m) => Int -> b -> WebT m b-resp status val = setResponseCode status >> return 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 :: (MonadIO m, Show a) => [ServerPartT m a] -> [ServerPartT m a]-debugFilter handle = [- ServerPartT $ \rq -> WebT $ do- r <- unWebT (unServerPartT (multi handle) rq)- return r]--anyRequest :: Monad m => WebT m a -> ServerPartT m a-anyRequest x = withRequest $ \_ -> x--applyRequest :: (ToMessage a, Monad m) =>- [ServerPartT m a] -> Request -> Either (m Response) b-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 $ addHeader headerName headerValue $ toResponse "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))-------------------------------------------------------------------- Error Handling------------------------------------------------------------------- | This ServerPart modifier enables the use of throwError and catchError inside the--- WebT actions, by adding the ErrorT monad transformer to the stack.------ You can wrap the complete second argument to 'simpleHTTP' in this function.------ See 'simpleErrorHandler' for an example error handler.-errorHandlerSP :: (Monad m, Error e) => (Request -> e -> WebT m a) -> [ServerPartT (ErrorT e m) a] -> [ServerPartT m a] -errorHandlerSP handler sps = [ ServerPartT $ \req -> WebT $ do- eer <- runErrorT $ unWebT $ unServerPartT (multi sps) req- case eer of- Left err -> unWebT (handler req err)- Right res -> return res- ]---- | An example error Handler to be used with 'errorHandlerSP', which returns the--- error message as a plain text message to the browser.------ Another possibility is to store the error message, e.g. as a FlashMsg, and--- then redirect the user somewhere.-simpleErrorHandler :: (Monad m) => Request -> String -> WebT m Response-simpleErrorHandler _ err = ok $ toResponse $ ("An error occured: " ++ err)------------------------------------------------------------------- * Output validation------------------------------------------------------------------- |Set the validator which should be used for this particular 'Response'--- when validation is enabled.------ Calling this function does not enable validation. That can only be--- done by enabling the validation in the 'Conf' that is passed to--- 'simpleHTTP'.------ You do not need to call this function if the validator set in--- 'Conf' does what you want already.------ Example: (use 'noopValidator' instead of the default supplied by 'validateConf')------ @--- simpleHTTP validateConf [ anyRequest $ ok . setValidator noopValidator =<< htmlPage ]--- @------ See also: 'validateConf', 'wdgHTMLValidator', 'noopValidator', 'lazyProcValidator'-setValidator :: (Response -> IO Response) -> Response -> Response-setValidator v r = r { rsValidator = Just v }---- |ServerPart version of 'setValidator'------ Example: (Set validator to 'noopValidator')------ @--- simpleHTTP validateConf $ [ setValidatorSP noopValidator (dir "ajax" [ ... ])]--- @------ See also: 'setValidator'-setValidatorSP :: (ToMessage r) => (Response -> IO Response) -> ServerPartT IO r -> ServerPartT IO Response-setValidatorSP v sp = return . setValidator v . toResponse =<< sp---- |This extends 'nullConf' by enabling validation and setting--- 'wdgHTMLValidator' as the default validator for @text\/html@.------ Example:------ @--- simpleHTTP validateConf [ anyRequest $ ok htmlPage ]--- @-validateConf :: Conf-validateConf = nullConf { validator = Just wdgHTMLValidator }---- |Actually perform the validation on a 'Response'--- --- Run the validator specified in the 'Response'. If none is provide--- use the supplied default instead. ------ Note: This function will run validation unconditionally. You--- probably want 'setValidator' or 'validateConf'.-runValidator :: (Response -> IO Response) -> Response -> IO Response-runValidator defaultValidator r =- case rsValidator r of- Nothing -> defaultValidator r- (Just altValidator) -> altValidator r---- |Validate @text\/html@ content with @WDG HTML Validator@.------ This function expects the executable to be named @validate@--- and it must be in the default @PATH@.------ See also: 'setValidator', 'validateConf', 'lazyProcValidator'-wdgHTMLValidator :: (MonadIO m, ToMessage r) => r -> m Response-wdgHTMLValidator = liftIO . lazyProcValidator "validate" ["-w","--verbose","--charset=utf-8"] Nothing Nothing handledContentTypes . toResponse- where- handledContentTypes (Just ct) = elem (takeWhile (\c -> c /= ';' && c /= ' ') (B.unpack ct)) [ "text/html", "application/xhtml+xml" ]- handledContentTypes Nothing = False---- |A validator which always succeeds.------ Useful for selectively disabling validation. For example, if you--- are sending down HTML fragments to an AJAX application and the--- default validator only understands complete documents.-noopValidator :: Response -> IO Response-noopValidator = return---- |Validate the 'Response' using an external application.--- --- If the external application returns 0, the original response is--- returned unmodified. If the external application returns non-zero, a 'Response'--- containing the error messages and original response body is--- returned instead.------ This function also takes a predicate filter which is applied to the--- content-type of the response. The filter will only be applied if--- the predicate returns true.------ NOTE: This function requirse the use of -threaded to avoid blocking.--- However, you probably need that for HAppS anyway.--- --- See also: 'wdgHTMLValidator'-lazyProcValidator :: FilePath -- ^ name of executable- -> [String] -- ^ arguements to pass to the executable- -> Maybe FilePath -- ^ optional path to working directory- -> Maybe [(String, String)] -- ^ optional environment (otherwise inherit)- -> (Maybe B.ByteString -> Bool) -- ^ content-type filter- -> Response -- ^ Response to validate- -> IO Response-lazyProcValidator exec args wd env mimeTypePred response- | mimeTypePred (getHeader "content-type" response) =- do (inh, outh, errh, ph) <- runInteractiveProcess exec args wd env- out <- hGetContents outh- err <- hGetContents errh- forkIO $ do L.hPut inh (rsBody response)- hClose inh- forkIO $ evaluate (length out) >> return ()- forkIO $ evaluate (length err) >> return ()- ec <- waitForProcess ph- case ec of- ExitSuccess -> return response- (ExitFailure _) -> - return $ toResponse (unlines ([ "ExitCode: " ++ show ec- , "stdout:"- , out- , "stderr:"- , err- , "input:"- ] ++ - showLines (rsBody response)))- | otherwise = return response- where- column = " " ++ (take 120 $ concatMap (\n -> " " ++ show n) (drop 1 $ cycle [0..9::Int]))- showLines :: L.ByteString -> [String]- showLines string = column : zipWith (\n -> \l -> show n ++ " " ++ (L.unpack l)) [1::Integer ..] (L.lines string)
− src/HAppS/Server/StdConfig.hs
@@ -1,16 +0,0 @@-{-# LANGUAGE ScopedTypeVariables #-}-module HAppS.Server.StdConfig where--import Control.Monad.Trans-import HAppS.Server.SimpleHTTP-import HAppS.Server.HTTP.FileServe--binarylocation :: String-binarylocation = "haskell/Main"-loglocation :: String-loglocation = "public/log"---errWrap :: MonadIO m => ServerPartT m Response-errWrap = errorwrapper binarylocation loglocation---stateFuns -- main actually has state so you can just import them
− src/HAppS/Server/XSLT.hs
@@ -1,147 +0,0 @@-{-# LANGUAGE TemplateHaskell, FlexibleInstances , UndecidableInstances,- DeriveDataTypeable, MultiParamTypeClasses, CPP, ScopedTypeVariables, PatternSignatures #-}--- | 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.Extensible(bracket,try,SomeException)-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 :: Priority -> String -> IO ()-logMX = logM "HAppS.Server.XSLT"--type XSLPath = FilePath--$(deriveAll [''Show,''Read,''Default, ''Eq, ''Ord]- [d|- data XSLTCmd = XSLTProc | Saxon - |]- )--xsltCmd :: XSLTCmd- -> XSLPath- -> FilePath- -> FilePath- -> (FilePath, [String])-xsltCmd XSLTProc = xsltproc'-xsltCmd Saxon = saxon'--xsltElem :: XSLPath -> Element -> String-xsltElem xsl = xsltString xsl . verbatim---procLBSIO :: XSLTCmd -> XSLPath -> L.ByteString -> IO L.ByteString-procLBSIO xsltp' xsl inp = - withTempFile "happs-src.xml" $ \sfp sh -> do- withTempFile "happs-dst.xml" $ \dfp dh -> do- let xsltp = xsltCmd xsltp'- L.hPut sh inp- hClose sh- hClose dh- xsltFileEx xsltp xsl sfp dfp- s <- L.readFile dfp- logMX DEBUG (">>> XSLT: result: "++ show s)- return s---procFPSIO :: XSLTCommand- -> XSLPath- -> [P.ByteString]- -> IO [P.ByteString]-procFPSIO xsltp 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 xsltp 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 :: XSLPath -> [P.ByteString] -> IO [P.ByteString]-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 :: XSLTCmd-xsltproc = XSLTProc---- | Use @saxon@ to transform XML.-saxon :: XSLTCmd-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 xsltp xsl src dst = do- let msg = (">>> XSLT: Starting xsltproc " ++ unwords ["-o",dst,xsl,src])- logMX DEBUG msg- uncurry runCommand $ xsltp 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--{-# 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 (\(_::SomeException) -> tryAny xs c) return =<< try x
− src/HAppS/Store/Util.hs
@@ -1,50 +0,0 @@-{-# LANGUAGE TemplateHaskell , FlexibleInstances, UndecidableInstances, CPP,- OverlappingInstances, DeriveDataTypeable, MultiParamTypeClasses #-}--module HAppS.Store.Util 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 ------interface with State--$( deriveAll [''Show,''Default,''Read,''Eq,''Ord]- [d|- newtype Context = Context String --this belongs elsewhere!- newtype EpochTime = EpochTime Integer - data Wrap a = Wrap {unwrap::a}- |])--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 _,es)->es) . groupBy-byRevTime::(Typeable a) => IxSet a -> [a]-byRevTime = concat . map (\(Published _,es)->es) . rGroupBy---fun0_1 :: String -> String -> String -> Dec-fun0_1 name fun arg = - FunD (mkName name) - [Clause [] (NormalB (AppE (VarE $ mkName fun) - (ConE $ mkName arg))) - []- ]-fun0_2 :: String -> String -> String -> String -> Dec-fun0_2 name fun arg1 arg2 = - FunD (mkName name) - [Clause [] (NormalB - (AppE (AppE (VarE $ mkName fun) - (ConE $ mkName arg1))- (ConE $ mkName arg2)))- []- ]
+ src/Happstack/Server.hs view
@@ -0,0 +1,15 @@+module Happstack.Server +(module Happstack.Server.XSLT+,module Happstack.Server.SimpleHTTP+,module Happstack.Server.HTTP.Client+,module Happstack.Server.MessageWrap+,module Happstack.Server.HTTP.FileServe+,module Happstack.Server.StdConfig)+where+import Happstack.Server.HTTP.Client+import Happstack.Server.StdConfig+import Happstack.Server.XSLT+import Happstack.Server.SimpleHTTP+import Happstack.Server.MessageWrap+import Happstack.Server.HTTP.FileServe+
+ src/Happstack/Server/Cookie.hs view
@@ -0,0 +1,138 @@+{-# LANGUAGE DeriveDataTypeable #-}++-- http://tools.ietf.org/html/rfc2109+module Happstack.Server.Cookie+ ( Cookie(..)+ , mkCookie+ , mkCookieHeader+ , getCookies+ , getCookie+ , getCookies'+ , getCookie'+ , parseCookies+ , cookiesParser+ )+ where++import qualified Data.ByteString.Char8 as C+import Data.Either+import Data.Char+import Data.List+import Data.Generics+import Happstack.Util.Common (Seconds)+import Text.ParserCombinators.Parsec hiding (token)++data Cookie = Cookie+ { cookieVersion :: String+ , cookiePath :: String+ , cookieDomain :: String+ , cookieName :: String+ , cookieValue :: String+ } deriving(Show,Eq,Read,Typeable,Data)++-- | Creates a cookie with a default version of 1 and path of "/"+mkCookie :: String -> String -> Cookie+mkCookie key val = Cookie "1" "/" "" key val++-- | 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 ])++fctl :: Char -> Bool+fctl ch = ch == chr 127 || ch <= chr 31++-- | Not an supported api. Takes a cookie header and returns+-- either a String error message or an array of parsed cookies+parseCookies :: String -> Either String [Cookie]+parseCookies str = either (Left . show) Right $ parse cookiesParser str str++-- | not a supported api. A parser for RFC 2109 cookies+cookiesParser :: GenParser Char st [Cookie]+cookiesParser = cookies+ where -- Parsers based on RFC 2109+ cookies = do+ ws+ ver<-option "" $ try (cookie_version >>= (\x -> cookieSep >> return x))+ cookieList<-(cookie_value ver) `sepBy1` try cookieSep+ ws+ eof+ return cookieList+ cookie_value ver = do+ name<-attr+ cookieEq+ val<-value+ path<-option "" $ try (cookieSep >> cookie_path)+ domain<-option "" $ try (cookieSep >> cookie_domain)+ return $ Cookie ver path domain (low name) val+ cookie_version = cookie_special "$Version"+ cookie_path = cookie_special "$Path"+ cookie_domain = cookie_special "$Domain"+ cookie_special s = do+ string s+ cookieEq+ value+ cookieSep = ws >> oneOf ",;" >> ws+ cookieEq = ws >> char '=' >> ws+ ws = spaces+ attr = token+ value = word+ word = try (quoted_string) <|> incomp_token++ -- Parsers based on RFC 2068+ token = many1 $ oneOf ((chars \\ ctl) \\ tspecials)+ quoted_string = do+ char '"'+ r <-many (oneOf qdtext)+ char '"'+ return r++ -- Custom parser, incompatible with RFC 2068, but very forgiving ;)+ incomp_token = many1 $ oneOf ((chars \\ ctl) \\ " \t\";")++ -- Primitives from RFC 2068+ tspecials = "()<>@,;:\\\"/[]?={} \t"+ ctl = map chr (127:[0..31])+ chars = map chr [0..127]+ octet = map chr [0..255]+ text = octet \\ ctl+ qdtext = text \\ "\""++-- | 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 h = getCookies' h >>= either (fail. ("Cookie parsing failed!"++)) return++-- | 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 = getCookie' s h >>= either (const $ fail ("getCookie: " ++ show s)) return++getCookies' :: Monad m => C.ByteString -> m (Either String [Cookie])+getCookies' header | C.null header = return $ Right []+ | otherwise = return $ parseCookies (C.unpack header)++getCookie' :: Monad m => String -> C.ByteString -> m (Either String Cookie)+getCookie' s h = do+ cs <- getCookies' h+ return $ do -- Either+ cooks <- cs+ case filter (\x->(==) (low s) (cookieName x) ) cooks of+ [] -> fail "No cookie found"+ f -> return $ head f++low :: String -> String+low = map toLower+
+ src/Happstack/Server/HTTP/Client.hs view
@@ -0,0 +1,50 @@+module Happstack.Server.HTTP.Client where+++import Happstack.Server.HTTP.Handler+import Happstack.Server.HTTP.Types+import Data.Maybe+import qualified Data.ByteString.Lazy.Char8 as L ++import System.IO+import qualified Data.ByteString.Char8 as B +import Network++getResponse :: Request -> IO (Either String Response)+getResponse rq = withSocketsDo $ do+ let (hostName,p) = span (/=':') $ fromJust $ fmap B.unpack $ getHeader "host" rq + portInt = if null p then 80 else read $ tail p+ portId = PortNumber $ toEnum $ portInt+ h <- connectTo hostName portId + hSetBuffering h NoBuffering++ putRequest h rq+ hFlush h++ inputStr <- L.hGetContents h+ return $ parseResponse inputStr++unproxify :: Request -> Request+unproxify rq = rq {rqPaths = tail $ rqPaths rq,+ rqHeaders = + forwardedFor $ forwardedHost $ + setHeader "host" (head $ rqPaths rq) $+ rqHeaders rq}+ where+ appendInfo hdr val = setHeader hdr (csv val $+ maybe "" B.unpack $+ getHeader hdr rq)+ forwardedFor = appendInfo "X-Forwarded-For" (fst $ rqPeer rq)+ forwardedHost = appendInfo "X-Forwarded-Host" + (B.unpack $ fromJust $ getHeader "host" rq)+ csv v "" = v+ csv v x = x++", " ++ v++unrproxify :: String -> [(String, String)] -> Request -> Request+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+
+ src/Happstack/Server/HTTP/Clock.hs view
@@ -0,0 +1,30 @@+{-# OPTIONS -fno-cse #-}+module Happstack.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 :: Int) * 1) -- Every second+ writeIORef ref =<< mkTime+ updater ref++getApproximateTime :: IO B.ByteString+getApproximateTime = readIORef clock
+ src/Happstack/Server/HTTP/FileServe.hs view
@@ -0,0 +1,215 @@+{-# LANGUAGE FlexibleContexts #-}+module Happstack.Server.HTTP.FileServe+ (+ MimeMap,fileServe, mimeTypes,isDot, blockDotFiles,doIndex,errorwrapper+ ) where++import Control.Exception.Extensible++import Control.Monad.Reader+import Control.Monad.Trans+import Data.List+import Data.Maybe+import Data.Int+import Happstack.Server.SimpleHTTP hiding (path)+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 Happstack.Server.SimpleHTTP as SH++ioErrors :: SomeException -> Maybe IOException+ioErrors = fromException++errorwrapper :: (MonadIO m, MonadPlus m, FilterMonad Response m) => String -> String -> m Response+errorwrapper binarylocation loglocation+ = require getErrorLog $ \errorLog ->+ return $ toResponse errorLog+ where getErrorLog+ = 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 :: (ServerMonad m, FilterMonad Response m, MonadIO m) =>+ [String] -> MimeMap -> String -> m Response+doIndex [] _mime _fp = do forbidden $ toResponse "Directory index forbidden"+doIndex (index:rest) mime fp =+ do+ let path = fp++'/':index+ --print path+ fe <- liftIO $ doesFileExist path+ if fe then retFile path else doIndex rest mime fp+ where retFile = returnFile mime+defaultIxFiles :: [String]+defaultIxFiles= ["index.html","index.xml","index.gif"]+++fileServe :: (ServerMonad m, FilterMonad Response m, MonadIO m) => [FilePath] -> FilePath -> m Response+fileServe ixFiles localpath = + 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' :: (ServerMonad m, FilterMonad Response m, MonadIO m) =>+ String+ -> (Map.Map String String -> String -> m Response)+ -> Map.Map String String+ -> m Response+fileServe' localpath fdir mime = do+ rq <- askRq+ 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 $ fakeFile $ (read $ drop 5 $ fp' :: Integer)+ 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 "Happstack.Server.HTTP.FileServe" DEBUG ("fileServe: "++show fp++" \t"++status)+ if de then fdir mime fp else do+ getFile mime fp >>= flip either (renderResponse mime) + (const $ returnGroup localpath mime safepath)++returnFile :: (ServerMonad m, FilterMonad Response m, MonadIO m) =>+ Map.Map String String -> String -> m Response+returnFile mime fp = + getFile mime fp >>= either fileNotFound (renderResponse mime)++-- if fp has , separated then return concatenation with content-type of last+-- and last modified of latest+tr :: (Eq a) => a -> a -> [a] -> [a]+tr a b = map (\x->if x==a then b else x)+ltrim :: String -> String+ltrim = dropWhile (flip elem " \t\r") ++returnGroup :: (ServerMonad m, FilterMonad Response m, MonadIO m) =>+ String -> Map.Map String String -> [String] -> m Response+returnGroup localPath mime 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 = maximum $ map (fst . fst) files :: ClockTime++ renderResponse mime ((maxTime,totSize),(fst $ snd $ head files,+ L.concat $ map (snd . snd) files))++++fileNotFound :: (Monad m, FilterMonad Response m) => String -> m Response+fileNotFound fp = do setResponseCode 404 + return $ toResponse $ "File not found "++ fp+--fakeLen = 71* 1024+fakeFile :: (Integral a) =>+ a -> ((ClockTime, Int64), (String, L.ByteString))+fakeFile fakeLen = ((TOD 0 0,L.length body),("text/javascript",body))+ where+ body = L.pack $ (("//"++(show len)++" ") ++ ) $ (replicate len '0') ++ "\n"+ len = fromIntegral fakeLen++getFile :: (MonadIO m) =>+ Map.Map String String+ -> String+ -> m (Either String ((ClockTime, Integer), (String, L.ByteString)))+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 :: (Monad m,+ ServerMonad m,+ FilterMonad Response m,+ Show t1) =>+ t+ -> ((ClockTime, t1), (String, L.ByteString))+ -> m Response+renderResponse _ ((modtime,size),(ct,body)) = do+ rq <- askRq+ 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+ -- modifyResponse (setHeader "HUH" $ show $ (fmap P.unpack mod == Just repr,mod,Just repr))+ setHeaderM "Last-modified" repr+ -- if %Z or UTC are in place of GMT below, wget complains that the last-modified header is invalid+ setHeaderM "Content-Length" (show size)+ setHeaderM "Content-Type" ct+ return $ resultBS 200 body++ +++getExt :: String -> String+getExt = reverse . takeWhile (/='.') . reverse++-- | 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")]+++-- | Prevents files of the form '.foo' or 'bar/.foo' from being served+blockDotFiles :: (Request -> IO Response) -> Request -> IO Response+blockDotFiles fn rq+ | isDot (intercalate "/" (rqPaths rq)) = return $ result 403 "Dot files not allowed."+ | otherwise = fn rq++-- | Returns True if the given String either starts with a . or is of the form+-- "foo/.bar", e.g. the typical *nix convention for hidden files.+isDot :: String -> Bool+isDot = isD . reverse+ where+ isD ('.':'/':_) = True+ isD ['.'] = True+ --isD ('/':_) = False+ isD (_:cs) = isD cs+ isD [] = False
+ src/Happstack/Server/HTTP/Handler.hs view
@@ -0,0 +1,322 @@+{-# LANGUAGE ScopedTypeVariables, PatternSignatures #-}++module Happstack.Server.HTTP.Handler(request-- version,required+ ,parseResponse,putRequest+-- ,unchunkBody,val,testChunk,pack+) where+-- ,fsepC,crlfC,pversion+import qualified Paths_happstack_server as Paths+import qualified Data.Version as DV+import Control.Exception.Extensible as E+import Control.Monad+import Data.List(elemIndex)+import Data.Char(toLower)+import Data.Maybe ( fromMaybe, fromJust, isJust, isNothing )+import Prelude hiding (last)+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.Map as M+import System.IO+import Numeric+import Data.Int (Int64)+import Happstack.Server.Cookie+import Happstack.Server.HTTP.Clock+import Happstack.Server.HTTP.LazyLiner+import Happstack.Server.HTTP.Types+import Happstack.Server.HTTP.Multipart+import Happstack.Server.HTTP.RFC822Headers+import Happstack.Server.MessageWrap+import Happstack.Server.SURI(SURI(..),path,query)+import Happstack.Server.SURI.ParseURI+import Happstack.Util.TimeOut+import Happstack.Util.LogFormat (formatRequestCombined)+import Data.Time.Clock (getCurrentTime)+import System.Log.Logger (Priority(..), logM)++log' = logM "Happstack.Server"++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 :: [Char]+transferEncodingC = "transfer-encoding"+rloop :: t+ -> Handle+ -> Host+ -> (Request -> IO Response)+ -> L.ByteString+ -> IO ()+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)+ let headers = mkHeaders 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)) (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 $+ do let ioseq act = act >>= \x -> x `seq` return x+ res <- ioseq (handler req) `E.catch` \(e::E.SomeException) -> return $ result 500 $ "Server error: " ++ show e+ + -- combined log format+ time <- getCurrentTime+ let host' = fst host+ user = "-"+ requestLine = unwords [show $ rqMethod req, rqUri req, show $ rqVersion req]+ responseCode = rsCode res+ size = toInteger $ L.length $ rsBody res+ referer = B.unpack $ fromMaybe (B.pack "") $ getHeader "Referer" req+ userAgent = B.unpack $ fromMaybe (B.pack "") $ getHeader "User-Agent" req+ log' NOTICE $ formatRequestCombined host' user time requestLine responseCode size referer userAgent+ + putAugmentedResult h req res+ when (continueHTTP req res) $ rloop conf h host handler rest++parseResponse :: L.ByteString -> Either String Response+parseResponse inputStr =+ do (topStr,restStr) <- required "failed to separate response" $ + splitAtEmptyLine inputStr+ (rsl,headerStr) <- required "failed to separate headers/body" $+ splitAtCRLF topStr+ let (_,code) = responseLine rsl+ headers' <- parseHeaders "host" (L.unpack headerStr)+ let headers = mkHeaders headers'+ let mbCL = fmap fst (B.readInt =<< getHeader "content-length" headers)+ (body,_) <-+ 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,rsValidator=Nothing}++-- 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 s = L.splitAt index s+ where index | crlfLC `L.isPrefixOf` s = 2+ | otherwise = let iscrlf = L.zipWith (\a b -> a == '\r' && b == '\n') s . L.tail $ s+ Just i = elemIndex True $ zipWith (&&) iscrlf (tail (tail iscrlf))+ in fromIntegral $ i+4++crlfLC :: L.ByteString+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')++requestLine :: L.ByteString -> (Method, SURI, Version)+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)+ x -> error $ "requestLine cannot handle input: " ++ (show x)++responseLine :: L.ByteString -> (B.ByteString, Int)+responseLine l = case B.words ((B.concat . L.toChunks) l) of + (v:c:_) -> version v `seq` (v,fst (fromJust (B.readInt c)))+ x -> error $ "responseLine cannot handle input: " ++ (show x)+++method :: B.ByteString -> Method+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)]++-- 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 = P.hPut h+ -- 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+ hFlush h+++putRequest :: Handle -> Request -> IO ()+putRequest h rq = do + let put = B.hPut h+ 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 -> [B.ByteString]+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 :: B.ByteString -> Version+version x | x == http09 = Version 0 9+ | x == http10 = Version 1 0+ | x == http11 = Version 1 1+ | otherwise = error "Invalid HTTP version"++http09 :: B.ByteString+http09 = P.pack "HTTP/0.9"+http10 :: B.ByteString+http10 = P.pack "HTTP/1.0"+http11 :: B.ByteString+http11 = P.pack "HTTP/1.1"++-- Constants++connectionC :: B.ByteString+connectionC = P.pack "Connection"+connectionCLower :: B.ByteString+connectionCLower = P.map toLower connectionC+closeC :: B.ByteString+closeC = P.pack "close"+keepAliveC :: B.ByteString+keepAliveC = P.pack "Keep-Alive"+crlfC :: B.ByteString+crlfC = P.pack "\r\n"+fsepC :: B.ByteString+fsepC = P.pack ": "+contentTypeC :: B.ByteString+contentTypeC = P.pack "Content-Type"+contentLengthC :: B.ByteString+contentLengthC = P.pack "Content-Length"+contentlengthC :: B.ByteString+contentlengthC = P.pack "content-length"+dateC :: B.ByteString+dateC = P.pack "Date"+dateCLower :: B.ByteString+dateCLower = P.map toLower dateC+serverC :: B.ByteString+serverC = P.pack "Server"+happsC :: B.ByteString+happsC = P.pack $ "Happstack/" ++ DV.showVersion Paths.version+textHtmlC :: B.ByteString+textHtmlC = P.pack "text/html; charset=utf-8"++-- Response code names++responseMessage :: (Num t) => t -> B.ByteString+responseMessage 100 = P.pack " 100 Continue\r\n"+responseMessage 101 = P.pack " 101 Switching Protocols\r\n"+responseMessage 200 = P.pack " 200 OK\r\n"+responseMessage 201 = P.pack " 201 Created\r\n"+responseMessage 202 = P.pack " 202 Accepted\r\n"+responseMessage 203 = P.pack " 203 Non-Authoritative Information\r\n"+responseMessage 204 = P.pack " 204 No Content\r\n"+responseMessage 205 = P.pack " 205 Reset Content\r\n"+responseMessage 206 = P.pack " 206 Partial Content\r\n"+responseMessage 300 = P.pack " 300 Multiple Choices\r\n"+responseMessage 301 = P.pack " 301 Moved Permanently\r\n"+responseMessage 302 = P.pack " 302 Found\r\n"+responseMessage 303 = P.pack " 303 See Other\r\n"+responseMessage 304 = P.pack " 304 Not Modified\r\n"+responseMessage 305 = P.pack " 305 Use Proxy\r\n"+responseMessage 307 = P.pack " 307 Temporary Redirect\r\n"+responseMessage 400 = P.pack " 400 Bad Request\r\n"+responseMessage 401 = P.pack " 401 Unauthorized\r\n"+responseMessage 402 = P.pack " 402 Payment Required\r\n"+responseMessage 403 = P.pack " 403 Forbidden\r\n"+responseMessage 404 = P.pack " 404 Not Found\r\n"+responseMessage 405 = P.pack " 405 Method Not Allowed\r\n"+responseMessage 406 = P.pack " 406 Not Acceptable\r\n"+responseMessage 407 = P.pack " 407 Proxy Authentication Required\r\n"+responseMessage 408 = P.pack " 408 Request Time-out\r\n"+responseMessage 409 = P.pack " 409 Conflict\r\n"+responseMessage 410 = P.pack " 410 Gone\r\n"+responseMessage 411 = P.pack " 411 Length Required\r\n"+responseMessage 412 = P.pack " 412 Precondition Failed\r\n"+responseMessage 413 = P.pack " 413 Request Entity Too Large\r\n"+responseMessage 414 = P.pack " 414 Request-URI Too Large\r\n"+responseMessage 415 = P.pack " 415 Unsupported Media Type\r\n"+responseMessage 416 = P.pack " 416 Requested range not satisfiable\r\n"+responseMessage 417 = P.pack " 417 Expectation Failed\r\n"+responseMessage 500 = P.pack " 500 Internal Server Error\r\n"+responseMessage 501 = P.pack " 501 Not Implemented\r\n"+responseMessage 502 = P.pack " 502 Bad Gateway\r\n"+responseMessage 503 = P.pack " 503 Service Unavailable\r\n"+responseMessage 504 = P.pack " 504 Gateway Time-out\r\n"+responseMessage 505 = P.pack " 505 HTTP Version not supported\r\n"+responseMessage x = P.pack (show x ++ "\r\n")+
+ src/Happstack/Server/HTTP/LazyLiner.hs view
@@ -0,0 +1,41 @@+{-# LANGUAGE ForeignFunctionInterface #-}+module Happstack.Server.HTTP.LazyLiner+ (Lazy, newLinerHandle, headerLines, getBytes, getBytesStrict, getRest, L.toChunks+ ) where++import Control.Concurrent.MVar+import System.IO+import qualified Data.ByteString.Char8 as P+import qualified Data.ByteString.Lazy.Char8 as L++newtype Lazy = Lazy (MVar L.ByteString)++newLinerHandle :: Handle -> IO Lazy+newLinerHandle h = fmap Lazy (newMVar =<< L.hGetContents h)++headerLines :: Lazy -> IO [P.ByteString]+headerLines (Lazy mv) = modifyMVar mv $ \l -> do+ let loop acc r0 = let (h,r) = L.break ((==) ch) r0+ ph = toStrict h+ phl = P.length ph+ ph2 = if phl == 0 || P.last ph /= '\x0D' then ph else P.init ph+ ch = '\x0A'+ r' = if L.null r then r else L.tail r+ in if P.length ph2 == 0 then (r', reverse acc) else loop (ph2:acc) r'+ return $ loop [] l++getBytesStrict :: Lazy -> Int -> IO P.ByteString+getBytesStrict (Lazy mv) len = modifyMVar mv $ \l -> do+ let (h,p) = L.splitAt (fromIntegral len) l+ return (p, toStrict h)++getBytes :: Lazy -> Int -> IO L.ByteString+getBytes (Lazy mv) len = modifyMVar mv $ \l -> do+ let (h,p) = L.splitAt (fromIntegral len) l+ return (p, h)++getRest :: Lazy -> IO L.ByteString+getRest (Lazy mv) = modifyMVar mv $ \l -> return (L.empty, l)++toStrict :: L.ByteString -> P.ByteString+toStrict = P.concat . L.toChunks
+ src/Happstack/Server/HTTP/Listen.hs view
@@ -0,0 +1,58 @@+{-# LANGUAGE CPP, ScopedTypeVariables, PatternSignatures #-}+module Happstack.Server.HTTP.Listen(listen) where++import Happstack.Server.HTTP.Types+import Happstack.Server.HTTP.Handler+import Happstack.Server.HTTP.Socket (acceptLite)+import Control.Exception.Extensible as E+import Control.Concurrent+import Network(PortID(..), listenOn, sClose)+import System.IO+{-+#ifndef mingw32_HOST_OS+-}+import System.Posix.Signals+{-+#endif+-}+import System.Log.Logger (Priority(..), logM)+log':: Priority -> String -> IO ()+log' = logM "Happstack.Server.HTTP.Listen"++listen :: Conf -> (Request -> IO Response) -> IO ()+listen conf hand = do+{-+#ifndef mingw32_HOST_OS+-}+ installHandler openEndedPipe Ignore Nothing+{-+#endif+-}+ let port' = port conf+ log' NOTICE ("Listening on port " ++ show port')+ s <- listenOn $ PortNumber $ toEnum port'+ let work (h,hn,p) = do -- hSetBuffering h NoBuffering+ let eh (x::SomeException) = log' ERROR ("HTTP request failed with: "++show x)+ request conf h (hn,fromIntegral p) hand `E.catch` eh+ hClose h+ let loop = do acceptLite s >>= forkIO . work+ loop+ let pe e = log' ERROR ("ERROR in accept thread: "+++ show e)+ let infi = loop `catchSome` pe >> infi -- loop `E.catch` pe >> infi+ infi `finally` sClose s+{--+#ifndef mingw32_HOST_OS+-}+ installHandler openEndedPipe Ignore Nothing+ return ()+{-+#endif+-}+ where -- why are these handlers needed?++ catchSome op h = op `E.catches` [+ Handler $ \(e :: ArithException) -> h (toException e),+ Handler $ \(e :: ArrayException) -> h (toException e)+ ]+
+ src/Happstack/Server/HTTP/LowLevel.hs view
@@ -0,0 +1,28 @@+module Happstack.Server.HTTP.LowLevel+ (-- * HTTP Implementation+ -- $impl++ -- * Problems+ -- $problems++ -- * API+ module Happstack.Server.HTTP.Handler,+ module Happstack.Server.HTTP.Listen,+ module Happstack.Server.HTTP.Types+ ) where++import Happstack.Server.HTTP.Handler+import Happstack.Server.HTTP.Listen+import Happstack.Server.HTTP.Types++-- $impl+-- The Happstack 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 Happstack closes it. In future it could+-- send a 408 response but this may be problematic if the sending+-- of a response caused the problem.
+ src/Happstack/Server/HTTP/Multipart.hs view
@@ -0,0 +1,216 @@+-- #hide++-----------------------------------------------------------------------------+-- |+-- Module : Happstack.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 Happstack.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 Happstack.Server.HTTP.RFC822Headers++import qualified Data.ByteString.Lazy.Char8 as BS+import Data.ByteString.Lazy.Char8 (ByteString)++--+-- * Multi-part stuff.+--++data MultiPart = MultiPart [BodyPart]+ deriving (Show, Read, Eq, Ord)++data BodyPart = BodyPart [Header] ByteString+ deriving (Show, Read, Eq, Ord)++-- | Read a multi-part message from a 'ByteString'.+parseMultipartBody :: String -- ^ Boundary+ -> ByteString -> Maybe MultiPart+parseMultipartBody b s = + do+ ps <- splitParts (BS.pack b) s+ liftM MultiPart $ mapM parseBodyPart ps++-- | Read a multi-part message from a 'Handle'.+-- Fails on parse errors.+hGetMultipartBody :: String -- ^ Boundary+ -> Handle+ -> IO MultiPart+hGetMultipartBody b h = + do+ s <- BS.hGetContents h+ case parseMultipartBody b s of+ Nothing -> fail "Error parsing multi-part message"+ Just m -> return m++++parseBodyPart :: ByteString -> Maybe BodyPart+parseBodyPart s =+ do+ (hdr,bdy) <- splitAtEmptyLine s+ hs <- parseM pHeaders "<input>" (BS.unpack hdr)+ return $ BodyPart hs bdy++--+-- * Splitting into multipart parts.+--++-- | Split a multipart message into the multipart parts.+splitParts :: ByteString -- ^ The boundary, without the initial dashes+ -> ByteString + -> Maybe [ByteString]+splitParts b s = dropPreamble b s >>= spl+ where+ spl x = case splitAtBoundary b x of+ Nothing -> Nothing+ Just (s1,d,s2) | isClose b d -> Just [s1]+ | otherwise -> spl s2 >>= Just . (s1:)++-- | Drop everything up to and including the first line starting +-- with the boundary. Returns 'Nothing' if there is no +-- line starting with a boundary.+dropPreamble :: ByteString -- ^ The boundary, without the initial dashes+ -> ByteString + -> Maybe ByteString+dropPreamble b s | isBoundary b s = fmap snd (splitAtCRLF s)+ | otherwise = dropLine s >>= dropPreamble b++-- | Split a string at the first boundary line.+splitAtBoundary :: ByteString -- ^ The boundary, without the initial dashes+ -> ByteString -- ^ String to split.+ -> Maybe (ByteString,ByteString,ByteString)+ -- ^ The part before the boundary, the boundary line,+ -- and the part after the boundary line. The CRLF+ -- before and the CRLF (if any) after the boundary line+ -- are not included in any of the strings returned.+ -- Returns 'Nothing' if there is no boundary.+splitAtBoundary b s = spl 0+ where+ spl i = case findCRLF (BS.drop i s) of+ Nothing -> Nothing+ Just (j,l) | isBoundary b s2 -> Just (s1,d,s3)+ | otherwise -> spl (i+j+l)+ where + s1 = BS.take (i+j) s+ s2 = BS.drop (i+j+l) s+ (d,s3) = splitAtCRLF_ s2++-- | Check whether a string starts with two dashes followed by+-- the given boundary string.+isBoundary :: ByteString -- ^ The boundary, without the initial dashes+ -> ByteString+ -> Bool+isBoundary b s = startsWithDashes s && b `BS.isPrefixOf` BS.drop 2 s++-- | Check whether a string for which 'isBoundary' returns true+-- has two dashes after the boudary string.+isClose :: ByteString -- ^ The boundary, without the initial dashes+ -> ByteString + -> Bool+isClose b = startsWithDashes . BS.drop (2+BS.length b)++-- | 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 = fmap snd . splitAtCRLF++-- | 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 = BS.findIndex (\c -> c == '\n' || c == '\r')++startsWithCRLF :: ByteString -> Bool+startsWithCRLF s = not (BS.null s) && (c == '\n' || c == '\r')+ where c = BS.index s 0++-- | Drop an initial CRLF, if any. If the string is empty, +-- nothing is done. If the string does not start with CRLF,+-- the first character is dropped.+dropCRLF :: ByteString -> ByteString+dropCRLF s | BS.null s = BS.empty+ | BS.null (BS.drop 1 s) = BS.empty+ | c0 == '\n' && c1 == '\r' = BS.drop 2 s+ | c0 == '\r' && c1 == '\n' = BS.drop 2 s+ | otherwise = BS.drop 1 s+ where c0 = BS.index s 0+ c1 = BS.index s 1
+ src/Happstack/Server/HTTP/RFC822Headers.hs view
@@ -0,0 +1,266 @@+-- #hide++-----------------------------------------------------------------------------+-- |+-- Module : Network.CGI.RFC822Headers+-- Copyright : (c) Peter Thiemann 2001,2002+-- (c) Bjorn Bringert 2005-2006+-- (c) Lemmih 2007+-- License : BSD-style+--+-- Maintainer : lemmih@vo.com+-- Stability : experimental+-- Portability : portable+--+-- Parsing of RFC822-style headers (name, value pairs)+-- Partly based on code from WASHMail.+--+-----------------------------------------------------------------------------+module Happstack.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 = parseM pHeaders++pHeader :: Parser Header+pHeader = + do name <- many1 headerNameChar+ char ':'+ many ws1+ line <- lineString+ crLf+ extraLines <- many extraFieldLine+ return (map toLower name, concat (line:extraLines))++extraFieldLine :: Parser String+extraFieldLine = + do sp <- ws1+ line <- lineString+ crLf+ return (sp:line)++--+-- * Parameters (for Content-type etc.)+--++showParameters :: [(String,String)] -> String+showParameters = concatMap f+ where f (n,v) = "; " ++ n ++ "=\"" ++ concatMap esc v ++ "\""+ esc '\\' = "\\\\"+ esc '"' = "\\\""+ esc c | c `elem` ['\\','"'] = '\\':[c]+ | otherwise = [c]++p_parameter :: Parser (String,String)+p_parameter =+ do lexeme $ char ';'+ p_name <- lexeme $ p_token+ lexeme $ char '='+ -- Workaround for seemingly standardized web browser bug+ -- where nothing is escaped in the filename parameter+ -- of the content-disposition header in multipart/form-data+ let litStr = if p_name == "filename" + then buggyLiteralString+ else literalString+ p_value <- litStr <|> p_token+ return (map toLower p_name, p_value)+++-- +-- * Content type+--++-- | A MIME media type value.+-- The 'Show' instance is derived automatically.+-- Use 'showContentType' to obtain the standard+-- string representation.+-- See <http://www.ietf.org/rfc/rfc2046.txt> for more+-- information about MIME media types.+data ContentType = + ContentType {+ -- | The top-level media type, the general type+ -- of the data. Common examples are+ -- \"text\", \"image\", \"audio\", \"video\",+ -- \"multipart\", and \"application\".+ ctType :: String,+ -- | The media subtype, the specific data format.+ -- Examples include \"plain\", \"html\",+ -- \"jpeg\", \"form-data\", etc.+ ctSubtype :: String,+ -- | Media type parameters. On common example is+ -- the charset parameter for the \"text\" + -- top-level type, e.g. @(\"charset\",\"ISO-8859-1\")@.+ ctParameters :: [(String, String)]+ }+ deriving (Show, Read, Eq, Ord)++-- | Produce the standard string representation of a content-type,+-- e.g. \"text\/html; charset=ISO-8859-1\".+showContentType :: ContentType -> String+showContentType (ContentType x y ps) = x ++ "/" ++ y ++ showParameters ps++pContentType :: Parser ContentType+pContentType = + do many ws1+ c_type <- p_token+ lexeme $ char '/'+ c_subtype <- lexeme $ p_token+ c_parameters <- many p_parameter+ return $ ContentType (map toLower c_type) (map toLower c_subtype) c_parameters++-- | Parse the standard representation of a content-type.+-- If the input cannot be parsed, this function calls+-- 'fail' with a (hopefully) informative error message.+parseContentType :: Monad m => String -> m ContentType+parseContentType = parseM pContentType "Content-type"++getContentType :: Monad m => [Header] -> m ContentType+getContentType hs = lookupM "content-type" hs >>= parseContentType++--+-- * Content transfer encoding+--++data ContentTransferEncoding =+ ContentTransferEncoding String+ deriving (Show, Read, Eq, Ord)++pContentTransferEncoding :: Parser ContentTransferEncoding+pContentTransferEncoding =+ do many ws1+ c_cte <- p_token+ return $ ContentTransferEncoding (map toLower c_cte)++parseContentTransferEncoding :: Monad m => String -> m ContentTransferEncoding+parseContentTransferEncoding = + parseM pContentTransferEncoding "Content-transfer-encoding"++getContentTransferEncoding :: Monad m => [Header] -> m ContentTransferEncoding+getContentTransferEncoding hs = + lookupM "content-transfer-encoding" hs >>= parseContentTransferEncoding++--+-- * Content disposition+--++data ContentDisposition =+ ContentDisposition String [(String, String)]+ deriving (Show, Read, Eq, Ord)++pContentDisposition :: Parser ContentDisposition+pContentDisposition =+ do many ws1+ c_cd <- p_token+ c_parameters <- many p_parameter+ return $ ContentDisposition (map toLower c_cd) c_parameters++parseContentDisposition :: Monad m => String -> m ContentDisposition+parseContentDisposition = parseM pContentDisposition "Content-disposition"++getContentDisposition :: Monad m => [Header] -> m ContentDisposition+getContentDisposition hs = + lookupM "content-disposition" hs >>= parseContentDisposition++--+-- * Utilities+--++parseM :: Monad m => Parser a -> SourceName -> String -> m a+parseM p n inp =+ case parse p n inp of+ Left e -> fail (show e)+ Right x -> return x++lookupM :: (Monad m, Eq a, Show a) => a -> [(a,b)] -> m b+lookupM n = maybe (fail ("No such field: " ++ show n)) return . lookup n++-- +-- * Parsing utilities+--++-- | RFC 822 LWSP-char+ws1 :: Parser Char+ws1 = oneOf " \t"++lexeme :: Parser a -> Parser a+lexeme p = do x <- p; many ws1; return x++-- | RFC 822 CRLF (but more permissive)+crLf :: Parser String+crLf = try (string "\n\r" <|> string "\r\n") <|> string "\n" <|> string "\r"++-- | One line+lineString :: Parser String+lineString = many (noneOf "\n\r")++literalString :: Parser String+literalString = do char '\"'+ str <- many (noneOf "\"\\" <|> quoted_pair)+ char '\"'+ return str++-- No web browsers seem to implement RFC 2046 correctly,+-- since they do not escape double quotes and backslashes+-- in the filename parameter in multipart/form-data.+--+-- Note that this eats everything until the last double quote on the line.+buggyLiteralString :: Parser String+buggyLiteralString = + do char '\"'+ str <- manyTill anyChar (try lastQuote)+ return str+ where lastQuote = do char '\"' + notFollowedBy (try (many (noneOf "\"") >> char '\"'))++headerNameChar :: Parser Char+headerNameChar = noneOf "\n\r:"++especials, tokenchar :: [Char]+especials = "()<>@,;:\\\"/[]?.="+tokenchar = "!\"#$%&'()*+,-./0123456789:;<=>?@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\\]^_`abcdefghijklmnopqrstuvwxyz{|}~" \\ especials++p_token :: Parser String+p_token = many1 (oneOf tokenchar)++text_chars :: [Char]+text_chars = map chr ([1..9] ++ [11,12] ++ [14..127])++p_text :: Parser Char+p_text = oneOf text_chars++quoted_pair :: Parser Char+quoted_pair = do char '\\'+ p_text
+ src/Happstack/Server/HTTP/Socket.hs view
@@ -0,0 +1,52 @@+{-# LANGUAGE TemplateHaskell #-}+module Happstack.Server.HTTP.Socket(acceptLite) where++import Happstack.Server.HTTP.SocketTH(supportsIPv6)+import Language.Haskell.TH.Syntax+import Happstack.Util.HostAddress+import qualified Network as N+ ( PortID(PortNumber)+ , socketPort+ )+import qualified Network.Socket as S+ ( Socket(..)+ , PortNumber()+ , SockAddr(..)+ , HostName+ , accept+ , socketToHandle+ )+import System.IO++-- alternative implementation of accept to work around EAI_AGAIN errors+acceptLite :: S.Socket -> IO (Handle, S.HostName, S.PortNumber)+acceptLite sock = do+ (sock', addr) <- S.accept sock+ h <- S.socketToHandle sock' ReadWriteMode+ (N.PortNumber p) <- N.socketPort sock'+ + let peer = $(if supportsIPv6+ then+ return $ CaseE (VarE (mkName "addr")) + [Match + (ConP (mkName "S.SockAddrInet") + [WildP,VarP (mkName "ha")]) + (NormalB (AppE (VarE (mkName "showHostAddress")) + (VarE (mkName "ha")))) []+ ,Match (ConP (mkName "S.SockAddrInet6") [WildP,WildP,VarP (mkName "ha"),WildP])+ (NormalB (AppE (VarE (mkName "showHostAddress6")) (VarE (mkName "ha")))) []+ ,Match WildP (NormalB (AppE (VarE (mkName "error")) (LitE (StringL "Unsupported socket")))) []]+ -- the above mess is the equivalent of this: + {-[| case addr of+ (S.SockAddrInet _ ha) -> showHostAddress ha+ (S.SockAddrInet6 _ _ ha _) -> showHostAddress6 ha+ _ -> error "Unsupported socket"+ |]-}+ else+ [| case addr of+ (S.SockAddrInet _ ha) -> showHostAddress ha+ _ -> error "Unsupported socket"+ |])+ + return (h, peer, p)+
+ src/Happstack/Server/HTTP/SocketTH.hs view
@@ -0,0 +1,16 @@+{-# LANGUAGE TemplateHaskell #-}+module Happstack.Server.HTTP.SocketTH(supportsIPv6) where+import Language.Haskell.TH++import Data.List+import Data.Maybe+import Network.Socket(SockAddr(..))++-- find out at compile time if the SockAddr6 / HostAddress6 constructors are available+supportsIPv6 :: Bool+supportsIPv6 = $(let c = "Network.Socket.SockAddrInet6"; d = ''SockAddr in+ do TyConI (DataD _ _ _ cs _) <- reify d+ if isJust (find (\(NormalC n _) -> show n == c) cs)+ then [| True |]+ else [| False |] )+
+ src/Happstack/Server/HTTP/Types.hs view
@@ -0,0 +1,252 @@+{-# LANGUAGE TypeSynonymInstances, DeriveDataTypeable #-}++module Happstack.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 Happstack.Server.SURI+import Data.Char (toLower)++import Happstack.Server.HTTP.Multipart ( ContentType(..) )+import Happstack.Server.Cookie+import Data.List+import Text.Show.Functions ()++-- | HTTP version+data Version = Version Int Int+ deriving(Read,Eq)++instance Show Version where+ show (Version x y) = (show x) ++ "." ++ (show y)++isHTTP1_1 :: Request -> Bool+isHTTP1_1 rq = case rqVersion rq of Version 1 1 -> True; _ -> False+isHTTP1_0 :: Request -> Bool+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.+ , validator :: Maybe (Response -> IO Response)+ } ++-- | Default configuration contains no validator and the port is set to 8000+nullConf :: Conf+nullConf = Conf { port = 8000+ , validator = Nothing+ }++-- | 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)++-- | Default RsFlags that will include the content-length header+nullRsFlags :: RsFlags+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)++data Response = Response { rsCode :: Int,+ rsHeaders :: Headers,+ rsFlags :: RsFlags,+ rsBody :: L.ByteString,+ rsValidator:: Maybe (Response -> IO Response)+ } deriving (Show,Typeable) ++data Request = Request { rqMethod :: Method,+ rqPaths :: [String],+ rqUri :: String,+ rqQuery :: String,+ rqInputs :: [(String,Input)],+ rqCookies :: [(String,Cookie)],+ rqVersion :: Version,+ rqHeaders :: Headers,+ rqBody :: RqBody,+ rqPeer :: Host+ } deriving(Show,Read,Typeable)+++-- | Converts a Request into a String representing the corresponding URL+rqURL :: Request -> String+rqURL rq = '/':intercalate "/" (rqPaths rq) ++ (rqQuery rq)++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 = f+ headers = id++newtype RqBody = Body L.ByteString deriving (Read,Show,Typeable)++-- | Sets the Response status code to the provided Int and lifts the computation+-- into a Monad.+setRsCode :: (Monad m) => Int -> Response -> m Response+setRsCode code rs = return rs {rsCode = code}++-- | Takes a list of (key,val) pairs and converts it into Headers. The+-- keys will be converted to lowercase+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 = getHeaderBS . pack++-- | Lookup header value. Key is a case-insensitive bytestring.+getHeaderBS :: HasHeaders r => ByteString -> r -> Maybe ByteString+getHeaderBS = getHeaderUnsafe . P.map toLower++-- | 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 = M.lookup key . headers++--------------------------------------------------------------+-- Querying header status+--------------------------------------------------------------++-- | Returns True if the associated key is found in the Headers. The lookup+-- is case insensitive.+hasHeader :: HasHeaders r => String -> r -> Bool+hasHeader key r = isJust (getHeader key r)++-- | Acts as 'hasHeader' with ByteStrings+hasHeaderBS :: HasHeaders r => ByteString -> r -> Bool+hasHeaderBS key r = isJust (getHeaderBS key r)++-- | Acts as 'hasHeaderBS' but the key is case sensitive. It should be+-- in lowercase.+hasHeaderUnsafe :: HasHeaders r => ByteString -> r -> Bool+hasHeaderUnsafe key r = isJust (getHeaderUnsafe' key r)++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+--------------------------------------------------------------++-- | Associates the key/value pair in the headers. Forces the key to be+-- lowercase.+setHeader :: HasHeaders r => String -> String -> r -> r+setHeader key val = setHeaderBS (pack key) (pack val)++-- | Acts as 'setHeader' but with ByteStrings.+setHeaderBS :: HasHeaders r => ByteString -> ByteString -> r -> r+setHeaderBS key val = setHeaderUnsafe (P.map toLower key) (HeaderPair key [val])++-- | Sets the key to the HeaderPair. This is the only way to associate a key+-- with multiple values via the setHeader* functions. Does not force the key+-- to be in lowercase or guarantee that the given key and the key in the HeaderPair will match. +setHeaderUnsafe :: HasHeaders r => ByteString -> HeaderPair -> r -> r+setHeaderUnsafe key val = updateHeaders (M.insert key val)++--------------------------------------------------------------+-- Adding headers+--------------------------------------------------------------++-- | Add a key/value pair to the header. If the key already has a value+-- associated with it, then the value will be appended. +-- Forces the key to be lowercase.+addHeader :: HasHeaders r => String -> String -> r -> r+addHeader key val = addHeaderBS (pack key) (pack val)++-- | Acts as addHeader except for ByteStrings+addHeaderBS :: HasHeaders r => ByteString -> ByteString -> r -> r+addHeaderBS key val = addHeaderUnsafe (P.map toLower key) (HeaderPair key [val])++-- | Add a key/value pair to the header using the underlying HeaderPair data+-- type. Does not force the key to be in lowercase or guarantee that the given key and the key in the HeaderPair will match. +addHeaderUnsafe :: HasHeaders r => ByteString -> HeaderPair -> r -> r+addHeaderUnsafe key val = updateHeaders (M.insertWith join key val)+ where join (HeaderPair k vs1) (HeaderPair _ vs2) = HeaderPair k (vs1++vs2)++-- | Creates a Response with the given Int as the status code and the provided+-- String as the body of the Response +result :: Int -> String -> Response+result code = resultBS code . L.pack++-- | Acts as 'result' but works with ByteStrings directly.+resultBS :: Int -> L.ByteString -> Response+resultBS code s = Response code M.empty nullRsFlags s Nothing++-- | Sets the Response's status code to the given Int and redirects to the given URI+redirect :: (ToSURI s) => Int -> s -> Response -> Response+redirect c s resp = setHeaderBS locationC (pack (render (toSURI s))) resp{rsCode = c}++-- constants here+locationC :: ByteString+locationC = P.pack "Location"+closeC :: ByteString+closeC = P.pack "close"+connectionC :: ByteString+connectionC = P.pack "Connection"+keepaliveC :: ByteString+keepaliveC = P.pack "Keep-Alive"+
+ src/Happstack/Server/HTTPClient/HTTP.hs view
@@ -0,0 +1,1019 @@+{-# LANGUAGE ScopedTypeVariables, PatternSignatures #-}+-----------------------------------------------------------------------------+-- |+-- Module : Happstack.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 Happstack.Server.HTTPClient.HTTP (+ module Happstack.Server.HTTPClient.Stream,+ module Happstack.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,++) where++++-----------------------------------------------------------------+------------------ Imports --------------------------------------+-----------------------------------------------------------------++import Control.Exception.Extensible as Exception++-- Networking+import Network.URI+import Happstack.Server.HTTPClient.Stream+import Happstack.Server.HTTPClient.TCP+++-- Util+import Data.Bits ((.&.))+import Data.Char+import Data.List (partition,elemIndex,intersperse)+import Data.Maybe+import Control.Monad (when,forM)+import Numeric (readHex)+import Text.ParserCombinators.ReadP+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 :: String+crlf = "\r\n"+sp :: String+sp = " "++-----------------------------------------------------------------+------------------ 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 : [ h | h@(Header n _) <- 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 = lookupHeader n . getHeaders++-- An anomally really:+lookupHeader :: HeaderName -> [Header] -> Maybe String+lookupHeader v (Header n s:t) | v == n = Just s+ | otherwise = lookupHeader v t+lookupHeader _ _ = Nothing++++-----------------------------------------------------------------+------------------ 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 :: [(String, RequestMethod)]+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+ ++ concatMap 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+ ++ concatMap 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 (uriRegName auth) (port auth)+ simpleHTTP_ c r+ where+ port auth = if null (uriPort auth)+ then 80+ else read $ uriPort auth+ ++-- | 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 :: URIAuth -> Request -> Request+ fixReq URIAuth{uriRegName=h} req = + insertHeaderIfMissing HdrConnection "close" $+ insertHeaderIfMissing HdrHost h $+ req { rqURI = (rqURI req){ uriScheme = "", + uriAuthority = Nothing } } ++-- | this is not the most graceful of implementations.+-- The problem is that Network.URI.authority is+-- deprecated. And we want to use Network.URI.URIAuth.+--+-- So this method use to parse a "host" field as a URI+-- auth, which is not stictly correct. We still +-- fake that behavior here.+getAuth :: Monad m => Request -> m URIAuth+getAuth r = case auth of+ Just x -> return x + Nothing -> fail $ "Error parsing URI authority '"+ ++ show (rqURI r) ++ "'"+ where+ auth = case findHeader HdrHost r of+ Just h -> Just $ fakeAuth h + Nothing -> uriAuthority (rqURI r)+ fakeAuth h = fst . head $ (flip readP_to_S) h $ do+ host<-many1 $ satisfy (\c -> c /= ':')+ port<-option "" $ char ':' >> many1 get+ return URIAuth{uriRegName=host, uriPort=port, uriUserInfo=""}+++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)+ (_,_) -> error "Case not supported in sendHTTP"++sendHTTPPipelined :: Stream s => s -> [Request] -> IO ([Response],Maybe ConnError)+sendHTTPPipelined conn rqs = + do { (ok,rsp) <- Exception.catch (main (map fixHostHeader rqs))+ (\(e::SomeException) -> do { close conn; throw e })+ ; let fn list = when (any 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 <- forM 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:_) = (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+ h = fmap uriRegName $ uriAuthority uri+ in case h of+ Just x -> insertHeaderIfMissing HdrHost x rq+ _ -> 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,c,info) ->+ let myftrs = Header HdrContentLength (show c) : 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 _+ = return $ Left $ ErrorParse "Unknown Transfer-Encoding"++-- | Remove leading crlfs then call readTillEmpty2 (not required by RFC)+readTillEmpty1 :: Stream s => s -> IO (Result [String])+readTillEmpty1 conn =+ do { line <- readLine conn+ ; case line of+ Left e -> return $ Left e+ Right s ->+ if s == crlf+ then readTillEmpty1 conn+ else readTillEmpty2 conn [s]+ }++-- | Read lines until an empty line (CRLF),+-- also accepts a connection close as end of+-- input, which is not an HTTP\/1.1 compliant+-- thing to do - so probably indicates an+-- error condition.+readTillEmpty2 :: Stream s => s -> [String] -> IO (Result [String])+readTillEmpty2 conn list =+ do { line <- readLine conn+ ; case line of+ Left e -> return $ Left e+ Right s ->+ if s == crlf || null s+ then return (Right $ reverse (s:list))+ else readTillEmpty2 conn (s:list)+ }++ +-----------------------------------------------------------------+------------------ A little friendly funtionality ---------------+-----------------------------------------------------------------+++{-+ I had a quick look around but couldn't find any RFC about+ the encoding of data on the query string. I did find an+ IETF memo, however, so this is how I justify the urlEncode+ and urlDecode methods.++ Doc name: draft-tiwari-appl-wxxx-forms-01.txt (look on www.ietf.org)++ Reserved chars: ";", "/", "?", ":", "@", "&", "=", "+", ",", and "$" are reserved.+ Unwise: "{" | "}" | "|" | "\" | "^" | "[" | "]" | "`"+ URI delims: "<" | ">" | "#" | "%" | <">+ Unallowed ASCII: <US-ASCII coded characters 00-1F and 7F hexadecimal>+ <US-ASCII coded character 20 hexadecimal>+ Also unallowed: any non-us-ascii character++ Escape method: char -> '%' a b where a, b :: Hex digits+-}++urlEncode, urlDecode :: String -> String++urlDecode ('%':a:b:rest) = chr (16 * digitToInt a + digitToInt b)+ : urlDecode rest+urlDecode (h:t) = h : urlDecode t+urlDecode [] = []++urlEncode (h:t) =+ let str = if reserved_ (ord h) then escape h else [h]+ in str ++ urlEncode t+ where+ reserved_ x+ | x >= ord 'a' && x <= ord 'z' = False+ | x >= ord 'A' && x <= ord 'Z' = False+ | x >= ord '0' && x <= ord '9' = False+ | x <= 0x20 || x >= 0x7F = True+ | otherwise = x `elem` map ord [';','/','?',':','@','&'+ ,'=','+',',','$','{','}'+ ,'|','\\','^','[',']','`'+ ,'<','>','#','%','"']+ -- wouldn't it be nice if the compiler+ -- optimised the above for us?++ escape x = + let y = ord x + in [ '%', intToDigit ((y `div` 16) .&. 0xf), intToDigit (y .&. 0xf) ]++urlEncode [] = []+ +++-- Encode form variables, useable in either the+-- query part of a URI, or the body of a POST request.+-- I have no source for this information except experience,+-- this sort of encoding worked fine in CGI programming.+urlEncodeVars :: [(String,String)] -> String+urlEncodeVars ((n,v):t) =+ let (same,diff) = partition ((==n) . fst) t+ in urlEncode n ++ '=' : foldl (\x y -> x ++ ',' : urlEncode y) (urlEncode $ v) (map snd same)+ ++ urlEncodeRest diff+ where urlEncodeRest [] = []+ urlEncodeRest diff = '&' : urlEncodeVars diff+urlEncodeVars [] = []
+ src/Happstack/Server/HTTPClient/Stream.hs view
@@ -0,0 +1,173 @@+-----------------------------------------------------------------------------+-- |+-- Module : Happstack.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 Happstack.Server.HTTPClient.Stream (+ -- ** Streams+ Debug,+ Stream(..),+ debugStream,+ + -- ** Errors+ ConnError(..),+ Result,+ handleSocketError,+ bindE,+ myrecv++) where++import Control.Exception.Extensible 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.SomeException -> IO (Result a)+handleSocketError sk e =+ do { se <- getSocketOption sk SoError+ ; if se == 0+ then throw e+ else return $ if se == 10054 -- reset+ then Left ErrorReset+ else Left $ ErrorMisc $ show se+ }+++++instance Stream Socket where+ readBlock sk n = (liftM Right $ fn n) `Exception.catch` (handleSocketError sk)+ where+ fn x = do { str <- myrecv sk x+ ; let len = length str+ ; if len < x && len /= 0+ then ( fn (x-len) >>= \more -> return (str++more) ) + else return str+ }++ -- Use of the following function is discouraged.+ -- The function reads in one character at a time, + -- which causes many calls to the kernel recv()+ -- hence causes many context switches.+ readLine sk = (liftM Right $ fn "") `Exception.catch` (handleSocketError sk)+ where+ fn str =+ do { c <- myrecv sk 1 -- like eating through a straw.+ ; if null c || c == "\n"+ then return (reverse str++c)+ else fn (head c:str)+ }+ + writeBlock sk str = (liftM Right $ fn str) `Exception.catch` (handleSocketError sk)+ where+ fn [] = return ()+ fn x = send sk x >>= \i -> fn (drop i x)++ -- This slams closed the connection (which is considered rude for TCP\/IP)+ close sk = shutdown sk ShutdownBoth >> sClose sk++myrecv :: Socket -> Int -> IO String+myrecv sock len =+ let handler e = if isEOFError e then return [] else ioError e+ in System.IO.Error.catch (recv sock len) handler++-- | Allows stream logging.+-- Refer to 'debugStream' below.+data Debug x = Dbg Handle x+++instance (Stream x) => Stream (Debug x) where+ readBlock (Dbg h c) n =+ do { val <- readBlock c n+ ; hPutStrLn h ("readBlock " ++ show n ++ ' ' : show val)+ ; hFlush h+ ; return val+ }++ readLine (Dbg h c) =+ do { val <- readLine c+ ; hPutStrLn h ("readLine " ++ show val)+ ; return val+ }++ writeBlock (Dbg h c) str =+ do { val <- writeBlock c str+ ; hPutStrLn h ("writeBlock " ++ show val ++ ' ' : show str)+ ; return val+ }++ close (Dbg h c) =+ do { hPutStrLn h "closing..."+ ; hFlush h+ ; close c+ ; hPutStrLn h "...closed"+ ; hClose h+ }+++-- | Wraps a stream with logging I\/O, the first+-- argument is a filename which is opened in AppendMode.+debugStream :: (Stream a) => String -> a -> IO (Debug a)+debugStream file stm = + do { h <- openFile file AppendMode+ ; hPutStrLn h "File opened for appending."+ ; return (Dbg h stm)+ }
+ src/Happstack/Server/HTTPClient/TCP.hs view
@@ -0,0 +1,193 @@+{-# LANGUAGE ScopedTypeVariables, PatternSignatures #-}+-----------------------------------------------------------------------------+-- |+-- Module : Happstack.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 Happstack.Server.HTTPClient.TCP (+ -- ** Connections+ Conn(..),+ Connection(..),+ openTCP,+ openTCPPort,+ isConnectedTo+) where++import Control.Exception.Extensible as Exception++-- Networking+import Network.BSD+import Network.Socket+import Happstack.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+ (\(_::SomeException) -> getHostByName uri >>= \host -> -- _shrug_ this will catch _any_ exception FIXME+ 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::SomeException) -> 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` (\(_::SomeException) -> return ()) -- FIXME see above+ ; 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+ }+ closeConn (MkConn _ _ _ _) = error "Case in closeConn not supported"++ suck :: Connection -> IO ()+ suck cn = readLine cn >>= + either (\_ -> return ()) -- catch errors & ignore+ (\x -> if null x then return () else suck cn)++-- | Checks both that the underlying Socket is connected+-- and that the connection peer matches the given+-- host name (which is recorded locally).+isConnectedTo :: Connection -> String -> IO Bool+isConnectedTo conn name =+ do { v <- readIORef (getRef conn)+ ; case v of+ ConnClosed -> return False+ (MkConn sk _ _ h) ->+ if (map toLower h == map toLower name)+ then sIsConnected sk+ else return False+ }+
+ src/Happstack/Server/JSON.hs view
@@ -0,0 +1,29 @@+module Happstack.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 :: Integral a => a -> JSON+jInt = JInt . fromIntegral++class ToJSON a where+ toJSON::a->JSON+instance ToJSON JSON where toJSON=id++jsonToString :: JSON -> String+jsonToString (JBool bool) = map toLower $ show bool+jsonToString (JString string) = show string+jsonToString (JInt int) = show int+jsonToString (JFloat float) = show float+jsonToString (JObj pairs) = '{' : (concat $ (intersperse "," $ map impl pairs) )++"}"+ where+ impl (name,val) = concat [show name,":",jsonToString val]+jsonToString (JList list) = + '[':(concat $ (intersperse "," $ map jsonToString list)) ++"]"+jsonToString JNull = "null"+type CallBack=String++data JSONCall x = JCall CallBack x
+ src/Happstack/Server/MessageWrap.hs view
@@ -0,0 +1,99 @@+{-# LANGUAGE FlexibleInstances #-}++module Happstack.Server.MessageWrap 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 Data.Maybe+import Happstack.Server.HTTP.Types as H+import Happstack.Server.HTTP.Multipart+import Happstack.Server.SURI as SURI+import Happstack.Util.Common++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 components from a String.+pathEls :: String -> [String]+pathEls = (drop 1) . map SURI.unEscape . splitList '/' ++-- | 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
+ src/Happstack/Server/MinHaXML.hs view
@@ -0,0 +1,215 @@+{-# LANGUAGE TemplateHaskell, FlexibleInstances,+ OverlappingInstances, UndecidableInstances, TypeSynonymInstances #-}+++ +module Happstack.Server.MinHaXML where+-- Copyright (c) Happstack.com 2009; (c) HAppS.org 2005. All Rights Reserved.++import Prelude hiding (elem, pi)++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 Happstack.Util.Common+import Data.Maybe+import System.Time++import Happstack.Data.Xml as Xml+import Happstack.Data.Xml.HaXml++type StyleURL=String+data StyleSheet = NoStyle+ | CSS {styleURL::StyleURL} + | XSL {styleURL::StyleURL} deriving (Read,Show)+hasStyleURL :: StyleSheet -> Bool+hasStyleURL NoStyle = False+hasStyleURL _ = True +type Element = Types.Element++ ++isCSS :: StyleSheet -> Bool+isCSS (CSS _)=True+isCSS _ = False+isXSL :: StyleSheet -> Bool+isXSL = not.isCSS++t :: Name -> [(Name, String)] -> CharData -> Types.Element+t=textElem+l :: Name -> [(Name, String)] -> [Types.Element] -> Types.Element+l=listElem+e :: Name -> [(Name, String)] -> Types.Element+e=emptyElem+(</<) :: Name+ -> [(Name, String)]+ -> [Types.Element]+ -> Types.Element+(</<)=l+(<>) :: Name -> [(Name, String)] -> CharData -> Types.Element+(<>)=t++++xmlElem :: (t -> [Content])+ -> Name+ -> [(Name, String)]+ -> t+ -> Types.Element+xmlElem f = \name attrs val -> xmlelem name attrs (f val)+ where + xmlelem name = Types.Elem name . map (uncurry attr)+ attr name val= (name,AttValue [Left val])++textElem :: Name -> [(Name, String)] -> CharData -> Types.Element+textElem = xmlElem (return.CString True)+emptyElem :: Name -> [(Name, String)] -> Types.Element+emptyElem = \n a->xmlElem id n a []+listElem :: Name+ -> [(Name, String)]+ -> [Types.Element]+ -> Types.Element+listElem = xmlElem $ map CElem++cdataElem :: CharData -> Content+cdataElem = CString False++-- Document (simpleProlog xsl) [] $ xmlEscape stdXmlEscaper root+simpleDocOld :: StyleSheet -> Types.Element -> String+simpleDocOld xsl = show . document . + flip (Document (simpleProlog xsl) []) [] . xmlStdEscape++simpleDoc :: StyleSheet -> Types.Element -> String+simpleDoc style elem = ("<?xml version='1.0' encoding='UTF-8' ?>\n"+++ if hasStyleURL style then pi else "") +++ (verbatim $ xmlStdEscape elem)+ where typeText=if isCSS style then "text/css" else "text/xsl"+ pi= "<?xml-stylesheet type=\""++ typeText ++ + "\" href=\""++styleURL style++"\" ?>\n"+++simpleDoc' :: StyleSheet -> Types.Element -> String+simpleDoc' style elem = (if hasStyleURL style then pi else "") +++ (verbatim $ xmlStdEscape elem)+ where typeText=if isCSS style then "text/css" else "text/xsl"+ pi= "<?xml-stylesheet type=\""++ typeText ++ + "\" href=\""++styleURL style++"\" ?>\n"++++xmlEscaper :: XmlEscaper+xmlEscaper=stdXmlEscaper+xmlStdEscape :: Types.Element -> Types.Element+xmlStdEscape = xmlEscape stdXmlEscaper+verbim :: (Verbatim a) => a -> String+verbim = verbatim++simpleProlog :: StyleSheet -> Prolog+simpleProlog style = + Prolog + (Just (XMLDecl "1.0" + (Just $ EncodingDecl "UTF-8") + Nothing -- standalone declaration+ ))+ [] Nothing+ (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 -> String -> Maybe Types.Element+nonEmpty name val = if val=="" then Nothing+ else Just $ textElem name [] val++getRoot :: Document -> Types.Element+getRoot (Document _ _ root _) = root++--toXML .< "App" attrs ./>+--toXML .< "App" attrs .> []+data XML a = XML StyleSheet a++class ToElement x where toElement::x->Types.Element+ +instance (ToElement x) => ToElement (Maybe x) where + toElement = maybe (emptyElem "Nothing" []) toElement++instance ToElement String where toElement = textElem "String" []+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 = epochPico++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+ un _ = error "Case not handled in Xml toElement instance"++wrapElem :: (ToElement x) => Name -> x -> Types.Element+wrapElem tag x= listElem tag [] [toElement x]+elF :: (ToElement b) => Name -> (a -> b) -> a -> Types.Element+elF tag f = wrapElem tag.f +-- label !<=! field = wrapField label field+attrF :: t1 -> (t -> String) -> t -> (t1, String)+attrF name f rec = (name,quoteEsc $ f rec)+attrFS :: (Show a) => t1 -> (t -> a) -> t -> (t1, String)+attrFS name f rec = (name,quoteEsc $ show $ f rec)+attrFMb :: (a -> String)+ -> String+ -> (a1 -> Maybe a)+ -> a1+ -> (String, String)+attrFMb r name f = maybe ("","") (\x->(name,quoteEsc $ r x)) . f ++--(\x->(name,quoteEsc $ r x)) . f +--(name,quoteEsc $ show $ f rec)++quoteEsc :: String -> String+quoteEsc [] = []+quoteEsc ('"':list) = """ ++ quoteEsc list+quoteEsc (x:xs) = x:quoteEsc xs++--quotescape \\ and " \"++recToEl :: Name+ -> [a -> (String, String)]+ -> [a -> Types.Element]+ -> a+ -> Types.Element+recToEl name attrs els rec = listElem name attrs' (revmap rec els)+ where+ attrs' = filter (\ (x,_)->not $ null x) (revmap rec attrs)+listToEl :: (ToElement a) =>+ Name -> [(Name, String)] -> [a] -> Types.Element+listToEl name attrs = listElem name attrs . map toElement ++toAttrs :: t -> [(t1, t -> t2)] -> [(t1, t2)]+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)
+ src/Happstack/Server/Parts.hs view
@@ -0,0 +1,153 @@+{-# LANGUAGE NoMonomorphismRestriction, FlexibleContexts #-}+module Happstack.Server.Parts(+ compressedResponseFilter+ ,gzipFilter+ ,deflateFilter+ ,encodings+) where+import Happstack.Server.SimpleHTTP+import Text.ParserCombinators.Parsec+import Control.Monad+import Data.Maybe+import Data.List+import qualified Data.ByteString.Char8 as BS+import qualified Codec.Compression.GZip as GZ+import qualified Codec.Compression.Zlib as Z++-- | reads the \"Accept-Encoding\" header. Then, if possible+-- will compress the response body with methods "gzip" or "deflate"+--+-- Returns the name of the coding chosen+compressedResponseFilter::+ (FilterMonad Response m, MonadPlus m, WebMonad Response m, ServerMonad m)+ => m String+compressedResponseFilter = do+ mbAccept<-getHeaderM "Accept-Encoding"+ accept<- maybe mzero return mbAccept+ let eEncoding = bestEncoding $ BS.unpack accept+ (coding,action) <- case eEncoding of+ Left _ -> do+ setResponseCode 406+ finishWith $ toResponse ""+ Right a -> return (a, maybe (fail "Encoding returned not in the list of known encodings")+ id (lookup a allEncodingHandlers))+ setHeaderM "Content-Encoding" coding+ action+ return coding++-- | compresses the body of the response with gzip.+-- does not set any headers.+gzipFilter::(FilterMonad Response m) => m()+gzipFilter = do+ composeFilter (\r -> r{rsBody = GZ.compress $ rsBody r})++-- | compresses the body of the response with zlib's+-- deflate method+-- does not set any headers.+deflateFilter::(FilterMonad Response m) => m()+deflateFilter = do+ composeFilter (\r -> r{rsBody = Z.compress $ rsBody r})++-- | based on the rules describe in rfc2616 sec. 14.3+bestEncoding :: String -> Either String String+bestEncoding encs = do+ encList<-either (Left . show) (Right) $ parse encodings "" encs+ case acceptable encList of+ [] -> Left "no encoding found"+ a -> Right $ head a+ where+ -- first intersect with the list of encodings we know how to deal with at all+ knownEncodings:: [(String,Maybe Double)] -> [(String, Maybe Double)]+ knownEncodings m = intersectBy (\x y->fst x == fst y) m (map (\x -> (x,Nothing)) allEncodings)+ -- this expands the wildcard, by figuring out if we need to include "identity" in the list+ -- Then it deletes the wildcard entry, drops all the "q=0" entries (which aren't allowed).+ --+ -- note this implementation is a little conservative. if someone were to specify "*"+ -- without a "q" value, it would be this server is willing to accept any format at all.+ -- We pretty much assume we can't send them /any/ format and that they really+ -- meant just "identity" this seems safe to me.+ knownEncodings':: [(String,Maybe Double)] -> [(String, Maybe Double)]+ knownEncodings' m = filter dropZero $ deleteBy (\(a,_) (b,_)->a==b) ("*",Nothing) $+ case lookup "*" (knownEncodings m) of+ Nothing -> addIdent $ knownEncodings m+ Just (Just a) | a>0 -> addIdent $ knownEncodings m+ | otherwise -> knownEncodings m+ Just (Nothing) -> addIdent $ knownEncodings m+ dropZero (_, Just a) | a==0 = False+ | otherwise = True+ dropZero (_, Nothing) = True+ addIdent:: [(String,Maybe Double)] -> [(String, Maybe Double)]+ addIdent m = if isNothing $ lookup "identity" m+ then m ++ [("identity",Nothing)]+ else m+ -- finally we sort the list of available encodings.+ acceptable:: [(String,Maybe Double)] -> [String]+ acceptable l = map fst $ sortBy (flip cmp) $ knownEncodings' l+ -- let the client choose but break ties with gzip+ encOrder = reverse $ zip (reverse allEncodings) [1..]+ m0 = maybe (0.0::Double) id+ cmp (s,mI) (t,mJ) | m0 mI == m0 mJ+ = compare (m0 $ lookup s encOrder) (m0 $ lookup t encOrder)+ | otherwise = compare (m0 mI) (m0 mJ)+++allEncodingHandlers:: (FilterMonad Response m) => [(String, m ())]+allEncodingHandlers = zip allEncodings handlers++allEncodings :: [String]+allEncodings =+ ["gzip"+ ,"x-gzip"+-- ,"compress" -- as far as I can tell there is no haskell library that supports this+-- ,"x-compress" -- as far as I can tell, there is no haskell library that supports this+ ,"deflate"+ ,"identity"+ ,"*"+ ]++handlers::(FilterMonad Response m) => [m ()]+handlers =+ [gzipFilter+ ,gzipFilter+-- ,compressFilter+-- ,compressFilter+ ,deflateFilter+ ,return ()+ ,fail $ "chose * as content encoding"+ ]++-- | unsupported: a parser for the Accept-Encoding header+encodings :: GenParser Char st [([Char], Maybe Double)]+encodings = ws >> (encoding1 `sepBy` try sep) >>= (\x -> ws >> eof >> return x)+ where+ ws = many space+ sep = do+ ws+ char ','+ ws+ encoding1 :: GenParser Char st ([Char], Maybe Double)+ encoding1 = do+ encoding <- many1 letter <|> string "*"+ ws+ quality<-optionMaybe qual+ return (encoding, fmap read quality)+ qual = do+ char ';' >> ws >> char 'q' >> ws >> char '=' >> ws+ q<-float+ return $ q+ int = many1 digit+ float = do+ wholePart<-many1 digit+ fractionalPart<-option "" fraction+ return $ wholePart ++ fractionalPart+ <|>+ do+ fractionalPart<-fraction+ return $ fractionalPart+ fraction :: GenParser Char st String+ fraction = do+ char '.'+ fractionalPart<-option "" int+ return $ '.':fractionalPart++
+ src/Happstack/Server/S3.hs view
@@ -0,0 +1,240 @@+{-# LANGUAGE PatternGuards #-}+module Happstack.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 Happstack.Crypto.HMAC ( hmacSHA1 )+import Happstack.Server.HTTPClient.HTTP+import qualified Happstack.Server.HTTPClient.Stream as Stream++import Network.URI hiding (path)+import Control.Concurrent ( newMVar, modifyMVar, swapMVar+ , 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 (uriAuthority (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 (uriRegName 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 (uriRegName auth, uriPort auth)+ c <- openTCPPort (uriRegName auth) (if null $ uriPort auth then 80 else read$ uriPort auth)+ return (Just c,c)+ where auth = fromJust (uriAuthority (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."+-}++--------------------------------------------------------------+-- 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 . auxFilter . getContent . xmlParse bucket $ lst+ where auxFilter = xtract "*/Key/-"+ getContent (Document _ _ e _) = CElem e++ ppContent xs = [ s | CString _ s <- xs ]++++amazonURI :: URI+amazonURI = fromJust $ parseURI "http://s3.amazonaws.com/"+localhost :: URI+localhost = fromJust $ parseURI "http://localhost/"+
+ src/Happstack/Server/SURI.hs view
@@ -0,0 +1,72 @@+{-# LANGUAGE TypeSynonymInstances, DeriveDataTypeable #-}++module Happstack.Server.SURI where+import Data.Maybe+import Data.Generics+import Happstack.Util.Common(mapFst)+import qualified Network.URI as URI++-- | Retrieves the path component from the URI+path :: SURI -> String+path = URI.uriPath . suri++-- | Retrieves the query component from the URI+query :: SURI -> String+query = URI.uriQuery . suri++-- | Retrieves the scheme component from the URI+scheme :: SURI -> String+scheme = URI.uriScheme . suri++-- | Modifies the scheme component of the URI using the provided function+u_scheme :: (String -> String) -> SURI -> SURI+u_scheme f (SURI u) = SURI (u {URI.uriScheme=f $ URI.uriScheme u})++-- | Modifies the path component of the URI using the provided function+u_path :: (String -> String) -> SURI -> SURI+u_path f (SURI u) = SURI $ u {URI.uriPath=f $ URI.uriPath u}++-- | Sets the scheme component of the URI+a_scheme :: String -> SURI -> SURI+a_scheme a (SURI u) = SURI $ u {URI.uriScheme=a}++-- | Sets the path component of the URI+a_path :: String -> SURI -> SURI+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++-- | Render should be used for prettyprinting URIs.+render :: (ToSURI a) => a -> String+render = show . suri . toSURI++-- | Parses a URI from a String. Returns Nothing on failure.+parse :: String -> Maybe SURI+parse = fmap SURI . URI.parseURIReference ++-- | Convenience class for converting data types to URIs+class ToSURI x where toSURI::x->SURI++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+++--handling obtaining things from URI paths+class FromPath x where fromPath::String->x
+ src/Happstack/Server/SURI/ParseURI.hs view
@@ -0,0 +1,81 @@+module Happstack.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 Happstack.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 :: ByteString+ -> (Maybe URIAuth -> String -> String -> String -> b)+ -> b+pabsuri fs cont =+ if length fs >= 2 && unsafeHead fs == '/' && unsafeIndex fs 1 == '/'+ then pauthority (drop 2 fs) cont+ else puriref fs $ cont Nothing+pauthority :: ByteString+ -> (Maybe URIAuth -> String -> String -> String -> b)+ -> b+pauthority fs cont =+ let (auth,rest) = breakChar '/' fs+ in puriref rest $! cont (Just $! pauthinner auth)+pauthinner :: ByteString -> URIAuth+pauthinner fs =+ case breakChar '@' fs of+ (a,b) -> pauthport b $ URIAuth (unpack a)+pauthport :: ByteString -> (String -> String -> t) -> t+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 :: ByteString -> (String -> String -> String -> b) -> 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) ""+ _ -> error "unexpected match"+pquery :: ByteString -> (String -> String -> t) -> t+pquery fs cont =+ case breakChar '#' fs of+ (a,b) -> cont ('?':unpack a) (unpack b)+pfragment :: ByteString -> (String -> b) -> b+pfragment fs cont =+ cont $ unpack fs++++unsafeTail :: ByteString -> ByteString+unsafeTail = BB.unsafeTail+unsafeHead :: ByteString -> Char+unsafeHead = BB.w2c . BB.unsafeHead+unsafeIndex :: ByteString -> Int -> Char+unsafeIndex s = BB.w2c . BB.unsafeIndex s+
+ src/Happstack/Server/SimpleHTTP.hs view
@@ -0,0 +1,1355 @@+{-# LANGUAGE UndecidableInstances, OverlappingInstances, ScopedTypeVariables, FlexibleInstances, TypeSynonymInstances,+ MultiParamTypeClasses, PatternGuards, FlexibleContexts, FunctionalDependencies, GeneralizedNewtypeDeriving, PatternSignatures+ #-}+{-# OPTIONS -fno-warn-orphans #-}+-----------------------------------------------------------------------------+-- |+-- Module : Happstack.Server.SimpleHTTP+-- Copyright : (c) Happstack.com 2009; (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.+-- +-- So the general nature of 'simpleHTTP' is no different than what you'd expect+-- from a web application container. First you figure out when function is+-- going to process your request, process the request to generate a response,+-- then return that response to the client. The web application container is+-- started with 'simpleHTTP', which takes a configuration and a+-- response-building structure ('ServerPartT' which I'll return too in a+-- moment), and picks the first handler that is willing to accept the request,+-- passes the request into the handler. A simple "hello world" style HAppS+-- simpleHTTP server looks like:+--+-- @+-- main = simpleHTTP nullConf $ return \"Hello World!\"+-- @+--+-- @simpleHTTP nullConf@ creates a HTTP server on port 8000.+-- return \"Hello World!\" creates a serverPartT that just returns that text.+--+-- 'ServerPartT' is the basic response builder. As you might expect, it's a+-- container for a function that takes a Request and converts it a response+-- suitable for sending back to the server. Most of the time though you don't+-- even need to worry about that as ServerPartT hides almost all the machinery+-- for building your response by exposing a few type classes.+-- +-- 'ServerPartT' is a pretty rich monad. You can interact with your request,+-- your response, do IO, etc. Here is a do block that validates basic+-- authentication It takes a realm name as a string, a Map of username to+-- password and a server part to run if authentication fails.+-- +-- @basicAuth'@ acts like a guard, and only produces a response when+-- authentication fails. So put it before any ServerPartT you want to demand+-- authentication for in any collection of ServerPartTs.+--+-- @+--+-- main = simpleHTTP nullConf $ myAuth, return \"Hello World!\"+-- where+-- myAuth = basicAuth\' \"Test\"+-- (M.fromList [(\"hello\", \"world\")]) (return \"Login Failed\")+--+-- basicAuth\' realmName authMap unauthorizedPart =+-- do+-- let validLogin name pass = M.lookup name authMap == Just pass+-- let parseHeader = break (\':\'==) . Base64.decode . B.unpack . B.drop 6+-- authHeader <- getHeaderM \"authorization\"+-- case authHeader of+-- Nothing -> err+-- Just x -> case parseHeader x of +-- (name, \':\':pass) | validLogin name pass -> mzero+-- | otherwise -> err+-- _ -> err+-- where+-- err = do+-- unauthorized ()+-- setHeaderM headerName headerValue+-- unauthorizedPart+-- headerValue = \"Basic realm=\\\"\" ++ realmName ++ \"\\\"\"+-- headerName = \"WWW-Authenticate\"+-- @+--+-- Here is another example that uses liftIO to embed IO in a request process+--+-- @+-- main = simpleHTTP nullConf $ myPart+-- myPart = do+-- line <- liftIO $ do -- IO+-- putStr \"return? \"+-- getLine+-- when (take 2 line \/= \"ok\") $ (notfound () >> return \"refused\")+-- return \"Hello World!\"+-- @+-- +-- This example will ask in the console \"return? \" if you type \"ok\" it will+-- show \"Hello World!\" and if you type anything else it will return a 404.+--+-----------------------------------------------------------------------------+module Happstack.Server.SimpleHTTP+ ( module Happstack.Server.HTTP.Types+ , module Happstack.Server.Cookie+ -- * SimpleHTTP+ , simpleHTTP+ , simpleHTTP'+ , parseConfig+ -- * ServerPartT+ , ServerPartT(..)+ , ServerPart+ , runServerPartT+ , mapServerPartT+ , mapServerPartT'+ , withRequest+ , anyRequest+ -- * WebT+ , WebT(..)+ , FilterFun+ , Web+ , mkWebT+ , ununWebT+ , runWebT+ , mapWebT+ -- * Type Classes+ , FromReqURI(..)+ , ToMessage(..)++ -- * Manipulating requests+ , FromData(..)+ , ServerMonad(..)+ , RqData+ , noHandle+ , getHeaderM+ , escape+ , escape'+ , multi+ -- * Manipulating responses+ , FilterMonad(..)+ , ignoreFilters+ , SetAppend(..)+ , FilterT(..)+ , WebMonad(..)+ , ok+ , modifyResponse+ , setResponseCode+ , badGateway+ , internalServerError+ , badRequest+ , unauthorized + , forbidden+ , notFound+ , seeOther+ , found+ , movedPermanently+ , tempRedirect+ , addCookie+ , addCookies+ , addHeaderM+ , setHeaderM++ -- * guards and building blocks+ , guardRq+ , dir+ , method+ , methodSP+ , methodM+ , methodOnly+ , nullDir+ , path+ , anyPath+ , anyPath'+ , withData+ , withDataFn+ , getDataFn+ , getData+ , require+ , requireM+ , basicAuth+ , uriRest+ , flatten+ , localContext+ -- * proxying+ , proxyServe+ , rproxyServe+ -- * unknown+ , debugFilter+ , applyRequest+ -- * 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+ -- * Error Handlng+ , errorHandlerSP+ , simpleErrorHandler+ , spUnwrapErrorT+ -- * Output Validation+ , setValidator+ , setValidatorSP+ , validateConf+ , runValidator+ , wdgHTMLValidator+ , noopValidator+ , lazyProcValidator+ ) where+import qualified Paths_happstack_server as Cabal+import qualified Data.Version as DV+import Happstack.Server.HTTP.Client+import Happstack.Data.Xml.HaXml+import qualified Happstack.Server.MinHaXML as H++import Happstack.Server.HTTP.Types hiding (Version(..))+import qualified Happstack.Server.HTTP.Types as Types+import Happstack.Server.HTTP.Listen as Listen+import Happstack.Server.XSLT+import Happstack.Server.SURI (ToSURI)+import Happstack.Util.Common+import Happstack.Server.Cookie+import Happstack.Data -- used by default implementation of fromData+import Control.Applicative+import Control.Concurrent (forkIO)+import Control.Exception (evaluate)+import Control.Monad.Reader+import Control.Monad.State+import Control.Monad.Error+import Control.Monad.Trans()+import Control.Monad.Maybe+import Control.Monad.Writer as Writer+import Data.Maybe+import Data.Monoid+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 Happstack.Crypto.Base64 as Base64+import Data.Char+import Data.List+import System.IO+import System.Console.GetOpt+import System.Process (runInteractiveProcess, waitForProcess)+import System.Exit+import Text.Show.Functions ()++-- | An alias for WebT when using IO+type Web a = WebT IO a+-- | An alias for using ServerPartT when using the IO+type ServerPart a = ServerPartT IO a++--------------------------------------+-- HERE BEGINS ServerPartT definitions++-- | ServerPartT is a container for processing requests and returning results+newtype ServerPartT m a = ServerPartT { unServerPartT :: ReaderT Request (WebT m) a }+ deriving (Monad, MonadIO, MonadPlus, Functor)++-- | particularly useful when combined with runWebT to produce+-- a @m (Maybe Response)@ from a request.+runServerPartT :: ServerPartT m a -> Request -> WebT m a+runServerPartT = runReaderT . unServerPartT++withRequest :: (Request -> WebT m a) -> ServerPartT m a+withRequest = ServerPartT . ReaderT++-- | Used to manipulate the containing monad. Very useful when embedding a+-- monad into a ServerPartT, since simpleHTTP requires a @ServerPartT IO a@.+-- Refer to 'WebT' for an explanation of the structure of the monad.+--+-- Here is an example. Suppose you want to embed an ErrorT into your+-- ServerPartT to enable throwError and catchError in your Monad.+--+-- @+-- type MyServerPartT e m a = ServerPartT (ErrorT e m) a+-- @+--+-- Now suppose you want to pass MyServerPartT into a function+-- that demands a @ServerPartT IO a@ (e.g. simpleHTTP). You+-- can provide the function:+--+-- @+-- unpackErrorT:: (Monad m, Show e) =>+-- -> (ErrorT e m) (Maybe ((Either Response a), FilterFun Response))+-- -> m (Maybe ((Either Response a), FilterFun Response))+-- unpackErrorT handler et = do+-- eitherV <- runErrorT et+-- case eitherV of+-- Left err -> return $ Just (Left "Catastrophic failure " ++ show e, Set $ Endo \r -> r{rsCode = 500})+-- Right x -> return x+-- @+-- +-- With @unpackErrorT@ you can now call simpleHTTP. Just wrap your @ServerPartT@ list.+--+-- @+-- simpleHTTP nullConf $ mapServerPartT unpackErrorT (myPart \`catchError\` myHandler)+-- @+-- +-- Or alternatively:+--+-- @+-- simpleHTTP' unpackErrorT nullConf (myPart \`catchError\` myHandler)+-- @+-- +-- Also see 'spUnwrapErrorT' for a more sophisticated version of this function+--+mapServerPartT :: (m (Maybe (Either Response a, FilterFun Response)) -> n (Maybe (Either Response b, FilterFun Response))) -> ServerPartT m a -> ServerPartT n b+mapServerPartT f ma = withRequest $ \rq -> mapWebT f (runServerPartT ma rq)++-- | A varient of mapServerPartT where the first argument, also takes a request.+-- useful if you want to runServerPartT on a different ServerPartT inside your+-- monad (see spUnwrapErrorT)+mapServerPartT' :: (Request -> m (Maybe (Either Response a, FilterFun Response)) -> n (Maybe (Either Response b, FilterFun Response))) -> ServerPartT m a -> ServerPartT n b+mapServerPartT' f ma = withRequest $ \rq -> mapWebT (f rq) (runServerPartT ma rq)+instance MonadTrans (ServerPartT) where+ lift m = withRequest (\_ -> lift m)++instance (Monad m) => Monoid (ServerPartT m a)+ where mempty = mzero+ mappend = mplus++instance (Monad m, Functor m) => Applicative (ServerPartT m) where+ pure = return+ (<*>) = ap++instance (Monad m, MonadWriter w m) => MonadWriter w (ServerPartT m) where+ tell = lift . tell+ listen m = withRequest $ \rq -> Writer.listen (runServerPartT m rq) >>= return+ pass m = withRequest $ \rq -> pass (runServerPartT m rq) >>= return++instance (Monad m, MonadError e m) => MonadError e (ServerPartT m) where+ throwError e = lift $ throwError e+ catchError action handler = withRequest $ \rq -> (runServerPartT action rq) `catchError` ((flip runServerPartT $ rq) . handler)++instance (Monad m, MonadReader r m) => MonadReader r (ServerPartT m) where+ ask = lift ask+ local fn m = withRequest $ \rq-> local fn (runServerPartT m rq)++instance Monad m => FilterMonad Response (ServerPartT m) where+ setFilter = anyRequest . setFilter+ composeFilter = anyRequest . composeFilter+ getFilter m = withRequest $ \rq -> getFilter (runServerPartT m rq)++instance Monad m => WebMonad Response (ServerPartT m) where+ finishWith r = anyRequest $ finishWith r++-- | yes, this is exactly like 'ReaderT' with new names.+-- Why you ask? Because ServerT can lift up a ReaderT.+-- If you did that, it would shadow ServerT's behavior+-- as a ReaderT, thus meaning if you lifted the ReaderT+-- you could no longer modify the Request. This way+-- you can add a ReaderT to your monad stack without+-- any trouble.+class Monad m => ServerMonad m where+ askRq :: m Request+ localRq :: (Request->Request)->m a->m a++instance (Monad m) => ServerMonad (ServerPartT m) where+ askRq = ServerPartT $ ask+ localRq f m = ServerPartT $ local f (unServerPartT m)+-------------------------------+-- HERE BEGINS WebT definitions++-- | A monoid operation container.+-- If a is a monoid, then SetAppend is a monoid with the following behaviors:+-- +-- @+-- Set x `mappend` Append y = Set (x `mappend` y)+-- Append x `mappend` Append y = Append (x `mappend` y)+-- \_ `mappend` Set y = Set y+-- @+--+-- A simple way of sumerizing this is, if the left side is Append, then the+-- right is appended to the left. If the left side is Set, then the right side+-- is ignored.+data SetAppend a = Set a | Append a+ deriving (Eq, Show)+instance Monoid a => Monoid (SetAppend a) where+ mempty = Append mempty+ Set x `mappend` Append y = Set (x `mappend` y)+ Append x `mappend` Append y = Append (x `mappend` y)+ _ `mappend` Set y = Set y++value :: SetAppend t -> t+value (Set x) = x+value (Append x) = x++instance Functor (SetAppend) where+ fmap f (Set x) = Set $ f x+ fmap f (Append x) = Append $ f x++-- | @FilterFun@ is a lot more fun to type than @SetAppend (Dual (Endo a))@+type FilterFun a = SetAppend (Dual (Endo a))++newtype FilterT a m b =+ FilterT { unFilterT :: WriterT (FilterFun a) m b }+ deriving (Monad, MonadTrans, Functor, MonadIO)++-- | A set of functions for manipulating filters. A ServerPartT implements+-- FilterMonad Response so these methods are the fundamental ways of+-- manipulating the response object, especially before you've converted your+-- monadic value to a 'Response'+class Monad m => FilterMonad a m | m->a where+ -- | Ignores all previous+ -- alterations to your filter+ --+ -- As an example:+ --+ -- @+ -- do+ -- composeFilter f+ -- setFilter g+ -- return \"Hello World\"+ -- @+ --+ -- setFilter g will cause the first composeFilter to be+ -- ignored.+ setFilter :: (a->a) -> m ()+ -- |+ -- composes your filter function with the+ -- existing filter function.+ composeFilter :: (a->a) -> m ()+ -- | retrives the filter from the environment+ getFilter :: m b -> m (b,a->a)++instance (Monad m) => FilterMonad a (FilterT a m) where+ setFilter f = FilterT $ Writer.tell $ Set $ Dual $ Endo f+ composeFilter f = FilterT $ Writer.tell $ Append $ Dual $ Endo f+ getFilter m = FilterT $ Writer.listens (appEndo . getDual . value) (unFilterT m) ++-- | The basic response building object.+-- It is worth discussing the unpacked structure of WebT a bit as it's exposed+-- in 'mapServerPartT' and 'mapWebT'.+--+-- A fully unpacked WebT has a structure that looks like:+-- +-- @+-- ununWebT $ WebT m a :: m (Maybe (Either Response a, FilterFun Response))+-- @+-- +-- So, ignoring m, as it is just the containing Monad, the outermost layer is+-- a Maybe. This is 'Nothing' if 'mzero' was called or @Just (Either Response+-- a, SetAppend (Endo Response))@ if 'mzero' wasn't called. Inside the Maybe,+-- there is a pair. The second element of the pair is our filter function+-- @FilterFun Response@. @FilterFun Response@ is a type alias for @SetAppend+-- (Dual (Endo Response))@. This is just a wrapper for a @Response->Response@+-- function with a particular Monoid behavior. The value+--+-- @+-- Append (Dual (Endo f))+-- @+--+-- Causes f to be composed with the previous filter.+--+-- @+-- Set (Dual (Endo f))+-- @+--+-- Causes f to not be composed with the previous filter.+--+-- Finally, the first element of the pair is either @Left Response@ or @Right a@.+--+-- Another way of looking at all these pieces is from the behaviors they control. The Maybe+-- controls the mzero behavior. @Set (Endo f)@ comes from the setFilter behavior.+-- Likewise, @Append (Endo f)@ is from composeFilter. @Left Response@ is what you+-- get when you call "finishWith" and @Right a@ is the normal exit.+--+-- An example case statement looks like:+-- @+-- ex1 webt = do+-- val <- ununWebT webt+-- case val of+-- Nothing -> Nothing -- this is the interior value when mzero was used+-- Just (Left r, f) -> Just (Left r, f) -- r is the value that was passed into "finishWith"+-- -- f is our filter function+-- Just (Right a, f) -> Just (Right a, f) -- a is our normal monadic value+-- -- f is still our filter function+-- @+-- +newtype WebT m a = WebT { unWebT :: ErrorT Response (FilterT (Response) (MaybeT m)) a }+ deriving (MonadIO, Functor)++instance Monad m => Monad (WebT m) where+ m >>= f = WebT $ unWebT m >>= unWebT . f+ return a = WebT $ return a+ fail s = mkFailMessage s++instance Error Response where+ strMsg = toResponse++class Monad m => WebMonad a m | m->a where+ -- | A control structure+ -- It ends the computation and returns the Response you passed into it+ -- immediately. This provides an alternate escape route. In particular+ -- it has a monadic value of any type. And unless you call @'setFilter' id@+ -- first your response filters will be applied normally.+ --+ -- Extremely useful when you're deep inside a monad and decide that you+ -- want to return a completely different content type, since it doesn't+ -- force you to convert all your return types to Response early just to+ -- accomodate this.+ finishWith :: a -> m b++instance (Monad m) => WebMonad Response (WebT m) where+ finishWith r = WebT $ throwError r++instance MonadTrans WebT where+ lift = WebT . lift . lift . lift++instance (Monad m) => MonadPlus (WebT m) where+ -- | Aborts a computation.+ --+ -- This is primarily useful because msum will take an array+ -- of MonadPlus and return the first one that isn't mzero,+ -- which is exactly the semantics expected from objects+ -- that take lists of ServerPartT+ mzero = WebT $ lift $ lift $ mzero+ mplus x y = WebT $ ErrorT $ FilterT $ (lower x) `mplus` (lower y)+ where lower = (unFilterT . runErrorT . unWebT)++-- | deprecated. use mzero+noHandle :: (MonadPlus m) => m a+noHandle = mzero+{-# DEPRECATED noHandle "Use mzero" #-}++instance (Monad m) => FilterMonad Response (WebT m) where+ setFilter f = WebT $ lift $ setFilter $ f+ composeFilter f = WebT . lift . composeFilter $ f+ getFilter m = WebT $ ErrorT $ getFilter (runErrorT $ unWebT m) >>= liftWebT+ where liftWebT (Left r, _) = return $ Left r+ liftWebT (Right a, f) = return $ Right (a, f)++instance (Monad m) => Monoid (WebT m a) where+ mempty = mzero+ mappend = mplus++-- | takes your WebT, converts the monadic value to a Response,+-- applys your filter, and returns it wrapped in a Maybe.+runWebT :: (ToMessage b, Monad m) => WebT m b -> m (Maybe Response)+runWebT m = runMaybeT $ do+ (r,ed) <- runWriterT $ unFilterT $ runErrorT $ unWebT $ m+ let f = appEndo $ getDual $ value ed+ return $ either (f) (f . toResponse) r+-- | for when you really need to unpack a WebT entirely (and not+-- just unwrap the first layer with unWebT)+ununWebT :: WebT m a+ -> m (Maybe+ (Either Response a,+ FilterFun Response))+ununWebT = runMaybeT . runWriterT . unFilterT . runErrorT . unWebT++-- | for wrapping a WebT back up. @mkWebT . ununWebT = id@+mkWebT :: m (Maybe+ (Either Response a,+ FilterFun Response)) -> WebT m a+mkWebT = WebT . ErrorT . FilterT . WriterT . MaybeT++-- | see 'mapServerPartT' for a discussion of this function+mapWebT :: (m (Maybe (Either Response a, FilterFun Response)) -> n (Maybe (Either Response b, FilterFun Response))) -> WebT m a -> WebT n b+mapWebT f ma = mkWebT $ f (ununWebT ma)+++instance (Monad m, Functor m) => Applicative (WebT m) where+ pure = return+ (<*>) = ap++instance MonadReader r m => MonadReader r (WebT m) where+ ask = lift ask+ local fn m = mkWebT $ local fn (ununWebT m)++instance MonadState st m => MonadState st (WebT m) where+ get = lift get+ put = lift . put++instance MonadError e m => MonadError e (WebT m) where+ throwError err = lift $ throwError err+ catchError action handler = mkWebT $ catchError (ununWebT action) (ununWebT . handler)++instance MonadWriter w m => MonadWriter w (WebT m) where+ tell = lift . Writer.tell+ listen m = mkWebT $ Writer.listen (ununWebT m) >>= (return . liftWebT)+ where liftWebT (Nothing, _) = Nothing+ liftWebT (Just (Left x,f), _) = Just (Left x,f)+ liftWebT (Just (Right x,f),w) = Just (Right (x,w),f)+ pass m = mkWebT $ ununWebT m >>= liftWebT+ where liftWebT Nothing = return Nothing+ liftWebT (Just (Left x,f)) = return $ Just (Left x, f)+ liftWebT (Just (Right x,f)) = pass (return x)>>= (\a -> return $ Just (Right a,f))++-- | An alias for setFilter id+-- It resets all your filters+ignoreFilters :: (FilterMonad a m) => m ()+ignoreFilters = setFilter id++-- | Used to ignore all your filters+-- and immediately end the computation. A combination of+-- 'ignoreFilters' and 'finishWith'+escape :: (WebMonad a m, FilterMonad a m) => m a -> m b+escape gen = ignoreFilters >> gen >>= finishWith++-- | An alternate form of 'escape' that can+-- be easily used within a do block.+escape' :: (WebMonad a m, FilterMonad a m) => a -> m b+escape' a = ignoreFilters >> finishWith a++----------------------------------------------+-- additional types+++-- | An array of 'OptDescr', useful for processing+-- command line options into an 'Conf' for 'simpleHTTP'+ho :: [OptDescr (Conf -> Conf)]+ho = [Option [] ["http-port"] (ReqArg (\h c -> c { port = read h }) "port") "port to bind http server"]++-- | parseConfig tries to parse your command line options+-- into a Conf.+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 a 'ServerPartT'.+-- Use msum to pick the first handler from a list of handlers that doesn't call+-- noHandle.+simpleHTTP :: (ToMessage a) => Conf -> ServerPartT IO a -> IO ()+simpleHTTP = simpleHTTP' id++-- | a combination of simpleHTTP and 'mapServerPartT'. See 'mapServerPartT' for a discussion+-- of the first argument of this function.+simpleHTTP' :: (Monad m, ToMessage b) =>+ (m (Maybe (Either Response a, FilterFun Response))+ -> IO (Maybe (Either Response b, FilterFun Response)))+ -> Conf+ -> ServerPartT m a+ -> IO ()+simpleHTTP' toIO conf hs = do+ Listen.listen conf (\req -> runValidator (fromMaybe return (validator conf)) =<< (simpleHTTP'' (mapServerPartT toIO hs) req))+ ++-- | Generate a result from a 'ServerPart' and a 'Request'. This is mainly used+-- by CGI (and fast-cgi) wrappers.+simpleHTTP'' :: (ToMessage b, Monad m) => ServerPartT m b -> Request -> m Response+simpleHTTP'' hs req = (runWebT $ runServerPartT hs req) >>= (return . (maybe standardNotFound id))+ where+ standardNotFound = setHeader "Content-Type" "text/html" $ toResponse notFoundHtml+++-- | a wrapper for Read apparently. Pretty much only used for 'path' and probably+-- unnecessarily, as it is exactly "readM"+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++-- | Useful for withData and getData' implement this on your preferred type+-- to use those functions+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'+--+-- Used to convert arbitrary types into an HTTP response. You need to implement+-- this if you want to pass @ServerPartT m@ containing your type into simpleHTTP+class ToMessage a where+ toContentType :: a -> B.ByteString+ toContentType _ = B.pack "text/plain"+ toMessage :: a -> L.ByteString+ toMessage = error "Happstack.Server.SimpleHTTP.ToMessage.toMessage: Not defined"+ toResponse:: a -> Response+ toResponse val =+ let bs = toMessage val+ res = Response 200 M.empty nullRsFlags bs Nothing+ in setHeaderBS (B.pack "Content-Type") (toContentType val)+ res++instance ToMessage [Element] where+ toContentType _ = B.pack "application/xml"+ toMessage [el] = L.pack $ H.simpleDoc H.NoStyle $ toHaXmlEl el -- !! OPTIMIZE+ toMessage x = error ("Happstack.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 m = (== m) +instance MatchMethod [Method] where matchMethod methods = (`elem` methods)+instance MatchMethod (Method -> Bool) where matchMethod f = f +instance MatchMethod () where matchMethod () _ = True++-- | flatten turns your arbitrary @m a@ and converts it too+-- a @m 'Response'@ with @'toResponse'@+flatten :: (ToMessage a, Functor f) => f a -> f Response+flatten = fmap toResponse++-- | This is kinda like a very oddly shaped mapServerPartT or mapWebT+-- You probably want one or the other of those.+localContext :: Monad m => (WebT m a -> WebT m' a) -> ServerPartT m a -> ServerPartT m' a+localContext fn hs+ = withRequest $ \rq -> fn (runServerPartT hs rq)+++-- | Get a header out of the request+getHeaderM :: (ServerMonad m) => String -> m (Maybe B.ByteString)+getHeaderM a = askRq >>= return . (getHeader a)++-- | adds headers into the response.+-- This method does not overwrite any existing header of+-- the same name, hence the name addHeaderM. If you+-- want to replace a header use setHeaderM.+addHeaderM :: (FilterMonad Response m) => String -> String -> m ()+addHeaderM a v = composeFilter $ \res-> addHeader a v res++-- | sets a header into the response. This will replace+-- an existing header of the same name. Use addHeaderM, if you +-- want to add more than one header of the same name.+setHeaderM :: (FilterMonad Response m) => String -> String -> m ()+setHeaderM a v = composeFilter $ \res -> setHeader a v res+-------------------------------------+-- guards++-- | guard using an arbitrary function on the request+guardRq :: (ServerMonad m, MonadPlus m) => (Request -> Bool) -> m ()+guardRq f = do+ rq <- askRq+ when ( f rq /= True ) mzero ++-- | Guard against the method. This function also guards against+-- any remaining path segments. See methodOnly for the version+-- that guards only by method+methodM :: (ServerMonad m, MonadPlus m, MatchMethod method) => method -> m ()+methodM meth = methodOnly meth >> nullDir++-- | guard against the method only. (as opposed to 'methodM')+methodOnly :: (ServerMonad m, MonadPlus m, MatchMethod method) => method -> m ()+methodOnly meth = guardRq $ \rq -> matchMethod meth (rqMethod rq)++-- | Guard against the method. Note, this function also guards against any+-- remaining path segments.+methodSP :: (ServerMonad m, MonadPlus m, MatchMethod method) => method -> m b-> m b+methodSP m handle = methodM m >> handle++-- | Guard against the method. Note, this function also guards against any+-- remaining path segments. This function id deprecated. You can probably+-- just use methodSP (or methodM) now.+method :: (MatchMethod method, Monad m) => method -> WebT m a -> ServerPartT m a+method m handle = methodSP m (anyRequest handle)+{-# DEPRECATED method "you should be able to use methodSP" #-}++-- | Guard against non-empty remaining path segments+nullDir :: (ServerMonad m, MonadPlus m) => m ()+nullDir = guardRq $ \rq -> null (rqPaths rq)++-- | Pop a path element and run the @ServerPartT@ if it matches the given string.+dir :: (ServerMonad m, MonadPlus m) => String -> m a -> m a+dir staticPath handle =+ do+ rq <- askRq+ case rqPaths rq of+ (p:xs) | p == staticPath -> localRq (\newRq -> newRq{rqPaths = xs}) handle+ | otherwise -> mzero+ _ -> mzero++-- | Pop a path element and parse it. Annoyingly enough, rather than just using Read+-- (or providing a parser argument), this method uses 'FromReqURI' which is just a wrapper+-- for Read.+path :: (FromReqURI a, MonadPlus m, ServerMonad m) => (a -> m b) -> m b+path handle = do+ rq <- askRq+ case rqPaths rq of+ (p:xs) | Just a <- fromReqURI p+ -> localRq (\newRq -> newRq{rqPaths = xs}) (handle a)+ | otherwise -> mzero+ _ -> mzero++-- | grabs the rest of the URL (dirs + query) and passes it to your handler+uriRest :: (ServerMonad m) => (String -> m a) -> m a+uriRest handle = askRq >>= handle . rqURL++-- | pops any path element and ignores when chosing a ServerPartT to handle the+--+-- request.+anyPath :: (ServerMonad m, MonadPlus m) => m r -> m r+anyPath x = path $ (\(_::String) -> x)++-- | Deprecated. Use 'anyPath'.+anyPath' :: (ServerMonad m, MonadPlus m) => m r -> m r+anyPath' = anyPath+{-# DEPRECATED anyPath' "Use anyPath" #-}++-- | used to read parse your request with a RqData (a ReaderT, basically)+-- For example here is a simple GET or POST variable based authentication+-- guard. It handles the request with errorHandler if authentication fails.+--+-- @+-- myRqData = do+-- username <- lookInput \"username\"+-- password <- lookInput \"password\"+-- return (username, password)+-- checkAuth errorHandler = do+-- d <- getData myRqDataA+-- case d of+-- Nothing -> errorHandler+-- Just a | isValid a -> mzero+-- Just a | otherwise -> errorHandler+-- @+getDataFn :: (ServerMonad m) => RqData a -> m (Maybe a)+getDataFn rqData = do+ rq <- askRq+ return $ runReaderT rqData (rqInputs rq, rqCookies rq)++-- | An varient of getData that uses FromData to chose your+-- RqData for you. The example from 'getData' becomes:+--+-- @+-- myRqData = do+-- username <- lookInput \"username\"+-- password <- lookInput \"password\"+-- return (username, password)+-- instance FromData (String,String) where+-- fromData = myRqData+-- checkAuth errorHandler = do+-- d <- getData\'+-- case d of+-- Nothing -> errorHandler+-- Just a | isValid a -> mzero+-- Just a | otherwise -> errorHandler+-- @+getData :: (ServerMonad m, FromData a) => m (Maybe a)+getData = getDataFn fromData++-- | Retrieve data from the input query or the cookies.+withData :: (FromData a, MonadPlus m, ServerMonad m) => (a -> m r) -> m r+withData = withDataFn fromData++-- | withDataFn is like with data, but you pass in a RqData monad+-- for reading.+withDataFn :: (MonadPlus m, ServerMonad m) => RqData a -> (a -> m r) -> m r+withDataFn fn handle = do+ d <- getDataFn fn+ case d of+ Nothing -> mzero+ Just a -> handle a++-- | proxyServe is for creating ServerPartT's that proxy.+-- The sole argument [String] is a list of allowed domains for+-- proxying. This matches the domain part of the request+-- and the wildcard * can be used. E.g.+--+-- * \"*\" to match anything.+--+-- * \"*.example.com\" to match anything under example.com+--+-- * \"example.com\" to match just example.com+--+--+-- TODO: annoyingly enough, this method eventually calls escape, so+-- any headers you set won't be used, and the computation immediatly ends.+proxyServe :: (MonadIO m, WebMonad Response m, ServerMonad m, MonadPlus m, FilterMonad Response m) => [String] -> m Response+proxyServe allowed = do+ rq <- askRq+ if cond rq then proxyServe' rq else mzero+ 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)++-- | Takes a proxy Request and creates a Response. Your basic proxy+-- building block. See 'unproxify'+--+-- TODO: this would be more useful if it didn\'t call "escape" (e.g. it let you+-- modify the response afterwards, or set additional headers)+proxyServe' :: (MonadIO m, FilterMonad Response m, WebMonad Response m) => Request-> m Response+proxyServe' rq = liftIO (getResponse (unproxify rq)) >>=+ either (badGateway . toResponse . show) escape'++-- | This is a reverse proxy implementation.+-- see 'unrproxify'+--+-- TODO: this would be more useful if it didn\'t call "escape", just like+-- proxyServe'+rproxyServe :: (MonadIO m, WebMonad Response m) =>+ String -- ^ defaultHost+ -> [(String, String)] -- ^ map to look up hostname mappings. For the reverse proxy+ -> ServerPartT m Response -- ^ the result is a ServerPartT that will reverse proxy for you.+rproxyServe defaultHost list = withRequest $ \rq ->+ liftIO (getResponse (unrproxify defaultHost list rq)) >>=+ either (badGateway . toResponse . show) (escape')++-- | Run an IO action and, if it returns @Just@, pass it to the second argument.+require :: (MonadIO m, MonadPlus m) => IO (Maybe a) -> (a -> m r) -> m r+require fn handle = do+ mbVal <- liftIO fn+ case mbVal of+ Nothing -> mzero+ Just a -> handle a++-- | A varient of require that can run in any monad, not just IO+requireM :: (MonadTrans t, Monad m, MonadPlus (t m)) => m (Maybe a) -> (a -> t m r) -> t m r+requireM fn handle = do+ mbVal <- lift fn+ case mbVal of+ Nothing -> mzero+ Just a -> handle a++-- | Use @cmd@ to transform XML against @xslPath@.+-- This function only acts if the content-type is @application\/xml@.+xslt :: (MonadIO m, MonadPlus m, ToMessage r) =>+ XSLTCmd -- ^ XSLT preprocessor. Usually 'xsltproc' or 'saxon'.+ -> XSLPath -- ^ Path to xslt stylesheet.+ -> m r -- ^ Affected @ServerParts@.+ -> m Response+xslt cmd xslPath parts = do+ res <- parts+ if toContentType res == B.pack "application/xml"+ then liftM toResponse (doXslt cmd xslPath (toResponse res))+ else return (toResponse res)++doXslt :: (MonadIO m) =>+ XSLTCmd -> XSLPath -> Response -> m Response+doXslt cmd xslPath res = + do new <- liftIO $ procLBSIO cmd xslPath $ rsBody res+ return $ setHeader "Content-Type" "text/html" $ + setHeader "Content-Length" (show $ L.length new) $+ res { rsBody = new }++-- | deprecated. Same as 'composeFilter'+modifyResponse :: (FilterMonad a m) => (a -> a) -> m()+modifyResponse = composeFilter+{-# DEPRECATED modifyResponse "Use composeFilter" #-}++-- | sets the return code in your response+setResponseCode :: FilterMonad Response m => Int -> m ()+setResponseCode code+ = composeFilter $ \r -> r{rsCode = code}++-- | adds the cookie with a timeout to the response+addCookie :: (FilterMonad Response m) => Seconds -> Cookie -> m ()+addCookie sec = (addHeaderM "Set-Cookie") . mkCookieHeader sec++-- | adds the list of cookie timeout pairs to the response+addCookies :: (FilterMonad Response m) => [(Seconds, Cookie)] -> m ()+addCookies = mapM_ (uncurry addCookie)++-- | same as setResponseCode status >> return val+resp :: (FilterMonad Response m) => Int -> b -> m b+resp status val = setResponseCode status >> return val++-- | Respond with @200 OK@.+ok :: (FilterMonad Response m) => a -> m a+ok = resp 200++internalServerError :: (FilterMonad Response m) => a -> m a+internalServerError = resp 500++badGateway :: (FilterMonad Response m) => a -> m a+badGateway = resp 502++-- | Respond with @400 Bad Request@.+badRequest :: (FilterMonad Response m) => a -> m a+badRequest = resp 400++-- | Respond with @401 Unauthorized@.+unauthorized :: (FilterMonad Response m) => a -> m a+unauthorized = resp 401++-- | Respond with @403 Forbidden@.+forbidden :: (FilterMonad Response m) => a -> m a+forbidden = resp 403++-- | Respond with @404 Not Found@.+notFound :: (FilterMonad Response m) => a -> m a+notFound = resp 404++-- | Respond with @303 See Other@.+seeOther :: (FilterMonad Response m, ToSURI uri) => uri -> res -> m res+seeOther uri res = do modifyResponse $ redirect 303 uri+ return res++-- | Respond with @302 Found@.+found :: (FilterMonad Response m, ToSURI uri) => uri -> res -> m res+found uri res = do modifyResponse $ redirect 302 uri+ return res++-- | Respond with @301 Moved Permanently@.+movedPermanently :: (FilterMonad Response m, ToSURI a) => a -> res -> m res+movedPermanently uri res = do modifyResponse $ redirect 301 uri+ return res++-- | Respond with @307 Temporary Redirect@.+tempRedirect :: (FilterMonad Response m, ToSURI a) => a -> res -> m res+tempRedirect val res = do modifyResponse $ redirect 307 val+ return res++-- | deprecated. Just use msum+multi :: Monad m => [ServerPartT m a] -> ServerPartT m a+multi = msum+{-# DEPRECATED multi "Use msum instead" #-}++-- | what is this for, exactly? I don't understand why @Show a@ is even in the context+-- This appears to do nothing at all.+debugFilter :: (MonadIO m, Show a) => ServerPartT m a -> ServerPartT m a+debugFilter handle =+ withRequest $ \rq -> do+ r <- runServerPartT handle rq+ return r++-- | a constructor for a ServerPartT when you don't care about the request+anyRequest :: Monad m => WebT m a -> ServerPartT m a+anyRequest x = withRequest $ \_ -> x++-- | again, why is this useful?+applyRequest :: (ToMessage a, Monad m) =>+ ServerPartT m a -> Request -> Either (m Response) b+applyRequest hs = simpleHTTP'' hs >>= return . Left++-- | a simple HTTP basic authentication guard+basicAuth :: (WebMonad Response m, ServerMonad m, FilterMonad Response m, MonadPlus m) =>+ String -- ^ the realm name+ -> M.Map String String -- ^ the username password map+ -> m a -- ^ the part to guard+ -> m a+basicAuth realmName authMap xs = basicAuthImpl `mplus` xs+ where+ basicAuthImpl = do+ aHeader <- getHeaderM "authorization"+ case aHeader of+ Nothing -> err+ Just x -> case parseHeader x of+ (name, ':':password) | validLogin name password -> mzero+ | otherwise -> err+ _ -> err+ validLogin name password = M.lookup name authMap == Just password+ parseHeader = break (':'==) . Base64.decode . B.unpack . B.drop 6+ headerName = "WWW-Authenticate"+ headerValue = "Basic realm=\"" ++ realmName ++ "\""+ err = do+ unauthorized ()+ setHeaderM headerName headerValue+ escape' $ toResponse "Not authorized"++--------------------------------------------------------------+-- Query/Post data validating+--------------------------------------------------------------++-- | Useful inside the RqData monad. Gets the named input parameter (either+-- from a POST or a GET)+lookInput :: String -> RqData Input+lookInput name+ = do inputs <- asks fst+ case lookup name inputs of+ Nothing -> fail "input not found"+ Just i -> return i++-- | Gets the named input parameter as a lazy byte string+lookBS :: String -> RqData L.ByteString+lookBS = fmap inputValue . lookInput++-- | Gets the named input as a String+look :: String -> RqData String+look = fmap L.unpack . lookBS++-- | Gets the named cookie+-- the cookie name is case insensitive+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++-- | gets the named cookie as a string+lookCookieValue :: String -> RqData String+lookCookieValue = fmap cookieValue . lookCookie++-- | gets the named cookie as the requested Read type+readCookieValue :: Read a => String -> RqData a+readCookieValue name = readM =<< fmap cookieValue (lookCookie name)++-- | like look, but Reads for you.+lookRead :: Read a => String -> RqData a+lookRead name = readM =<< look name++-- | gets all the input parameters, and converts them to a string+lookPairs :: RqData [(String,String)]+lookPairs = asks fst >>= return . map (\(n,vbs)->(n,L.unpack $ inputValue vbs))+++--------------------------------------------------------------+-- Error Handling+--------------------------------------------------------------++-- | This ServerPart modifier enables the use of throwError and catchError inside the+-- WebT actions, by adding the ErrorT monad transformer to the stack.+--+-- You can wrap the complete second argument to 'simpleHTTP' in this function.+--+errorHandlerSP :: (Monad m, Error e) => (Request -> e -> WebT m a) -> ServerPartT (ErrorT e m) a -> ServerPartT m a +errorHandlerSP handler sps = withRequest $ \req -> mkWebT $ do+ eer <- runErrorT $ ununWebT $ runServerPartT sps req+ case eer of+ Left err -> ununWebT (handler req err)+ Right res -> return res+{-# DEPRECATED errorHandlerSP "Use spUnwrapErrorT" #-}++-- | An example error Handler to be used with 'spUnWrapErrorT', which returns the+-- error message as a plain text message to the browser.+--+-- Another possibility is to store the error message, e.g. as a FlashMsg, and+-- then redirect the user somewhere.+simpleErrorHandler :: (Monad m) => String -> ServerPartT m Response+simpleErrorHandler err = ok $ toResponse $ ("An error occured: " ++ err)++-- | This is a for use with mapServerPartT\' It it unwraps+-- the interior monad for use with simpleHTTP. If you+-- have a ServerPartT (ErrorT e m) a, this will convert+-- that monad into a ServerPartT m a. Used with+-- mapServerPartT\' to allow throwError and catchError inside your+-- monad. Eg.+-- +-- @+-- simpleHTTP conf $ mapServerPartT\' (spUnWrapErrorT failurePart) $ myPart \`catchError\` errorPart+-- @+-- +-- Note that @failurePart@ will only be run if errorPart threw an error+-- so it doesn\'t have to be very complex.+spUnwrapErrorT:: Monad m =>+ (e -> ServerPartT m a)+ -> Request+ -> ErrorT e m (Maybe (Either Response a, FilterFun Response))+ -> m (Maybe (Either Response a, FilterFun Response))+spUnwrapErrorT handler rq = \x -> do+ err <- runErrorT x+ case err of+ Left e -> ununWebT $ runServerPartT (handler e) rq+ Right a -> return a++--------------------------------------------------------------+-- * Output validation+--------------------------------------------------------------++-- |Set the validator which should be used for this particular 'Response'+-- when validation is enabled.+--+-- Calling this function does not enable validation. That can only be+-- done by enabling the validation in the 'Conf' that is passed to+-- 'simpleHTTP'.+--+-- You do not need to call this function if the validator set in+-- 'Conf' does what you want already.+--+-- Example: (use 'noopValidator' instead of the default supplied by 'validateConf')+--+-- @+-- simpleHTTP validateConf . anyRequest $ ok . setValidator noopValidator =<< htmlPage+-- @+--+-- See also: 'validateConf', 'wdgHTMLValidator', 'noopValidator', 'lazyProcValidator'+setValidator :: (Response -> IO Response) -> Response -> Response+setValidator v r = r { rsValidator = Just v }++-- |ServerPart version of 'setValidator'+--+-- Example: (Set validator to 'noopValidator')+--+-- @+-- simpleHTTP validateConf $ setValidatorSP noopValidator (dir "ajax" ... )+-- @+--+-- See also: 'setValidator'+setValidatorSP :: (Monad m, ToMessage r) => (Response -> IO Response) -> m r -> m Response+setValidatorSP v sp = return . setValidator v . toResponse =<< sp++-- |This extends 'nullConf' by enabling validation and setting+-- 'wdgHTMLValidator' as the default validator for @text\/html@.+--+-- Example:+--+-- @+-- simpleHTTP validateConf . anyRequest $ ok htmlPage+-- @+validateConf :: Conf+validateConf = nullConf { validator = Just wdgHTMLValidator }++-- |Actually perform the validation on a 'Response'+-- +-- Run the validator specified in the 'Response'. If none is provide+-- use the supplied default instead. +--+-- Note: This function will run validation unconditionally. You+-- probably want 'setValidator' or 'validateConf'.+runValidator :: (Response -> IO Response) -> Response -> IO Response+runValidator defaultValidator r =+ case rsValidator r of+ Nothing -> defaultValidator r+ (Just altValidator) -> altValidator r++-- |Validate @text\/html@ content with @WDG HTML Validator@.+--+-- This function expects the executable to be named @validate@+-- and it must be in the default @PATH@.+--+-- See also: 'setValidator', 'validateConf', 'lazyProcValidator'+wdgHTMLValidator :: (MonadIO m, ToMessage r) => r -> m Response+wdgHTMLValidator = liftIO . lazyProcValidator "validate" ["-w","--verbose","--charset=utf-8"] Nothing Nothing handledContentTypes . toResponse+ where+ handledContentTypes (Just ct) = elem (takeWhile (\c -> c /= ';' && c /= ' ') (B.unpack ct)) [ "text/html", "application/xhtml+xml" ]+ handledContentTypes Nothing = False++-- |A validator which always succeeds.+--+-- Useful for selectively disabling validation. For example, if you+-- are sending down HTML fragments to an AJAX application and the+-- default validator only understands complete documents.+noopValidator :: Response -> IO Response+noopValidator = return++-- |Validate the 'Response' using an external application.+-- +-- If the external application returns 0, the original response is+-- returned unmodified. If the external application returns non-zero, a 'Response'+-- containing the error messages and original response body is+-- returned instead.+--+-- This function also takes a predicate filter which is applied to the+-- content-type of the response. The filter will only be applied if+-- the predicate returns true.+--+-- NOTE: This function requirse the use of -threaded to avoid blocking.+-- However, you probably need that for Happstack anyway.+-- +-- See also: 'wdgHTMLValidator'+lazyProcValidator :: FilePath -- ^ name of executable+ -> [String] -- ^ arguements to pass to the executable+ -> Maybe FilePath -- ^ optional path to working directory+ -> Maybe [(String, String)] -- ^ optional environment (otherwise inherit)+ -> (Maybe B.ByteString -> Bool) -- ^ content-type filter+ -> Response -- ^ Response to validate+ -> IO Response+lazyProcValidator exec args wd env mimeTypePred response+ | mimeTypePred (getHeader "content-type" response) =+ do (inh, outh, errh, ph) <- runInteractiveProcess exec args wd env+ out <- hGetContents outh+ err <- hGetContents errh+ forkIO $ do L.hPut inh (rsBody response)+ hClose inh+ forkIO $ evaluate (length out) >> return ()+ forkIO $ evaluate (length err) >> return ()+ ec <- waitForProcess ph+ case ec of+ ExitSuccess -> return response+ (ExitFailure _) -> + return $ toResponse (unlines ([ "ExitCode: " ++ show ec+ , "stdout:"+ , out+ , "stderr:"+ , err+ , "input:"+ ] ++ + showLines (rsBody response)))+ | otherwise = return response+ where+ column = " " ++ (take 120 $ concatMap (\n -> " " ++ show n) (drop 1 $ cycle [0..9::Int]))+ showLines :: L.ByteString -> [String]+ showLines string = column : zipWith (\n -> \l -> show n ++ " " ++ (L.unpack l)) [1::Integer ..] (L.lines string)++mkFailMessage :: (FilterMonad Response m, WebMonad Response m) => String -> m b+mkFailMessage s = do+ ignoreFilters+ internalServerError ()+ setHeaderM "Content-Type" "text/html"+ res <- return $ toResponse $ failHtml s+ finishWith $ res++failHtml:: String->String+failHtml errString = "<html><head><title>Happstack "+ ++ ver ++ " Internal Server Error</title>"+ ++ "<body><h1>Happstack " ++ ver ++ "</h1>"+ ++ "<p>Something went wrong here<br />"+ ++ "Internal server error<br />"+ ++ "Everything has stopped</p>"+ ++ "<p>The error was \"" ++ errString ++ "\"</p></body></html>"+ where ver = DV.showVersion Cabal.version++notFoundHtml :: String+notFoundHtml = "<html><head><title>Happstack "+ ++ ver ++ " File not found</title>"+ ++ "<body><h1>Happstack " ++ ver ++ "</h1>"+ ++ "<p>Your file is not found<br />"+ ++ "To try again is useless<br />"+ ++ "It is just not here</p>"+ ++ "</body></html>"+ where ver = DV.showVersion Cabal.version
+ src/Happstack/Server/StdConfig.hs view
@@ -0,0 +1,22 @@+{-# LANGUAGE ScopedTypeVariables #-}+module Happstack.Server.StdConfig where++import Control.Monad.Trans+import Control.Monad+import Happstack.Server.SimpleHTTP+import Happstack.Server.HTTP.FileServe++-- | Is equal to "haskell/Main"+binarylocation :: String+binarylocation = "haskell/Main"++-- | Is equal to "public/log"+loglocation :: String+loglocation = "public/log"++-- | Convenience function around 'errorwrapper'+-- with the default binary location set to 'binarylocation' and the+-- log location set to 'loglocation'. +errWrap :: (MonadPlus m, FilterMonad Response m, MonadIO m) => m Response+errWrap = errorwrapper binarylocation loglocation+--stateFuns -- main actually has state so you can just import them
+ src/Happstack/Server/XSLT.hs view
@@ -0,0 +1,157 @@+{-# LANGUAGE TemplateHaskell, FlexibleInstances , UndecidableInstances,+ DeriveDataTypeable, MultiParamTypeClasses, CPP, ScopedTypeVariables,+ PatternSignatures #-}+module Happstack.Server.XSLT+ (xsltFile, xsltString, xsltElem, xsltFPS, xsltFPSIO, XSLPath,+ xsltproc,saxon,procFPSIO,procLBSIO,XSLTCommand,XSLTCmd+ ) where+++import System.Log.Logger++import Happstack.Server.MinHaXML+import Happstack.Util.Common(runCommand)+import Control.Exception.Extensible(bracket,try,SomeException)+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 Happstack.Data hiding (Element)++logMX :: Priority -> String -> IO ()+logMX = logM "Happstack.Server.XSLT"++type XSLPath = FilePath++$(deriveAll [''Show,''Read,''Default, ''Eq, ''Ord]+ [d|+ data XSLTCmd = XSLTProc | Saxon + |]+ )++xsltCmd :: XSLTCmd+ -> XSLPath+ -> FilePath+ -> FilePath+ -> (FilePath, [String])+xsltCmd XSLTProc = xsltproc'+xsltCmd Saxon = saxon'++-- | Uses 'xsltString' to transform the given XML 'Element' into a+-- a 'String'. +xsltElem :: XSLPath -> Element -> String+xsltElem xsl = xsltString xsl . verbatim+++procLBSIO :: XSLTCmd -> XSLPath -> L.ByteString -> IO L.ByteString+procLBSIO xsltp' xsl inp = + withTempFile "happs-src.xml" $ \sfp sh -> do+ withTempFile "happs-dst.xml" $ \dfp dh -> do+ let xsltp = xsltCmd xsltp'+ L.hPut sh inp+ hClose sh+ hClose dh+ xsltFileEx xsltp xsl sfp dfp+ s <- L.readFile dfp+ logMX DEBUG (">>> XSLT: result: "++ show s)+ return s+++procFPSIO :: XSLTCommand+ -> XSLPath+ -> [P.ByteString]+ -> IO [P.ByteString]+procFPSIO xsltp 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 xsltp xsl sfp dfp+ s <- P.readFile dfp+ logMX DEBUG (">>> XSLT: result: "++ show s)+ return [s]++-- | Performs an XSL transformation with lists of ByteStrings instead of+-- a String.+xsltFPS :: XSLPath -> [P.ByteString] -> [P.ByteString]+xsltFPS xsl = unsafePerformIO . xsltFPSIO xsl++-- | Equivalent to 'xsltFPS' but does not hide the inherent IO of the low-level+-- ByteString operations.+xsltFPSIO :: XSLPath -> [P.ByteString] -> IO [P.ByteString]+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]++-- | Uses the provided xsl file to transform the given string.+-- This function creates temporary files during its execution, but+-- guarantees their cleanup.+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 :: XSLTCmd+xsltproc = XSLTProc+xsltproc' :: XSLTCommand+xsltproc' dst xsl src = ("xsltproc",["-o",dst,xsl,src])+++-- | Use @saxon@ to transform XML.+saxon :: XSLTCmd+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 xsltp xsl src dst = do+ let msg = (">>> XSLT: Starting xsltproc " ++ unwords ["-o",dst,xsl,src])+ logMX DEBUG msg+ uncurry runCommand $ xsltp 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++{-# 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 (\(_::SomeException) -> tryAny xs c) return =<< try x
− tests/HAppS/Server/Tests.hs
@@ -1,12 +0,0 @@--- |HUnit tests and QuickQuick properties for HAppS.Server.*-module HAppS.Server.Tests (allTests) where--import Test.HUnit as HU (Test(..),(~:),(~?))---- |All of the tests for happstack-util should be listed here. -allTests :: Test-allTests = - "happstack-server tests" ~: [dummyTest]--dummyTest :: Test-dummyTest = "dummyTest" ~: True ~? "True"
+ tests/Happstack/Server/Tests.hs view
@@ -0,0 +1,41 @@+-- |HUnit tests and QuickQuick properties for Happstack.Server.*+module Happstack.Server.Tests (allTests) where++import Test.HUnit as HU (Test(..),(~:),(~?),(@?=))+import Happstack.Server.Cookie+import Happstack.Server.Parts+import Text.ParserCombinators.Parsec++-- |All of the tests for happstack-util should be listed here. +allTests :: Test+allTests = + "happstack-server tests" ~: [cookieParserTest, acceptEncodingParserTest]++cookieParserTest :: Test+cookieParserTest = + "cookieParserTest" ~:+ [parseCookies "$Version=1;Cookie1=value1;$Path=\"/testpath\";$Domain=example.com;cookie2=value2"+ @?= (Right [+ Cookie "1" "/testpath" "example.com" "cookie1" "value1"+ , Cookie "1" "" "" "cookie2" "value2"+ ])+ ,parseCookies " \t $Version = \"1\" ; cookie1 = \"randomcrap!@#%^&*()-_+={}[]:;'<>,.?/\\|\" , $Path=/ "+ @?= (Right [+ Cookie "1" "/" "" "cookie1" "randomcrap!@#%^&*()-_+={}[]:;'<>,.?/\\|"+ ])+ ,parseCookies " cookie1 = value1 "+ @?= (Right [+ Cookie "" "" "" "cookie1" "value1"+ ])+ ,parseCookies " $Version=\"1\";buggygooglecookie = valuewith=whereitshouldnotbe "+ @?= (Right [+ Cookie "1" "" "" "buggygooglecookie" "valuewith=whereitshouldnotbe"+ ])+ ]++acceptEncodingParserTest :: Test+acceptEncodingParserTest =+ "acceptEncodingParserTest" ~:+ [either (Left . show) Right (parse encodings "" " gzip;q=1,*, compress ; q = 0.5 ")+ @?= (Right [("gzip", Just 1),("*", Nothing),("compress", Just 0.5)])+ ]
tests/Test.hs view
@@ -1,6 +1,6 @@ module Main where -import HAppS.Server.Tests (allTests)+import Happstack.Server.Tests (allTests) import Test.HUnit (errors, failures, putTextToShowS,runTestText, runTestTT) import System.Exit (exitFailure) import System.IO (hIsTerminalDevice, stdout)