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