X-Git-Url: http://git.cielonegro.org/gitweb.cgi?a=blobdiff_plain;f=Network%2FHTTP%2FLucu%2FMultipartForm.hs;h=c4631300e9efae3b3d14ac57917597ef685032fd;hb=70bf5bd248aa426ca4e410b3fb9a0529354aedaf;hp=21fca67b8519f2a13d29c5c11cfbda6a116c5c18;hpb=e53a2f3202f763e844de725712f1bf26b82cd41f;p=Lucu.git

diff --git a/Network/HTTP/Lucu/MultipartForm.hs b/Network/HTTP/Lucu/MultipartForm.hs
index 21fca67..c463130 100644
--- a/Network/HTTP/Lucu/MultipartForm.hs
+++ b/Network/HTTP/Lucu/MultipartForm.hs
@@ -1,10 +1,15 @@
+{-# LANGUAGE
+    UnboxedTuples
+  , UnicodeSyntax
+  #-}
 module Network.HTTP.Lucu.MultipartForm
-    ( multipartFormP
+    ( FormData(..)
+    , multipartFormP
     )
     where
 
-import           Data.ByteString.Base (LazyByteString(..))
 import qualified Data.ByteString.Char8 as C8
+import qualified Data.ByteString.Lazy.Char8 as L8
 import           Data.Char
 import           Data.List
 import           Network.HTTP.Lucu.Abortion
@@ -15,7 +20,15 @@ import           Network.HTTP.Lucu.Response
 import           Network.HTTP.Lucu.Utils
 
 
-data Part = Part Headers String
+data Part = Part Headers L8.ByteString
+
+-- |This data type represents a form value and possibly an uploaded
+-- file name.
+data FormData
+    = FormData {
+        fdFileName :: Maybe String
+      , fdContent  :: L8.ByteString
+      }
 
 instance HasHeaders Part where
     getHeaders (Part hs _)    = hs
@@ -40,63 +53,92 @@ instance Show ContDispo where
                                    value
 
 
-multipartFormP :: String -> Parser [(String, String)]
+multipartFormP :: String -> Parser [(String, FormData)]
 multipartFormP boundary
     = do parts <- many (partP boundary)
-         string "--"
-         string boundary
-         string "--"
-         crlf
+         _     <- string "--"
+         _     <- string boundary
+         _     <- string "--"
+         _     <- crlf
          eof
-         return $ map partToPair parts
+         return $ map partToFormPair parts
 
 
 partP :: String -> Parser Part
 partP boundary
-    = do string "--"
-         string boundary
-         crlf -- バウンダリの末尾に -- が付いてゐたらここで fail する。
+    = do _    <- string "--"
+         _    <- string boundary
+         _    <- crlf -- バウンダリの末尾に -- が付いてゐたらここで fail する。
          hs   <- headersP
          body <- bodyP boundary
          return $ Part hs body
 
 
-bodyP :: String -> Parser String
+bodyP :: String -> Parser L8.ByteString
 bodyP boundary
-    = do body <- many $
-                 do notFollowedBy $ do crlf
-                                       string "--"
-                                       string boundary
+    = do body <- manyChar $
+                 do notFollowedBy $ ( crlf         >>
+                                      string "--"  >>
+                                      string boundary )
                     anyChar
-         crlf
+         _    <- crlf
          return body
 
 
-partToPair :: Part -> (String, String)
-partToPair part@(Part _ body)
+partToFormPair :: Part -> (String, FormData)
+partToFormPair part@(Part _ body)
+    = let name  = partName part
+          fname = partFileName part
+          fd    = FormData {
+                    fdFileName = fname
+                  , fdContent  = body
+                  }
+      in (name, fd)
+
+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 []
                (Just "There is a part without Content-Disposition in the multipart/form-data.")
-        Just dispo
-            -> case parse contDispoP (LPS [dispo]) of
+        Just dispoStr
+            -> case parse contDispoP (L8.fromChunks [dispoStr]) of
                  (# Success dispo, _ #)
-                     -> (getName dispo, body)
+                     -> dispo
                  (# _, _ #)
                      -> abortPurely BadRequest []
-                        (Just $ "Unparsable Content-Disposition: " ++ C8.unpack dispo)
-      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)
+                        (Just $ "Unparsable Content-Disposition: " ++ C8.unpack dispoStr)
 
 
 contDispoP :: Parser ContDispo
@@ -105,10 +147,10 @@ contDispoP = do dispoType <- token
                 return $ ContDispo dispoType params
     where
       paramP :: Parser (String, String)
-      paramP = do many lws
-                  char ';'
-                  many lws
-                  name <- token
-                  char '='
+      paramP = do _     <- many lws
+                  _     <- char ';'
+                  _     <- many lws
+                  name  <- token
+                  _     <- char '='
                   value <- token <|> quotedStr
                   return (name, value)