output <- openOutput opts
eTag <- getETag opts input
- let gzippedData = compressWith BestCompression input
+ let compParams = defaultCompressParams { compressLevel = BestCompression }
+ gzippedData = compressWith compParams input
originalLen = L.length input
gzippedLen = L.length gzippedData
useGZip = originalLen > gzippedLen
messing around FastCGI. It is also intended to be run behind a
reverse-proxy so it doesn't have some facilities like logging,
client filtering or such like.
-Version: 0.1
+Version: 0.2
License: PublicDomain
License-File: COPYING
Author: PHO <pho at cielonegro dot org>
Stability: experimental
Homepage: http://cielonegro.org/Lucu.html
Category: Network
-Tested-With: GHC == 6.8.1
-Cabal-Version: >= 1.2
+Tested-With: GHC == 6.10.1
+Cabal-Version: >= 1.2.3
Build-Type: Simple
Extra-Source-Files:
Network.HTTP.Lucu.RequestReader
Network.HTTP.Lucu.ResponseWriter
Extensions:
- DeriveDataTypeable, UnboxedTuples
+ BangPatterns, DeriveDataTypeable, UnboxedTuples
ghc-options:
-Wall
-funbox-strict-fields
$(MAKE) -C examples clean
doc: dist/setup-config Setup
- ./Setup haddock --hyperlink-source --hscolour-css=../hscolour/hscolour.css
+ ./Setup haddock
install: build
sudo ./Setup install
-Changes from 0.1 to ???
+Changes from 0.1 to 0.2
-----------------------
+* Fixed breakage on GHC 6.10.1. And now it requires 6.10.1...
* data/mime.types:
- Deleted application/x-wavpack
- Deleted application/x-wavpack-correction
--- #prune
+{-# OPTIONS_HADDOCK prune #-}
-- |Aborting the computation of 'Network.HTTP.Lucu.Resource.Resource'
-- in any 'Prelude.IO' monads or arrows.
, aboMessage :: !(Maybe String)
} deriving (Show, Typeable)
+instance Exception Abortion where
+ toException = SomeException
+ fromException (SomeException e) = cast e
+
-- |Computation of @'abort' status headers msg@ aborts the
-- 'Network.HTTP.Lucu.Resource.Resource' monad with given status,
-- additional response headers, and optional message string.
--
--- What this really does is to just throw a special
--- 'Control.Exception.DynException'. The exception will be caught by
--- the Lucu.
+-- What this really does is to throw a special
+-- 'Control.Exception.Exception'. The exception will be caught by the
+-- Lucu system.
--
-- 1. If the 'Network.HTTP.Lucu.Resource.Resource' is in the /Deciding
-- Header/ or any precedent states, it is possible to use the
abort status headers msg
= status `seq` headers `seq` msg `seq`
let abo = Abortion status (toHeaders $ map pack headers) msg
- exc = DynException (toDyn abo)
in
- liftIO $ throwIO exc
+ liftIO $ throwIO abo
where
pack (x, y) = (C8.pack x, C8.pack y)
--- #prune
+{-# OPTIONS_HADDOCK prune #-}
-- |Manipulation of WWW authorization.
module Network.HTTP.Lucu.Authorization
--- #prune
+{-# OPTIONS_HADDOCK prune #-}
-- |Manipulation of entity tags.
module Network.HTTP.Lucu.ETag
--- #prune
+{-# OPTIONS_HADDOCK prune #-}
-- |Manipulation of HTTP version string.
module Network.HTTP.Lucu.HttpVersion
httpVersionP :: Parser HttpVersion
-httpVersionP = do string "HTTP/"
- major <- many1 digit
- char '.'
- minor <- many1 digit
- return $ HttpVersion (read' major) (read' minor)
- where
- read' "1" = 1 -- この二つが
- read' "0" = 0 -- 壓倒的に頻出する
- read' s = read s
+httpVersionP = string "HTTP/"
+ >>
+ -- 頻出するので高速化
+ choice [ do string "1.0"
+ return $ HttpVersion 1 0
+ , do string "1.1"
+ return $ HttpVersion 1 1
+ -- 一般の場合
+ , do major <- many1 digit
+ char '.'
+ minor <- many1 digit
+ return $ HttpVersion (read major) (read minor)
+ ]
hPutHttpVersion :: Handle -> HttpVersion -> IO ()
-hPutHttpVersion h (HttpVersion maj min)
- = h `seq`
- do C8.hPut h (C8.pack "HTTP/")
- hPutStr h (show maj)
- hPutChar h '.'
- hPutStr h (show min)
\ No newline at end of file
+hPutHttpVersion !h !v
+ = case v of
+ -- 頻出するので高速化
+ HttpVersion 1 0 -> C8.hPut h (C8.pack "HTTP/1.0")
+ HttpVersion 1 1 -> C8.hPut h (C8.pack "HTTP/1.1")
+ -- 一般の場合
+ HttpVersion !maj !min
+ -> do C8.hPut h (C8.pack "HTTP/")
+ hPutStr h (show maj)
+ hPutChar h '.'
+ hPutStr h (show min)
--- #prune
+{-# OPTIONS_HADDOCK prune #-}
-- |Manipulation of MIME Types.
module Network.HTTP.Lucu.MIMEType
, char
, string
, (<|>)
+ , choice
, oneOf
, digit
, hexDigit
runParser g
+choice :: [Parser a] -> Parser a
+choice = foldl (<|>) failP
+
+
oneOf :: [Char] -> Parser Char
oneOf = foldl (<|>) failP . map char
--- #prune
+{-# OPTIONS_HADDOCK prune #-}
-- |Definition of things related on HTTP request.
--
requestReader :: Config -> ResTree -> [FallbackHandler] -> Handle -> SockAddr -> InteractionQueue -> IO ()
-requestReader cnf tree fbs h addr tQueue
- = cnf `seq` tree `seq` fbs `seq` h `seq` addr `seq` tQueue `seq`
- do catch (do input <- B.hGetContents h
- acceptRequest input) $ \ exc ->
- case exc of
- IOException _ -> return ()
- AsyncException ThreadKilled -> return ()
- BlockedIndefinitely -> putStrLn "requestReader: blocked indefinitely"
- _ -> print exc
+requestReader !cnf !tree !fbs !h !addr !tQueue
+ = do input <- B.hGetContents h
+ acceptRequest input
+ `catches`
+ [ Handler (( \ _ -> return () ) :: IOException -> IO ())
+ , Handler ( \ ThreadKilled -> return () )
+ , Handler ( \ BlockedIndefinitely -> hPutStrLn stderr "requestReader: blocked indefinitely" )
+ , Handler (( \ e -> hPutStrLn stderr (show e) ) :: SomeException -> IO ())
+ ]
where
acceptRequest :: ByteString -> IO ()
acceptRequest input
--- #prune
+{-# OPTIONS_HADDOCK prune #-}
-- |This is the Resource Monad; monadic actions to define the behavior
-- of each resources. The 'Resource' Monad is a kind of 'Prelude.IO'
--- #prune
+{-# OPTIONS_HADDOCK prune #-}
-- | Repository of the resources in httpd.
module Network.HTTP.Lucu.Resource.Tree
import Control.Exception
import Control.Monad
import qualified Data.ByteString.Char8 as C8
-import Data.Dynamic
import Data.List
import qualified Data.Map as M
import Data.Map (Map)
where
walkTree :: ResSubtree -> [String] -> [String] -> Maybe ([String], ResourceDef)
+ walkTree _ [] _
+ = error "Internal error: should not reach here."
+
walkTree tree (name:[]) soFar
= case M.lookup name tree of
Nothing -> Nothing
Just _ -> xs
Nothing -> []
- processException :: Exception -> IO ()
+ toAbortion :: SomeException -> Abortion
+ toAbortion e = case fromException e of
+ Just abortion -> abortion
+ Nothing -> Abortion InternalServerError emptyHeaders (Just (show e))
+
+ processException :: SomeException -> IO ()
processException exc
- = do let abo = case exc of
- ErrorCall msg -> Abortion InternalServerError emptyHeaders $ Just msg
- IOException ioE -> Abortion InternalServerError emptyHeaders $ Just $ formatIOE ioE
- DynException dynE -> case fromDynamic dynE of
- Just a
- -> a :: Abortion
- Nothing
- -> Abortion InternalServerError emptyHeaders
- $ Just $ show exc
- _ -> Abortion InternalServerError emptyHeaders $ Just $ show exc
+ = do let abo = toAbortion exc
conf = itrConfig itr
-- まだ DecidingHeader 以前の状態だったら、この途中終了
-- を應答に反映させる餘地がある。さうでなければ stderr
--- #prune
+{-# OPTIONS_HADDOCK prune #-}
-- |Definition of things related on HTTP response.
module Network.HTTP.Lucu.Response
responseWriter :: Config -> Handle -> InteractionQueue -> ThreadId -> IO ()
-responseWriter cnf h tQueue readerTID
- = cnf `seq` h `seq` tQueue `seq` readerTID `seq`
- catch awaitSomethingToWrite $ \ exc ->
- case exc of
- IOException _ -> return ()
- AsyncException ThreadKilled -> return ()
- BlockedIndefinitely -> putStrLn "requestWriter: blocked indefinitely"
- _ -> print exc
+responseWriter !cnf !h !tQueue !readerTID
+ = awaitSomethingToWrite
+ `catches`
+ [ Handler (( \ _ -> return () ) :: IOException -> IO ())
+ , Handler ( \ ThreadKilled -> return () )
+ , Handler ( \ BlockedIndefinitely -> hPutStrLn stderr "requestWriter: blocked indefinitely" )
+ , Handler (( \ e -> hPutStrLn stderr (show e) ) :: SomeException -> IO ())
+ ]
where
awaitSomethingToWrite :: IO ()
awaitSomethingToWrite