Reimplement MultipartForm

Ditz-issue: 8959dadc07db1bd363283dee401073f6e48dc7fa

diff --git a/ImplantFile.hs b/ImplantFile.hs
index c3cff030271fd2e881be0d0db07180291858c9b2..c253c2abd05395b3311dba1fd9d3ed999d37d89b 100644 (file)
--- a/ImplantFile.hs
+++ b/ImplantFile.hs
@@ -106,13 +106,13 @@ main = do (opts, sources, errors) ← getOpt Permute options <$> getArgs
 
 generateHaskellSource ∷ [CmdOpt] → FilePath → IO ()
 generateHaskellSource opts srcFile
 
 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
+         mType   ← getMIMEType opts srcFile
+         lastMod ← getLastModified srcFile
+         input   ← openInput srcFile
+         output  ← openOutput opts
+         tag     ← getETag opts input

 
          let compParams  = defaultCompressParams { compressLevel = bestCompression }
              gzippedData = compressWith compParams input
 
          let compParams  = defaultCompressParams { compressLevel = bestCompression }
              gzippedData = compressWith compParams input


@@ -122,14 +122,14 @@ generateHaskellSource opts srcFile
              rawB64      = B64.encode <$> Lazy.toChunks input
              gzippedB64  = B64.encode <$> Lazy.toChunks gzippedData
 
              rawB64      = B64.encode <$> Lazy.toChunks input
              gzippedB64  = B64.encode <$> Lazy.toChunks gzippedData
 

-         header ← mkHeader srcFile originalLen gzippedLen useGZip mimeType eTag lastMod
+         header ← mkHeader srcFile originalLen gzippedLen useGZip mType tag lastMod

 
          let hsModule = mkModule modName symName imports decls
              imports  = mkImports useGZip
              decls    = concat [ resourceDecl symName useGZip
 
          let hsModule = mkModule modName symName imports decls
              imports  = mkImports useGZip
              decls    = concat [ resourceDecl symName useGZip

-                               , entityTagDecl eTag
+                               , entityTagDecl tag

                                , lastModifiedDecl lastMod
                                , lastModifiedDecl lastMod

-                               , contentTypeDecl mimeType
+                               , contentTypeDecl mType

                                , if useGZip then
                                      dataDecl (name "gzippedData") gzippedB64
                                  else
                                , if useGZip then
                                      dataDecl (name "gzippedData") gzippedB64
                                  else


@@ -257,7 +257,7 @@ putChunksStmt ∷ Exp → Stmt
 putChunksStmt = qualStmt ∘ putChunksExp
 
 entityTagDecl ∷ ETag → [Decl]
 putChunksStmt = qualStmt ∘ putChunksExp
 
 entityTagDecl ∷ ETag → [Decl]

-entityTagDecl eTag
+entityTagDecl tag

     = [ TypeSig (⊥) [varName] (TyCon (UnQual (name "ETag")))
       , nameBind (⊥) varName valExp
       ]
     = [ TypeSig (⊥) [varName] (TyCon (UnQual (name "ETag")))
       , nameBind (⊥) varName valExp
       ]


@@ -266,7 +266,7 @@ entityTagDecl eTag
       varName = name "entityTag"
 
       valExp ∷ Exp
       varName = name "entityTag"
 
       valExp ∷ Exp

-      valExp = function "parseETag" `app` strE (eTagToString eTag)
+      valExp = function "parseETag" `app` strE (eTagToString tag)

 
 lastModifiedDecl ∷ UTCTime → [Decl]
 lastModifiedDecl lastMod
 
 lastModifiedDecl ∷ UTCTime → [Decl]
 lastModifiedDecl lastMod


@@ -316,7 +316,7 @@ dataDecl varName chunks
             strE (Strict.unpack chunk)
 
 mkHeader ∷ FilePath → Int64 → Int64 → Bool → MIMEType → ETag → UTCTime → IO String
             strE (Strict.unpack chunk)
 
 mkHeader ∷ FilePath → Int64 → Int64 → Bool → MIMEType → ETag → UTCTime → IO String

-mkHeader srcFile originalLen gzippedLen useGZip mimeType eTag lastMod
+mkHeader srcFile originalLen gzippedLen useGZip mType tag lastMod

     = do localLastMod ← utcToLocalZonedTime lastMod
          return $ concat
                     [ "{- DO NOT EDIT THIS FILE.\n"
     = do localLastMod ← utcToLocalZonedTime lastMod
          return $ concat
                     [ "{- DO NOT EDIT THIS FILE.\n"


@@ -333,8 +333,8 @@ mkHeader srcFile originalLen gzippedLen useGZip mimeType eTag lastMod
                           "         Compression: gzip\n"
                       else
                           "         Compression: disabled\n"
                           "         Compression: gzip\n"
                       else
                           "         Compression: disabled\n"

-                    , "           MIME Type: ", mimeTypeToString mimeType, "\n"
-                    , "                ETag: ", eTagToString eTag, "\n"
+                    , "           MIME Type: ", mimeTypeToString mType, "\n"
+                    , "                ETag: ", eTagToString tag, "\n"

                     , "       Last Modified: ", show localLastMod, "\n"
                     , " -}"
                     ]
                     , "       Last Modified: ", show localLastMod, "\n"
                     , " -}"
                     ]

diff --git a/Lucu.cabal b/Lucu.cabal
index dcfd8320ba13f4dcd2515a626a696295c7db5bb6..46fabcf51b093126ccca1b320db0472037775d10 100644 (file)
--- a/Lucu.cabal
+++ b/Lucu.cabal
@@ -63,10 +63,8 @@ Library
         mtl                        == 2.0.*,
         network                    == 2.3.*,
         stm                        == 2.2.*,
         mtl                        == 2.0.*,
         network                    == 2.3.*,
         stm                        == 2.2.*,

-        strict                     == 0.3.*,

         stringsearch               == 0.3.*,
         text                       == 0.11.*,
         stringsearch               == 0.3.*,
         text                       == 0.11.*,

-        text-icu                   == 0.6.*,

         time                       == 1.2.*,
         time-http                  == 0.2.*,
         transformers               == 0.2.*,
         time                       == 1.2.*,
         time-http                  == 0.2.*,
         transformers               == 0.2.*,


@@ -83,6 +81,7 @@ Library
         Network.HTTP.Lucu.MIMEType
         Network.HTTP.Lucu.MIMEType.DefaultExtensionMap
         Network.HTTP.Lucu.MIMEType.Guess
         Network.HTTP.Lucu.MIMEType
         Network.HTTP.Lucu.MIMEType.DefaultExtensionMap
         Network.HTTP.Lucu.MIMEType.Guess

+        Network.HTTP.Lucu.MultipartForm

         Network.HTTP.Lucu.Parser.Http
         Network.HTTP.Lucu.Parser
         Network.HTTP.Lucu.RFC2231
         Network.HTTP.Lucu.Parser.Http
         Network.HTTP.Lucu.Parser
         Network.HTTP.Lucu.RFC2231


@@ -101,7 +100,6 @@ Library
         Network.HTTP.Lucu.HandleLike
         Network.HTTP.Lucu.Headers
         Network.HTTP.Lucu.Interaction
         Network.HTTP.Lucu.HandleLike
         Network.HTTP.Lucu.Headers
         Network.HTTP.Lucu.Interaction

-        Network.HTTP.Lucu.MultipartForm

         Network.HTTP.Lucu.Postprocess
         Network.HTTP.Lucu.Preprocess
         Network.HTTP.Lucu.RequestReader
         Network.HTTP.Lucu.Postprocess
         Network.HTTP.Lucu.Preprocess
         Network.HTTP.Lucu.RequestReader

diff --git a/Network/HTTP/Lucu/Authentication.hs b/Network/HTTP/Lucu/Authentication.hs
index 3f8d76297169aeaa074c70310d7773af988ddff2..753af6ecbe72153ab3394a76ba1e1b0da2e79c81 100644 (file)
--- a/Network/HTTP/Lucu/Authentication.hs
+++ b/Network/HTTP/Lucu/Authentication.hs
@@ -11,7 +11,7 @@ module Network.HTTP.Lucu.Authentication
     , Password
 
     , printAuthChallenge
     , Password
 
     , printAuthChallenge

-    , authCredentialP
+    , authCredential

     )
     where
 import Control.Monad
     )
     where
 import Control.Monad


@@ -55,8 +55,8 @@ printAuthChallenge (BasicAuthChallenge realm)
       A.toAsciiBuilder "Basic realm=" ⊕ quoteStr realm
 
 -- |'Parser' for an 'AuthCredential'.
       A.toAsciiBuilder "Basic realm=" ⊕ quoteStr realm
 
 -- |'Parser' for an 'AuthCredential'.

-authCredentialP ∷ Parser AuthCredential
-authCredentialP
+authCredential ∷ Parser AuthCredential
+authCredential

     = do void $ string "Basic"
          skipMany1 lws
          b64 ← takeWhile1 base64
     = do void $ string "Basic"
          skipMany1 lws
          b64 ← takeWhile1 base64

diff --git a/Network/HTTP/Lucu/Chunk.hs b/Network/HTTP/Lucu/Chunk.hs
index b48727cc0f364fdbe3037cd759cbbf01476216a4..e8c9de41286c4fb3240425843acc67c52e565db5 100644 (file)
--- a/Network/HTTP/Lucu/Chunk.hs
+++ b/Network/HTTP/Lucu/Chunk.hs
@@ -2,9 +2,9 @@
     UnicodeSyntax
   #-}
 module Network.HTTP.Lucu.Chunk
     UnicodeSyntax
   #-}
 module Network.HTTP.Lucu.Chunk

-    ( chunkHeaderP
-    , chunkFooterP
-    , chunkTrailerP
+    ( chunkHeader
+    , chunkFooter
+    , chunkTrailer

     )
     where
 import Control.Applicative
     )
     where
 import Control.Applicative


@@ -13,12 +13,12 @@ import Data.Bits
 import Network.HTTP.Lucu.Headers
 import Network.HTTP.Lucu.Parser.Http
 
 import Network.HTTP.Lucu.Headers
 import Network.HTTP.Lucu.Parser.Http
 

-chunkHeaderP ∷ (Integral a, Bits a) ⇒ Parser a
-{-# INLINEABLE chunkHeaderP #-}
-chunkHeaderP = do len ← hexadecimal
-                  extension
-                  crlf
-                  return len
+chunkHeader ∷ (Integral a, Bits a) ⇒ Parser a
+{-# INLINEABLE chunkHeader #-}
+chunkHeader = do len ← hexadecimal
+                 extension
+                 crlf
+                 return len

     where
       extension ∷ Parser ()
       extension
     where
       extension ∷ Parser ()
       extension


@@ -27,8 +27,8 @@ chunkHeaderP = do len ← hexadecimal
                        char '=' *>
                        (token <|> quotedStr) )
 
                        char '=' *>
                        (token <|> quotedStr) )
 

-chunkFooterP ∷ Parser ()
-chunkFooterP = crlf
+chunkFooter ∷ Parser ()
+chunkFooter = crlf

 
 

-chunkTrailerP ∷ Parser Headers
-chunkTrailerP = headersP
+chunkTrailer ∷ Parser Headers
+chunkTrailer = headers

diff --git a/Network/HTTP/Lucu/ContentCoding.hs b/Network/HTTP/Lucu/ContentCoding.hs
index 3ce7806dee86d5271ec50e8e1d4a68d7fd97a1ad..a5f02b13ecf69ac28f15e747016f4af124eb2191 100644 (file)
--- a/Network/HTTP/Lucu/ContentCoding.hs
+++ b/Network/HTTP/Lucu/ContentCoding.hs
@@ -5,7 +5,7 @@
 module Network.HTTP.Lucu.ContentCoding
     ( AcceptEncoding(..)
 
 module Network.HTTP.Lucu.ContentCoding
     ( AcceptEncoding(..)
 

-    , acceptEncodingListP
+    , acceptEncodingList

     , normalizeCoding
     , unnormalizeCoding
     )
     , normalizeCoding
     , unnormalizeCoding
     )


