Release 0.3.3

Ignore-this: d01a902c8221a1e31a12ba50faa08b46

* Network.HTTP.Lucu.Resource:
    - getQueryForm and inputForm now returns [FormData] instead of
      [(String, String)] to possibly include a name of uploaded file.

darcs-hash:20091103070543-62b54-c5a9028cee38478ef6b6002907f236b130d7a431.gz

diff --git a/Lucu.cabal b/Lucu.cabal
index 325195c87cc47e221491fed7a26d8510d3d793f8..110eda1228e19dbe247ddd65957176148c803f47 100644 (file)
--- a/Lucu.cabal
+++ b/Lucu.cabal
@@ -8,7 +8,7 @@ Description:
         messing around FastCGI. It is also intended to be run behind a
         reverse-proxy so it doesn't have some facilities like logging,
         client filtering or such like.
         messing around FastCGI. It is also intended to be run behind a
         reverse-proxy so it doesn't have some facilities like logging,
         client filtering or such like.

-Version: 0.3.2
+Version: 0.3.3

 License: PublicDomain
 License-File: COPYING
 Author: PHO <pho at cielonegro dot org>
 License: PublicDomain
 License-File: COPYING
 Author: PHO <pho at cielonegro dot org>


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

-        BangPatterns, DeriveDataTypeable, UnboxedTuples
+        BangPatterns, DeriveDataTypeable, ScopedTypeVariables, UnboxedTuples

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


@@ -92,7 +92,7 @@ Executable lucu-implant-file
         Buildable: False
     Main-Is: ImplantFile.hs
     Extensions:
         Buildable: False
     Main-Is: ImplantFile.hs
     Extensions:

-        BangPatterns, UnboxedTuples
+        BangPatterns, ScopedTypeVariables, UnboxedTuples

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


@@ -101,3 +101,8 @@ Executable lucu-implant-file
 --    Main-Is: HelloWorld.hs
 --    Hs-Source-Dirs: ., examples
 --    ghc-options: -fglasgow-exts -Wall -funbox-strict-fields -O3 -prof -auto-all
 --    Main-Is: HelloWorld.hs
 --    Hs-Source-Dirs: ., examples
 --    ghc-options: -fglasgow-exts -Wall -funbox-strict-fields -O3 -prof -auto-all

+
+--Executable Multipart
+--    Main-Is: Multipart.hs
+--    Hs-Source-Dirs: ., examples
+--    ghc-options: -XBangPatterns -fglasgow-exts -Wall -funbox-strict-fields -prof -auto-all

diff --git a/NEWS b/NEWS
index c5814dcc2d0d5d6803688bbaccf5f3c62e19a1e5..52c508211534029d8798d9d5350330855bb5dc3a 100644 (file)
--- a/NEWS
+++ b/NEWS
@@ -1,3 +1,9 @@
+Changes from 0.3.2 to 0.3.3
+---------------------------
+* Network.HTTP.Lucu.Resource:
+    - getQueryForm and inputForm now returns [FormData] instead of
+      [(String, String)] to possibly include a name of uploaded file.
+

 Changes from 0.3.1 to 0.3.2
 ---------------------------
 * Network.HTTP.Lucu.Parser:
 Changes from 0.3.1 to 0.3.2
 ---------------------------
 * Network.HTTP.Lucu.Parser:

diff --git a/Network/HTTP/Lucu/MultipartForm.hs b/Network/HTTP/Lucu/MultipartForm.hs
index 8903d7f88d3c4736faccf4aaacf6c3d8361c98cd..4a34ba549764e722ea613de97ff5ff80bd116d79 100644 (file)
--- a/Network/HTTP/Lucu/MultipartForm.hs
+++ b/Network/HTTP/Lucu/MultipartForm.hs
@@ -1,5 +1,6 @@
 module Network.HTTP.Lucu.MultipartForm
 module Network.HTTP.Lucu.MultipartForm

-    ( multipartFormP
+    ( FormData(..)
+    , multipartFormP

     )
     where
 
     )
     where
 


