Network/HTTP/Lucu/MultipartForm.hs

   1 module Network.HTTP.Lucu.MultipartForm
   2     ( multipartFormP
   3     )
   4     where
   5
   6 import qualified Data.ByteString.Char8 as C8
   7 import qualified Data.ByteString.Lazy.Char8 as L8
   8 import           Data.Char
   9 import           Data.List
  10 import           Network.HTTP.Lucu.Abortion
  11 import           Network.HTTP.Lucu.Headers
  12 import           Network.HTTP.Lucu.Parser
  13 import           Network.HTTP.Lucu.Parser.Http
  14 import           Network.HTTP.Lucu.Response
  15 import           Network.HTTP.Lucu.Utils
  16
  17
  18 data Part = Part Headers String
  19
  20 instance HasHeaders Part where
  21     getHeaders (Part hs _)    = hs
  22     setHeaders (Part _  b) hs = Part hs b
  23
  24
  25 data ContDispo = ContDispo String [(String, String)]
  26
  27 instance Show ContDispo where
  28     show (ContDispo dType dParams)
  29         = dType ++
  30           if null dParams then
  31               ""
  32           else
  33               "; " ++ joinWith "; " (map showPair dParams)
  34         where
  35           showPair :: (String, String) -> String
  36           showPair (name, value)
  37               = name ++ "=" ++ if any (not . isToken) value then
  38                                    quoteStr value
  39                                else
  40                                    value
  41
  42
  43 multipartFormP :: String -> Parser [(String, String)]
  44 multipartFormP boundary
  45     = do parts <- many (partP boundary)
  46          string "--"
  47          string boundary
  48          string "--"
  49          crlf
  50          eof
  51          return $ map partToPair parts
  52
  53
  54 partP :: String -> Parser Part
  55 partP boundary
  56     = do string "--"
  57          string boundary
  58          crlf -- バウンダリの末尾に -- が付いてゐたらここで fail する。
  59          hs   <- headersP
  60          body <- bodyP boundary
  61          return $ Part hs body
  62
  63
  64 bodyP :: String -> Parser String
  65 bodyP boundary
  66     = do body <- many $
  67                  do notFollowedBy $ do crlf
  68                                        string "--"
  69                                        string boundary
  70                     anyChar
  71          crlf
  72          return body
  73
  74
  75 partToPair :: Part -> (String, String)
  76 partToPair part@(Part _ body)
  77     = case getHeader (C8.pack "Content-Disposition") part of
  78         Nothing
  79             -> abortPurely BadRequest []
  80                (Just "There is a part without Content-Disposition in the multipart/form-data.")
  81         Just dispoStr
  82             -> case parse contDispoP (L8.fromChunks [dispoStr]) of
  83                  (# Success dispo, _ #)
  84                      -> (getName dispo, body)
  85                  (# _, _ #)
  86                      -> abortPurely BadRequest []
  87                         (Just $ "Unparsable Content-Disposition: " ++ C8.unpack dispoStr)
  88       where
  89         getName :: ContDispo -> String
  90         getName dispo@(ContDispo dType dParams)
  91             | map toLower dType == "form-data"
  92                 = case find ((== "name") . map toLower . fst) dParams of
  93                     Just (_, name) -> name
  94                     Nothing
  95                         -> abortPurely BadRequest []
  96                            (Just $ "form-data without name: " ++ show dispo)
  97             | otherwise
  98                 = abortPurely BadRequest []
  99                   (Just $ "Content-Disposition type is not form-data: " ++ dType)
 100
 101
 102 contDispoP :: Parser ContDispo
 103 contDispoP = do dispoType <- token
 104                 params    <- allowEOF $ many paramP
 105                 return $ ContDispo dispoType params
 106     where
 107       paramP :: Parser (String, String)
 108       paramP = do many lws
 109                   char ';'
 110                   many lws
 111                   name <- token
 112                   char '='
 113                   value <- token <|> quotedStr
 114                   return (name, value)