]> gitweb @ CieloNegro.org - Lucu.git/commitdiff
The library now compiles, and I'm now working on ImplantFile.hs
authorPHO <pho@cielonegro.org>
Wed, 12 Oct 2011 18:01:43 +0000 (03:01 +0900)
committerPHO <pho@cielonegro.org>
Wed, 12 Oct 2011 18:01:43 +0000 (03:01 +0900)
Ditz-issue: 8959dadc07db1bd363283dee401073f6e48dc7fa

16 files changed:
ImplantFile.hs
Lucu.cabal
Network/HTTP/Lucu.hs
Network/HTTP/Lucu/Abortion.hs
Network/HTTP/Lucu/Authorization.hs
Network/HTTP/Lucu/ETag.hs
Network/HTTP/Lucu/Format.hs [deleted file]
Network/HTTP/Lucu/Interaction.hs
Network/HTTP/Lucu/MIMEType.hs
Network/HTTP/Lucu/MIMEType/Guess.hs
Network/HTTP/Lucu/RequestReader.hs
Network/HTTP/Lucu/Resource.hs
Network/HTTP/Lucu/Resource/Tree.hs
Network/HTTP/Lucu/ResponseWriter.hs
data/Makefile
examples/Makefile

index fd57fadc456023ef5e78eee0b018098b12cada39..b95c45508cd23d11a134451081edd61c4de45a42 100644 (file)
@@ -1,28 +1,34 @@
-import           Codec.Compression.GZip
-import           Control.Monad
-import           Data.Bits
-import qualified Data.ByteString as BS
+{-# LANGUAGE
+    UnicodeSyntax
+  #-}
+module Main where
+import Codec.Compression.GZip
+import Control.Applicative
+import Control.Monad
+import qualified Data.Ascii as A
+import Data.Bits
 import qualified Data.ByteString.Base64 as B64
-import qualified Data.ByteString.Char8 as C8
-import qualified Data.ByteString.Lazy as Lazy (ByteString)
-import qualified Data.ByteString.Lazy as LS hiding (ByteString)
-import           Data.Char
-import           Data.Int
-import           Data.Maybe
-import           Data.Time
-import           Data.Time.Clock.POSIX
-import           Language.Haskell.Pretty
-import           Language.Haskell.Syntax
-import           Network.HTTP.Lucu.MIMEType
-import           Network.HTTP.Lucu.MIMEType.DefaultExtensionMap
-import           Network.HTTP.Lucu.MIMEType.Guess
-import           OpenSSL
-import           OpenSSL.EVP.Digest
-import           System.Console.GetOpt
-import           System.Environment
-import           System.Exit
-import           System.Posix.Files
-import           System.IO
+import qualified Data.ByteString.Char8 as Strict
+import qualified Data.ByteString.Lazy as Lazy
+import Data.Char
+import Data.Int
+import Data.Maybe
+import Data.Time
+import Data.Time.Clock.POSIX
+import Language.Haskell.Exts.Build
+import Language.Haskell.Exts.Extension
+import Language.Haskell.Exts.Pretty
+import Language.Haskell.Exts.Syntax
+import Network.HTTP.Lucu.ETag
+import Network.HTTP.Lucu.MIMEType
+import Network.HTTP.Lucu.MIMEType.DefaultExtensionMap
+import Network.HTTP.Lucu.MIMEType.Guess
+import Prelude.Unicode
+import System.Console.GetOpt
+import System.Environment
+import System.Exit
+import System.Posix.Files
+import System.IO
 
 data CmdOpt
     = OptOutput FilePath
@@ -33,8 +39,7 @@ data CmdOpt
     | OptHelp
     deriving (Eq, Show)
 
-
-options :: [OptDescr CmdOpt]
+options ∷ [OptDescr CmdOpt]
 options = [ Option ['o'] ["output"]
                        (ReqArg OptOutput "FILE")
                        "Output to the FILE."
@@ -60,112 +65,88 @@ options = [ Option ['o'] ["output"]
                        "Print this message."
           ]
 
-
-printUsage :: IO ()
-printUsage = do putStrLn ""
-                putStrLn "Description:"
-                putStrLn ("  lucu-implant-file is an utility that generates " ++
-                          "Haskell code containing an arbitrary file to " ++
-                          "compile it directly into programs and serve it " ++
-                          "statically with the Lucu HTTP server.")
-                putStrLn ""
-                putStrLn "Usage:"
-                putStrLn "  lucu-implant-file [OPTIONS...] FILE"
-                putStrLn ""
+printUsage ∷ IO ()
+printUsage = do mapM_ putStrLn msg
                 putStr $ usageInfo "Options:" options
                 putStrLn ""
+    where
+      msg = [ ""
+            , "Description:"
+            , concat [ "  lucu-implant-file is an utility that generates " 
+                     , "Haskell code containing an arbitrary file to "
+                     , "compile it directly into programs and serve it "
+                     , "statically with the Lucu HTTP server."
+                     ]
+            , ""
+            , "Usage:"
+            , "  lucu-implant-file [OPTIONS...] FILE"
+            , ""
+            ]
 
-
-main :: IO ()
-main = withOpenSSL $
-       do (opts, sources, errors) <- return . getOpt Permute options =<< getArgs
+main ∷ IO ()
+main = do (opts, sources, errors) ← getOpt Permute options <$> getArgs
 
           unless (null errors)
-                   $ do mapM_ putStr errors
-                        exitWith $ ExitFailure 1
+              $ do mapM_ putStr errors
+                   exitWith $ ExitFailure 1
 
-          when (any (== OptHelp) opts)
-                   $ do printUsage
-                        exitWith ExitSuccess
+          when (any ( OptHelp) opts)
+              $ do printUsage
+                   exitWith ExitSuccess
 
           when (null sources)
-                   $ do printUsage
-                        exitWith $ ExitFailure 1
+               $ do printUsage
+                    exitWith $ ExitFailure 1
 
-          when (length sources >= 2)
-                   $ error "too many input files."
+          when (length sources  2)
+               $ error "too many input files."
 
           generateHaskellSource opts (head sources)
 
-
-generateHaskellSource :: [CmdOpt] -> FilePath -> IO ()
+generateHaskellSource ∷ [CmdOpt] → FilePath → IO ()
 generateHaskellSource opts srcFile
-    = do modName  <- getModuleName opts
-         symName  <- getSymbolName opts modName
-         mimeType <- getMIMEType opts srcFile
-         lastMod  <- getLastModified srcFile
-         input    <- openInput srcFile
-         output   <- openOutput opts
-         eTag     <- getETag opts input
+    = do modName   getModuleName opts
+         symName   getSymbolName opts modName
+         mimeType  getMIMEType opts srcFile
+         lastMod   getLastModified srcFile
+         input     openInput srcFile
+         output    openOutput opts
+         eTag      getETag opts input
 
          let compParams  = defaultCompressParams { compressLevel = bestCompression }
              gzippedData = compressWith compParams input
-             originalLen = LS.length input
-             gzippedLen  = LS.length gzippedData
+             originalLen = Lazy.length input
+             gzippedLen  = Lazy.length gzippedData
              useGZip     = originalLen > gzippedLen
-             rawB64      = B64.encode $ BS.concat $ LS.toChunks input
-             gzippedB64  = B64.encode $ BS.concat $ LS.toChunks gzippedData
-
-         header <- mkHeader srcFile originalLen gzippedLen useGZip mimeType eTag lastMod
-             
-         let hsModule = HsModule undefined (Module modName) (Just exports) imports decls
-             exports  = [HsEVar (UnQual (HsIdent symName))]
-             imports  = [ HsImportDecl undefined (Module "Data.ByteString.Base64")
-                                       True (Just (Module "B64")) Nothing
-                        , HsImportDecl undefined (Module "Data.ByteString.Char8")
-                                       True (Just (Module "C8")) Nothing
-                        , HsImportDecl undefined (Module "Data.ByteString.Lazy")
-                                       True (Just (Module "LS")) Nothing
-                        , HsImportDecl undefined (Module "Data.Time")
-                                       False Nothing Nothing
-                        , HsImportDecl undefined (Module "Network.HTTP.Lucu")
-                                       False Nothing Nothing
-                        ]
-                        ++
-                        (if useGZip then
-                             [ HsImportDecl undefined (Module "Control.Monad")
-                                            False Nothing Nothing
-                             , HsImportDecl undefined (Module "Codec.Compression.GZip")
-                                            False Nothing Nothing
-                             ]
-                         else
-                             [])
-             decls    = declResourceDef
-                        ++
-                        declEntityTag
-                        ++
-                        declLastModified
-                        ++
-                        declContentType
-                        ++
-                        (if useGZip
-                         then declGZippedData
-                         else declRawData)
-
-             declResourceDef :: [HsDecl]
+             rawB64      = B64.encode <$> Lazy.toChunks input
+             gzippedB64  = B64.encode <$> Lazy.toChunks gzippedData
+
+         header ← mkHeader srcFile originalLen gzippedLen useGZip mimeType eTag lastMod
+
+         let hsModule = mkModule (ModuleName modName) (name symName) imports decls
+             imports  = mkImports useGZip
+             decls    = concat [ declResourceDef
+                               , entityTagDecl eTag
+                               , lastModifiedDecl lastMod
+                               , contentTypeDecl mimeType
+                               , if useGZip then
+                                     dataDecl (name "gzippedData") gzippedB64
+                                 else
+                                     dataDecl (name "rawData") rawB64
+                               ]
              declResourceDef
-                 = [ HsTypeSig undefined [HsIdent symName]
+                 = [ HsTypeSig (⊥) [HsIdent symName]
                                (HsQualType []
                                 (HsTyCon (UnQual (HsIdent "ResourceDef"))))
-                   , HsFunBind [HsMatch undefined (HsIdent symName)
+                   , HsFunBind [HsMatch (⊥) (HsIdent symName)
                                 [] (HsUnGuardedRhs defResourceDef) []]
                    ]
 
-             defResourceDef :: HsExp
+             defResourceDef  HsExp
              defResourceDef 
                  = let defResGet = if useGZip
                                    then defResGetGZipped
-                                   else defResGetRaw
+                                   else resGetRaw
                    in 
                      (HsRecConstr (UnQual (HsIdent "ResourceDef"))
                       [ HsFieldUpdate (UnQual (HsIdent "resUsesNativeThread"))
@@ -184,22 +165,15 @@ generateHaskellSource opts srcFile
                       ]
                      )
 
-             defResGetGZipped :: HsExp
+             defResGetGZipped  HsExp
              defResGetGZipped
-                 = let doExp = HsDo [ doFoundEntity
-                                    , doSetContentType
+                 = let doExp = HsDo [ foundEntityStmt
+                                    , setContentTypeStmt
                                     , bindMustGunzip
                                     , doConditionalOutput
                                     ]
-                       doFoundEntity
-                           = HsQualifier (HsApp (HsApp (HsVar (UnQual (HsIdent "foundEntity")))
-                                                 (HsVar (UnQual (HsIdent "entityTag"))))
-                                          (HsVar (UnQual (HsIdent "lastModified"))))
-                       doSetContentType
-                           = HsQualifier (HsApp (HsVar (UnQual (HsIdent "setContentType")))
-                                          (HsVar (UnQual (HsIdent "contentType"))))
                        bindMustGunzip
-                           = HsGenerator undefined
+                           = HsGenerator (⊥)
                              (HsPVar (HsIdent "mustGunzip"))
                              (HsApp (HsApp (HsVar (UnQual (HsIdent "liftM")))
                                      (HsVar (UnQual (HsIdent "not"))))
@@ -217,128 +191,154 @@ generateHaskellSource opts srcFile
                                (HsApp (HsVar (UnQual (HsIdent "decompress")))
                                       (HsVar (UnQual (HsIdent "gzippedData"))))))
                        expOutputGZipped
-                           = HsDo [ doSetContentEncodingGZip
-                                  , doOutputGZipped
+                           = HsDo [ setContentEncodingGZipStmt
+                                  , outputStmt (var $ name "gzippedData")
                                   ]
-                       doSetContentEncodingGZip
-                           = HsQualifier (HsApp (HsVar (UnQual (HsIdent "setContentEncoding")))
-                                          (HsList [HsLit (HsString "gzip")]))
-                       doOutputGZipped
-                           = HsQualifier (HsApp (HsVar (UnQual (HsIdent "outputLBS")))
-                                          (HsVar (UnQual (HsIdent "gzippedData"))))
                    in 
                      HsApp (HsCon (UnQual (HsIdent "Just")))
                            (HsParen doExp)
 
-             defResGetRaw :: HsExp
-             defResGetRaw
-                 = let doExp = HsDo [ doFoundEntity
-                                    , doSetContentType
-                                    , doOutputRawData
-                                    ]
-                       doFoundEntity
-                           = HsQualifier (HsApp (HsApp (HsVar (UnQual (HsIdent "foundEntity")))
-                                                 (HsVar (UnQual (HsIdent "entityTag"))))
-                                          (HsVar (UnQual (HsIdent "lastModified"))))
-                       doSetContentType
-                           = HsQualifier (HsApp (HsVar (UnQual (HsIdent "setContentType")))
-                                          (HsVar (UnQual (HsIdent "contentType"))))
-                       doOutputRawData
-                           = HsQualifier (HsApp (HsVar (UnQual (HsIdent "outputLBS")))
-                                          (HsVar (UnQual (HsIdent "rawData"))))
-                   in
-                     HsApp (HsCon (UnQual (HsIdent "Just")))
-                           (HsParen doExp)
-
-             declEntityTag :: [HsDecl]
-             declEntityTag
-                 = [ HsTypeSig undefined [HsIdent "entityTag"]
-                               (HsQualType []
-                                (HsTyCon (UnQual (HsIdent "ETag"))))
-                   , HsFunBind [HsMatch undefined (HsIdent "entityTag")
-                                [] (HsUnGuardedRhs defEntityTag) []]
-                   ]
-
-             defEntityTag :: HsExp
-             defEntityTag
-                 = HsApp (HsVar (UnQual (HsIdent "strongETag")))
-                   (HsLit (HsString eTag))
-
-             declLastModified :: [HsDecl]
-             declLastModified
-                 = [ HsTypeSig undefined [HsIdent "lastModified"]
-                               (HsQualType []
-                                (HsTyCon (UnQual (HsIdent "UTCTime"))))
-                   , HsFunBind [HsMatch undefined (HsIdent "lastModified")
-                                [] (HsUnGuardedRhs defLastModified) []]
-                   ]
+         hPutStrLn output header
+         hPutStrLn output (prettyPrint hsModule)
+         hClose output
 
-             defLastModified :: HsExp
-             defLastModified 
-                 = HsApp (HsVar (UnQual (HsIdent "read")))
-                   (HsLit (HsString $ show lastMod))
-                            
+mkModule ∷ ModuleName → Name → [ImportDecl] → [Decl]
+mkModule modName symName imports decls
+    = let modPragma = [ LanguagePragma (⊥) [ name (show OverloadedStrings)
+                                           ]
+                      ]
+          exports   = [ EVar (UnQual symName)
+                      ]
+      in
+        Module (⊥) modName modPragma Nothing (Just exports) imports decls
+
+mkImports ∷ Bool → [ImportDecl]
+mkImports useGZip
+    = [ ImportDecl (⊥) (ModuleName "Data.ByteString.Base64")
+                   True False (Just (ModuleName "B64")) Nothing
+      , ImportDecl (⊥) (ModuleName "Data.ByteString.Lazy")
+                   True False (Just (ModuleName "Lazy")) Nothing
+      , ImportDecl (⊥) (ModuleName "Data.Time")
+                   False False Nothing Nothing
+      , ImportDecl (⊥) (ModuleName "Network.HTTP.Lucu")
+                   False False Nothing Nothing
+      ]
+      ⧺
+      if useGZip then
+          [ ImportDecl (⊥) (ModuleName "Codec.Compression.GZip")
+                       False False Nothing Nothing
+          ]
+      else
+          []
+
+resHead ∷ Exp
+resHead
+    = infixApp (var $ name "Just")
+               (op  $ name "$"   )
+               (doE [ foundEntityStmt
+                    , setContentTypeStmt
+                    ])
+
+resGetRaw ∷ Exp
+resGetRaw
+    = infixApp (var $ name "Just")
+               (op  $ name "$"   )
+               (doE [ foundEntityStmt
+                    , setContentTypeStmt
+                    , outputStmt (var $ name "rawData")
+                    ])
+
+setContentEncodingGZipStmt ∷ Stmt
+setContentEncodingGZipStmt
+    = qualStmt $
+      metaFunction "setContentEncoding" $
+      [ listE [ strE "gzip" ] ]
+
+foundEntityStmt ∷ Stmt
+foundEntityStmt
+    = qualStmt $
+      metaFunction "foundEntity" $
+      [ var $ name "entityTag"
+      , var $ name "lastModified"
+      ]
+
+setContentTypeStmt ∷ Stmt
+setContentTypeStmt
+    = qualStmt $
+      metaFunction "setContentType" $
+      [var $ name "contentType"]
+
+outputStmt ∷ Exp → Stmt
+outputStmt e
+    = qualStmt $
+      metaFunction "output" [e]
+
+entityTagDecl ∷ ETag → [Decl]
+entityTagDecl eTag
+    = [ TypeSig (⊥) [varName] (TyCon (UnQual (name "ETag")))
+      , nameBind (⊥) varName valExp
+      ]
+    where
+      varName ∷ Name
+      varName = name "entityTag"
 
-             declContentType :: [HsDecl]
-             declContentType 
-                 = [ HsTypeSig undefined [HsIdent "contentType"]
-                               (HsQualType []
-                                (HsTyCon (UnQual (HsIdent "MIMEType"))))
-                   , HsFunBind [HsMatch undefined (HsIdent "contentType")
-                                [] (HsUnGuardedRhs defContentType) []]
-                   ]
+      valExp ∷ Exp
+      valExp = metaFunction "parseETag" [strE $ eTagToString eTag]
 
-             defContentType :: HsExp
-             defContentType
-                 = HsApp (HsVar (UnQual (HsIdent "read")))
-                   (HsLit (HsString $ show mimeType))
+      eTagToString ∷ ETag → String
+      eTagToString = A.toString ∘ A.fromAsciiBuilder ∘ printETag
 
-             declGZippedData :: [HsDecl]
-             declGZippedData 
-                 = [ HsTypeSig undefined [HsIdent "gzippedData"]
-                               (HsQualType []
-                                (HsTyCon (Qual (Module "LS") (HsIdent "ByteString"))))
-                   , HsFunBind [HsMatch undefined (HsIdent "gzippedData")
-                                [] (HsUnGuardedRhs defGZippedData) []]
-                   ]
+lastModifiedDecl ∷ UTCTime → [Decl]
+lastModifiedDecl lastMod
+    = [ TypeSig (⊥) [varName] (TyCon (UnQual (name "UTCTime")))
+      , nameBind (⊥) varName valExp
+      ]
+    where
+      varName ∷ Name
+      varName = name "lastModified"
 
-             defGZippedData :: HsExp
-             defGZippedData 
-                 = HsApp (HsVar (Qual (Module "LS") (HsIdent "fromChunks")))
-                   (HsList [HsApp (HsVar (Qual (Module "B64") (HsIdent "decodeLenient")))
-                            (HsParen
-                             (HsApp (HsVar (Qual (Module "C8") (HsIdent "pack")))
-                              (HsLit (HsString $ C8.unpack gzippedB64))))])
-
-             declRawData :: [HsDecl]
-             declRawData 
-                 = [ HsTypeSig undefined [HsIdent "rawData"]
-                               (HsQualType []
-                                (HsTyCon (Qual (Module "LS") (HsIdent "ByteString"))))
-                   , HsFunBind [HsMatch undefined (HsIdent "rawData")
-                                [] (HsUnGuardedRhs defRawData) []]
-                   ]
+      valExp ∷ Exp
+      valExp = metaFunction "read" [strE $ show lastMod]
 
-             defRawData :: HsExp
-             defRawData
-                 = HsApp (HsVar (Qual (Module "LS") (HsIdent "fromChunks")))
-                   (HsList [HsApp (HsVar (Qual (Module "B64") (HsIdent "decodeLenient")))
-                            (HsParen
-                             (HsApp (HsVar (Qual (Module "C8") (HsIdent "pack")))
-                              (HsLit (HsString $ C8.unpack rawB64))))])
+contentTypeDecl ∷ MIMEType → [Decl]
+contentTypeDecl mime
+    = [ TypeSig (⊥) [varName] (TyCon (UnQual (name "MIMEType")))
+      , nameBind (⊥) varName valExp
+      ]
+    where
+      varName ∷ Name
+      varName = name "contentType"
 
-         hPutStrLn output header
-         hPutStrLn output (prettyPrint hsModule)
-         hClose output
+      valExp ∷ Exp
+      valExp = metaFunction "parseMIMEType" [mimeToString mime]
 
+      mimeToString ∷ MIMEType → String
+      mimeToString = A.toString ∘ A.fromAsciiBuilder ∘ printMIMEType
 
-mkHeader :: FilePath -> Int64 -> Int64 -> Bool -> MIMEType -> String -> UTCTime -> IO String
+dataDecl ∷ Name → [Strict.ByteString] → [Decl]
+dataDecl varName chunks
+    = [ TypeSig (⊥) [varName] (TyCon (Qual (ModuleName "Lazy") (name "ByteString")))
+      , nameBind (⊥) varName valExp
+      ]
+    where
+      valExp ∷ Exp
+      valExp = qvar (ModuleName "Lazy") (name "fromChunks")
+               `app`
+               listE (chunkToExp <$> chunks)
+
+      chunkToExp ∷ Strict.ByteString → Exp
+      chunkToExp chunk
+          = qvar (ModuleName "B64") (name "decodeLenient")
+            `app`
+            strE (Strict.unpack chunk)
+
+mkHeader ∷ FilePath → Int64 → Int64 → Bool → MIMEType → String → UTCTime → IO String
 mkHeader srcFile originalLen gzippedLen useGZip mimeType eTag lastMod
-    = do localLastMod <- utcToLocalZonedTime lastMod
+    = do localLastMod  utcToLocalZonedTime lastMod
          return ("{- DO NOT EDIT THIS FILE.\n" ++
                  "   This file is automatically generated by the lucu-implant-file program.\n" ++
                  "\n" ++
-                 "              Source: " ++ (if srcFile == "-"
+                 "              Source: " ++ (if srcFile  "-"
                                               then "(stdin)"
                                               else srcFile) ++ "\n" ++
                  "     Original Length: " ++ show originalLen ++ " bytes\n" ++
@@ -352,104 +352,111 @@ mkHeader srcFile originalLen gzippedLen useGZip mimeType eTag lastMod
                  " -}")
 
 
-getModuleName :: [CmdOpt] -> IO String
+getModuleName ∷ [CmdOpt] → IO String
 getModuleName opts
-    = let modNameOpts = filter (\ x -> case x of
-                                         OptModName _ -> True
-                                         _            -> False) opts
+    = let modNameOpts = filter (\ x  case x of
+                                         OptModName _  True
+                                         _             False) opts
       in
         case modNameOpts of
-          []                      -> error "a module name must be given."
-          (OptModName modName):[] -> return modName
-          _                       -> error "too many --module options."
+          []                       error "a module name must be given."
+          (OptModName modName):[]  return modName
+          _                        error "too many --module options."
 
 
-getSymbolName :: [CmdOpt] -> String -> IO String
+getSymbolName ∷ [CmdOpt] → String → IO String
 getSymbolName opts modName
-    = let symNameOpts    = filter (\ x -> case x of
-                                            OptSymName _ -> True
-                                            _            -> False) opts
+    = let symNameOpts    = filter (\ x  case x of
+                                            OptSymName _  True
+                                            _             False) opts
           -- モジュール名をピリオドで分割した時の最後の項目の先頭文字を
           -- 小文字にしたものを使ふ。
           defaultSymName  = mkDefault modName
-          mkDefault       = headToLower . getLastComp
+          mkDefault       = headToLower  getLastComp
           headToLower str = case str of
-                              []     -> error "module name must not be empty"
-                              (x:xs) -> toLower x : xs
-          getLastComp     = reverse . fst . break (== '.') . reverse
+                              []      error "module name must not be empty"
+                              (x:xs)  toLower x : xs
+          getLastComp     = reverse ∘ fst ∘ break (≡ '.') ∘ reverse
       in
         case symNameOpts of
-          []                      -> return defaultSymName
-          (OptSymName symName):[] -> return symName
-          _                       -> error "too many --symbol options."
+          []                       return defaultSymName
+          (OptSymName symName):[]  return symName
+          _                        error "too many --symbol options."
 
 
-getMIMEType :: [CmdOpt] -> FilePath -> IO MIMEType
+getMIMEType ∷ [CmdOpt] → FilePath → IO MIMEType
 getMIMEType opts srcFile
-    = let mimeTypeOpts = filter (\ x -> case x of
-                                          OptMIMEType _ -> True
-                                          _             -> False) opts
-          defaultType  = fromMaybe (read "application/octet-stream")
-                         $ guessTypeByFileName defaultExtensionMap srcFile
-      in
-        case mimeTypeOpts of
-          []                        -> return defaultType
-          (OptMIMEType mimeType):[] -> return $ read mimeType
-          _                         -> error "too many --mime-type options."
+    = case mimeTypeOpts of
+        []                  → return defaultType
+        (OptMIMEType ty):[] → return $ read ty
+        _                   → error "too many --mime-type options."
+    where
+      mimeTypeOpts ∷ [CmdOpt]
+      mimeTypeOpts
+          = filter (\ x → case x of
+                             OptMIMEType _ → True
+                             _             → False) opts
+
+      octetStream ∷ MIMEType
+      octetStream = parseMIMEType "application/octet-stream"
+
+      defaultType ∷ MIMEType
+      defaultType = fromMaybe octetStream
+                    $ guessTypeByFileName defaultExtensionMap srcFile
 
 
-getLastModified :: FilePath -> IO UTCTime
+getLastModified ∷ FilePath → IO UTCTime
 getLastModified "-"   = getCurrentTime
-getLastModified fpath = fmap (posixSecondsToUTCTime . fromRational . toRational . modificationTime)
-                        $ getFileStatus fpath
+getLastModified fpath = (posixSecondsToUTCTime ∘ fromRational ∘ toRational ∘ modificationTime)
+                        <$>
+                        getFileStatus fpath
 
 
-getETag :: [CmdOpt] -> Lazy.ByteString -> IO String
+getETag ∷ [CmdOpt] → Lazy.ByteString → IO String
 getETag opts input
-    = let eTagOpts = filter (\ x -> case x of
-                                      OptETag _ -> True
-                                      _         -> False) opts
+    = let eTagOpts = filter (\ x  case x of
+                                      OptETag _  True
+                                      _          False) opts
       in
         case eTagOpts of
-          []               -> fmap (mkETagFromInput . fromJust) (getDigestByName "SHA1")
-          (OptETag str):[] -> return str
-          _                -> error "too many --etag options."
+          []               → fmap (mkETagFromInput ∘ fromJust) (getDigestByName "SHA1")
+          (OptETag str):[]  return str
+          _                 error "too many --etag options."
     where
-      mkETagFromInput :: Digest -> String
+      mkETagFromInput ∷ Digest → String
       mkETagFromInput sha1 = "SHA-1:" ++ toHex (digestLBS sha1 input)
 
-      toHex :: String -> String
-      toHex = foldr ((++) . hexByte . fromEnum) ""
+      toHex ∷ String → String
+      toHex = foldr ((++) ∘ hexByte ∘ fromEnum) ""
 
-      hexByte :: Int -> String
+      hexByte ∷ Int → String
       hexByte n
           = [ hex4bit ((n `shiftR` 4) .&. 0x0F)
             , hex4bit ( n             .&. 0x0F)
             ]
 
-      hex4bit :: Int -> Char
+      hex4bit ∷ Int → Char
       hex4bit n
           | n < 10    = chr $ ord '0' + n
           | n < 16    = chr $ ord 'a' + n - 10
-          | otherwise = undefined
+          | otherwise = (⊥)
 
 
-openInput :: FilePath -> IO Lazy.ByteString
-openInput "-"   = LS.getContents
-openInput fpath = LS.readFile fpath
+openInput ∷ FilePath → IO Lazy.ByteString
+openInput "-"   = Lazy.getContents
+openInput fpath = Lazy.readFile fpath
 
 
-openOutput :: [CmdOpt] -> IO Handle
+openOutput ∷ [CmdOpt] → IO Handle
 openOutput opts
-    = let outputOpts = filter (\ x -> case x of
-                                        OptOutput _ -> True
-                                        _           -> False) opts
+    = let outputOpts = filter (\ x  case x of
+                                        OptOutput _  True
+                                        _            False) opts
       in
         case outputOpts of
-          []                   -> return stdout
-          (OptOutput fpath):[] -> openFile fpath WriteMode
-          _                    -> error "two many --output options."
-
+          []                   → return stdout
+          (OptOutput fpath):[] → openFile fpath WriteMode
+          _                    → error "two many --output options."
 
 {-
   作られるファイルの例 (壓縮されない場合):
@@ -465,69 +472,78 @@ openOutput opts
                   ETag: d41d8cd98f00b204e9800998ecf8427e
          Last Modified: 2007-11-05 13:53:42.231882 JST
    -}
+  {-# LANGUAGE OverloadedStrings #-}
   module Foo.Bar.Baz (baz) where
   import qualified Data.ByteString.Base64 as B64
-  import qualified Data.ByteString.Char8 as C8
-  import qualified Data.ByteString.Lazy as LS
+  import qualified Data.ByteString.Lazy as Lazy
   import Data.Time
   import Network.HTTP.Lucu
 
-  baz :: ResourceDef
+  baz  ResourceDef
   baz = ResourceDef {
           resUsesNativeThread = False
         , resIsGreedy         = False
         , resGet
-            = Just (do foundEntity entityTag lastModified
-                       setContentType contentType
-                       outputLBS rawData)
-        , resHead   = Nothing
+            = Just $ do foundEntity entityTag lastModified
+                        setContentType contentType
+                        output rawData
+        , resHead
+            = Just $ do foundEntity entityTag lastModified
+                        setContentType contentType
         , resPost   = Nothing
         , resPut    = Nothing
         , resDelete = Nothing
         }
 
-  entityTag :: ETag
+  entityTag  ETag
   entityTag = strongETag "d41d8cd98f00b204e9800998ecf8427e"
 
-  lastModified :: UTCTime
+  lastModified  UTCTime
   lastModified = read "2007-11-05 04:47:56.008366 UTC"
 
-  contentType :: MIMEType
-  contentType = read "image/png"
+  contentType  MIMEType
+  contentType = parseMIMEType "image/png"
 
-  rawData :: LS.ByteString
-  rawData = LS.fromChunks [B64.decodeLenient (C8.pack "IyEvdXNyL2Jpbi9lbnYgcnVuZ2hjCgppbXBvcnQgRGlzdHJ...")]
+  rawData ∷ Lazy.ByteString
+  rawData = Lazy.fromChunks
+            [ B64.decodeLenient "IyEvdXNyL2Jpbi9lbnYgcnVuZ2hjCgppbXBvcnQgRG..."
+            , B64.decodeLenient "Otb/+DniOlRgAAAAYAAAAGAAAAB/6QOmToAEIGAAAA..."
+            ]
   ------------------------------------------------------------------------------
 
   壓縮される場合は次のやうに變はる:
   ------------------------------------------------------------------------------
   -- import に追加
-  import Control.Monad
   import Codec.Compression.GZip
 
   -- ResourceDef は次のやうに變化
-  baz :: ResourceDef
+  baz  ResourceDef
   baz = ResourceDef {
           resUsesNativeThread = False
         , resIsGreedy         = False
         , resGet
-            = Just (do foundEntity entityTag lastModified
-                       setContentType contentType
-
-                       mustGunzip <- liftM not (isEncodingAcceptable "gzip")
-                       if mustGunzip then
-                           outputLBS (decompress gzippedData)
-                         else
-                           do setContentEncoding ["gzip"]
-                              outputLBS gzippedData
-        , resHead   = Nothing
+            = Just $ do foundEntity entityTag lastModified
+                        setContentType contentType
+
+                        gzip ← isEncodingAcceptable "gzip"
+                        if gzip then
+                            do setContentEncoding ["gzip"]
+                               output gzippedData
+                        else
+                            output (decompress gzippedData)
+        , resHead
+            = Just $ do foundEntity entityTag lastModified
+                        setContentType contentType
         , resPost   = Nothing
         , resPut    = Nothing
         , resDelete = Nothing
         }
   
   -- rawData の代はりに gzippedData
-  gzippedData :: LS.ByteString
-  gzippedData = LS.fromChunks [B64.decodeLenient (C8.pack "Otb/+DniOlRgAAAAYAAAAGAAAAB/6QOmToAEIGAAAAB...")]
+  gzippedData ∷ Lazy.ByteString
+  gzippedData = Lazy.fromChunks
+                [ B64.decodeLenient "IyEvdXNyL2Jpbi9lbnYgcnVuZ2hjCgppbXBvcnQ..."
+                , B64.decodeLenient "Otb/+DniOlRgAAAAYAAAAGAAAAB/6QOmToAEIGA..."
+                ]
   ------------------------------------------------------------------------------
  -}
index 2521c48bebba2cfead559cfda8ee5f12db7ca9f8..0667fe28a225aedb9d53a659d35017cfc8506010 100644 (file)
@@ -8,7 +8,7 @@ Description:
         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 or such like.
-Version: 0.7.0.3
+Version: 1.0
 License: PublicDomain
 License-File: COPYING
 Author: PHO <pho at cielonegro dot org>
@@ -58,7 +58,7 @@ Library
         containers-unicode-symbols == 0.3.*,
         filepath                   == 1.2.*,
         directory                  == 1.1.*,
-        haskell-src                == 1.0.*,
+        haskell-src-exts           == 1.11.*,
         hxt                        == 9.1.*,
         mtl                        == 2.0.*,
         network                    == 2.3.*,
@@ -94,7 +94,6 @@ Library
         Network.HTTP.Lucu.Chunk
         Network.HTTP.Lucu.ContentCoding
         Network.HTTP.Lucu.DefaultPage
-        Network.HTTP.Lucu.Format
         Network.HTTP.Lucu.HandleLike
         Network.HTTP.Lucu.Headers
         Network.HTTP.Lucu.Interaction
index 52315d6952afdce4e2c0e07600627b8a03dfd8ab..79b74144aadfd87d07625f581653ee1c04c46572 100644 (file)
@@ -33,8 +33,6 @@
 --   wicked clients. No attacker should be able to cause a
 --   buffer-overflow but can possibly DoS it.
 --
-
-
 module Network.HTTP.Lucu
     ( -- * Entry Point
       runHttpd
@@ -65,9 +63,11 @@ module Network.HTTP.Lucu
     , ETag(..)
     , strongETag
     , weakETag
+    , parseETag
 
       -- *** MIME Type
     , MIMEType(..)
+    , parseMIMEType
 
       -- *** Authorization
     , AuthChallenge(..)
@@ -79,7 +79,6 @@ module Network.HTTP.Lucu
     , module Network.HTTP.Lucu.StaticFile
     )
     where
-
 import Network.HTTP.Lucu.Abortion
 import Network.HTTP.Lucu.Authorization
 import Network.HTTP.Lucu.Config
index c36ebc07912176949d2005e37e8e4dc7a8d2c625..4e237c4fe1f220fad90e8aaf63060c788b52741a 100644 (file)
@@ -1,11 +1,9 @@
 {-# LANGUAGE
     Arrows
-  , BangPatterns
   , DeriveDataTypeable
   , TypeOperators
   , UnicodeSyntax
   #-}
-{-# OPTIONS_HADDOCK prune #-}
 
 -- |Aborting the computation of 'Network.HTTP.Lucu.Resource.Resource'
 -- in any 'Prelude.IO' monads or arrows.
@@ -101,7 +99,7 @@ abortA = proc (status, (headers, msg)) →
 -- Nothing の場合は getDefaultPage を使ってデフォルトのメッセージを得な
 -- ければならない。
 abortPage :: Config → Maybe Request → Response → Abortion → Lazy.Text
-abortPage !conf !reqM !res !abo
+abortPage conf reqM res abo
     = case aboMessage abo of
         Just msg
             → let [html] = runLA ( mkDefaultPage conf (aboStatus abo) (txt $ T.unpack msg)
index 11de19962d75b6c78817ab3df33207dcb126bc5d..d91fe29024dc3a8ac6e27bb1e989ffa287044b9b 100644 (file)
@@ -2,7 +2,6 @@
     OverloadedStrings
   , UnicodeSyntax
   #-}
-{-# OPTIONS_HADDOCK prune #-}
 
 -- |Manipulation of WWW authorization.
 module Network.HTTP.Lucu.Authorization
@@ -13,7 +12,7 @@ module Network.HTTP.Lucu.Authorization
     , Password
 
     , printAuthChallenge
-    , authCredentialP -- private
+    , authCredentialP
     )
     where
 import Data.Ascii (Ascii)
index acc496fa2113ef6a0848e570dffd56c453566f4b..7e618782c45e17e75ec16ef8667510447c518a20 100644 (file)
@@ -2,12 +2,10 @@
     OverloadedStrings
   , UnicodeSyntax
   #-}
-{-# OPTIONS_HADDOCK prune #-}
-
 -- |Manipulation of entity tags.
 module Network.HTTP.Lucu.ETag
     ( ETag(..)
-
+    , parseETag
     , printETag
 
     , strongETag
@@ -16,14 +14,15 @@ module Network.HTTP.Lucu.ETag
     , eTagListP
     )
     where
+import Control.Applicative
 import Control.Monad
-import Control.Monad.Unicode
 import Data.Ascii (Ascii)
 import qualified Data.Ascii as A
 import Data.Attoparsec.Char8
 import Data.Monoid.Unicode
 import Network.HTTP.Lucu.Parser.Http hiding (token)
 import Network.HTTP.Lucu.Utils
+import Prelude.Unicode
 
 -- |An entity tag is made of a weakness flag and a opaque string.
 data ETag = ETag {
@@ -47,6 +46,19 @@ printETag et
         ⊕
         quoteStr (etagToken et) )
 
+-- |Parse 'Etag' from an 'Ascii'. This functions throws an exception
+-- for parse error.
+parseETag ∷ Ascii → ETag
+parseETag str
+    = let p  = do et ← eTagP
+                  endOfInput
+                  return et
+          bs = A.toByteString str
+      in
+        case parseOnly p bs of
+          Right et → et
+          Left err → error ("unparsable ETag: " ⧺ A.toString str ⧺ ": " ⧺ err)
+
 -- |This is equivalent to @'ETag' 'Prelude.False'@. If you want to
 -- generate an ETag from a file, try using
 -- 'Network.HTTP.Lucu.StaticFile.generateETagFromFile'.
@@ -58,7 +70,7 @@ weakETag ∷ Ascii → ETag
 weakETag = ETag True
 
 eTagP ∷ Parser ETag
-eTagP = do isWeak ← option False (string "W/"  return True)
+eTagP = do isWeak ← option False (string "W/" *> return True)
            str    ← quotedStr
            return $ ETag isWeak str
 
diff --git a/Network/HTTP/Lucu/Format.hs b/Network/HTTP/Lucu/Format.hs
deleted file mode 100644 (file)
index 8db643d..0000000
+++ /dev/null
@@ -1,120 +0,0 @@
-{-# LANGUAGE
-    OverloadedStrings
-  , ScopedTypeVariables
-  , UnboxedTuples
-  , UnicodeSyntax
-  #-}
--- 本當にこんなものを自分で書く必要があったのだらうか。Printf は重いの
--- で駄目だが、それ以外のモジュールを探しても見付からなかった。
-module Network.HTTP.Lucu.Format
-    ( {-fmtInt
-
-    , fmtDec
-    , fmtHex-}
-    )
-    where
-import qualified Blaze.ByteString.Builder.Char8 as BC
-import Data.Ascii (AsciiBuilder)
-import qualified Data.ByteString.Char8 as BS
-import qualified Data.Ascii as A
-import Data.Char
-import Data.Monoid.Unicode
-import Prelude.Unicode
-
-fmtInt ∷ ∀n. Integral n ⇒ n → Int → n → AsciiBuilder
-{-# INLINEABLE fmtInt #-}
-fmtInt base minWidth n
-    = let (# raw, len #) = fmt' (abs n) (∅) 0
-      in
-        if n < 0 then
-            ( A.toAsciiBuilder "-" ⊕
-              mkPad (minWidth - 1) len ⊕
-              raw
-            )
-        else
-            mkPad minWidth len ⊕ raw
-    where
-      fmt' ∷ n → AsciiBuilder → Int → (# AsciiBuilder, Int #)
-      {-# INLINEABLE fmt' #-}
-      fmt' x b len
-          | x < base
-              = let b' = b ⊕ fromDigit x
-                in
-                  (# b', len + 1 #)
-          | otherwise
-              = let x' = x `div` base
-                    y  = x `mod` base
-                    b' = b ⊕ fromDigit y
-                in
-                  fmt' x' b' (len + 1)
-
-mkPad ∷ Int → Int → AsciiBuilder
-{-# INLINEABLE mkPad #-}
-mkPad minWidth len
-    = A.toAsciiBuilder $
-      A.unsafeFromByteString $
-      BS.replicate (minWidth - len) '0'
-
-fmtDec ∷ Integral n ⇒ Int → n → AsciiBuilder
-{-# INLINE fmtDec #-}
-fmtDec minWidth n
-    | minWidth == 2 = fmtDec2 n -- optimization 
-    | minWidth == 3 = fmtDec3 n -- optimization
-    | minWidth == 4 = fmtDec4 n -- optimization
-    | otherwise     = fmtInt 10 minWidth n
-
-fmtDec2 ∷ Integral n ⇒ n → AsciiBuilder
-{-# INLINEABLE fmtDec2 #-}
-fmtDec2 n
-    | n < 0 ∨ n ≥ 100 = fmtInt 10 2 n -- fallback
-    | n < 10          = A.toAsciiBuilder "0"   ⊕
-                        fromDigit n
-    | otherwise       = fromDigit (n `div` 10) ⊕
-                        fromDigit (n `mod` 10)
-
-fmtDec3 ∷ Integral n ⇒ n → AsciiBuilder
-{-# INLINEABLE fmtDec3 #-}
-fmtDec3 n
-    | n < 0 ∨ n ≥ 1000 = fmtInt 10 3 n -- fallback
-    | n < 10           = A.toAsciiBuilder "00"              ⊕
-                         fromDigit n
-    | n < 100          = A.toAsciiBuilder "0"               ⊕
-                         fromDigit ((n `div`  10) `mod` 10) ⊕
-                         fromDigit ( n            `mod` 10)
-    | otherwise        = fromDigit  (n `div` 100)           ⊕
-                         fromDigit ((n `div`  10) `mod` 10) ⊕
-                         fromDigit ( n            `mod` 10)
-
-fmtDec4 ∷ Integral n ⇒ n → AsciiBuilder
-{-# INLINEABLE fmtDec4 #-}
-fmtDec4 n
-    | n < 0 ∨ n ≥ 10000 = fmtInt 10 4 n -- fallback
-    | n < 10            = A.toAsciiBuilder "000"              ⊕
-                          fromDigit n
-    | n < 100           = A.toAsciiBuilder "00"               ⊕
-                          fromDigit ((n `div`   10) `mod` 10) ⊕
-                          fromDigit ( n             `mod` 10)
-    | n < 1000          = A.toAsciiBuilder "0"                ⊕
-                          fromDigit ((n `div`  100) `mod` 10) ⊕
-                          fromDigit ((n `div`   10) `mod` 10) ⊕
-                          fromDigit ( n             `mod` 10)
-    | otherwise         = fromDigit  (n `div` 1000)           ⊕
-                          fromDigit ((n `div`  100) `mod` 10) ⊕
-                          fromDigit ((n `div`   10) `mod` 10) ⊕
-                          fromDigit ( n             `mod` 10)
-
-fmtHex ∷ Integral n ⇒ Int → n → AsciiBuilder
-{-# INLINE fmtHex #-}
-fmtHex = fmtInt 16
-
-digitToChar ∷ Integral n ⇒ n → Char
-{-# INLINE digitToChar #-}
-digitToChar n
-    | n < 0     = (⊥)
-    | n < 10    = chr (ord '0' + fromIntegral  n    )
-    | n < 16    = chr (ord 'A' + fromIntegral (n-10))
-    | otherwise = (⊥)
-
-fromDigit ∷ Integral n ⇒ n → AsciiBuilder
-{-# INLINE fromDigit #-}
-fromDigit = A.unsafeFromBuilder ∘ BC.fromChar ∘ digitToChar
index 58215792fd968846532b6e7f27c065c4f874203e..ac5c1d6285aa33d936d4ae23135cb09b4ef8e125 100644 (file)
@@ -41,7 +41,7 @@ data Interaction = Interaction {
     , itrExpectedContinue  ∷ !(Maybe Bool)
     , itrReqBodyLength     ∷ !(Maybe RequestBodyLength)
 
-    , itrReqBodyWanted     ∷ !(TVar (Maybe Int))
+    , itrReqBodyWanted     ∷ !(TVar Int)
     , itrReqBodyWasteAll   ∷ !(TVar Bool)
     , itrReqChunkIsOver    ∷ !(TVar Bool)
     , itrReceivedBody      ∷ !(TVar (Seq BS.ByteString))
@@ -88,9 +88,9 @@ newInteraction conf@(Config {..}) port addr cert request
                    , resHeaders = singleton "Content-Type" defaultPageContentType
                    }
 
-         reqBodyWanted   ← newTVarIO Nothing -- Resource が要求してゐるチャンク長
-         reqBodyWasteAll ← newTVarIO False   -- 殘りの body を讀み捨てよと云ふ要求
-         reqChunkIsOver  ← newTVarIO False   -- 最後のチャンクを讀み終へた
+         reqBodyWanted   ← newTVarIO 0
+         reqBodyWasteAll ← newTVarIO False
+         reqChunkIsOver  ← newTVarIO False
          receivedBody    ← newTVarIO S.empty
          receivedBodyLen ← newTVarIO 0
 
index ce637d53f8331b75bdcaddae468f8c8122a72800..acd76b67b1bfc7b9796498fd6b2cbfa2adbcdf8e 100644 (file)
@@ -2,7 +2,6 @@
     OverloadedStrings
   , UnicodeSyntax
   #-}
-{-# OPTIONS_HADDOCK prune #-}
 
 -- |Manipulation of MIME Types.
 module Network.HTTP.Lucu.MIMEType
@@ -18,7 +17,6 @@ import Control.Applicative
 import Data.Ascii (Ascii, AsciiBuilder, CIAscii)
 import qualified Data.Ascii as A
 import Data.Attoparsec.Char8 as P
-import qualified Data.ByteString.Char8 as C8
 import Data.Map (Map)
 import Data.Monoid.Unicode
 import Data.Text (Text)
@@ -54,7 +52,7 @@ parseMIMEType str
       in
         case parseOnly p bs of
           Right  t → t
-          Left err → error ("unparsable MIME Type: " ⧺ C8.unpack bs ⧺ ": " ⧺ err)
+          Left err → error ("unparsable MIME Type: " ⧺ A.toString str ⧺ ": " ⧺ err)
 
 mimeTypeP ∷ Parser MIMEType
 mimeTypeP = do maj    ← A.toCIAscii <$> token
index 3e3df1631b7af87c29012159681bc2474df5c10f..3917cf25dac133c9487454090fbb5ac63b30dba5 100644 (file)
@@ -1,6 +1,5 @@
 {-# LANGUAGE
-    BangPatterns
-  , UnicodeSyntax
+    UnicodeSyntax
   #-}
 -- |MIME Type guessing by a file extension. This is a poor man's way
 -- of guessing MIME Types. It is simple and fast.
@@ -25,8 +24,10 @@ import Data.Maybe
 import Data.Text (Text)
 import qualified Data.Text as T
 import Data.Text.Encoding
-import Language.Haskell.Pretty
-import Language.Haskell.Syntax
+import Language.Haskell.Exts.Build
+import Language.Haskell.Exts.Extension
+import Language.Haskell.Exts.Pretty
+import Language.Haskell.Exts.Syntax
 import Network.HTTP.Lucu.MIMEType
 import Prelude.Unicode
 import System.FilePath
@@ -36,7 +37,7 @@ type ExtMap = Map Text MIMEType
 
 -- |Guess the MIME Type of file.
 guessTypeByFileName ∷ ExtMap → FilePath → Maybe MIMEType
-guessTypeByFileName !extMap !fpath
+guessTypeByFileName extMap fpath
     = let ext = T.pack $ takeExtension fpath
       in
         M.lookup ext extMap
@@ -99,45 +100,39 @@ compile = M.fromList ∘ concat ∘ map tr
 -- surely generated using this function.
 serializeExtMap ∷ ExtMap → String → String → String
 serializeExtMap extMap moduleName variableName
-    = let hsModule = HsModule (⊥) modName (Just exports) imports decls
-          modName  = Module moduleName
-          exports  = [HsEVar (UnQual (HsIdent variableName))]
-          imports  = [ HsImportDecl (⊥) (Module "Network.HTTP.Lucu.MIMEType") False Nothing Nothing
-                     , HsImportDecl (⊥) (Module "Network.HTTP.Lucu.MIMEType.Guess") False Nothing Nothing
-                     , HsImportDecl (⊥) (Module "Data.Ascii") True (Just (Module "A")) Nothing
-                     , HsImportDecl (⊥) (Module "Data.Map") True (Just (Module "M")) Nothing
-                     , HsImportDecl (⊥) (Module "Data.Text") True (Just (Module "T")) Nothing
-                     ]
-          decls    = [ HsTypeSig (⊥) [HsIdent variableName]
-                                     (HsQualType []
-                                      (HsTyCon (UnQual (HsIdent "ExtMap"))))
-                     , HsFunBind [HsMatch (⊥) (HsIdent variableName)
-                                  [] (HsUnGuardedRhs extMapExp) []]
-                     ]
-          extMapExp = HsApp (HsVar (Qual (Module "M") (HsIdent "fromList"))) (HsList records)
-          comment   =   "{- !!! WARNING !!!\n"
-                      ⧺ "   This file is automatically generated.\n"
-                      ⧺ "   DO NOT EDIT BY HAND OR YOU WILL REGRET -}\n\n"
+    = let hsModule  = Module (⊥) (ModuleName moduleName) modPragma
+                      Nothing (Just exports) imports decls
+          modPragma = [ LanguagePragma (⊥) [ name (show OverloadedStrings) ] ]
+          exports   = [ EVar (UnQual (name variableName)) ]
+          imports   = [ ImportDecl (⊥) (ModuleName "Network.HTTP.Lucu.MIMEType")
+                                   False False Nothing Nothing Nothing
+                      , ImportDecl (⊥) (ModuleName "Network.HTTP.Lucu.MIMEType.Guess")
+                                   False False Nothing Nothing Nothing
+                      , ImportDecl (⊥) (ModuleName "Data.Ascii")
+                                   False False Nothing Nothing (Just (False, []))
+                      , ImportDecl (⊥) (ModuleName "Data.Map")
+                                   True False Nothing (Just (ModuleName "M")) Nothing
+                      ]
+          decls     = [ TypeSig (⊥) [name variableName]
+                                    (TyCon (UnQual (name "ExtMap")))
+                      , nameBind (⊥) (name variableName) extMapExp
+                      ]
+          comment   = concat [ "{- !!! WARNING !!!\n"
+                             , "   This file is automatically generated.\n"
+                             , "   DO NOT EDIT BY HAND OR YOU WILL REGRET -}\n\n"
+                             ]
+          extMapExp = qvar (ModuleName "M") (name "fromList") `app` listE records
       in
         comment ⧺ prettyPrint hsModule ⧺ "\n"
     where
-      records ∷ [HsExp]
+      records ∷ [Exp]
       records = map record $ M.assocs extMap
 
-      record ∷ (Text, MIMEType) → HsExp
+      record ∷ (Text, MIMEType) → Exp
       record (ext, mime)
-          = HsTuple
-            [ HsApp (HsVar (Qual (Module "T") (HsIdent "pack")))
-                    (HsLit (HsString (T.unpack ext)))
-            , mimeToExp mime
-            ]
-                    
-      mimeToExp ∷ MIMEType → HsExp
-      mimeToExp mt
-          = HsApp (HsVar (UnQual (HsIdent "parseMIMEType")))
-            (HsParen
-             (HsApp (HsVar (Qual (Module "A") (HsIdent "unsafeFromString")))
-              (HsLit (HsString $ mimeToString mt))))
+          = tuple [ strE (T.unpack ext)
+                  , metaFunction "parseMIMEType" [strE $ mimeToString mime]
+                  ]
 
       mimeToString ∷ MIMEType → String
       mimeToString = A.toString ∘ A.fromAsciiBuilder ∘ printMIMEType
index fbc8551bac76a4f2a273ad323525a24613eb2031..49317a99ea8343270f222b7061c8bdd8c00cb322 100644 (file)
@@ -185,16 +185,14 @@ observeChunkedRequest ctx itr input remaining
          if isOver then
              return $ acceptRequest ctx input
          else
-             do wantedM ← readTVar $ itrReqBodyWanted itr
-                case wantedM of
-                  Nothing
-                      → do wasteAll ← readTVar $ itrReqBodyWasteAll itr
-                           if wasteAll then
-                               return $ wasteCurrentChunk ctx itr input remaining
-                           else
-                               retry
-                  Just wanted
-                      → return $ readCurrentChunk ctx itr input wanted remaining
+             do wanted ← readTVar $ itrReqBodyWanted itr
+                case wanted of
+                  0 → do wasteAll ← readTVar $ itrReqBodyWasteAll itr
+                         if wasteAll then
+                             return $ wasteCurrentChunk ctx itr input remaining
+                         else
+                             retry
+                  _ → return $ readCurrentChunk ctx itr input wanted remaining
 
 wasteCurrentChunk ∷ HandleLike h
                   ⇒ Context h
@@ -226,9 +224,7 @@ readCurrentChunk ctx itr input wanted remaining
         = do let bytesToRead     = fromIntegral $ min wanted remaining
                  (chunk, input') = Lazy.splitAt bytesToRead input
                  actualReadBytes = fromIntegral $ Lazy.length chunk
-                 newWanted       = case wanted - actualReadBytes of
-                                     0 → Nothing
-                                     n → Just n
+                 newWanted       = wanted - actualReadBytes
                  newRemaining    = remaining - actualReadBytes
                  chunk'          = S.fromList $ Lazy.toChunks chunk
                  updateStates    = atomically $
@@ -289,16 +285,14 @@ observeNonChunkedRequest ∷ HandleLike h
 observeNonChunkedRequest ctx itr input remaining
     = join $
       atomically $
-      do wantedM ← readTVar $ itrReqBodyWanted itr
-         case wantedM of
-           Nothing
-               → do wasteAll ← readTVar $ itrReqBodyWasteAll itr
-                    if wasteAll then
-                        return $ wasteNonChunkedRequestBody ctx itr input remaining
-                    else
-                        retry
-           Just wanted
-               → return $ readNonChunkedRequestBody ctx itr input wanted remaining
+      do wanted ← readTVar $ itrReqBodyWanted itr
+         case wanted of
+           0 → do wasteAll ← readTVar $ itrReqBodyWasteAll itr
+                  if wasteAll then
+                      return $ wasteNonChunkedRequestBody ctx itr input remaining
+                  else
+                      retry
+           _ → return $ readNonChunkedRequestBody ctx itr input wanted remaining
 
 wasteNonChunkedRequestBody ∷ HandleLike h
                            ⇒ Context h
@@ -322,12 +316,13 @@ readNonChunkedRequestBody ctx itr input wanted remaining
     = do let bytesToRead     = min wanted remaining
              (chunk, input') = Lazy.splitAt (fromIntegral bytesToRead) input
              actualReadBytes = fromIntegral $ Lazy.length chunk
+             newWanted       = wanted - actualReadBytes
              newRemaining    = remaining - actualReadBytes
              isOver          = actualReadBytes < bytesToRead ∨ newRemaining ≡ 0
              chunk'          = S.fromList $ Lazy.toChunks chunk
          atomically $
              do writeTVar (itrReqChunkIsOver  itr) isOver
-                writeTVar (itrReqBodyWanted   itr) Nothing
+                writeTVar (itrReqBodyWanted   itr) newWanted
                 writeTVar (itrReceivedBody    itr) chunk'
                 writeTVar (itrReceivedBodyLen itr) actualReadBytes
          if isOver then
index 298b9b2541edd0f4d3d8b170bccb6cc9965bfe4e..01b61813971e9e1ce4ba80e18ed374e400a5ce5a 100644 (file)
@@ -5,7 +5,6 @@
   , RecordWildCards
   , UnicodeSyntax
   #-}
-{-# 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'
@@ -70,7 +69,7 @@ module Network.HTTP.Lucu.Resource
     -- * Types
       Resource
     , FormData(..)
-    , runRes -- private
+    , runRes
 
     -- * Actions
 
@@ -624,7 +623,7 @@ input limit
                         $ fail ("inputLBS: limit must be positive: " ⧺ show actualLimit)
                -- Reader にリクエスト
                liftIO $ atomically
-                      $ writeTVar itrReqBodyWanted (Just actualLimit)
+                      $ writeTVar itrReqBodyWanted actualLimit
                -- 應答を待つ。トランザクションを分けなければ當然デッドロックする。
                chunk ← liftIO $ atomically
                        $ do chunkLen    ← readTVar itrReceivedBodyLen
@@ -692,7 +691,7 @@ inputChunk limit
                         $ fail ("inputChunkLBS: limit must be positive: " ++ show actualLimit)
                -- Reader にリクエスト
                liftIO $ atomically
-                      $ writeTVar itrReqBodyWanted (Just actualLimit)
+                      $ writeTVar itrReqBodyWanted actualLimit
                -- 應答を待つ。トランザクションを分けなければ當然デッドロック。
                chunk ← liftIO $ atomically
                        $ do chunkLen ← readTVar itrReceivedBodyLen
index 6bf422f72fcf1ee14a567664c79341db03f7d138..8fbe2bf2d6b529aa1b00ad4fc4c6b17b943b64b8 100644 (file)
@@ -4,7 +4,6 @@
   , RecordWildCards
   , UnicodeSyntax
   #-}
-{-# OPTIONS_HADDOCK prune #-}
 
 -- | Repository of the resources in httpd.
 module Network.HTTP.Lucu.Resource.Tree
index 034bd782aade719fa1a3beac140fdf2780e8d62b..872e07807adc12c77245818e7dff61cbf947ea27 100644 (file)
@@ -9,11 +9,11 @@ module Network.HTTP.Lucu.ResponseWriter
     )
     where
 import qualified Blaze.ByteString.Builder.HTTP as BB
-import qualified Data.Ascii as A
 import Control.Concurrent
 import Control.Concurrent.STM
 import Control.Exception
 import Control.Monad
+import qualified Data.Ascii as A
 import Data.Monoid.Unicode
 import qualified Data.Sequence as S
 import Data.Sequence (ViewR(..))
@@ -34,6 +34,11 @@ data Context h
       , cReader ∷ !ThreadId
       }
 
+data Phase = Initial
+           | WroteContinue
+           | WroteHeader
+             deriving (Eq, Ord, Show)
+
 responseWriter ∷ HandleLike h ⇒ Config → h → InteractionQueue → ThreadId → IO ()
 responseWriter cnf h tQueue readerTID
     = awaitSomethingToWrite (Context cnf h tQueue readerTID)
@@ -52,57 +57,69 @@ awaitSomethingToWrite ctx@(Context {..})
       atomically $
       -- キューが空でなくなるまで待つ
       do queue ← readTVar cQueue
-         -- GettingBody 状態にあり、Continue が期待されてゐて、それがま
-         -- だ送信前なのであれば、Continue を送信する。
          case S.viewr queue of
-           EmptyR   → retry
-           _ :> itr → do state ← readTVar $ itrState itr
-                         if state ≡ GettingBody then
-                             writeContinueIfNeeded ctx itr
-                         else
-                             if state ≥ DecidingBody then
-                                 writeHeaderOrBodyIfNeeded ctx itr
-                             else
-                                 retry
+           EmptyR        → retry
+           queue' :> itr → do writeTVar cQueue queue'
+                              return $ awaitSomethingToWriteOn ctx itr Initial
 
-writeContinueIfNeeded ∷ HandleLike h ⇒ Context h → Interaction → STM (IO ())
-writeContinueIfNeeded ctx itr@(Interaction {..})
-    = do expectedContinue ← readTVar itrExpectedContinue
-         if expectedContinue then
-             do wroteContinue ← readTVar itrWroteContinue
-                if wroteContinue then
-                    -- 既に Continue を書込み濟
-                    retry
-                else
-                    do reqBodyWanted ← readTVar itrReqBodyWanted
-                       if reqBodyWanted ≢ Nothing then
-                           return $ writeContinue ctx itr
-                       else
-                           retry
+-- GettingBody 状態にあり、Continue が期待されてゐて、それがまだ送信前
+-- なのであれば、Continue を送信する。
+awaitSomethingToWriteOn ∷ HandleLike h
+                        ⇒ Context h
+                        → Interaction
+                        → Phase
+                        → IO ()
+awaitSomethingToWriteOn ctx itr phase
+    = join $
+      atomically $
+      do state ← readTVar $ itrState itr
+         if state ≡ GettingBody then
+             writeContinueIfNeeded ctx itr phase
          else
-             retry
+             if state ≥ DecidingBody then
+                 writeHeaderOrBodyIfNeeded ctx itr phase
+             else
+                 retry
+
+writeContinueIfNeeded ∷ HandleLike h
+                      ⇒ Context h
+                      → Interaction
+                      → Phase
+                      → STM (IO ())
+writeContinueIfNeeded ctx itr@(Interaction {..}) phase
+    | phase ≡ Initial ∧ itrExpectedContinue ≡ Just True
+        = do reqBodyWanted ← readTVar itrReqBodyWanted
+             if reqBodyWanted > 0 then
+                 return $ writeContinue ctx itr
+             else
+                 retry
+    | otherwise
+        = retry
 
 -- DecidingBody 以降の状態にあり、まだヘッダを出力する前であれば、ヘッ
 -- ダを出力する。ヘッダ出力後であり、bodyToSend が空でなければ、それを
 -- 出力する。空である時は、もし状態がDone であれば後処理をする。
-writeHeaderOrBodyIfNeeded ∷ HandleLike h ⇒ Context h → Interaction → STM (IO ())
-writeHeaderOrBodyIfNeeded ctx itr@(Interaction {..})
-    = do wroteHeader ← readTVar itrWroteHeader
-         if not wroteHeader then
-             return $ writeHeader ctx itr
-         else
-             do noBodyToWrite ← isEmptyTMVar itrBodyToSend
-                if noBodyToWrite then
-                    do state ← readTVar itrState
-                       if state ≡ Done then
-                           return $ finalize ctx itr
-                       else
-                           retry
-                else
-                    return $ writeBodyChunk ctx itr
+writeHeaderOrBodyIfNeeded ∷ HandleLike h
+                          ⇒ Context h
+                          → Interaction
+                          → Phase
+                          → STM (IO ())
+writeHeaderOrBodyIfNeeded ctx itr@(Interaction {..}) phase
+    | phase < WroteHeader
+        = return $ writeHeader ctx itr
+    | otherwise
+        = do noBodyToWrite ← isEmptyTMVar itrBodyToSend
+             if noBodyToWrite then
+                 do state ← readTVar itrState
+                    if state ≡ Done then
+                        return $ finalize ctx itr
+                    else
+                        retry
+             else
+                 return $ writeBodyChunk ctx itr phase
 
 writeContinue ∷ HandleLike h ⇒ Context h → Interaction → IO ()
-writeContinue ctx@(Context {..}) (Interaction {..})
+writeContinue ctx@(Context {..}) itr@(Interaction {..})
     = do let cont = Response {
                       resVersion = HttpVersion 1 1
                     , resStatus  = Continue
@@ -111,26 +128,30 @@ writeContinue ctx@(Context {..}) (Interaction {..})
          cont' ← completeUnconditionalHeaders cConfig cont
          hPutBuilder cHandle $ A.toBuilder $ printResponse cont'
          hFlush cHandle
-         atomically $ writeTVar itrWroteContinue True
-         awaitSomethingToWrite ctx
+         awaitSomethingToWriteOn ctx itr WroteContinue
 
-writeHeader ∷ HandleLike h ⇒ Context h → Interaction → IO ()
-writeHeader ctx@(Context {..}) (Interaction {..})
-    = do res ← atomically
-               $ do writeTVar itrWroteHeader True
-                    readTVar itrResponse
+writeHeader ∷ HandleLike h
+            ⇒ Context h
+            → Interaction
+            → IO ()
+writeHeader ctx@(Context {..}) itr@(Interaction {..})
+    = do res ← atomically $ readTVar itrResponse
          hPutBuilder cHandle $ A.toBuilder $ printResponse res
          hFlush cHandle
-         awaitSomethingToWrite ctx
+         awaitSomethingToWriteOn ctx itr WroteHeader
 
-writeBodyChunk ∷ HandleLike h ⇒ Context h → Interaction → IO ()
-writeBodyChunk ctx@(Context {..}) (Interaction {..})
+writeBodyChunk ∷ HandleLike h
+               ⇒ Context h
+               → Interaction
+               → Phase
+               → IO ()
+writeBodyChunk ctx@(Context {..}) itr@(Interaction {..}) phase
     = join $
       atomically $
       do willDiscardBody ← readTVar itrWillDiscardBody
          if willDiscardBody then
              do _ ← tryTakeTMVar itrBodyToSend
-                return $ awaitSomethingToWrite ctx
+                return $ awaitSomethingToWriteOn ctx itr phase
          else
              do willChunkBody ← readTVar itrWillChunkBody
                 chunk         ← takeTMVar itrBodyToSend
@@ -140,7 +161,7 @@ writeBodyChunk ctx@(Context {..}) (Interaction {..})
                        else
                            hPutBuilder cHandle chunk
                        hFlush cHandle
-                       awaitSomethingToWrite ctx
+                       awaitSomethingToWriteOn ctx itr phase
 
 finishBodyChunk ∷ HandleLike h ⇒ Context h → Interaction → IO ()
 finishBodyChunk (Context {..}) (Interaction {..})
index 23c69ed5ced6af25687db13e03462d77819077af..04bd97f73c0d4365fe443634aa7c486718c108bc 100644 (file)
@@ -1,10 +1,18 @@
-../Network/HTTP/Lucu/MIMEType/DefaultExtensionMap.hs: mime.types CompileMimeTypes
-       ./CompileMimeTypes $< $@
+../Network/HTTP/Lucu/MIMEType/DefaultExtensionMap.hs: dist/DefaultExtensionMap.hs
+       cp -f $< $@
 
-CompileMimeTypes:
-       ghc --make $@ -i..
+dist/DefaultExtensionMap.hs: mime.types compiler
+       ./CompileMimeTypes $< $@.tmp
+       if diff $@ $@.tmp >/dev/null; then \
+               rm -f $@.tmp; \
+       else \
+               mv -f $@.tmp $@; \
+       fi
+
+compiler:
+       ghc --make CompileMimeTypes -i.. -odir dist -hidir dist
 
 clean:
-       rm -f *.hi *.o CompileMimeTypes
+       rm -rf dist DefaultExtensionMap.hs CompileMimeTypes
 
-.PHONY: clean
+.PHONY: clean compiler
index abd928eb482b505dc60b8a194b7d65d2e29192ba..26d6670f49a5c2d4df6cd5cbabf0e5c134f6f1a4 100644 (file)
@@ -10,7 +10,7 @@ TARGETS = \
 build: $(TARGETS)
 
 %: %.hs
-       ghc --make $@ -threaded -O3 -fwarn-unused-imports
+       ghc --make $@ -threaded -O3 -Wall
 
 run: build
        ./HelloWorld