@@ -34,16 +34,16 @@ instance Ord AcceptEncoding where
           q1' = fromMaybe 0 q1
           q2' = fromMaybe 0 q2
 
           q1' = fromMaybe 0 q1
           q2' = fromMaybe 0 q2
 

-acceptEncodingListP ∷ Parser [AcceptEncoding]
-acceptEncodingListP = listOf accEncP
+acceptEncodingList ∷ Parser [AcceptEncoding]
+acceptEncodingList = listOf accEnc

 
 

-accEncP ∷ Parser AcceptEncoding
-accEncP = do coding ← toCIAscii <$> token
-             qVal   ← option Nothing
-                      $ do _ ← string ";q="
-                           q ← qvalue
-                           return $ Just q
-             return $ AcceptEncoding (normalizeCoding coding) qVal
+accEnc ∷ Parser AcceptEncoding
+accEnc = do coding ← toCIAscii <$> token
+            qVal   ← option Nothing
+                     $ do _ ← string ";q="
+                          q ← qvalue
+                          return $ Just q
+            return $ AcceptEncoding (normalizeCoding coding) qVal

 
 normalizeCoding ∷ CIAscii → CIAscii
 normalizeCoding coding
 
 normalizeCoding ∷ CIAscii → CIAscii
 normalizeCoding coding

diff --git a/Network/HTTP/Lucu/ETag.hs b/Network/HTTP/Lucu/ETag.hs
index d4a157fa2eabeb66d133afe1b25c3393a59f2946..76df18378bf3e48417dddd8c73dc6222b65d5136 100644 (file)
--- a/Network/HTTP/Lucu/ETag.hs
+++ b/Network/HTTP/Lucu/ETag.hs
@@ -10,8 +10,8 @@ module Network.HTTP.Lucu.ETag
 
     , strongETag
     , weakETag
 
     , strongETag
     , weakETag

-    , eTagP
-    , eTagListP
+    , eTag
+    , eTagList

     )
     where
 import Control.Applicative
     )
     where
 import Control.Applicative


