{-# 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