@@ -17,6 +18,15 @@ import           Network.HTTP.Lucu.Utils
 
 data Part = Part Headers String
 
 
 data Part = Part Headers String
 

+-- |This data type represents a form entry name, form value and
+-- possibly an uploaded file name.
+data FormData
+    = FormData {
+        fdName     :: String
+      , fdFileName :: Maybe String
+      , fdContent  :: String
+      }
+

 instance HasHeaders Part where
     getHeaders (Part hs _)    = hs
     setHeaders (Part _  b) hs = Part hs b
 instance HasHeaders Part where
     getHeaders (Part hs _)    = hs
     setHeaders (Part _  b) hs = Part hs b


@@ -40,7 +50,7 @@ instance Show ContDispo where
                                    value
 
 
                                    value
 
 

-multipartFormP :: String -> Parser [(String, String)]
+multipartFormP :: String -> Parser [FormData]

 multipartFormP boundary
     = do parts <- many (partP boundary)
          string "--"
 multipartFormP boundary
     = do parts <- many (partP boundary)
          string "--"


@@ -48,7 +58,7 @@ multipartFormP boundary
          string "--"
          crlf
          eof
          string "--"
          crlf
          eof

-         return $ map partToPair parts
+         return $ map partToFormData parts

 
 
 partP :: String -> Parser Part
 
 
 partP :: String -> Parser Part


@@ -72,8 +82,51 @@ bodyP boundary
          return body
 
 
          return body
 
 

-partToPair :: Part -> (String, String)
-partToPair part@(Part _ body)
+partToFormData :: Part -> FormData
+partToFormData part@(Part _ body)
+    = let name  = partName part
+          fName = partFileName part
+      in
+        FormData {
+          fdName     = name
+        , fdFileName = fName
+        , fdContent  = body
+        }
+
+
+partName :: Part -> String
+partName = getName' . getContDispoFormData
+    where
+      getName' :: ContDispo -> String
+      getName' dispo@(ContDispo _ dParams)
+          = case find ((== "name") . map toLower . fst) dParams of
+              Just (_, name) -> name
+              Nothing   
+                  -> abortPurely BadRequest []
+                     (Just $ "form-data without name: " ++ show dispo)
+
+
+partFileName :: Part -> Maybe String
+partFileName = getFileName' . getContDispoFormData
+    where
+      getFileName' :: ContDispo -> Maybe String
+      getFileName' (ContDispo _ dParams)
+          = do (_, fileName) <- find ((== "filename") . map toLower . fst) dParams
+               return fileName
+
+getContDispoFormData :: Part -> ContDispo
+getContDispoFormData part
+    = let dispo@(ContDispo dType _) = getContDispo part
+      in
+        if map toLower dType == "form-data" then
+            dispo
+        else
+            abortPurely BadRequest []
+            (Just $ "Content-Disposition type is not form-data: " ++ dType)
+
+
+getContDispo :: Part -> ContDispo
+getContDispo part

     = case getHeader (C8.pack "Content-Disposition") part of
         Nothing  
             -> abortPurely BadRequest []
     = case getHeader (C8.pack "Content-Disposition") part of
         Nothing  
             -> abortPurely BadRequest []


