Lucu 0.1 → 0.2

raw patch · 17 files changed

+95/−71 lines, 17 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• ImplantFile.hs +2/−1
• Lucu.cabal +6/−5
• NEWS +8/−0
• Network/HTTP/Lucu/Abortion.hs +9/−6
• Network/HTTP/Lucu/Authorization.hs +1/−1
• Network/HTTP/Lucu/ETag.hs +1/−1
• Network/HTTP/Lucu/HttpVersion.hs +25/−16
• Network/HTTP/Lucu/MIMEType.hs +1/−1
• Network/HTTP/Lucu/MIMEType/DefaultExtensionMap.hs +4/−5
• Network/HTTP/Lucu/Parser.hs +5/−0
• Network/HTTP/Lucu/Request.hs +1/−1
• Network/HTTP/Lucu/RequestReader.hs +9/−9
• Network/HTTP/Lucu/Resource.hs +1/−1
• Network/HTTP/Lucu/Resource/Tree.hs +11/−13
• Network/HTTP/Lucu/Response.hs +1/−1
• Network/HTTP/Lucu/ResponseWriter.hs +8/−8
• data/mime.types +2/−2

@@ -106,7 +106,8 @@          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

@@ -7,8 +7,8 @@         used to create an efficient web-based application without         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 and so on.-Version: 0.1+        client filtering or such like.+Version: 0.2 License: PublicDomain License-File: COPYING Author: PHO <pho at cielonegro dot org>@@ -16,12 +16,13 @@ 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:     ImplantFile.hs+    NEWS     data/CompileMimeTypes.hs     data/mime.types     examples/HelloWorld.hs@@ -68,7 +69,7 @@         Network.HTTP.Lucu.RequestReader         Network.HTTP.Lucu.ResponseWriter     Extensions:-        DeriveDataTypeable, UnboxedTuples+        BangPatterns, DeriveDataTypeable, UnboxedTuples     ghc-options:         -Wall         -funbox-strict-fields

@@ -0,0 +1,8 @@+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+    - Added audio/x-wavpack+    - Added audio/x-wavpack-correction

@@ -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 @@     , 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 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) 

@@ -1,4 +1,4 @@--- #prune+{-# OPTIONS_HADDOCK prune #-}  -- |Manipulation of WWW authorization. module Network.HTTP.Lucu.Authorization

@@ -1,4 +1,4 @@--- #prune+{-# OPTIONS_HADDOCK prune #-}  -- |Manipulation of entity tags. module Network.HTTP.Lucu.ETag

@@ -1,4 +1,4 @@--- #prune+{-# OPTIONS_HADDOCK prune #-}  -- |Manipulation of HTTP version string. module Network.HTTP.Lucu.HttpVersion@@ -30,21 +30,30 @@   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)+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)

@@ -1,4 +1,4 @@--- #prune+{-# OPTIONS_HADDOCK prune #-}  -- |Manipulation of MIME Types. module Network.HTTP.Lucu.MIMEType

@@ -168,11 +168,10 @@        ("wmls", read "text/vnd.wap.wmlscript"),        ("wmlsc", read "application/vnd.wap.wmlscriptc"),        ("wmv", read "video/x-ms-asf"), ("wrl", read "model/vrml"),-       ("wv", read "application/x-wavpack"),-       ("wvc", read "application/x-wavpack-correction"),-       ("wvp", read "application/x-wavpack"),-       ("xbm", read "image/x-xbitmap"), ("xcf", read "image/x-xcf"),-       ("xht", read "application/xhtml+xml"),+       ("wv", read "audio/x-wavpack"),+       ("wvc", read "audio/x-wavpack-correction"),+       ("wvp", read "audio/x-wavpack"), ("xbm", read "image/x-xbitmap"),+       ("xcf", read "image/x-xcf"), ("xht", read "application/xhtml+xml"),        ("xhtml", read "application/xhtml+xml"),        ("xls", read "application/vnd.ms-excel"),        ("xm", read "audio/x-mod"), ("xml", read "application/xml"),

@@ -33,6 +33,7 @@     , char     , string     , (<|>)+    , choice     , oneOf     , digit     , hexDigit@@ -177,6 +178,10 @@                                      else                                          do put saved                                             runParser g+++choice :: [Parser a] -> Parser a+choice = foldl (<|>) failP   oneOf :: [Char] -> Parser Char

@@ -1,4 +1,4 @@--- #prune+{-# OPTIONS_HADDOCK prune #-}  -- |Definition of things related on HTTP request. --

@@ -28,15 +28,15 @@   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

@@ -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'

@@ -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.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 @@     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 @@                        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

@@ -1,4 +1,4 @@--- #prune+{-# OPTIONS_HADDOCK prune #-}  -- |Definition of things related on HTTP response. module Network.HTTP.Lucu.Response

@@ -22,14 +22,14 @@   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 

@@ -62,8 +62,6 @@ application/x-troff-me		me application/x-troff-ms		ms application/x-ustar		ustar-application/x-wavpack   wv wvp-application/x-wavpack-correction        wvc application/x-wais-source	src application/xhtml+xml		xhtml xht application/xslt+xml		xslt@@ -94,6 +92,8 @@ audio/x-voc                 voc audio/x-w64                 w64 audio/x-wav			wav+audio/x-wavpack   wv wvp+audio/x-wavpack-correction        wvc chemical/x-pdb			pdb chemical/x-xyz			xyz image/bmp			bmp