{-# OPTIONS -fglasgow-exts -cpp #-} module HAppS.Server.HTTP.Handler(request-- version,required ,parseResponse,putRequest -- ,unchunkBody,val,testChunk,pack ) where -- ,fsepC,crlfC,pversion import Control.Exception as E import Control.Monad import Data.List(foldl',unfoldr,elemIndex) import Data.Char(toLower) import Data.Maybe ( fromMaybe, fromJust ) import qualified Data.List as List import qualified Data.ByteString.Char8 as P import qualified Data.ByteString.Char8 as B import qualified Data.ByteString.Lazy.Char8 as L import qualified Data.ByteString.Unsafe as U import qualified Data.Map as M import System.IO import System.Locale(defaultTimeLocale) import System.Time import Numeric import Data.Maybe import Data.Int (Int64) import HAppS.Server.Cookie import HAppS.Server.HTTP.Clock import HAppS.Server.HTTP.LazyLiner import HAppS.Server.HTTP.Types import HAppS.Server.HTTP.Multipart import HAppS.Server.HTTP.RFC822Headers --import HAppS.Server.HTTP.RFC822HeadersBinary import HAppS.Server.MessageWrap import HAppS.Server.SURI(SURI(..),path,query) import HAppS.Server.SURI.ParseURI import HAppS.Util.ByteStringCompat import HAppS.Util.TimeOut import System.Log.Logger hiding (debugM) pack = L.pack logMH = logM "HAppS.Server.HTTP.Handler" DEBUG request :: Conf -> Handle -> Host -> (Request -> IO Response) -> IO () request conf h host handler = rloop conf h host handler =<< L.hGetContents h required :: String -> Maybe a -> Either String a required err Nothing = Left err required _ (Just a) = Right a transferEncodingC = "transfer-encoding" rloop conf h host handler inputStr | L.null inputStr = return () | otherwise = join $ withTimeOut (30 * second) $ do let parseRequest = do (topStr, restStr) <- required "failed to separate request" $ splitAtEmptyLine inputStr (rql, headerStr) <- required "failed to separate headers/body" $ splitAtCRLF topStr let (m,u,v) = requestLine rql headers' <- parseHeaders "host" (L.unpack headerStr) -- headers' <- required "host" $ parseBHeaders headerStr let headers = mkHeaders headers' -- let headers = M.fromList $ headers' let contentLength = fromMaybe 0 $ fmap fst (P.readInt =<< getHeaderUnsafe contentlengthC headers) (body, nextRequest) <- case () of () | contentLength < 0 -> fail "negative content-length" | isJust $ getHeader transferEncodingC headers -> return $ consumeChunks restStr | otherwise -> return (L.splitAt (fromIntegral contentLength) restStr) let cookies = [ (cookieName c, c) | cl <- fromMaybe [] (fmap getCookies (getHeader "Cookie" headers)), c <- cl ] -- Ugle rqTmp = Request m (pathEls (path u)) (query u) [] cookies v headers (Body body) host rq = rqTmp{rqInputs = queryInput u ++ bodyInput rqTmp} return (rq, nextRequest) case parseRequest of Left err -> error $ "failed to parse HTTP request: " ++ err Right (req, rest) -> return $ -- logMH (show req) >> do let ioseq act = act >>= \x -> x `seq` return x res <- ioseq (handler req) `E.catch` \e -> return $ result 500 $ "Server error: " ++ show e putAugmentedResult h req res when (continueHTTP req res) $ rloop conf h host handler rest parseResponse inputStr = do (topStr,restStr) <- required "failed to separate response" $ splitAtEmptyLine inputStr (rsl,headerStr) <- required "failed to separate headers/body" $ splitAtCRLF topStr let (v,code) = responseLine rsl headers' <- parseHeaders "host" (L.unpack headerStr) let headers = mkHeaders headers' let mbCL = fmap fst (B.readInt =<< getHeader "content-length" headers) rsFlags = RsFlags $ not $ isJust mbCL (body,nextResp) <- maybe (if (isNothing $ getHeader "transfer-encoding" headers) then return (restStr,L.pack "") else return $ consumeChunks restStr) (\cl->return (L.splitAt (fromIntegral cl) restStr)) mbCL return $ Response {rsCode=code,rsHeaders=headers,rsBody=body,rsFlags=RsFlags True} val = "71 \r\n\n i2x.com \n\n\n

This is i2x.com

\n\nContact us.\n\r\n0\r\n\r\n" testChunk x = x == (L.unpack $ fst $ consumeChunks $ L.pack x) -- http://www.w3.org/Protocols/rfc2616/rfc2616-sec3.html -- note this does NOT handle extenions consumeChunks::L.ByteString->(L.ByteString,L.ByteString) consumeChunks str = let (parts,tr,rest) = consumeChunksImpl str in (L.concat . (++ [tr]) .map snd $ parts,rest) consumeChunksImpl :: L.ByteString -> ([(Int64, L.ByteString)], L.ByteString, L.ByteString) consumeChunksImpl str | L.null str = ([],L.empty,str) | chunkLen == 0 = let (last,rest') = L.splitAt lenLine1 str (tr,rest'') = getTrailer rest' in ([(0,last)],tr,rest'') | otherwise = ((chunkLen,part):crest,tr,rest2) where line1 = head $ lazylines str lenLine1 = (L.length line1) + 1 -- endchar chunkLen = (fst $ head $ readHex $ L.unpack line1) len = chunkLen + lenLine1 + 2 (part,rest) = L.splitAt len str (crest,tr,rest2) = consumeChunksImpl rest getTrailer str = L.splitAt index str where index | crlfLC `L.isPrefixOf` str = 2 | otherwise = let iscrlf = L.zipWith (\a b -> a == '\r' && b == '\n') str . L.tail $ str Just i = elemIndex True $ zipWith (&&) iscrlf (tail (tail iscrlf)) in fromIntegral $ i+4 chunk :: Int64 -> L.ByteString -> L.ByteString chunk n = L.concat . concatMap (\c -> [L.pack . flip showHex "" . L.length $ c,crlfLC,c,crlfLC]) . (++ [L.empty]) . splits n where splits n = unfoldr (\xs -> if L.null xs then Nothing else Just (L.splitAt n xs)) unchunk :: L.ByteString -> (L.ByteString, L.ByteString -- the trailer part, unparsed, plus the final \r\n ,L.ByteString) unchunk bs = let (parts,tr,rest) = consumeChunksImpl bs in (L.concat . map clean $ parts,tr, rest) where clean (sz,bs) = L.take sz . L.drop 1 . snd . L.break (== '\n') $ bs crlfLC = L.pack "\r\n" -- Properly lazy version of 'lines' for lazy bytestrings lazylines :: L.ByteString -> [L.ByteString] lazylines s | L.null s = [] | otherwise = let (l,s') = L.break ((==) '\n') s in l : if L.null s' then [] else lazylines (L.tail s') {- presult :: Handle -> IO Result presult h = do liner <- newLinerHandle h rls@(rql:hrl) <- headerLines liner let c = responseLine rql hh = combineHeaders $ headers hrl [] let mread k = return (fmap fst (P.readInt =<< M.lookup k hh)) cl <- mread contentlengthC body <- case cl of Nothing -> fmap toChunks $ getRest liner Just c | c < 0 -> fail "Negative content-length" | otherwise -> fmap toChunks $ getBytes liner c return $ Result c hh nullRsFlags body -} headers [] acc = acc headers (line:rest) acc = let space = let x = P.head line in x == ' ' || x == '\t' in case () of _ | space && null acc -> error "Continuation header as first header" | space -> let ((k,v):r) = acc in headers rest ((k,P.append v line):r) | otherwise -> let (k,raw) = breakChar ':' line v = dropSpaceEnd $ dropSpace $ P.tail raw in headers rest ((k,v):acc) requestLine l = case P.words ((P.concat . L.toChunks) l) of [rq,uri,ver] -> (method rq, SURI $ parseURIRef uri, version ver) [rq,uri] -> (method rq, SURI $ parseURIRef uri,Version 0 9) --responseLine l = case P.words l of (v:c:_) -> version v `seq` fst (fromJust (P.readInt c)) responseLine l = case B.words ((B.concat . L.toChunks) l) of (v:c:_) -> version v `seq` (v,fst (fromJust (B.readInt c))) method r = fj $ lookup r mtable where fj (Just x) = x fj Nothing = error "invalid request method" mtable = [(P.pack "GET", GET), (P.pack "HEAD", HEAD), (P.pack "POST", POST), (P.pack "PUT", PUT), (P.pack "DELETE", DELETE), (P.pack "TRACE", TRACE), (P.pack "OPTIONS", OPTIONS), (P.pack "CONNECT", CONNECT)] combineHeaders :: [(P.ByteString,P.ByteString)] -> M.Map P.ByteString P.ByteString combineHeaders = foldl' w M.empty where w m (k,v) = M.insertWith (\n o -> P.concat [o, P.pack ", ", n]) (P.map toLower k) v m -- Result side staticHeaders :: Headers staticHeaders = foldr (uncurry setHeaderBS) (mkHeaders []) [ (serverC, happsC), (contentTypeC, textHtmlC) ] putAugmentedResult :: Handle -> Request -> Response -> IO () putAugmentedResult h req res = do let ph (HeaderPair k vs) = map (\v -> P.concat [k, fsepC, v, crlfC]) vs raw <- getApproximateTime let cl = L.length $ rsBody res let put x = P.hPut h x -- TODO: Hoist static headers to the toplevel. let stdHeaders = staticHeaders `M.union` M.fromList ( [ (dateCLower, HeaderPair dateC [raw]) , (connectionCLower, HeaderPair connectionC [if continueHTTP req res then keepAliveC else closeC]) ] ++ if rsfContentLength (rsFlags res) then [(contentlengthC, HeaderPair contentLengthC [P.pack (show cl)])] else [] ) allHeaders = rsHeaders res `M.union` stdHeaders -- 'union' prefers 'headers res' when duplicate keys are encountered. mapM_ put $ concat [ (pversion $ rqVersion req) -- Print HTTP version , [responseMessage $ rsCode res] -- Print responseCode , concatMap ph (M.elems allHeaders) -- Print all headers , [crlfC] ] when (rqMethod req /= HEAD) $ L.hPut h $ rsBody res -- logMH "Flushing connection" hFlush h putRequest h rq = do let put x = B.hPut h x ph (HeaderPair k vs) = map (\v -> B.concat [k, fsepC, v, crlfC]) vs sp = [B.pack " "] mapM_ put $ concat [[B.pack $ show $ rqMethod rq],sp ,[B.pack $ rqURL rq],sp ,(pversion $ rqVersion rq), [crlfC] ,concatMap ph (M.elems $ rqHeaders rq) ,[crlfC] ] let Body body = rqBody rq L.hPut h body hFlush h -- Version pversion (Version 1 1) = [http11] pversion (Version 1 0) = [http10] pversion (Version x y) = [P.pack "HTTP/", P.pack (show x), P.pack ".", P.pack (show y)] version x | x == http09 = Version 0 9 | x == http10 = Version 1 0 | x == http11 = Version 1 1 | otherwise = error "Invalid HTTP version" http09 = P.pack "HTTP/0.9" http10 = P.pack "HTTP/1.0" http11 = P.pack "HTTP/1.1" -- Constants connectionC = P.pack "Connection" connectionCLower = P.map toLower connectionC closeC = P.pack "close" keepAliveC = P.pack "Keep-Alive" --connectionCloseC = P.pack "Connection: close\r\n" --connectionKeepC = P.pack "Connection: keep-alive\r\n" crlfC = P.pack "\r\n" fsepC = P.pack ": " contentTypeC = P.pack "Content-Type" contentLengthC = P.pack "Content-Length" contentlengthC = P.pack "content-length" dateC = P.pack "Date" dateCLower = P.map toLower dateC serverC = P.pack "Server" happsC = P.pack "HAppS/0.8.4" textHtmlC = P.pack "text/html; charset=utf-8" -- Response code names responseMessage 100 = P.pack " 100 Continue\r\n" responseMessage 101 = P.pack " 101 Switching Protocols\r\n" responseMessage 200 = P.pack " 200 OK\r\n" responseMessage 201 = P.pack " 201 Created\r\n" responseMessage 202 = P.pack " 202 Accepted\r\n" responseMessage 203 = P.pack " 203 Non-Authoritative Information\r\n" responseMessage 204 = P.pack " 204 No Content\r\n" responseMessage 205 = P.pack " 205 Reset Content\r\n" responseMessage 206 = P.pack " 206 Partial Content\r\n" responseMessage 300 = P.pack " 300 Multiple Choices\r\n" responseMessage 301 = P.pack " 301 Moved Permanently\r\n" responseMessage 302 = P.pack " 302 Found\r\n" responseMessage 303 = P.pack " 303 See Other\r\n" responseMessage 304 = P.pack " 304 Not Modified\r\n" responseMessage 305 = P.pack " 305 Use Proxy\r\n" responseMessage 307 = P.pack " 307 Temporary Redirect\r\n" responseMessage 400 = P.pack " 400 Bad Request\r\n" responseMessage 401 = P.pack " 401 Unauthorized\r\n" responseMessage 402 = P.pack " 402 Payment Required\r\n" responseMessage 403 = P.pack " 403 Forbidden\r\n" responseMessage 404 = P.pack " 404 Not Found\r\n" responseMessage 405 = P.pack " 405 Method Not Allowed\r\n" responseMessage 406 = P.pack " 406 Not Acceptable\r\n" responseMessage 407 = P.pack " 407 Proxy Authentication Required\r\n" responseMessage 408 = P.pack " 408 Request Time-out\r\n" responseMessage 409 = P.pack " 409 Conflict\r\n" responseMessage 410 = P.pack " 410 Gone\r\n" responseMessage 411 = P.pack " 411 Length Required\r\n" responseMessage 412 = P.pack " 412 Precondition Failed\r\n" responseMessage 413 = P.pack " 413 Request Entity Too Large\r\n" responseMessage 414 = P.pack " 414 Request-URI Too Large\r\n" responseMessage 415 = P.pack " 415 Unsupported Media Type\r\n" responseMessage 416 = P.pack " 416 Requested range not satisfiable\r\n" responseMessage 417 = P.pack " 417 Expectation Failed\r\n" responseMessage 500 = P.pack " 500 Internal Server Error\r\n" responseMessage 501 = P.pack " 501 Not Implemented\r\n" responseMessage 502 = P.pack " 502 Bad Gateway\r\n" responseMessage 503 = P.pack " 503 Service Unavailable\r\n" responseMessage 504 = P.pack " 504 Gateway Time-out\r\n" responseMessage 505 = P.pack " 505 HTTP Version not supported\r\n" responseMessage x = P.pack (show x ++ "\r\n")