@@ -81,22 +134,10 @@ partToPair part@(Part _ body)
         Just dispoStr
             -> case parse contDispoP (L8.fromChunks [dispoStr]) of
                  (# Success dispo, _ #)
         Just dispoStr
             -> case parse contDispoP (L8.fromChunks [dispoStr]) of
                  (# Success dispo, _ #)

-                     -> (getName dispo, body)
+                     -> dispo

                  (# _, _ #)
                      -> abortPurely BadRequest []
                         (Just $ "Unparsable Content-Disposition: " ++ C8.unpack dispoStr)
                  (# _, _ #)
                      -> abortPurely BadRequest []
                         (Just $ "Unparsable Content-Disposition: " ++ C8.unpack dispoStr)

-      where
-        getName :: ContDispo -> String
-        getName dispo@(ContDispo dType dParams)
-            | map toLower dType == "form-data"
-                = case find ((== "name") . map toLower . fst) dParams of
-                    Just (_, name) -> name
-                    Nothing   
-                        -> abortPurely BadRequest []
-                           (Just $ "form-data without name: " ++ show dispo)
-            | otherwise
-                = abortPurely BadRequest []
-                  (Just $ "Content-Disposition type is not form-data: " ++ dType)

 
 
 contDispoP :: Parser ContDispo
 
 
 contDispoP :: Parser ContDispo

diff --git a/Network/HTTP/Lucu/Parser.hs b/Network/HTTP/Lucu/Parser.hs
index 8c591defd4be602e13db5534567637039b0679bb..6c66e7f42e3c02c7fc12b63ceab537dfda0774d1 100644 (file)
--- a/Network/HTTP/Lucu/Parser.hs
+++ b/Network/HTTP/Lucu/Parser.hs
@@ -54,6 +54,9 @@ module Network.HTTP.Lucu.Parser
 import           Control.Monad.State.Strict
 import qualified Data.ByteString.Lazy as Lazy (ByteString)
 import qualified Data.ByteString.Lazy.Char8 as B hiding (ByteString)
 import           Control.Monad.State.Strict
 import qualified Data.ByteString.Lazy as Lazy (ByteString)
 import qualified Data.ByteString.Lazy.Char8 as B hiding (ByteString)

+import qualified Data.Foldable as Fold
+import qualified Data.Sequence as Seq
+import           Data.Sequence (Seq, (|>))

 
 -- |@'Parser' a@ is obviously a parser which parses and returns @a@.
 newtype Parser a = Parser {
 
 -- |@'Parser' a@ is obviously a parser which parses and returns @a@.
 newtype Parser a = Parser {


@@ -142,22 +145,22 @@ allowEOF f = f `seq`
 
 
 satisfy :: (Char -> Bool) -> Parser Char
 
 
 satisfy :: (Char -> Bool) -> Parser Char

-satisfy f = f `seq`
-            do c <- anyChar
-               if f $! c then
-                   return c
-                 else
-                   failP
+satisfy !f
+    = do c <- anyChar
+         if f c then
+             return c
+           else
+             failP

 
 
 char :: Char -> Parser Char
 
 
 char :: Char -> Parser Char

-char c = c `seq` satisfy (== c)
+char !c = satisfy (== c)

 
 
 string :: String -> Parser String
 
 
 string :: String -> Parser String

-string str = str `seq`
-             do mapM_ char str
-                return str
+string !str = str `seq`
+              do mapM_ char str
+                 return str

 
 
 infixr 0 <|>
 
 
 infixr 0 <|>


@@ -190,9 +193,8 @@ oneOf = foldl (<|>) failP . map char
 
 
 notFollowedBy :: Parser a -> Parser ()
 
 
 notFollowedBy :: Parser a -> Parser ()

-notFollowedBy p
-    = p `seq`
-      Parser $! do saved  <- get -- 状態を保存
+notFollowedBy !p
+    = Parser $! do saved  <- get -- 状態を保存

                    result <- runParser p
                    case result of
                      Success _    -> do put saved -- 状態を復歸
                    result <- runParser p
                    case result of
                      Success _    -> do put saved -- 状態を復歸


@@ -221,25 +223,22 @@ hexDigit = do c <- anyChar
                   failP
 
 
                   failP
 
 

-many :: Parser a -> Parser [a]
-many !p = Parser $! many' p []
-
--- This implementation is rather ugly but we need to make it
--- tail-recursive to avoid stack overflow.
-many' :: Parser a -> [a] -> State ParserState (ParserResult [a])
-many' !p !soFar
-    = do saved  <- get
-         result <- runParser p
-         case result of
-           Success a    -> many' p (a:soFar)
-           IllegalInput -> do put saved
-                              return $! Success $ reverse soFar
-           ReachedEOF   -> if pstIsEOFFatal saved then
-                               do put saved
-                                  return ReachedEOF
-                           else
-                               do put saved
-                                  return $! Success $ reverse soFar
+many :: forall a. Parser a -> Parser [a]
+many !p = Parser $!
+          do state <- get
+             let (# result, state' #) = many' state Seq.empty
+             put state'
+             return result
+    where
+      many' :: ParserState -> Seq a -> (# ParserResult [a], ParserState #)
+      many' !st !soFar
+          = case runState (runParser p) st of
+              (Success a,  st') -> many' st' (soFar |> a)
+              (IllegalInput, _) -> (# Success (Fold.toList soFar), st #)
+              (ReachedEOF  , _) -> if pstIsEOFFatal st then
+                                       (# ReachedEOF, st #)
+                                   else
+                                       (# Success (Fold.toList soFar), st #)

 
 
 many1 :: Parser a -> Parser [a]
 
 
 many1 :: Parser a -> Parser [a]


@@ -249,16 +248,16 @@ many1 !p = do x  <- p
 
 
 count :: Int -> Parser a -> Parser [a]
 
 
 count :: Int -> Parser a -> Parser [a]

-count !n !p = Parser $! count' n p []
+count !n !p = Parser $! count' n p Seq.empty

 
 -- This implementation is rather ugly but we need to make it
 -- tail-recursive to avoid stack overflow.
 
 -- This implementation is rather ugly but we need to make it
 -- tail-recursive to avoid stack overflow.

-count' :: Int -> Parser a -> [a] -> State ParserState (ParserResult [a])
-count' 0  _  !soFar = return $! Success $ reverse soFar
+count' :: Int -> Parser a -> Seq a -> State ParserState (ParserResult [a])
+count' 0  _  !soFar = return $! Success $! Fold.toList soFar

 count' !n !p !soFar = do saved  <- get
                          result <- runParser p
                          case result of
 count' !n !p !soFar = do saved  <- get
                          result <- runParser p
                          case result of

-                           Success a    -> count' (n-1) p (a:soFar)
+                           Success a    -> count' (n-1) p (soFar |> a)

                            IllegalInput -> do put saved
                                               return IllegalInput
                            ReachedEOF   -> do put saved
                            IllegalInput -> do put saved
                                               return IllegalInput
                            ReachedEOF   -> do put saved

diff --git a/Network/HTTP/Lucu/Resource.hs b/Network/HTTP/Lucu/Resource.hs
index 3a27e9ca5e1acbe786d83a949e7711c6d0657ffb..a9d487c0908188dbe1c5ad4294a5b224778e7ec2 100644 (file)
--- a/Network/HTTP/Lucu/Resource.hs
+++ b/Network/HTTP/Lucu/Resource.hs
@@ -61,7 +61,8 @@
 module Network.HTTP.Lucu.Resource
     (
     -- * Monad
 module Network.HTTP.Lucu.Resource
     (
     -- * Monad

-    Resource
+      Resource
+    , FormData(..)

     , runRes -- private
 
     -- * Actions
     , runRes -- private
 
     -- * Actions


@@ -302,9 +303,17 @@ getPathInfo = do rsrcPath <- getResourcePath
 -- | Assume the query part of request URI as
 -- application\/x-www-form-urlencoded, and parse it. This action
 -- doesn't parse the request body. See 'inputForm'.
 -- | Assume the query part of request URI as
 -- application\/x-www-form-urlencoded, and parse it. This action
 -- doesn't parse the request body. See 'inputForm'.

-getQueryForm :: Resource [(String, String)]
+getQueryForm :: Resource [FormData]

 getQueryForm = do uri <- getRequestURI
 getQueryForm = do uri <- getRequestURI

-                  return $! parseWWWFormURLEncoded $ snd $ splitAt 1 $ uriQuery uri
+                  return $! map pairToFormData $ parseWWWFormURLEncoded $ snd $ splitAt 1 $ uriQuery uri
+
+pairToFormData :: (String, String) -> FormData
+pairToFormData (name, value)
+    = FormData {
+        fdName     = name
+      , fdFileName = Nothing
+      , fdContent  = value
+      }

 
 -- |Get a value of given request header. Comparison of header name is
 -- case-insensitive. Note that this action is not intended to be used
 
 -- |Get a value of given request header. Comparison of header name is
 -- case-insensitive. Note that this action is not intended to be used


@@ -716,7 +725,7 @@ inputChunkLBS limit
 -- makes 'Resource' abort with status \"415 Unsupported Media
 -- Type\". If the request has no \"Content-Type\", it aborts with
 -- \"400 Bad Request\".
 -- makes 'Resource' abort with status \"415 Unsupported Media
 -- Type\". If the request has no \"Content-Type\", it aborts with
 -- \"400 Bad Request\".

-inputForm :: Int -> Resource [(String, String)]
+inputForm :: Int -> Resource [FormData]

 inputForm limit
     = limit `seq` 
       do cTypeM <- getContentType
 inputForm limit
     = limit `seq` 
       do cTypeM <- getContentType


@@ -733,7 +742,7 @@ inputForm limit
     where
       readWWWFormURLEncoded
           = do src <- input limit
     where
       readWWWFormURLEncoded
           = do src <- input limit

-               return $ parseWWWFormURLEncoded src
+               return $ map pairToFormData $ parseWWWFormURLEncoded src

 
       readMultipartFormData params
           = do case find ((== "boundary") . map toLower . fst) params of
 
       readMultipartFormData params
           = do case find ((== "boundary") . map toLower . fst) params of


@@ -742,7 +751,7 @@ inputForm limit
                  Just (_, boundary)
                      -> do src <- inputLBS limit
                            case parse (multipartFormP boundary) src of
                  Just (_, boundary)
                      -> do src <- inputLBS limit
                            case parse (multipartFormP boundary) src of

-                             (# Success pairs, _ #) -> return pairs
+                             (# Success fdList, _ #) -> return fdList

                              (# _, _ #)
                                  -> abort BadRequest [] (Just "Unparsable multipart/form-data")
 
                              (# _, _ #)
                                  -> abort BadRequest [] (Just "Unparsable multipart/form-data")
 

diff --git a/examples/Multipart.hs b/examples/Multipart.hs
index 6c15cd3a8a4ab1130737c1c770983892edb2d596..1e2d50b3fd2ea9370ed45b44536e4ad6837744cb 100644 (file)
--- a/examples/Multipart.hs
+++ b/examples/Multipart.hs
@@ -28,11 +28,13 @@ resMain
       , resHead   = Nothing
       , resPost
           = Just $ do form <- inputForm defaultLimit
       , resHead   = Nothing
       , resPost
           = Just $ do form <- inputForm defaultLimit

-                      let text = fromMaybe "" $ fmap snd $ find ((== "text") . fst) form
-                          file = fromMaybe "" $ fmap snd $ find ((== "file") . fst) form
+                      let text     = fromMaybe "" $ fmap fdContent $ find ((== "text") . fdName) form
+                          file     = fromMaybe "" $ fmap fdContent $ find ((== "file") . fdName) form
+                          fileName = fdFileName =<< find ((== "file") . fdName) form

                       setContentType $ read "text/plain"
                       outputChunk ("You entered \"" ++ text ++ "\".\n")
                       setContentType $ read "text/plain"
                       outputChunk ("You entered \"" ++ text ++ "\".\n")

-                      output ("You uploaded a " ++ show (length file) ++ " bytes long file.\n")
+                      outputChunk ("You uploaded a " ++ show (length file) ++ " bytes long file.\n")
+                      output ("The file name is " ++ show fileName ++ ".\n")

       , resPut    = Nothing
       , resDelete = Nothing
       }
\ No newline at end of file
       , resPut    = Nothing
       , resDelete = Nothing
       }
\ No newline at end of file