From: pho Date: Fri, 16 Jan 2009 08:26:17 +0000 (+0900) Subject: Fixed breakage on GHC 6.10.1 X-Git-Tag: RELEASE-0_2_1~3 X-Git-Url: http://git.cielonegro.org/gitweb.cgi?p=Lucu.git;a=commitdiff_plain;h=1196f43ecedbb123515065f0440844864af906fb Fixed breakage on GHC 6.10.1 darcs-hash:20090116082617-62b54-32b25b00103053e2368fae94c1d31214b559a822.gz --- diff --git a/ImplantFile.hs b/ImplantFile.hs index 2fbab00..ae749b9 100644 --- a/ImplantFile.hs +++ b/ImplantFile.hs @@ -106,7 +106,8 @@ generateHaskellSource opts srcFile 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 diff --git a/Lucu.cabal b/Lucu.cabal index a20a1b5..3b8d53d 100644 --- a/Lucu.cabal +++ b/Lucu.cabal @@ -8,7 +8,7 @@ Description: 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 @@ -16,8 +16,8 @@ Maintainer: PHO 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: @@ -69,7 +69,7 @@ Library Network.HTTP.Lucu.RequestReader Network.HTTP.Lucu.ResponseWriter Extensions: - DeriveDataTypeable, UnboxedTuples + BangPatterns, DeriveDataTypeable, UnboxedTuples ghc-options: -Wall -funbox-strict-fields diff --git a/Makefile b/Makefile index 5cb2248..4f04f26 100644 --- a/Makefile +++ b/Makefile @@ -21,7 +21,7 @@ clean: $(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 diff --git a/NEWS b/NEWS index d32fdef..7a38aaf 100644 --- a/NEWS +++ b/NEWS @@ -1,5 +1,6 @@ -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 diff --git a/Network/HTTP/Lucu/Abortion.hs b/Network/HTTP/Lucu/Abortion.hs index dc33eb1..52e7e23 100644 --- a/Network/HTTP/Lucu/Abortion.hs +++ b/Network/HTTP/Lucu/Abortion.hs @@ -1,4 +1,4 @@ --- #prune +{-# OPTIONS_HADDOCK prune #-} -- |Aborting the computation of 'Network.HTTP.Lucu.Resource.Resource' -- in any 'Prelude.IO' monads or arrows. @@ -38,13 +38,17 @@ data Abortion = Abortion { , 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 @@ -66,9 +70,8 @@ abort :: MonadIO m => StatusCode -> [ (String, String) ] -> Maybe String -> m a 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) diff --git a/Network/HTTP/Lucu/Authorization.hs b/Network/HTTP/Lucu/Authorization.hs index b0b0e06..5c3b9ee 100644 --- a/Network/HTTP/Lucu/Authorization.hs +++ b/Network/HTTP/Lucu/Authorization.hs @@ -1,4 +1,4 @@ --- #prune +{-# OPTIONS_HADDOCK prune #-} -- |Manipulation of WWW authorization. module Network.HTTP.Lucu.Authorization diff --git a/Network/HTTP/Lucu/ETag.hs b/Network/HTTP/Lucu/ETag.hs index 158144c..d607ad1 100644 --- a/Network/HTTP/Lucu/ETag.hs +++ b/Network/HTTP/Lucu/ETag.hs @@ -1,4 +1,4 @@ --- #prune +{-# OPTIONS_HADDOCK prune #-} -- |Manipulation of entity tags. module Network.HTTP.Lucu.ETag diff --git a/Network/HTTP/Lucu/HttpVersion.hs b/Network/HTTP/Lucu/HttpVersion.hs index e0694f1..c988aab 100644 --- a/Network/HTTP/Lucu/HttpVersion.hs +++ b/Network/HTTP/Lucu/HttpVersion.hs @@ -1,4 +1,4 @@ --- #prune +{-# OPTIONS_HADDOCK prune #-} -- |Manipulation of HTTP version string. module Network.HTTP.Lucu.HttpVersion @@ -30,21 +30,30 @@ instance Ord HttpVersion where 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) diff --git a/Network/HTTP/Lucu/MIMEType.hs b/Network/HTTP/Lucu/MIMEType.hs index a8f0437..e28238e 100644 --- a/Network/HTTP/Lucu/MIMEType.hs +++ b/Network/HTTP/Lucu/MIMEType.hs @@ -1,4 +1,4 @@ --- #prune +{-# OPTIONS_HADDOCK prune #-} -- |Manipulation of MIME Types. module Network.HTTP.Lucu.MIMEType diff --git a/Network/HTTP/Lucu/Parser.hs b/Network/HTTP/Lucu/Parser.hs index 4bb8fa0..90c5269 100644 --- a/Network/HTTP/Lucu/Parser.hs +++ b/Network/HTTP/Lucu/Parser.hs @@ -33,6 +33,7 @@ module Network.HTTP.Lucu.Parser , char , string , (<|>) + , choice , oneOf , digit , hexDigit @@ -179,6 +180,10 @@ f <|> g runParser g +choice :: [Parser a] -> Parser a +choice = foldl (<|>) failP + + oneOf :: [Char] -> Parser Char oneOf = foldl (<|>) failP . map char diff --git a/Network/HTTP/Lucu/Request.hs b/Network/HTTP/Lucu/Request.hs index 3fc0164..c98a400 100644 --- a/Network/HTTP/Lucu/Request.hs +++ b/Network/HTTP/Lucu/Request.hs @@ -1,4 +1,4 @@ --- #prune +{-# OPTIONS_HADDOCK prune #-} -- |Definition of things related on HTTP request. -- diff --git a/Network/HTTP/Lucu/RequestReader.hs b/Network/HTTP/Lucu/RequestReader.hs index c6cdc0e..f6fa769 100644 --- a/Network/HTTP/Lucu/RequestReader.hs +++ b/Network/HTTP/Lucu/RequestReader.hs @@ -28,15 +28,15 @@ import System.IO 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 diff --git a/Network/HTTP/Lucu/Resource.hs b/Network/HTTP/Lucu/Resource.hs index d3967ed..f1186b7 100644 --- a/Network/HTTP/Lucu/Resource.hs +++ b/Network/HTTP/Lucu/Resource.hs @@ -1,4 +1,4 @@ --- #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' diff --git a/Network/HTTP/Lucu/Resource/Tree.hs b/Network/HTTP/Lucu/Resource/Tree.hs index 51c30b6..40a4150 100644 --- a/Network/HTTP/Lucu/Resource/Tree.hs +++ b/Network/HTTP/Lucu/Resource/Tree.hs @@ -1,4 +1,4 @@ --- #prune +{-# OPTIONS_HADDOCK prune #-} -- | Repository of the resources in httpd. module Network.HTTP.Lucu.Resource.Tree @@ -18,7 +18,6 @@ import Control.Concurrent.STM 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) @@ -166,6 +165,9 @@ findResource (ResTree (ResNode rootDefM subtree)) fbs uri 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 @@ -234,18 +236,14 @@ runResource def itr 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 diff --git a/Network/HTTP/Lucu/Response.hs b/Network/HTTP/Lucu/Response.hs index 8adf88a..3260542 100644 --- a/Network/HTTP/Lucu/Response.hs +++ b/Network/HTTP/Lucu/Response.hs @@ -1,4 +1,4 @@ --- #prune +{-# OPTIONS_HADDOCK prune #-} -- |Definition of things related on HTTP response. module Network.HTTP.Lucu.Response diff --git a/Network/HTTP/Lucu/ResponseWriter.hs b/Network/HTTP/Lucu/ResponseWriter.hs index 830baa6..3ab4bda 100644 --- a/Network/HTTP/Lucu/ResponseWriter.hs +++ b/Network/HTTP/Lucu/ResponseWriter.hs @@ -22,14 +22,14 @@ import System.IO 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