Fixed breakage on GHC 6.10.1

darcs-hash:20090116082617-62b54-32b25b00103053e2368fae94c1d31214b559a822.gz

diff --git a/ImplantFile.hs b/ImplantFile.hs
index 2fbab0052a62b746b6c64d1e6572b9eb6e56e0f8..ae749b9886c5a7422cd25bceb2137a83debb796f 100644 (file)
--- a/ImplantFile.hs
+++ b/ImplantFile.hs
@@ -106,7 +106,8 @@ generateHaskellSource opts srcFile
          output   <- openOutput opts
          eTag     <- getETag opts input
 
          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
              originalLen = L.length input
              gzippedLen  = L.length gzippedData
              useGZip     = originalLen > gzippedLen

diff --git a/Lucu.cabal b/Lucu.cabal
index a20a1b5a40c8442ed2c21453fd363e6149f3939a..3b8d53db30c9e167fa0e534b5d3272a8f27f394a 100644 (file)
--- 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.
         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>
 License: PublicDomain
 License-File: COPYING
 Author: PHO <pho at cielonegro dot org>


@@ -16,8 +16,8 @@ Maintainer: PHO <pho at cielonegro dot org>
 Stability: experimental
 Homepage: http://cielonegro.org/Lucu.html
 Category: Network
 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:
 Build-Type: Simple
 
 Extra-Source-Files:


@@ -69,7 +69,7 @@ Library
         Network.HTTP.Lucu.RequestReader
         Network.HTTP.Lucu.ResponseWriter
     Extensions:
         Network.HTTP.Lucu.RequestReader
         Network.HTTP.Lucu.ResponseWriter
     Extensions:

-        DeriveDataTypeable, UnboxedTuples
+        BangPatterns, DeriveDataTypeable, UnboxedTuples

     ghc-options:
         -Wall
         -funbox-strict-fields
     ghc-options:
         -Wall
         -funbox-strict-fields

diff --git a/Makefile b/Makefile
index 5cb2248eca3e1ca0cbef45191fc9f7b1d22d7c12..4f04f26ccafb1536242963637ab557181a660edb 100644 (file)
--- a/Makefile
+++ b/Makefile
@@ -21,7 +21,7 @@ clean:
        $(MAKE) -C examples clean
 
 doc: dist/setup-config Setup
        $(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
 
 install: build
        sudo ./Setup install

diff --git a/NEWS b/NEWS
index d32fdefd8cfddc92608349ae4dcadf31ac497833..7a38aafc642cae9c3c5b0f599fd6d1a70c65acf3 100644 (file)
--- 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
 * 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 dc33eb125bfda4027413bb5782aaac51b09cca8c..52e7e23d6047b2e0fb6d824fa500e1f393269414 100644 (file)
--- 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.
 
 -- |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)
 
     , 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.
 --
 -- |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
 --
 -- 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
 abort status headers msg
     = status `seq` headers `seq` msg `seq`
       let abo = Abortion status (toHeaders $ map pack headers) msg

-          exc = DynException (toDyn abo)

       in
       in

-        liftIO $ throwIO exc
+        liftIO $ throwIO abo

     where
       pack (x, y) = (C8.pack x, C8.pack y)
 
     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 b0b0e06c2d36deb8a7e66135976411eba5454375..5c3b9eec7229638f0ca5a1dcecc1336a5c415b3e 100644 (file)
--- 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
 
 -- |Manipulation of WWW authorization.
 module Network.HTTP.Lucu.Authorization

diff --git a/Network/HTTP/Lucu/ETag.hs b/Network/HTTP/Lucu/ETag.hs
index 158144cc5254677e59c5080d2636a80c7c6a3b2c..d607ad12db4d2fa22ec529a2f0456f9c7e4644f7 100644 (file)
--- 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
 
 -- |Manipulation of entity tags.
 module Network.HTTP.Lucu.ETag

