Network/HTTP/Lucu/MultipartForm.hs

   1 {-# LANGUAGE
   2     UnboxedTuples
   3   , UnicodeSyntax
   4   #-}
   5 module Network.HTTP.Lucu.MultipartForm
   6     ( FormData(..)
   7     , multipartFormP
   8     )
   9     where
  10 import qualified Data.ByteString.Char8 as C8
  11 import qualified Data.ByteString.Lazy.Char8 as L8
  12 import           Data.Char
  13 import           Data.List
  14 import           Network.HTTP.Lucu.Abortion
  15 import           Network.HTTP.Lucu.Headers
  16 import           Network.HTTP.Lucu.Parser.Http
  17 import           Network.HTTP.Lucu.Response
  18 import           Network.HTTP.Lucu.Utils
  19
  20 data Part = Part Headers L8.ByteString
  21
  22 -- |This data type represents a form value and possibly an uploaded
  23 -- file name.
  24 data FormData
  25     = FormData {
  26         fdFileName :: Maybe String
  27       , fdContent  :: L8.ByteString
  28       }
  29
  30 instance HasHeaders Part where
  31     getHeaders (Part hs _)    = hs
  32     setHeaders (Part _  b) hs = Part hs b
  33
  34
  35 data ContDispo = ContDispo String [(String, String)]
  36
  37 instance Show ContDispo where
  38     show (ContDispo dType dParams)
  39         = dType ++
  40           if null dParams then
  41               ""
  42           else
  43               "; " ++ joinWith "; " (map showPair dParams)
  44         where
  45           showPair :: (String, String) -> String
  46           showPair (name, value)
  47               = name ++ "=" ++ if any (not . isToken) value then
  48                                    quoteStr value
  49                                else
  50                                    value
  51
  52
  53 multipartFormP :: String -> Parser [(String, FormData)]
  54 multipartFormP boundary
  55     = do parts <- many (partP boundary)
  56          _     <- string "--"
  57          _     <- string boundary
  58          _     <- string "--"
  59          _     <- crlf
  60          eof
  61          return $ map partToFormPair parts
  62
  63
  64 partP :: String -> Parser Part
  65 partP boundary
  66     = do _    <- string "--"
  67          _    <- string boundary
  68          _    <- crlf -- バウンダリの末尾に -- が付いてゐたらここで fail する。
  69          hs   <- headersP
  70          body <- bodyP boundary
  71          return $ Part hs body
  72
  73
  74 bodyP :: String -> Parser L8.ByteString
  75 bodyP boundary
  76     = do body <- manyChar $
  77                  do notFollowedBy $ ( crlf         >>
  78                                       string "--"  >>
  79                                       string boundary )
  80                     anyChar
  81          _    <- crlf
  82          return body
  83
  84
  85 partToFormPair :: Part -> (String, FormData)
  86 partToFormPair part@(Part _ body)
  87     = let name  = partName part
  88           fname = partFileName part
  89           fd    = FormData {
  90                     fdFileName = fname
  91                   , fdContent  = body
  92                   }
  93       in (name, fd)
  94
  95 partName :: Part -> String
  96 partName = getName' . getContDispoFormData
  97     where
  98       getName' :: ContDispo -> String
  99       getName' dispo@(ContDispo _ dParams)
 100           = case find ((== "name") . map toLower . fst) dParams of
 101               Just (_, name) -> name
 102               Nothing
 103                   -> abortPurely BadRequest []
 104                      (Just $ "form-data without name: " ++ show dispo)
 105
 106
 107 partFileName :: Part -> Maybe String
 108 partFileName = getFileName' . getContDispoFormData
 109     where
 110       getFileName' :: ContDispo -> Maybe String
 111       getFileName' (ContDispo _ dParams)
 112           = do (_, fileName) <- find ((== "filename") . map toLower . fst) dParams
 113                return fileName
 114
 115 getContDispoFormData :: Part -> ContDispo
 116 getContDispoFormData part
 117     = let dispo@(ContDispo dType _) = getContDispo part
 118       in
 119         if map toLower dType == "form-data" then
 120             dispo
 121         else
 122             abortPurely BadRequest []
 123             (Just $ "Content-Disposition type is not form-data: " ++ dType)
 124
 125
 126 getContDispo :: Part -> ContDispo
 127 getContDispo part
 128     = case getHeader (C8.pack "Content-Disposition") part of
 129         Nothing
 130             -> abortPurely BadRequest []
 131                (Just "There is a part without Content-Disposition in the multipart/form-data.")
 132         Just dispoStr
 133             -> case parse contDispoP (L8.fromChunks [dispoStr]) of
 134                  (# Success dispo, _ #)
 135                      -> dispo
 136                  (# _, _ #)
 137                      -> abortPurely BadRequest []
 138                         (Just $ "Unparsable Content-Disposition: " ++ C8.unpack dispoStr)
 139
 140
 141 contDispoP :: Parser ContDispo
 142 contDispoP = do dispoType <- token
 143                 params    <- allowEOF $ many paramP
 144                 return $ ContDispo dispoType params
 145     where
 146       paramP :: Parser (String, String)
 147       paramP = do _     <- many lws
 148                   _     <- char ';'
 149                   _     <- many lws
 150                   name  <- token
 151                   _     <- char '='
 152                   value <- token <|> quotedStr
 153                   return (name, value)