@@ -58,7 +58,7 @@ parseETag str
     where
       p ∷ Parser ETag
       {-# INLINE p #-}
     where
       p ∷ Parser ETag
       {-# INLINE p #-}

-      p = do et ← eTagP
+      p = do et ← eTag

              endOfInput
              return et
 
              endOfInput
              return et
 


@@ -75,16 +75,16 @@ weakETag ∷ Ascii → ETag
 weakETag = ETag True
 
 -- |'Parser' for an 'ETag'.
 weakETag = ETag True
 
 -- |'Parser' for an 'ETag'.

-eTagP ∷ Parser ETag
-{-# INLINEABLE eTagP #-}
-eTagP = do isWeak ← option False (string "W/" *> return True)
-           str    ← quotedStr
-           return $ ETag isWeak str
+eTag ∷ Parser ETag
+{-# INLINEABLE eTag #-}
+eTag = do isWeak ← option False (string "W/" *> return True)
+          str    ← quotedStr
+          return $ ETag isWeak str

 
 -- |'Parser' for a list of 'ETag's.
 
 -- |'Parser' for a list of 'ETag's.

-eTagListP ∷ Parser [ETag]
-{-# INLINEABLE eTagListP #-}
-eTagListP = do xs ← listOf eTagP
-               when (null xs) $
-                   fail "empty list of ETags"
-               return xs
+eTagList ∷ Parser [ETag]
+{-# INLINEABLE eTagList #-}
+eTagList = do xs ← listOf eTag
+              when (null xs) $
+                  fail "empty list of ETags"
+              return xs

diff --git a/Network/HTTP/Lucu/Headers.hs b/Network/HTTP/Lucu/Headers.hs
index 5e48ee4bd52ad8a1edc1c5a3c9ede9b2b687f100..a47f2ac9ea60c1869221c573238b2186f076618e 100644 (file)
--- a/Network/HTTP/Lucu/Headers.hs
+++ b/Network/HTTP/Lucu/Headers.hs
@@ -12,7 +12,7 @@ module Network.HTTP.Lucu.Headers
     , toHeaders
     , fromHeaders
 
     , toHeaders
     , fromHeaders
 

-    , headersP
+    , headers

     , printHeaders
     )
     where
     , printHeaders
     )
     where


@@ -116,11 +116,11 @@ fromHeaders (Headers m) = M.toList m
   field-value の先頭および末尾にある LWS は全て削除され、それ以外の
   LWS は單一の SP に變換される。
 -}
   field-value の先頭および末尾にある LWS は全て削除され、それ以外の
   LWS は單一の SP に變換される。
 -}

-headersP ∷ Parser Headers
-{-# INLINEABLE headersP #-}
-headersP = do xs ← P.many header
-              crlf
-              return $ toHeaders xs
+headers ∷ Parser Headers
+{-# INLINEABLE headers #-}
+headers = do xs ← P.many header
+             crlf
+             return $ toHeaders xs

     where
       header ∷ Parser (CIAscii, Ascii)
       header = do name ← A.toCIAscii <$> token
     where
       header ∷ Parser (CIAscii, Ascii)
       header = do name ← A.toCIAscii <$> token

diff --git a/Network/HTTP/Lucu/HttpVersion.hs b/Network/HTTP/Lucu/HttpVersion.hs
index 2029a7facbaf3e5eec5a1bc42201a74e26ff9151..36b6c499b1428e48f9ea4c0c1a383fbeab8f8026 100644 (file)
--- a/Network/HTTP/Lucu/HttpVersion.hs
+++ b/Network/HTTP/Lucu/HttpVersion.hs
@@ -6,11 +6,9 @@
 module Network.HTTP.Lucu.HttpVersion
     ( HttpVersion(..)
     , printHttpVersion
 module Network.HTTP.Lucu.HttpVersion
     ( HttpVersion(..)
     , printHttpVersion

-
-    , httpVersionP
+    , httpVersion

     )
     where
     )
     where

-import qualified Blaze.Text.Int as BT

 import Control.Applicative
 import Control.Applicative.Unicode
 import Data.Ascii (AsciiBuilder)
 import Control.Applicative
 import Control.Applicative.Unicode
 import Data.Ascii (AsciiBuilder)


@@ -39,18 +37,15 @@ printHttpVersion v
         -- Optimisation for special cases.
         HttpVersion 1 0 → A.toAsciiBuilder "HTTP/1.0"
         HttpVersion 1 1 → A.toAsciiBuilder "HTTP/1.1"
         -- Optimisation for special cases.
         HttpVersion 1 0 → A.toAsciiBuilder "HTTP/1.0"
         HttpVersion 1 1 → A.toAsciiBuilder "HTTP/1.1"

-        -- General cases.
+        -- General (but almost never stumbling) cases.

         HttpVersion maj min
         HttpVersion maj min

-            → A.toAsciiBuilder    "HTTP/"           ⊕
-              A.unsafeFromBuilder (BT.integral maj) ⊕
-              A.toAsciiBuilder    "."               ⊕
-              A.unsafeFromBuilder (BT.integral min)
+            → A.toAsciiBuilder "HTTP/" ⊕
+              A.toAsciiBuilder (A.unsafeFromString $ show maj) ⊕
+              A.toAsciiBuilder "." ⊕
+              A.toAsciiBuilder (A.unsafeFromString $ show min)

 
 -- |'Parser' for an 'HttpVersion'.
 
 -- |'Parser' for an 'HttpVersion'.

-httpVersionP ∷ Parser HttpVersion
-httpVersionP = string "HTTP/"
-               *>
-               choice [ string "1.1" *> pure (HttpVersion 1 1)
-                      , string "1.0" *> pure (HttpVersion 1 0)
-                      , HttpVersion <$> decimal ⊛ (char '.' *> decimal)
-                      ]
+httpVersion ∷ Parser HttpVersion
+httpVersion = string "HTTP/"
+              *>
+              (HttpVersion <$> decimal ⊛ (char '.' *> decimal))

diff --git a/Network/HTTP/Lucu/Interaction.hs b/Network/HTTP/Lucu/Interaction.hs
index e871159ada06c278078b8d29f8fb61aaec2ca8a2..3be8928bf83a7edf473458c6760b06275b3cf886 100644 (file)
--- a/Network/HTTP/Lucu/Interaction.hs
+++ b/Network/HTTP/Lucu/Interaction.hs
@@ -34,7 +34,6 @@ import Data.Ascii (Ascii)
 import qualified Data.ByteString as Strict
 import Data.Monoid.Unicode
 import Data.Sequence (Seq)
 import qualified Data.ByteString as Strict
 import Data.Monoid.Unicode
 import Data.Sequence (Seq)

-import qualified Data.Strict.Maybe as S

 import Data.Time
 import qualified Data.Time.HTTP as HTTP
 import Data.Typeable
 import Data.Time
 import qualified Data.Time.HTTP as HTTP
 import Data.Typeable


@@ -94,7 +93,7 @@ data SemanticallyInvalidInteraction
     = SEI {
         seiRequest          ∷ !Request
       , seiExpectedContinue ∷ !Bool
     = SEI {
         seiRequest          ∷ !Request
       , seiExpectedContinue ∷ !Bool

-      , seiReqBodyLength    ∷ !(S.Maybe RequestBodyLength)
+      , seiReqBodyLength    ∷ !(Maybe RequestBodyLength)

 
       , seiResponse         ∷ !Response
       , seiWillChunkBody    ∷ !Bool
 
       , seiResponse         ∷ !Response
       , seiWillChunkBody    ∷ !Bool


@@ -138,7 +137,7 @@ data NormalInteraction
       , niRequest          ∷ !Request
       , niResourcePath     ∷ ![Strict.ByteString]
       , niExpectedContinue ∷ !Bool
       , niRequest          ∷ !Request
       , niResourcePath     ∷ ![Strict.ByteString]
       , niExpectedContinue ∷ !Bool

-      , niReqBodyLength    ∷ !(S.Maybe RequestBodyLength)
+      , niReqBodyLength    ∷ !(Maybe RequestBodyLength)

 
       , niReceiveBodyReq   ∷ !(TMVar ReceiveBodyRequest)
       , niReceivedBody     ∷ !(TMVar Strict.ByteString)
 
       , niReceiveBodyReq   ∷ !(TMVar ReceiveBodyRequest)
       , niReceivedBody     ∷ !(TMVar Strict.ByteString)

diff --git a/Network/HTTP/Lucu/MIMEType.hs b/Network/HTTP/Lucu/MIMEType.hs
index 4b509bf1e1a25f0d23bff16efc700debde2dcd0b..ab0e06596320d343164211017a8725ada3b9f07b 100644 (file)
--- a/Network/HTTP/Lucu/MIMEType.hs
+++ b/Network/HTTP/Lucu/MIMEType.hs
@@ -11,8 +11,8 @@ module Network.HTTP.Lucu.MIMEType
     , parseMIMEType
     , printMIMEType
 
     , parseMIMEType
     , printMIMEType
 

-    , mimeTypeP
-    , mimeTypeListP
+    , mimeType
+    , mimeTypeList

     )
     where
 import Control.Applicative
     )
     where
 import Control.Applicative


@@ -52,7 +52,7 @@ printMIMEType (MIMEType maj min params)
     = A.toAsciiBuilder (A.fromCIAscii maj) ⊕
       A.toAsciiBuilder "/" ⊕
       A.toAsciiBuilder (A.fromCIAscii min) ⊕
     = A.toAsciiBuilder (A.fromCIAscii maj) ⊕
       A.toAsciiBuilder "/" ⊕
       A.toAsciiBuilder (A.fromCIAscii min) ⊕

-      printParams params
+      printMIMEParams params

 
 -- |Parse 'MIMEType' from an 'Ascii'. This function throws an
 -- exception for parse error.
 
 -- |Parse 'MIMEType' from an 'Ascii'. This function throws an
 -- exception for parse error.


@@ -65,20 +65,20 @@ parseMIMEType str
     where
       p ∷ Parser MIMEType
       {-# INLINE p #-}
     where
       p ∷ Parser MIMEType
       {-# INLINE p #-}

-      p = do t ← mimeTypeP
+      p = do t ← mimeType

              endOfInput
              return t
 
 -- |'Parser' for an 'MIMEType'.
              endOfInput
              return t
 
 -- |'Parser' for an 'MIMEType'.

-mimeTypeP ∷ Parser MIMEType
-{-# INLINEABLE mimeTypeP #-}
-mimeTypeP = do maj    ← A.toCIAscii <$> token
-               _      ← char '/'
-               min    ← A.toCIAscii <$> token
-               params ← paramsP
-               return $ MIMEType maj min params
+mimeType ∷ Parser MIMEType
+{-# INLINEABLE mimeType #-}
+mimeType = do maj    ← A.toCIAscii <$> token
+              _      ← char '/'
+              min    ← A.toCIAscii <$> token
+              params ← mimeParams
+              return $ MIMEType maj min params

 
 -- |'Parser' for a list of 'MIMEType's.
 
 -- |'Parser' for a list of 'MIMEType's.

-mimeTypeListP ∷ Parser [MIMEType]
-{-# INLINE mimeTypeListP #-}
-mimeTypeListP = listOf mimeTypeP
+mimeTypeList ∷ Parser [MIMEType]
+{-# INLINE mimeTypeList #-}
+mimeTypeList = listOf mimeType

diff --git a/Network/HTTP/Lucu/MIMEType/Guess.hs b/Network/HTTP/Lucu/MIMEType/Guess.hs
index 86d7df6ef48277a798bd6e46145f77222097583d..d8bca8e785658efa5390862f8baa97c071a93f58 100644 (file)
--- a/Network/HTTP/Lucu/MIMEType/Guess.hs
+++ b/Network/HTTP/Lucu/MIMEType/Guess.hs
@@ -14,6 +14,7 @@ module Network.HTTP.Lucu.MIMEType.Guess
     )
     where
 import Control.Applicative
     )
     where
 import Control.Applicative

+import Control.Monad

 import qualified Data.Ascii as A
 import Data.Attoparsec.Char8 as P
 import qualified Data.Attoparsec.Lazy as LP
 import qualified Data.Ascii as A
 import Data.Attoparsec.Char8 as P
 import qualified Data.Attoparsec.Lazy as LP


@@ -60,7 +61,7 @@ parseExtMapFile fpath
                → fail ("Failed to parse: " ⧺ fpath ⧺ ": " ⧺ e)
 
 extMapP ∷ Parser [ (MIMEType, [Text]) ]
                → fail ("Failed to parse: " ⧺ fpath ⧺ ": " ⧺ e)
 
 extMapP ∷ Parser [ (MIMEType, [Text]) ]

-extMapP = do xs ← P.many (comment <|> validLine <|> emptyLine)
+extMapP = do xs ← P.many (try comment <|> try validLine <|> emptyLine)

              endOfInput
              return $ catMaybes xs
     where
              endOfInput
              return $ catMaybes xs
     where


@@ -68,16 +69,14 @@ extMapP = do xs ← P.many (comment <|> validLine <|> emptyLine)
       isSpc c = c ≡ '\x20' ∨ c ≡ '\x09'
 
       comment ∷ Parser (Maybe (MIMEType, [Text]))
       isSpc c = c ≡ '\x20' ∨ c ≡ '\x09'
 
       comment ∷ Parser (Maybe (MIMEType, [Text]))

-      comment = try $
-                do skipWhile isSpc
-                   _ ← char '#'
+      comment = do skipWhile isSpc
+                   void $ char '#'

                    skipWhile (≢ '\x0A')
                    return Nothing
 
       validLine ∷ Parser (Maybe (MIMEType, [Text]))
                    skipWhile (≢ '\x0A')
                    return Nothing
 
       validLine ∷ Parser (Maybe (MIMEType, [Text]))

-      validLine = try $
-                  do skipWhile isSpc
-                     mime ← mimeTypeP
+      validLine = do skipWhile isSpc
+                     mime ← mimeType

                      skipWhile isSpc
                      exts ← sepBy extP (skipWhile isSpc)
                      return $ Just (mime, exts)
                      skipWhile isSpc
                      exts ← sepBy extP (skipWhile isSpc)
                      return $ Just (mime, exts)


@@ -86,9 +85,8 @@ extMapP = do xs ← P.many (comment <|> validLine <|> emptyLine)
       extP = decodeUtf8 <$> takeWhile1 (\c → (¬) (isSpc c ∨ c ≡ '\x0A'))
 
       emptyLine ∷ Parser (Maybe (MIMEType, [Text]))
       extP = decodeUtf8 <$> takeWhile1 (\c → (¬) (isSpc c ∨ c ≡ '\x0A'))
 
       emptyLine ∷ Parser (Maybe (MIMEType, [Text]))

-      emptyLine = try $
-                  do skipWhile isSpc
-                     _ ← char '\x0A'
+      emptyLine = do skipWhile isSpc
+                     void $ char '\x0A'

                      return Nothing
 
 compile ∷ Ord k ⇒ [(v, [k])] → Either (k, v, v) (Map k v)
                      return Nothing
 
 compile ∷ Ord k ⇒ [(v, [k])] → Either (k, v, v) (Map k v)

diff --git a/Network/HTTP/Lucu/MultipartForm.hs b/Network/HTTP/Lucu/MultipartForm.hs
index 72eef21c1ec9e99be27857e48169cd0b068d6c3e..53174fa94d0a2f0ac448e4a53182800e5da64c43 100644 (file)
--- a/Network/HTTP/Lucu/MultipartForm.hs
+++ b/Network/HTTP/Lucu/MultipartForm.hs
@@ -1,52 +1,62 @@
 {-# LANGUAGE
     DoAndIfThenElse
 {-# LANGUAGE
     DoAndIfThenElse

+  , FlexibleContexts

   , OverloadedStrings
   , RecordWildCards
   , ScopedTypeVariables
   , UnicodeSyntax
   #-}
   , OverloadedStrings
   , RecordWildCards
   , ScopedTypeVariables
   , UnicodeSyntax
   #-}

+-- |Parse \"multipart/form-data\" based on RFC 2388:
+-- <http://www.faqs.org/rfcs/rfc2388.html>
+--
+-- You usually don't have to use this module directly.

 module Network.HTTP.Lucu.MultipartForm
     ( FormData(..)
 module Network.HTTP.Lucu.MultipartForm
     ( FormData(..)

-    , multipartFormP
+    , parseMultipartFormData

     )
     where
 import Control.Applicative hiding (many)
     )
     where
 import Control.Applicative hiding (many)

-import Control.Monad
+import Control.Applicative.Unicode hiding ((∅))
+import Control.Monad.Error
+import Control.Monad.Unicode

 import Data.Ascii (Ascii, CIAscii)
 import qualified Data.Ascii as A
 import Data.Attoparsec
 import Data.Ascii (Ascii, CIAscii)
 import qualified Data.Ascii as A
 import Data.Attoparsec

-import qualified Data.ByteString.Char8 as BS
+import qualified Data.Attoparsec.Lazy as LP

 import qualified Data.ByteString.Lazy.Char8 as LS
 import qualified Data.ByteString.Lazy.Char8 as LS

+import Data.ByteString.Lazy.Search
+import Data.Foldable
+import Data.List

 import Data.Map (Map)
 import qualified Data.Map as M
 import Data.Maybe
 import Data.Monoid.Unicode
 import Data.Map (Map)
 import qualified Data.Map as M
 import Data.Maybe
 import Data.Monoid.Unicode

+import Data.Sequence (Seq)
+import Data.Sequence.Unicode hiding ((∅))

 import Data.Text (Text)
 import Data.Text (Text)

+import qualified Data.Text as T

 import Network.HTTP.Lucu.Headers
 import Network.HTTP.Lucu.Headers

-import Network.HTTP.Lucu.Parser
+import Network.HTTP.Lucu.MIMEType

 import Network.HTTP.Lucu.Parser.Http
 import Network.HTTP.Lucu.RFC2231
 import Prelude.Unicode
 
 import Network.HTTP.Lucu.Parser.Http
 import Network.HTTP.Lucu.RFC2231
 import Prelude.Unicode
 

--- |This data type represents a form value and possibly an uploaded
--- file name.
+-- |'FormData' represents a form value and possibly an uploaded file
+-- name.

 data FormData
     = FormData {
 data FormData
     = FormData {

-        fdFileName ∷ Maybe Text
-      , fdContent  ∷ LS.ByteString
+        fdFileName ∷ !(Maybe Text)
+      , fdMIMEType ∷ !MIMEType
+      , fdContent  ∷ !(LS.ByteString)

       }
 
 data Part
     = Part {
       }
 
 data Part
     = Part {

-        ptHeaders   ∷ Headers
-      , ptContDispo ∷ ContDispo
-      , ptBody      ∷ LS.ByteString
+        ptContDispo ∷ !ContDispo
+      , ptContType  ∷ !MIMEType
+      , ptBody      ∷ !LS.ByteString

       }
 
       }
 

-instance HasHeaders Part where
-    getHeaders = ptHeaders
-    setHeaders pt hs = pt { ptHeaders = hs }
-

 data ContDispo
     = ContDispo {
         dType   ∷ !CIAscii
 data ContDispo
     = ContDispo {
         dType   ∷ !CIAscii


@@ -58,93 +68,179 @@ printContDispo d
     = A.fromAsciiBuilder
       ( A.toAsciiBuilder (A.fromCIAscii $ dType d)
         ⊕
     = A.fromAsciiBuilder
       ( A.toAsciiBuilder (A.fromCIAscii $ dType d)
         ⊕

-        printParams (dParams d) )
-
-multipartFormP ∷ Ascii → Parser [(Text, FormData)]
-multipartFormP boundary
-    = do void boundaryP
-         parts ← many $ partP boundaryP
-         void (string "--" <?> "suffix")
-         crlf
-         catMaybes <$> mapM partToFormPair parts
-      <?>
-      "multipartFormP"
+        printMIMEParams (dParams d) )
+
+-- |Parse \"multipart/form-data\" and return either @'Left' err@ or
+-- @'Right' result@. Note that there are currently the following
+-- limitations:
+--
+--   * Multiple files embedded as \"multipart/mixed\" within the
+--     \"multipart/form-data\" aren't decomposed.
+--
+--   * \"Content-Transfer-Encoding\"s are always ignored.
+--
+--   * RFC 2388 says that non-ASCII field names are encoded according
+--     to the method in RFC 2047
+--     <http://www.faqs.org/rfcs/rfc2047.html>, but they aren't
+--     decoded.
+parseMultipartFormData ∷ Ascii -- ^boundary
+                       → LS.ByteString -- ^input
+                       → Either String [(Ascii, FormData)]
+parseMultipartFormData boundary = (mapM partToFormPair =≪) ∘ go

     where
     where

-      boundaryP ∷ Parser BS.ByteString
-      boundaryP = string ("--" ⊕ A.toByteString boundary)
-                  <?>
-                  "boundaryP"
-
-partP ∷ Parser α → Parser Part
-partP boundaryP
-    = do crlf
-         hs   ← headersP
-         d    ← getContDispo hs
-         body ← bodyP boundaryP
-         return $ Part hs d body
+      go ∷ (Functor m, MonadError String m)
+         ⇒ LS.ByteString
+         → m [Part]
+      {-# INLINEABLE go #-}
+      go src
+          = case LP.parse (prologue boundary) src of
+              LP.Done src' _
+                  → go' src' (∅)
+              LP.Fail _ eCtx e
+                  → throwError $ "Unparsable multipart/form-data: "
+                               ⧺ intercalate ", " eCtx
+                               ⧺ ": "
+                               ⧺ e
+      go' ∷ (Functor m, MonadError String m)
+          ⇒ LS.ByteString
+          → Seq Part
+          → m [Part]
+      {-# INLINEABLE go' #-}
+      go' src xs
+          = case LP.parse epilogue src of
+              LP.Done _ _
+                  → return $ toList xs
+              LP.Fail _ _ _
+                  → do (src', x) ← parsePart boundary src
+                       go' src' $ xs ⊳ x
+
+prologue ∷ Ascii → Parser ()
+prologue boundary
+    = ( (string "--" <?> "prefix")
+        *>
+        (string (A.toByteString boundary) <?> "boundary")
+        *>
+        pure ()
+      )

       <?>
       <?>

-      "partP"
+      "prologue"
+
+epilogue ∷ Parser ()
+epilogue = ( (string "--" <?> "suffix")
+             *>
+             crlf
+             *>
+             endOfInput
+           )
+           <?>
+           "epilogue"
+
+parsePart ∷ (Functor m, MonadError String m)
+          ⇒ Ascii
+          → LS.ByteString
+          → m (LS.ByteString, Part)
+{-# INLINEABLE parsePart #-}
+parsePart boundary src
+    = case LP.parse partHeader src of
+        LP.Done src' hdrs
+            → do dispo ← getContDispo hdrs
+                 cType ← fromMaybe defaultCType <$> getContType hdrs
+                 (body, src'')
+                       ← getBody boundary src'
+                 return (src'', Part dispo cType body)
+        LP.Fail _ eCtx e
+            → throwError $ "unparsable part: "
+                         ⧺ intercalate ", " eCtx
+                         ⧺ ": "
+                         ⧺ e
+      where
+        defaultCType ∷ MIMEType
+        defaultCType = parseMIMEType "text/plain"
+
+partHeader ∷ Parser Headers
+partHeader = crlf *> headers
+
+getContDispo ∷ MonadError String m ⇒ Headers → m ContDispo
+{-# INLINEABLE getContDispo #-}
+getContDispo hdrs
+    = case getHeader "Content-Disposition" hdrs of
+        Nothing
+            → throwError "Content-Disposition is missing"
+        Just str
+            → case parseOnly p $ A.toByteString str of
+                 Right  d → return d
+                 Left err → throwError $ "malformed Content-Disposition: "
+                                       ⧺ A.toString str
+                                       ⧺ ": "
+                                       ⧺ err
+    where
+      p = do dispo ← contentDisposition
+             endOfInput
+             return dispo

 
 

-bodyP ∷ Parser α → Parser LS.ByteString
-bodyP boundaryP
-    = manyOctetsTill anyWord8 (try $ crlf *> boundaryP)
+contentDisposition ∷ Parser ContDispo
+contentDisposition
+    = (ContDispo <$> (A.toCIAscii <$> token) ⊛ mimeParams)

       <?>
       <?>

-      "bodyP"
+      "contentDisposition"
+
+getContType ∷ MonadError String m ⇒ Headers → m (Maybe MIMEType)
+{-# INLINEABLE getContType #-}
+getContType hdrs
+    = case getHeader "Content-Type" hdrs of
+        Nothing
+            → return Nothing
+        Just str
+            → case parseOnly p $ A.toByteString str of
+                 Right  d → return $ Just d
+                 Left err → throwError $ "malformed Content-Type: "
+                                       ⧺ A.toString str
+                                       ⧺ ": "
+                                       ⧺ err
+    where
+      p = do t ← mimeType
+             endOfInput
+             return t
+
+getBody ∷ MonadError String m
+        ⇒ Ascii
+        → LS.ByteString
+        → m (LS.ByteString, LS.ByteString)
+{-# INLINEABLE getBody #-}
+getBody boundary src
+    = case breakFindAfter (A.toByteString boundary) src of
+        ((before, after), True)
+            → return (before, after)
+        _   → throwError "missing boundary"

 
 

-partToFormPair ∷ Monad m ⇒ Part → m (Maybe (Text, FormData))
+partToFormPair ∷ MonadError String m ⇒ Part → m (Ascii, FormData)

 {-# INLINEABLE partToFormPair #-}
 {-# INLINEABLE partToFormPair #-}

-partToFormPair pt
-    | dType (ptContDispo pt) ≡ "form-data"
+partToFormPair pt@(Part {..})
+    | dType ptContDispo ≡ "form-data"

         = do name ← partName pt
         = do name ← partName pt

-             let fname = partFileName pt
-             let fd    = FormData {
-                           fdFileName = fname
-                         , fdContent  = ptBody pt
-                         }
-             return $ Just (name, fd)
+             let fd = FormData {
+                        fdFileName = partFileName pt
+                      , fdMIMEType = ptContType
+                      , fdContent  = ptBody
+                      }
+             return (name, fd)

     | otherwise
     | otherwise

-        = return Nothing
+        = throwError $ "disposition type is not \"form-data\": "
+                     ⧺ A.toString (A.fromCIAscii $ dType ptContDispo)

 
 

-partName ∷ Monad m ⇒ Part → m Text
+partName ∷ MonadError String m ⇒ Part → m Ascii

 {-# INLINEABLE partName #-}
 partName (Part {..})
     = case M.lookup "name" $ dParams ptContDispo of
         Just name
 {-# INLINEABLE partName #-}
 partName (Part {..})
     = case M.lookup "name" $ dParams ptContDispo of
         Just name

-            → return name
+            → case A.fromText name of
+                 Just a  → return a
+                 Nothing → throwError $ "Non-ascii part name: "
+                                      ⧺ T.unpack name

         Nothing
         Nothing

-            → fail ("form-data without name: " ⧺
-                    A.toString (printContDispo ptContDispo))
+            → throwError $ "form-data without name: "
+                         ⧺ A.toString (printContDispo ptContDispo)

 
 partFileName ∷ Part → Maybe Text
 
 partFileName ∷ Part → Maybe Text

-{-# INLINEABLE partFileName #-}

 partFileName (Part {..})
     = M.lookup "filename" $ dParams ptContDispo
 partFileName (Part {..})
     = M.lookup "filename" $ dParams ptContDispo

-
-getContDispo ∷ Monad m ⇒ Headers → m ContDispo
-{-# INLINEABLE getContDispo #-}
-getContDispo hdr
-    = case getHeader "Content-Disposition" hdr of
-        Nothing
-            → fail "There is a part without Content-Disposition in the multipart/form-data."
-        Just str
-            → let p  = do d ← contDispoP
-                          endOfInput
-                          return d
-                  bs = A.toByteString str
-              in
-                case parseOnly p bs of
-                  Right  d → return d
-                  Left err → fail (concat [ "Unparsable Content-Disposition: "
-                                          , BS.unpack bs
-                                          , ": "
-                                          , err
-                                          ])
-
-contDispoP ∷ Parser ContDispo
-{-# INLINEABLE contDispoP #-}
-contDispoP
-    = do dispoType ← A.toCIAscii <$> token
-         params    ← paramsP
-         return $ ContDispo dispoType params
-      <?>
-      "contDispoP"

diff --git a/Network/HTTP/Lucu/Parser.hs b/Network/HTTP/Lucu/Parser.hs
index 6b935c8aed2af35805f257a26f25de44e95b6a4f..87722647018232d0379aa309d08c265610f06313 100644 (file)
--- a/Network/HTTP/Lucu/Parser.hs
+++ b/Network/HTTP/Lucu/Parser.hs
@@ -7,21 +7,10 @@
 -- use this module directly.
 module Network.HTTP.Lucu.Parser
     ( atMost
 -- use this module directly.
 module Network.HTTP.Lucu.Parser
     ( atMost

-    , manyOctetsTill

     )
     where
     )
     where

-import Blaze.ByteString.Builder (Builder, Write)
-import qualified Blaze.ByteString.Builder as BB
-import qualified Blaze.ByteString.Builder.Internal as BI

 import Control.Applicative
 import Control.Applicative

-import Control.Applicative.Unicode hiding ((∅))
-import Control.Monad.Unicode
-import qualified Data.ByteString as BS
-import qualified Data.ByteString.Lazy as LS
-import Data.Monoid
-import Data.Monoid.Unicode
-import Data.Word
-import Prelude.Unicode
+import Control.Applicative.Unicode

 
 -- |@'atMost' n v@ is like @'P.many' v@ but accumulates @v@ at most
 -- @n@ times.
 
 -- |@'atMost' n v@ is like @'P.many' v@ but accumulates @v@ at most
 -- @n@ times.


@@ -31,67 +20,3 @@ atMost 0 _ = pure []
 atMost n v = ( (:) <$> v ⊛ atMost (n-1) v )
              <|>
              pure []
 atMost n v = ( (:) <$> v ⊛ atMost (n-1) v )
              <|>
              pure []

-
-data OctetAccumState
-    = OctetAccumState {
-        casChunks    ∷ !Builder
-      , casLastChunk ∷ !Write
-      }
-
-instance Monoid OctetAccumState where
-    {-# INLINE mempty #-}
-    mempty
-        = OctetAccumState {
-            casChunks    = (∅)
-          , casLastChunk = (∅)
-          }
-    {-# INLINEABLE mappend #-}
-    mappend !a !b
-        = b {
-            casChunks = casChunks a ⊕ lastChunk a ⊕ casChunks b
-          }
-
-lastChunk ∷ OctetAccumState → Builder
-{-# INLINEABLE lastChunk #-}
-lastChunk !s = case toChunk s of
-                 c → BB.insertByteString c
-    where
-      toChunk ∷ OctetAccumState → BS.ByteString
-      {-# INLINE toChunk #-}
-      toChunk = BB.toByteString ∘ BB.fromWrite ∘ casLastChunk
-
-snoc ∷ OctetAccumState → Word8 → OctetAccumState
-{-# INLINEABLE snoc #-}
-snoc !s !o
-    | BI.getBound (casLastChunk s) ≥ BI.defaultBufferSize
-        = s {
-            casChunks    = casChunks s ⊕ lastChunk s
-          , casLastChunk = BB.writeWord8 o
-          }
-    | otherwise
-        = s {
-            casLastChunk = casLastChunk s ⊕ BB.writeWord8 o
-          }
-
-finish ∷ OctetAccumState → LS.ByteString
-{-# INLINEABLE finish #-}
-finish = BB.toLazyByteString ∘ toChunks
-    where
-      toChunks ∷ OctetAccumState → Builder
-      {-# INLINE toChunks #-}
-      toChunks !s = casChunks s ⊕ lastChunk s
-
--- |@'manyOctetsTill' p end@ takes as many octets untill @p@ succeeds.
-manyOctetsTill ∷ ∀m b. (Monad m, Alternative m)
-              ⇒ m Word8
-              → m b
-              → m LS.ByteString
-{-# INLINEABLE manyOctetsTill #-}
-manyOctetsTill p end = scan (∅)
-    where
-      scan ∷ OctetAccumState → m LS.ByteString
-      {-# INLINE scan #-}
-      scan !s
-          = (end *> pure (finish s))
-            <|>
-            (scan =≪ (snoc s <$> p))

diff --git a/Network/HTTP/Lucu/Preprocess.hs b/Network/HTTP/Lucu/Preprocess.hs
index 8e3087ebae70654ae0b4a8f74b5e1f0a4102c466..26fbd53546a2412a90d40f5f30c234620ab6890d 100644 (file)
--- a/Network/HTTP/Lucu/Preprocess.hs
+++ b/Network/HTTP/Lucu/Preprocess.hs
@@ -17,7 +17,6 @@ import Data.Ascii (Ascii)
 import qualified Data.Ascii as A
 import qualified Data.ByteString.Char8 as C8
 import Data.Maybe
 import qualified Data.Ascii as A
 import qualified Data.ByteString.Char8 as C8
 import Data.Maybe

-import qualified Data.Strict.Maybe as S

 import Data.Text (Text)
 import qualified Data.Text as T
 import qualified Data.Text.Encoding as T
 import Data.Text (Text)
 import qualified Data.Text as T
 import qualified Data.Text.Encoding as T


@@ -37,7 +36,7 @@ data AugmentedRequest
       , arWillDiscardBody  ∷ !Bool
       , arWillClose        ∷ !Bool
       , arExpectedContinue ∷ !Bool
       , arWillDiscardBody  ∷ !Bool
       , arWillClose        ∷ !Bool
       , arExpectedContinue ∷ !Bool

-      , arReqBodyLength    ∷ !(S.Maybe RequestBodyLength)
+      , arReqBodyLength    ∷ !(Maybe RequestBodyLength)

       }
 
 data RequestBodyLength
       }
 
 data RequestBodyLength


@@ -57,7 +56,7 @@ preprocess localHost localPort req@(Request {..})
                   , arWillDiscardBody  = False
                   , arWillClose        = False
                   , arExpectedContinue = False
                   , arWillDiscardBody  = False
                   , arWillClose        = False
                   , arExpectedContinue = False

-                  , arReqBodyLength    = S.Nothing
+                  , arReqBodyLength    = Nothing

                   }
       go ∷ State AugmentedRequest ()
       go = do examineHttpVersion
                   }
       go ∷ State AugmentedRequest ()
       go = do examineHttpVersion


@@ -78,7 +77,7 @@ setWillClose ∷ Bool → State AugmentedRequest ()
 setWillClose b
     = modify $ \ar → ar { arWillClose = b }
 
 setWillClose b
     = modify $ \ar → ar { arWillClose = b }
 

-setBodyLength ∷ S.Maybe RequestBodyLength → State AugmentedRequest ()
+setBodyLength ∷ Maybe RequestBodyLength → State AugmentedRequest ()

 setBodyLength len
     = modify $ \ar → ar { arReqBodyLength = len }
 
 setBodyLength len
     = modify $ \ar → ar { arReqBodyLength = len }
 


@@ -174,7 +173,7 @@ examineHeaders
                | v ≡ "identity"
                    → return ()
                | v ≡ "chunked"
                | v ≡ "identity"
                    → return ()
                | v ≡ "chunked"

-                   → setBodyLength $ S.Just Chunked
+                   → setBodyLength $ Just Chunked

                | otherwise
                    → setStatus NotImplemented
 
                | otherwise
                    → setStatus NotImplemented
 


@@ -183,7 +182,7 @@ examineHeaders
            Just value → case C8.readInt value of
                            Just (len, garbage)
                                | C8.null garbage ∧ len ≥ 0
            Just value → case C8.readInt value of
                            Just (len, garbage)
                                | C8.null garbage ∧ len ≥ 0

-                                   → setBodyLength $ S.Just $ Fixed len
+                                   → setBodyLength $ Just $ Fixed len

                            _       → setStatus BadRequest
 
          case getCIHeader "Connection" req of
                            _       → setStatus BadRequest
 
          case getCIHeader "Connection" req of


@@ -198,9 +197,9 @@ examineBodyLength
          len ← gets arReqBodyLength
          if reqMustHaveBody req then
              -- POST and PUT requests must have an entity body.
          len ← gets arReqBodyLength
          if reqMustHaveBody req then
              -- POST and PUT requests must have an entity body.

-             when (S.isNothing len)
+             when (isNothing len)

                  $ setStatus LengthRequired
          else
              -- Other requests must NOT have an entity body.
                  $ setStatus LengthRequired
          else
              -- Other requests must NOT have an entity body.

-             when (S.isJust len)
+             when (isJust len)

                  $ setStatus BadRequest
                  $ setStatus BadRequest

diff --git a/Network/HTTP/Lucu/RFC2231.hs b/Network/HTTP/Lucu/RFC2231.hs
index 791c891f46d8be9009da9632537b40400c4bf378..1046c5df516f47ebcb06bcaf1ea1228a381cba72 100644 (file)
--- a/Network/HTTP/Lucu/RFC2231.hs
+++ b/Network/HTTP/Lucu/RFC2231.hs
@@ -2,7 +2,6 @@
     DoAndIfThenElse
   , OverloadedStrings
   , RecordWildCards
     DoAndIfThenElse
   , OverloadedStrings
   , RecordWildCards

-  , ScopedTypeVariables

   , UnicodeSyntax
   #-}
 -- |Provide functionalities to encode/decode MIME parameter values in
   , UnicodeSyntax
   #-}
 -- |Provide functionalities to encode/decode MIME parameter values in


@@ -11,12 +10,11 @@
 --
 -- You usually don't have to use this module directly.
 module Network.HTTP.Lucu.RFC2231
 --
 -- You usually don't have to use this module directly.
 module Network.HTTP.Lucu.RFC2231

-    ( printParams
-    , paramsP
+    ( printMIMEParams
+    , mimeParams

     )
     where
 import Control.Applicative
     )
     where
 import Control.Applicative

-import qualified Control.Exception as E

 import Control.Monad hiding (mapM)
 import Control.Monad.Unicode
 import Data.Ascii (Ascii, CIAscii, AsciiBuilder)
 import Control.Monad hiding (mapM)
 import Control.Monad.Unicode
 import Data.Ascii (Ascii, CIAscii, AsciiBuilder)


@@ -34,21 +32,19 @@ import qualified Data.Sequence as S
 import Data.Sequence.Unicode hiding ((∅))
 import Data.Text (Text)
 import qualified Data.Text as T
 import Data.Sequence.Unicode hiding ((∅))
 import Data.Text (Text)
 import qualified Data.Text as T

-import qualified Data.Text.ICU.Convert as TC

 import Data.Text.Encoding
 import Data.Text.Encoding

-import Data.Text.ICU.Error
+import Data.Text.Encoding.Error

 import Data.Traversable
 import Data.Word
 import Network.HTTP.Lucu.Parser.Http
 import Network.HTTP.Lucu.Utils
 import Prelude hiding (concat, mapM, takeWhile)
 import Prelude.Unicode
 import Data.Traversable
 import Data.Word
 import Network.HTTP.Lucu.Parser.Http
 import Network.HTTP.Lucu.Utils
 import Prelude hiding (concat, mapM, takeWhile)
 import Prelude.Unicode

-import System.IO.Unsafe

 
 

--- |Convert parameter values to an 'AsciiBuilder'.
-printParams ∷ Map CIAscii Text → AsciiBuilder
-{-# INLINEABLE printParams #-}
-printParams m = M.foldlWithKey f (∅) m
+-- |Convert MIME parameter values to an 'AsciiBuilder'.
+printMIMEParams ∷ Map CIAscii Text → AsciiBuilder
+{-# INLINEABLE printMIMEParams #-}
+printMIMEParams m = M.foldlWithKey f (∅) m

     -- THINKME: Use foldlWithKey' for newer Data.Map
     where
       f ∷ AsciiBuilder → CIAscii → Text → AsciiBuilder
     -- THINKME: Use foldlWithKey' for newer Data.Map
     where
       f ∷ AsciiBuilder → CIAscii → Text → AsciiBuilder


@@ -127,10 +123,10 @@ section ∷ ExtendedParam → Integer
 section (InitialEncodedParam {..}) = 0
 section ep                         = epSection ep
 
 section (InitialEncodedParam {..}) = 0
 section ep                         = epSection ep
 

--- |'Parser' for parameter values.
-paramsP ∷ Parser (Map CIAscii Text)
-{-# INLINEABLE paramsP #-}
-paramsP = decodeParams =≪ P.many (try paramP)
+-- |'Parser' for MIME parameter values.
+mimeParams ∷ Parser (Map CIAscii Text)
+{-# INLINEABLE mimeParams #-}
+mimeParams = decodeParams =≪ P.many (try paramP)

 
 paramP ∷ Parser ExtendedParam
 paramP = do skipMany lws
 
 paramP ∷ Parser ExtendedParam
 paramP = do skipMany lws


@@ -168,6 +164,7 @@ initialEncodedValue
              -- 2231 doesn't tell us what we should do when the
              -- charset is omitted.
              return ("US-ASCII", payload)
              -- 2231 doesn't tell us what we should do when the
              -- charset is omitted.
              return ("US-ASCII", payload)

+             -- FIXME: Rethink about this behaviour.

          else
              return (charset, payload)
     where
          else
              return (charset, payload)
     where


@@ -209,12 +206,13 @@ decodeParams ∷ Monad m ⇒ [ExtendedParam] → m (Map CIAscii Text)
 {-# INLINE decodeParams #-}
 decodeParams = (mapM decodeSections =≪) ∘ sortBySection
 
 {-# INLINE decodeParams #-}
 decodeParams = (mapM decodeSections =≪) ∘ sortBySection
 

-sortBySection ∷ ∀m. Monad m
+sortBySection ∷ Monad m

               ⇒ [ExtendedParam]
               → m (Map CIAscii (Map Integer ExtendedParam))
 sortBySection = flip go (∅)
     where
               ⇒ [ExtendedParam]
               → m (Map CIAscii (Map Integer ExtendedParam))
 sortBySection = flip go (∅)
     where

-      go ∷ [ExtendedParam]
+      go ∷ Monad m
+         ⇒ [ExtendedParam]

          → Map CIAscii (Map Integer ExtendedParam)
          → m (Map CIAscii (Map Integer ExtendedParam))
       go []     m = return m
          → Map CIAscii (Map Integer ExtendedParam)
          → m (Map CIAscii (Map Integer ExtendedParam))
       go []     m = return m


@@ -240,10 +238,11 @@ sortBySection = flip go (∅)
                                           , "'"
                                           ])
 
                                           , "'"
                                           ])
 

-decodeSections ∷ ∀m. Monad m ⇒ Map Integer ExtendedParam → m Text
+decodeSections ∷ Monad m ⇒ Map Integer ExtendedParam → m Text

 decodeSections = (decodeSeq =≪) ∘ flip (flip toSeq 0) (∅)
     where
 decodeSections = (decodeSeq =≪) ∘ flip (flip toSeq 0) (∅)
     where

-      toSeq ∷ Map Integer ExtendedParam
+      toSeq ∷ Monad m
+            ⇒ Map Integer ExtendedParam

             → Integer
             → Seq ExtendedParam
             → m (Seq ExtendedParam)
             → Integer
             → Seq ExtendedParam
             → m (Seq ExtendedParam)


@@ -262,15 +261,15 @@ decodeSections = (decodeSeq =≪) ∘ flip (flip toSeq 0) (∅)
                                        , "'"
                                        ])
 
                                        , "'"
                                        ])
 

-      decodeSeq ∷ Seq ExtendedParam → m Text
+      decodeSeq ∷ Monad m ⇒ Seq ExtendedParam → m Text

       decodeSeq sects
           = case S.viewl sects of
               EmptyL
                   → fail "decodeSeq: internal error: empty seq"
               InitialEncodedParam {..} :< xs
       decodeSeq sects
           = case S.viewl sects of
               EmptyL
                   → fail "decodeSeq: internal error: empty seq"
               InitialEncodedParam {..} :< xs

-                  → do conv ← openConv epCharset
-                       let t = TC.toUnicode conv epPayload
-                       decodeSeq' (Just conv) xs $ S.singleton t
+                  → do d ← getDecoder epCharset
+                       t ← decodeStr d epPayload
+                       decodeSeq' (Just d) xs $ S.singleton t

               ContinuedEncodedParam {..} :< _
                   → fail "decodeSeq: internal error: CEP at section 0"
               AsciiParam {..} :< xs
               ContinuedEncodedParam {..} :< _
                   → fail "decodeSeq: internal error: CEP at section 0"
               AsciiParam {..} :< xs


@@ -278,22 +277,22 @@ decodeSections = (decodeSeq =≪) ∘ flip (flip toSeq 0) (∅)
                     in
                       decodeSeq' Nothing xs $ S.singleton t
 
                     in
                       decodeSeq' Nothing xs $ S.singleton t
 

-      decodeSeq' ∷ Maybe (TC.Converter)
+      decodeSeq' ∷ Monad m
+                 ⇒ Maybe Decoder

                  → Seq ExtendedParam
                  → Seq Text
                  → m Text
                  → Seq ExtendedParam
                  → Seq Text
                  → m Text

-      decodeSeq' convM sects chunks
+      decodeSeq' decoder sects chunks

           = case S.viewl sects of
               EmptyL
                   → return $ T.concat $ toList chunks
               InitialEncodedParam {..} :< _
                   → fail "decodeSeq': internal error: IEP at section > 0"
               ContinuedEncodedParam {..} :< xs
           = case S.viewl sects of
               EmptyL
                   → return $ T.concat $ toList chunks
               InitialEncodedParam {..} :< _
                   → fail "decodeSeq': internal error: IEP at section > 0"
               ContinuedEncodedParam {..} :< xs

-                  → case convM of
-                       Just conv
-                           → let t = TC.toUnicode conv epPayload
-                             in
-                               decodeSeq' convM xs $ chunks ⊳ t
+                  → case decoder of
+                       Just d
+                           → do t ← decodeStr d epPayload
+                                decodeSeq' decoder xs $ chunks ⊳ t

                        Nothing
                            → fail (concat [ "Section "
                                           , show epSection
                        Nothing
                            → fail (concat [ "Section "
                                           , show epSection


@@ -304,13 +303,19 @@ decodeSections = (decodeSeq =≪) ∘ flip (flip toSeq 0) (∅)
               AsciiParam {..} :< xs
                   → let t = A.toText apPayload
                     in
               AsciiParam {..} :< xs
                   → let t = A.toText apPayload
                     in

-                      decodeSeq' convM xs $ chunks ⊳ t
+                      decodeSeq' decoder xs $ chunks ⊳ t
+
+type Decoder = BS.ByteString → Either UnicodeException Text
+
+decodeStr ∷ Monad m ⇒ Decoder → BS.ByteString → m Text
+decodeStr decoder str
+    = case decoder str of
+        Right t → return t
+        Left  e → fail $ show e

 
 

-      openConv ∷ CIAscii → m TC.Converter
-      openConv charset
-          = let cs    = A.toString $ A.fromCIAscii charset
-                open' = TC.open cs (Just True)
-            in
-              case unsafePerformIO $ E.try open' of
-                Right conv → return conv
-                Left  err  → fail $ show (err ∷ ICUError)
+getDecoder ∷ Monad m ⇒ CIAscii → m Decoder
+getDecoder charset
+    | charset ≡ "UTF-8"    = return decodeUtf8'
+    | charset ≡ "US-ASCII" = return decodeUtf8'
+    | otherwise            = fail $ "No decoders found for charset: "
+                                  ⧺ A.toString (A.fromCIAscii charset)

diff --git a/Network/HTTP/Lucu/Request.hs b/Network/HTTP/Lucu/Request.hs
index 853907a479c851c48896705e2b42a2a720c78f83..58286dbe6130733fcdc4b19057a061410df43a29 100644 (file)
--- a/Network/HTTP/Lucu/Request.hs
+++ b/Network/HTTP/Lucu/Request.hs
@@ -10,7 +10,7 @@ module Network.HTTP.Lucu.Request
     ( Method(..)
     , Request(..)
     , reqMustHaveBody
     ( Method(..)
     , Request(..)
     , reqMustHaveBody

-    , requestP
+    , request

     )
     where
 import Control.Applicative
     )
     where
 import Control.Applicative


@@ -62,42 +62,42 @@ reqMustHaveBody (reqMethod → m)
     | otherwise = False
 
 -- |'Parser' for a 'Request'.
     | otherwise = False
 
 -- |'Parser' for a 'Request'.

-requestP ∷ Parser Request
-requestP = do skipMany crlf
-              (method, uri, version) ← requestLineP
-              headers                ← headersP
-              return Request {
-                           reqMethod  = method
-                         , reqURI     = uri
-                         , reqVersion = version
-                         , reqHeaders = headers
-                         }
+request ∷ Parser Request
+request = do skipMany crlf
+             (meth, u, ver) ← requestLine
+             hdrs           ← headers
+             return Request {
+                          reqMethod  = meth
+                        , reqURI     = u
+                        , reqVersion = ver
+                        , reqHeaders = hdrs
+                        }

 
 

-requestLineP ∷ Parser (Method, URI, HttpVersion)
-requestLineP = do method ← methodP
-                  sp
-                  uri    ← uriP
-                  sp
-                  ver    ← httpVersionP
-                  crlf
-                  return (method, uri, ver)
+requestLine ∷ Parser (Method, URI, HttpVersion)
+requestLine = do meth ← method
+                 sp
+                 u ← uri
+                 sp
+                 ver ← httpVersion
+                 crlf
+                 return (meth, u, ver)

 
 

-methodP ∷ Parser Method
-methodP = choice
-          [ string "OPTIONS" ≫ return OPTIONS
-          , string "GET"     ≫ return GET
-          , string "HEAD"    ≫ return HEAD
-          , string "POST"    ≫ return POST
-          , string "PUT"     ≫ return PUT
-          , string "DELETE"  ≫ return DELETE
-          , string "TRACE"   ≫ return TRACE
-          , string "CONNECT" ≫ return CONNECT
-          , ExtensionMethod <$> token
-          ]
+method ∷ Parser Method
+method = choice
+         [ string "OPTIONS" ≫ return OPTIONS
+         , string "GET"     ≫ return GET
+         , string "HEAD"    ≫ return HEAD
+         , string "POST"    ≫ return POST
+         , string "PUT"     ≫ return PUT
+         , string "DELETE"  ≫ return DELETE
+         , string "TRACE"   ≫ return TRACE
+         , string "CONNECT" ≫ return CONNECT
+         , ExtensionMethod <$> token
+         ]

 
 

-uriP ∷ Parser URI
-uriP = do bs ← takeWhile1 (\c → (¬) (isCtl c ∨ c ≡ '\x20'))
-          let str = C8.unpack bs
-          case parseURIReference str of
-            Nothing  -> fail ("Unparsable URI: " ⧺ str)
-            Just uri -> return uri
+uri ∷ Parser URI
+uri = do bs ← takeWhile1 (\c → (¬) (isCtl c ∨ c ≡ '\x20'))
+         let str = C8.unpack bs
+         case parseURIReference str of
+           Nothing → fail ("Unparsable URI: " ⧺ str)
+           Just u  → return u

diff --git a/Network/HTTP/Lucu/RequestReader.hs b/Network/HTTP/Lucu/RequestReader.hs
index 5a4559e1948e29c6015ff831231b9751b91521a5..7f48c9b0f4774ff853286bda721420dceb2fc678 100644 (file)
--- a/Network/HTTP/Lucu/RequestReader.hs
+++ b/Network/HTTP/Lucu/RequestReader.hs
@@ -17,7 +17,7 @@ import qualified Data.Attoparsec.Lazy as LP
 import qualified Data.ByteString as Strict
 import qualified Data.ByteString.Lazy as Lazy
 import Data.List
 import qualified Data.ByteString as Strict
 import qualified Data.ByteString.Lazy as Lazy
 import Data.List

-import qualified Data.Strict.Maybe as S
+import Data.Maybe

 import Data.Monoid.Unicode
 import qualified Data.Sequence as S
 import Data.Sequence.Unicode hiding ((∅))
 import Data.Monoid.Unicode
 import qualified Data.Sequence as S
 import Data.Sequence.Unicode hiding ((∅))


@@ -96,7 +96,7 @@ acceptRequest ctx@(Context {..}) input
          -- リクエストを讀む。パースできない場合は直ちに 400 Bad
          -- Request 應答を設定し、それを出力してから切斷するやうに
          -- ResponseWriter に通知する。
          -- リクエストを讀む。パースできない場合は直ちに 400 Bad
          -- Request 應答を設定し、それを出力してから切斷するやうに
          -- ResponseWriter に通知する。

-         case LP.parse requestP input of
+         case LP.parse request input of

            LP.Done input' req → acceptParsableRequest ctx req input'
            LP.Fail _ _ _      → acceptNonparsableRequest ctx
 
            LP.Done input' req → acceptParsableRequest ctx req input'
            LP.Fail _ _ _      → acceptNonparsableRequest ctx
 


@@ -157,7 +157,7 @@ waitForReceiveBodyReq ∷ HandleLike h
                       → Lazy.ByteString
                       → IO ()
 waitForReceiveBodyReq ctx ni@(NI {..}) rsrcTid input
                       → Lazy.ByteString
                       → IO ()
 waitForReceiveBodyReq ctx ni@(NI {..}) rsrcTid input

-    = case S.fromJust niReqBodyLength of
+    = case fromJust niReqBodyLength of

         Chunked
             → waitForReceiveChunkedBodyReqForTheFirstTime ctx ni rsrcTid input
         Fixed len
         Chunked
             → waitForReceiveChunkedBodyReqForTheFirstTime ctx ni rsrcTid input
         Fixed len


@@ -207,13 +207,13 @@ wasteAllChunks ctx rsrcTid = go
     where
       go ∷ Lazy.ByteString → ChunkReceivingState → IO ()
       go input Initial
     where
       go ∷ Lazy.ByteString → ChunkReceivingState → IO ()
       go input Initial

-          = case LP.parse chunkHeaderP input of
+          = case LP.parse chunkHeader input of

               LP.Done input' chunkLen
                   | chunkLen ≡ 0 → gotFinalChunk input'
                   | otherwise    → gotChunk input' chunkLen
               LP.Fail _ eCtx e
                   → chunkWasMalformed rsrcTid eCtx e
               LP.Done input' chunkLen
                   | chunkLen ≡ 0 → gotFinalChunk input'
                   | otherwise    → gotChunk input' chunkLen
               LP.Fail _ eCtx e
                   → chunkWasMalformed rsrcTid eCtx e

-                        "wasteAllChunks: chunkHeaderP"
+                       "wasteAllChunks: chunkHeader"

       go input (InChunk chunkLen)
           = gotChunk input chunkLen
 
       go input (InChunk chunkLen)
           = gotChunk input chunkLen
 


@@ -221,21 +221,21 @@ wasteAllChunks ctx rsrcTid = go
       gotChunk input chunkLen
           = let input' = Lazy.drop (fromIntegral chunkLen) input
             in
       gotChunk input chunkLen
           = let input' = Lazy.drop (fromIntegral chunkLen) input
             in

-              case LP.parse chunkFooterP input' of
+              case LP.parse chunkFooter input' of

                 LP.Done input'' _
                     → go input'' Initial
                 LP.Fail _ eCtx e
                     → chunkWasMalformed rsrcTid eCtx e
                 LP.Done input'' _
                     → go input'' Initial
                 LP.Fail _ eCtx e
                     → chunkWasMalformed rsrcTid eCtx e

-                          "wasteAllChunks: chunkFooterP"
+                          "wasteAllChunks: chunkFooter"

 
       gotFinalChunk ∷ Lazy.ByteString → IO ()
       gotFinalChunk input
 
       gotFinalChunk ∷ Lazy.ByteString → IO ()
       gotFinalChunk input

-          = case LP.parse chunkTrailerP input of
+          = case LP.parse chunkTrailer input of

               LP.Done input' _
                   → acceptRequest ctx input'
               LP.Fail _ eCtx e
                   → chunkWasMalformed rsrcTid eCtx e
               LP.Done input' _
                   → acceptRequest ctx input'
               LP.Fail _ eCtx e
                   → chunkWasMalformed rsrcTid eCtx e

-                        "wasteAllChunks: chunkTrailerP"
+                        "wasteAllChunks: chunkTrailer"

 
 readCurrentChunk ∷ HandleLike h
                  ⇒ Context h
 
 readCurrentChunk ∷ HandleLike h
                  ⇒ Context h


@@ -249,7 +249,7 @@ readCurrentChunk ctx ni@(NI {..}) rsrcTid wanted = go
     where
       go ∷ Lazy.ByteString → ChunkReceivingState → IO ()
       go input Initial
     where
       go ∷ Lazy.ByteString → ChunkReceivingState → IO ()
       go input Initial

-          = case LP.parse chunkHeaderP input of
+          = case LP.parse chunkHeader input of

               LP.Done input' chunkLen
                   | chunkLen ≡ 0
                       → gotFinalChunk input'
               LP.Done input' chunkLen
                   | chunkLen ≡ 0
                       → gotFinalChunk input'


@@ -257,7 +257,7 @@ readCurrentChunk ctx ni@(NI {..}) rsrcTid wanted = go
                       → gotChunk input' chunkLen
               LP.Fail _ eCtx e
                   → chunkWasMalformed rsrcTid eCtx e
                       → gotChunk input' chunkLen
               LP.Fail _ eCtx e
                   → chunkWasMalformed rsrcTid eCtx e

-                        "readCurrentChunk: chunkHeaderP"
+                        "readCurrentChunk: chunkHeader"

       go input (InChunk chunkLen)
           = gotChunk input chunkLen
 
       go input (InChunk chunkLen)
           = gotChunk input chunkLen
 


@@ -270,24 +270,24 @@ readCurrentChunk ctx ni@(NI {..}) rsrcTid wanted = go
                    chunkLen'       = chunkLen - actualReadBytes
                atomically $ putTMVar niReceivedBody block'
                if chunkLen' ≡ 0 then
                    chunkLen'       = chunkLen - actualReadBytes
                atomically $ putTMVar niReceivedBody block'
                if chunkLen' ≡ 0 then

-                   case LP.parse chunkFooterP input' of
+                   case LP.parse chunkFooter input' of

                      LP.Done input'' _
                          → waitForReceiveChunkedBodyReq ctx ni rsrcTid input'' Initial
                      LP.Fail _ eCtx e
                          → chunkWasMalformed rsrcTid eCtx e
                      LP.Done input'' _
                          → waitForReceiveChunkedBodyReq ctx ni rsrcTid input'' Initial
                      LP.Fail _ eCtx e
                          → chunkWasMalformed rsrcTid eCtx e

-                               "readCurrentChunk: chunkFooterP: "
+                               "readCurrentChunk: chunkFooter"

                else
                    waitForReceiveChunkedBodyReq ctx ni rsrcTid input' $ InChunk chunkLen'
 
       gotFinalChunk ∷ Lazy.ByteString → IO ()
       gotFinalChunk input
           = do atomically $ putTMVar niReceivedBody (∅)
                else
                    waitForReceiveChunkedBodyReq ctx ni rsrcTid input' $ InChunk chunkLen'
 
       gotFinalChunk ∷ Lazy.ByteString → IO ()
       gotFinalChunk input
           = do atomically $ putTMVar niReceivedBody (∅)

-               case LP.parse chunkTrailerP input of
+               case LP.parse chunkTrailer input of

                  LP.Done input' _
                      → acceptRequest ctx input'
                  LP.Fail _ eCtx e
                      → chunkWasMalformed rsrcTid eCtx e
                  LP.Done input' _
                      → acceptRequest ctx input'
                  LP.Fail _ eCtx e
                      → chunkWasMalformed rsrcTid eCtx e

-                           "readCurrentChunk: chunkTrailerP"
+                           "readCurrentChunk: chunkTrailer"

 
 chunkWasMalformed ∷ ThreadId → [String] → String → String → IO ()
 chunkWasMalformed tid eCtx e msg
 
 chunkWasMalformed ∷ ThreadId → [String] → String → String → IO ()
 chunkWasMalformed tid eCtx e msg

diff --git a/Network/HTTP/Lucu/Resource.hs b/Network/HTTP/Lucu/Resource.hs
index 71ff4838c3945380d44f2dee36fddc2b3952d3d1..6463bc8fd7d0fc0ee12b50a8a3363891af894127 100644 (file)
--- a/Network/HTTP/Lucu/Resource.hs
+++ b/Network/HTTP/Lucu/Resource.hs
@@ -141,13 +141,13 @@ import Blaze.ByteString.Builder (Builder)
 import qualified Blaze.ByteString.Builder as BB
 import qualified Blaze.ByteString.Builder.Internal as BB
 import Control.Applicative
 import qualified Blaze.ByteString.Builder as BB
 import qualified Blaze.ByteString.Builder.Internal as BB
 import Control.Applicative

+import Control.Arrow

 import Control.Monad
 import Control.Monad.IO.Class
 import Control.Monad.Unicode
 import Data.Ascii (Ascii, CIAscii)
 import qualified Data.Ascii as A
 import qualified Data.Attoparsec.Char8 as P
 import Control.Monad
 import Control.Monad.IO.Class
 import Control.Monad.Unicode
 import Data.Ascii (Ascii, CIAscii)
 import qualified Data.Ascii as A
 import qualified Data.Attoparsec.Char8 as P

-import qualified Data.Attoparsec.Lazy  as LP

 import Data.ByteString (ByteString)
 import qualified Data.ByteString as Strict
 import qualified Data.ByteString.Lazy as Lazy
 import Data.ByteString (ByteString)
 import qualified Data.ByteString as Strict
 import qualified Data.ByteString.Lazy as Lazy


@@ -158,7 +158,6 @@ import Data.Monoid
 import Data.Monoid.Unicode
 import Data.Text (Text)
 import qualified Data.Text as T
 import Data.Monoid.Unicode
 import Data.Text (Text)
 import qualified Data.Text as T

-import qualified Data.Text.Encoding as T

 import Data.Time
 import qualified Data.Time.HTTP as HTTP
 import Network.HTTP.Lucu.Abortion
 import Data.Time
 import qualified Data.Time.HTTP as HTTP
 import Network.HTTP.Lucu.Abortion


@@ -182,15 +181,17 @@ import Prelude.Unicode
 -- |Get the string representation of the address of remote host. If
 -- you want a 'SockAddr' instead of 'HostName', use 'getRemoteAddr'.
 getRemoteAddr' ∷ Resource HostName
 -- |Get the string representation of the address of remote host. If
 -- you want a 'SockAddr' instead of 'HostName', use 'getRemoteAddr'.
 getRemoteAddr' ∷ Resource HostName

-getRemoteAddr'
-    = do sa ← getRemoteAddr
-         (fromJust ∘ fst) <$> (liftIO $ getNameInfo [NI_NUMERICHOST] True False sa)
+getRemoteAddr' = liftIO ∘ toNM =≪ getRemoteAddr
+    where
+      toNM ∷ SockAddr → IO HostName
+      toNM = (fromJust ∘ fst <$>) ∘ getNameInfo [NI_NUMERICHOST] True False

 
 -- |Resolve an address to the remote host.
 getRemoteHost ∷ Resource (Maybe HostName)
 
 -- |Resolve an address to the remote host.
 getRemoteHost ∷ Resource (Maybe HostName)

-getRemoteHost
-    = do sa ← getRemoteAddr
-         fst <$> (liftIO $ getNameInfo [] True False sa)
+getRemoteHost = liftIO ∘ getHN =≪ getRemoteAddr
+    where
+      getHN ∷ SockAddr → IO (Maybe HostName)
+      getHN = (fst <$>) ∘ getNameInfo [] True False

 
 -- |Get the 'Method' value of the request.
 getMethod ∷ Resource Method
 
 -- |Get the 'Method' value of the request.
 getMethod ∷ Resource Method


@@ -218,9 +219,8 @@ getPathInfo = do rsrcPath ← getResourcePath
 -- |Assume the query part of request URI as
 -- application\/x-www-form-urlencoded, and parse it into pairs of
 -- @(name, formData)@. This function doesn't read the request
 -- |Assume the query part of request URI as
 -- application\/x-www-form-urlencoded, and parse it into pairs of
 -- @(name, formData)@. This function doesn't read the request

--- body. Field names are decoded in UTF-8 for an hardly avoidable
--- reason. See 'getForm'.
-getQueryForm ∷ Resource [(Text, FormData)]
+-- body.
+getQueryForm ∷ Resource [(Strict.ByteString, FormData)]

 getQueryForm = parse' <$> getRequestURI
     where
       parse' = map toPairWithFormData ∘
 getQueryForm = parse' <$> getRequestURI
     where
       parse' = map toPairWithFormData ∘


@@ -230,13 +230,14 @@ getQueryForm = parse' <$> getRequestURI
                drop 1 ∘
                uriQuery
 
                drop 1 ∘
                uriQuery
 

-toPairWithFormData ∷ (ByteString, ByteString) → (Text, FormData)
+toPairWithFormData ∷ (ByteString, ByteString) → (Strict.ByteString, FormData)

 toPairWithFormData (name, value)
     = let fd = FormData {
                  fdFileName = Nothing
 toPairWithFormData (name, value)
     = let fd = FormData {
                  fdFileName = Nothing

+               , fdMIMEType = parseMIMEType "text/plain"

                , fdContent  = Lazy.fromChunks [value]
                }
                , fdContent  = Lazy.fromChunks [value]
                }

-      in (T.decodeUtf8 name, fd)
+      in (name, fd)

 
 -- |@'getHeader' name@ returns the value of the request header field
 -- @name@. Comparison of header name is case-insensitive. Note that
 
 -- |@'getHeader' name@ returns the value of the request header field
 -- @name@. Comparison of header name is case-insensitive. Note that


@@ -260,7 +261,7 @@ getAccept
                     Left  _  → abort $ mkAbortion' BadRequest
                                      $ "Unparsable Accept: " ⊕ A.toText accept
     where
                     Left  _  → abort $ mkAbortion' BadRequest
                                      $ "Unparsable Accept: " ⊕ A.toText accept
     where

-      p = do xs ← mimeTypeListP
+      p = do xs ← mimeTypeList

              P.endOfInput
              return xs
 
              P.endOfInput
              return xs
 


@@ -292,7 +293,7 @@ getAcceptEncoding
                        Left  _  → abort $ mkAbortion' BadRequest
                                         $ "Unparsable Accept-Encoding: " ⊕ A.toText ae
     where
                        Left  _  → abort $ mkAbortion' BadRequest
                                         $ "Unparsable Accept-Encoding: " ⊕ A.toText ae
     where

-      p = do xs ← acceptEncodingListP
+      p = do xs ← acceptEncodingList

              P.endOfInput
              return xs
 
              P.endOfInput
              return xs
 


@@ -320,7 +321,7 @@ getContentType
                     Left  _ → abort $ mkAbortion' BadRequest
                                     $ "Unparsable Content-Type: " ⊕ A.toText cType
     where
                     Left  _ → abort $ mkAbortion' BadRequest
                                     $ "Unparsable Content-Type: " ⊕ A.toText cType
     where

-      p = do t ← mimeTypeP
+      p = do t ← mimeType

              P.endOfInput
              return t
 
              P.endOfInput
              return t
 


@@ -337,7 +338,7 @@ getAuthorization
                     Right ac → return $ Just ac
                     Left  _  → return Nothing
     where
                     Right ac → return $ Just ac
                     Left  _  → return Nothing
     where

-      p = do ac ← authCredentialP
+      p = do ac ← authCredential

              P.endOfInput
              return ac
 
              P.endOfInput
              return ac
 


@@ -436,7 +437,7 @@ foundETag tag
 
          driftTo ReceivingBody
     where
 
          driftTo ReceivingBody
     where

-      p = do xs ← eTagListP
+      p = do xs ← eTagList

              P.endOfInput
              return xs
 
              P.endOfInput
              return xs
 


@@ -527,7 +528,6 @@ foundNoEntity' ∷ Resource ()
 {-# INLINE foundNoEntity' #-}
 foundNoEntity' = foundNoEntity Nothing
 
 {-# INLINE foundNoEntity' #-}
 foundNoEntity' = foundNoEntity Nothing
 

-

 -- |@'getChunks' limit@ attemts to read the entire request body up to
 -- @limit@ bytes, and then make the 'Resource' transit to the
 -- /Deciding Header/ state. When the actual size of the body is larger
 -- |@'getChunks' limit@ attemts to read the entire request body up to
 -- @limit@ bytes, and then make the 'Resource' transit to the
 -- /Deciding Header/ state. When the actual size of the body is larger


@@ -577,13 +577,9 @@ getChunks' limit = go limit (∅)
 -- Media Type\". If the request has no \"Content-Type\", it aborts
 -- with \"400 Bad Request\".
 --
 -- Media Type\". If the request has no \"Content-Type\", it aborts
 -- with \"400 Bad Request\".
 --

--- Field names in @multipart\/form-data@ will be precisely decoded in
--- accordance with RFC 2231. On the other hand,
--- @application\/x-www-form-urlencoded@ says nothing about character
--- encodings for field names, so they'll always be decoded in
--- UTF-8. (This could be a bad design, but I can't think of any better
--- idea.)
-getForm ∷ Maybe Int → Resource [(Text, FormData)]
+-- Note that there are currently a few limitations on parsing
+-- @multipart/form-data@. See 'parseMultipartFormData'
+getForm ∷ Maybe Int → Resource [(Strict.ByteString, FormData)]

 getForm limit
     = do cTypeM ← getContentType
          case cTypeM of
 getForm limit
     = do cTypeM ← getContentType
          case cTypeM of


@@ -620,19 +616,9 @@ getForm limit
                                 Just b  → return b
                                 Nothing → abort $ mkAbortion' BadRequest
                                                 $ "Malformed boundary: " ⊕ boundary
                                 Just b  → return b
                                 Nothing → abort $ mkAbortion' BadRequest
                                                 $ "Malformed boundary: " ⊕ boundary

-                       case LP.parse (p b) src of
-                         LP.Done _ formList
-                             → return formList
-                         LP.Fail _ eCtx e
-                             → abort $ mkAbortion' BadRequest
-                                     $ "Unparsable multipart/form-data: "
-                                     ⊕ T.pack (intercalate ", " eCtx)
-                                     ⊕ ": "
-                                     ⊕ T.pack e
-          where
-            p b = do xs ← multipartFormP b
-                     P.endOfInput
-                     return xs
+                       case parseMultipartFormData b src of
+                         Right xs → return $ map (first A.toByteString) xs
+                         Left err → abort $ mkAbortion' BadRequest $ T.pack err

 
 -- |@'redirect' code uri@ declares the response status as @code@ and
 -- \"Location\" header field as @uri@. The @code@ must satisfy
 
 -- |@'redirect' code uri@ declares the response status as @code@ and
 -- \"Location\" header field as @uri@. The @code@ must satisfy

diff --git a/Network/HTTP/Lucu/Resource/Internal.hs b/Network/HTTP/Lucu/Resource/Internal.hs
index 9df36a601cf7dc460dd8b98f92ed084054719504..0a1f89f0c270288321ab9472b6ba4ce13872bb11 100644 (file)
--- a/Network/HTTP/Lucu/Resource/Internal.hs
+++ b/Network/HTTP/Lucu/Resource/Internal.hs
@@ -329,9 +329,7 @@ setStatus sc
 -- body and thinks that the residual 10 bytes is a part of the header
 -- of the next response.
 setHeader ∷ CIAscii → Ascii → Resource ()
 -- body and thinks that the residual 10 bytes is a part of the header
 -- of the next response.
 setHeader ∷ CIAscii → Ascii → Resource ()

-setHeader name value
-    = do ni ← getInteraction
-         liftIO $ atomically $ go ni
+setHeader name value = liftIO ∘ atomically ∘ go =≪ getInteraction

     where
       go ∷ NormalInteraction → STM ()
       go (NI {..})
     where
       go ∷ NormalInteraction → STM ()
       go (NI {..})


@@ -346,9 +344,7 @@ setHeader name value
 -- |@'deleteHeader' name@ deletes a response header @name@ if
 -- any. This function is not intended to be used so frequently.
 deleteHeader ∷ CIAscii → Resource ()
 -- |@'deleteHeader' name@ deletes a response header @name@ if
 -- any. This function is not intended to be used so frequently.
 deleteHeader ∷ CIAscii → Resource ()

-deleteHeader name
-    = do ni ← getInteraction
-         liftIO $ atomically $ go ni
+deleteHeader name = liftIO ∘ atomically ∘ go =≪ getInteraction

     where
       go ∷ NormalInteraction → STM ()
       go (NI {..})
     where
       go ∷ NormalInteraction → STM ()
       go (NI {..})


@@ -368,9 +364,7 @@ deleteHeader name
 -- \"Content-Type\" before applying this function. See
 -- 'setContentType'.
 putBuilder ∷ Builder → Resource ()
 -- \"Content-Type\" before applying this function. See
 -- 'setContentType'.
 putBuilder ∷ Builder → Resource ()

-putBuilder b
-    = do ni ← getInteraction
-         liftIO $ atomically $ go ni
+putBuilder b = liftIO ∘ atomically ∘ go =≪ getInteraction

     where
       go ∷ NormalInteraction → STM ()
       go ni@(NI {..})
     where
       go ∷ NormalInteraction → STM ()
       go ni@(NI {..})


@@ -383,9 +377,7 @@ putBuilder b
                putTMVar niBodyToSend b
 
 driftTo ∷ InteractionState → Resource ()
                putTMVar niBodyToSend b
 
 driftTo ∷ InteractionState → Resource ()

-driftTo newState
-    = do ni ← getInteraction
-         liftIO $ atomically $ driftTo' ni newState
+driftTo = (getInteraction ≫=) ∘ ((liftIO ∘ atomically) ∘) ∘ flip driftTo'

 
 driftTo' ∷ NormalInteraction → InteractionState → STM ()
 driftTo' ni@(NI {..}) newState
 
 driftTo' ∷ NormalInteraction → InteractionState → STM ()
 driftTo' ni@(NI {..}) newState

diff --git a/Network/HTTP/Lucu/Response.hs b/Network/HTTP/Lucu/Response.hs
index 5c25b543006a7320a6ec05968aa02d3eda6eb848..35c168fb38cde77ea2227cb2b808d00c9da79322 100644 (file)
--- a/Network/HTTP/Lucu/Response.hs
+++ b/Network/HTTP/Lucu/Response.hs
@@ -23,8 +23,6 @@ module Network.HTTP.Lucu.Response
     , isError
     , isClientError
     , isServerError
     , isError
     , isClientError
     , isServerError

-
-    , statusCode

     )
     where
 import Data.Ascii (Ascii, AsciiBuilder)
     )
     where
 import Data.Ascii (Ascii, AsciiBuilder)


@@ -176,8 +174,6 @@ satisfy ∷ (Int → Bool) → StatusCode → Bool
 {-# INLINE satisfy #-}
 satisfy p (statusCode → (# num, _ #)) = p num
 
 {-# INLINE satisfy #-}
 satisfy p (statusCode → (# num, _ #)) = p num
 

--- |@'statusCode' sc@ returns an unboxed tuple of numeric and textual
--- representation of @sc@.

 statusCode ∷ StatusCode → (# Int, Ascii #)
 {-# INLINEABLE statusCode #-}
 
 statusCode ∷ StatusCode → (# Int, Ascii #)
 {-# INLINEABLE statusCode #-}
 


@@ -231,3 +227,5 @@ statusCode ServiceUnavailable          = (# 503, "Service Unavailable"
 statusCode GatewayTimeout              = (# 504, "Gateway Timeout"               #)
 statusCode HttpVersionNotSupported     = (# 505, "HTTP Version Not Supported"    #)
 statusCode InsufficientStorage         = (# 507, "Insufficient Storage"          #)
 statusCode GatewayTimeout              = (# 504, "Gateway Timeout"               #)
 statusCode HttpVersionNotSupported     = (# 505, "HTTP Version Not Supported"    #)
 statusCode InsufficientStorage         = (# 507, "Insufficient Storage"          #)

+-- FIXME: Textual representations should also include numbers.
+-- FIXME: StatusCode should be a type class rather than a type.

diff --git a/Network/HTTP/Lucu/Utils.hs b/Network/HTTP/Lucu/Utils.hs
index 7dbb1162cbda616ae5eb57ce989bc481f813a9ac..3d38b8b3aec36c9dff990cb4c7e66d05995ad27e 100644 (file)
--- a/Network/HTTP/Lucu/Utils.hs
+++ b/Network/HTTP/Lucu/Utils.hs
@@ -96,3 +96,5 @@ show3 = A.unsafeFromBuilder ∘ go
            | i ≥ 0 ∧ i < 100  = B.fromByteString "0"  ⊕ BT.integral i
            | i ≥ 0 ∧ i < 1000 =                         BT.integral i
            | otherwise        = error ("show3: the integer i must satisfy 0 <= i < 1000: " ⧺ show i)
            | i ≥ 0 ∧ i < 100  = B.fromByteString "0"  ⊕ BT.integral i
            | i ≥ 0 ∧ i < 1000 =                         BT.integral i
            | otherwise        = error ("show3: the integer i must satisfy 0 <= i < 1000: " ⧺ show i)

+-- FIXME: Drop this function as soon as possible, to eliminate the
+-- dependency on blaze-textual.

diff --git a/bugs/issue-a5e6a89da31d2ca0a69d89ad1d579fee8d0c131f.yaml b/bugs/issue-a5e6a89da31d2ca0a69d89ad1d579fee8d0c131f.yaml
index e4a9614fb4579334b3210145a50a4c6bc5ed004d..43cf56d460681ce457e910138c71d43fc35f07ef 100644 (file)
--- a/bugs/issue-a5e6a89da31d2ca0a69d89ad1d579fee8d0c131f.yaml
+++ b/bugs/issue-a5e6a89da31d2ca0a69d89ad1d579fee8d0c131f.yaml
@@ -1,5 +1,5 @@
 --- !ditz.rubyforge.org,2008-03-06/issue 
 --- !ditz.rubyforge.org,2008-03-06/issue 

-title: "Add a configuration flag -fSSL to enable SSL support (default: on)"
+title: "Add a configuration flag -fSSL to enable SSL support (default: off)"

 desc: |-
   Reason #1: SSL support isn't essential for Lucu.
   Reason #2: We have toooo many dependencies now, want to drop at least HsOpenSSL.
 desc: |-
   Reason #1: SSL support isn't essential for Lucu.
   Reason #2: We have toooo many dependencies now, want to drop at least HsOpenSSL.


@@ -18,4 +18,8 @@ log_events:
   - PHO <pho@cielonegro.org>
   - created
   - ""
   - PHO <pho@cielonegro.org>
   - created
   - ""

+- - 2011-10-27 17:33:31.904875 Z
+  - PHO <pho@cielonegro.org>
+  - edited title
+  - Should be defaulted to off!

 git_branch: 
 git_branch: 

diff --git a/data/CompileMimeTypes.hs b/data/CompileMimeTypes.hs
index 811840670178be97fa220b74fa082ae5d526c082..9ba5b1ed0ed228b5a1ca83d5aac33f8fae1d21ba 100755 (executable)
--- a/data/CompileMimeTypes.hs
+++ b/data/CompileMimeTypes.hs
@@ -1,10 +1,13 @@
 #!/usr/bin/env runghc
 #!/usr/bin/env runghc

-
+{-# LANGUAGE
+    UnicodeSyntax
+  #-}

 import Network.HTTP.Lucu.MIMEType.Guess
 import System
 
 import Network.HTTP.Lucu.MIMEType.Guess
 import System
 

-main = do [inFile, outFile] <- getArgs
-          extMap <- parseExtMapFile inFile
+main ∷ IO ()
+main = do [inFile, outFile] ← getArgs
+          extMap ← parseExtMapFile inFile

 
           let src = serializeExtMap
                     extMap
 
           let src = serializeExtMap
                     extMap