diff --git a/Network/HTTP/Lucu/HttpVersion.hs b/Network/HTTP/Lucu/HttpVersion.hs
index e0694f151d97db6a1ff3ddd44fa4c4a0293faf1d..c988aab3dcd99776547f61cf8a09471c09918957 100644 (file)
--- 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
 
 -- |Manipulation of HTTP version string.
 module Network.HTTP.Lucu.HttpVersion


@@ -30,21 +30,30 @@ instance Ord HttpVersion where
 
 
 httpVersionP :: Parser 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 :: 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 a8f04377da6defab7c0ef546c7b969eabd43262f..e28238e53297237f633dc4bcca4f581f4f0f102f 100644 (file)
--- 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
 
 -- |Manipulation of MIME Types.
 module Network.HTTP.Lucu.MIMEType

diff --git a/Network/HTTP/Lucu/Parser.hs b/Network/HTTP/Lucu/Parser.hs
index 4bb8fa013e79f84d65aec51ec4c658d9ea461d6d..90c52696fbb4293e95849e5335758d7a255913bd 100644 (file)
--- a/Network/HTTP/Lucu/Parser.hs
+++ b/Network/HTTP/Lucu/Parser.hs
@@ -33,6 +33,7 @@ module Network.HTTP.Lucu.Parser
     , char
     , string
     , (<|>)
     , char
     , string
     , (<|>)

+    , choice

     , oneOf
     , digit
     , hexDigit
     , oneOf
     , digit
     , hexDigit


@@ -179,6 +180,10 @@ f <|> g
                                             runParser g
 
 
                                             runParser g
 
 

+choice :: [Parser a] -> Parser a
+choice = foldl (<|>) failP
+
+

 oneOf :: [Char] -> Parser Char
 oneOf = foldl (<|>) failP . map char
 
 oneOf :: [Char] -> Parser Char
 oneOf = foldl (<|>) failP . map char
 

diff --git a/Network/HTTP/Lucu/Request.hs b/Network/HTTP/Lucu/Request.hs
index 3fc0164ca167de1116504478e0363e6e421de1cb..c98a400c0748ba2c01aa7e9978791d470ccc8833 100644 (file)
--- 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.
 --
 
 -- |Definition of things related on HTTP request.
 --

diff --git a/Network/HTTP/Lucu/RequestReader.hs b/Network/HTTP/Lucu/RequestReader.hs
index c6cdc0e54198eee6f5bc1aaf49d24a03c30fcdaf..f6fa769cbadf04cc90d5eac6d3426f4de7835e51 100644 (file)
--- 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 :: 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
     where
       acceptRequest :: ByteString -> IO ()
       acceptRequest input

diff --git a/Network/HTTP/Lucu/Resource.hs b/Network/HTTP/Lucu/Resource.hs
index d3967edf8ab5224c7e08dd2e1285669223f26944..f1186b7170635c4a4d7181cf84da509b2b24e08a 100644 (file)
--- 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'
 
 -- |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 51c30b6908ac67e02bf178d02640f25b6489ad81..40a4150dc9fe1694cee60f55703f257c10032a0c 100644 (file)
--- 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
 
 -- | 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           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)
 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)
 
     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
       walkTree tree (name:[]) soFar
           = case M.lookup name tree of
               Nothing               -> Nothing


@@ -234,18 +236,14 @@ runResource def itr
                        Just _  -> xs
                        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
       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
                    conf = itrConfig itr
                -- まだ DecidingHeader 以前の状態だったら、この途中終了
                -- を應答に反映させる餘地がある。さうでなければ stderr

diff --git a/Network/HTTP/Lucu/Response.hs b/Network/HTTP/Lucu/Response.hs
index 8adf88a27ba207597d00d26403e440cd02b80358..326054214915d1df157723308094bd867b3521bf 100644 (file)
--- 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
 
 -- |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 830baa68eb05ae0944c2cb19a35a412d5a58f971..3ab4bda714fc37295a3f2992e854e4179518e722 100644 (file)
--- 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 :: 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 
     where
       awaitSomethingToWrite :: IO ()
       awaitSomethingToWrite