Network/HTTP/Lucu/MultipartForm.hs

   1 module Network.HTTP.Lucu.MultipartForm
   2     ( FormData(..)
   3     , multipartFormP
   4     )
   5     where
   6
   7 import qualified Data.ByteString.Char8 as C8
   8 import qualified Data.ByteString.Lazy.Char8 as L8
   9 import           Data.Char
  10 import           Data.List
  11 import           Network.HTTP.Lucu.Abortion
  12 import           Network.HTTP.Lucu.Headers
  13 import           Network.HTTP.Lucu.Parser
  14 import           Network.HTTP.Lucu.Parser.Http
  15 import           Network.HTTP.Lucu.Response
  16 import           Network.HTTP.Lucu.Utils
  17
  18
  19 data Part = Part Headers L8.ByteString
  20
  21 -- |This data type represents a form entry name, form value and
  22 -- possibly an uploaded file name.
  23 data FormData
  24     = FormData {
  25         fdName     :: String
  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 [FormData]
  54 multipartFormP boundary
  55     = do parts <- many (partP boundary)
  56          string "--"
  57          string boundary
  58          string "--"
  59          crlf
  60          eof
  61          return $ map partToFormData 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 $ do crlf
  78                                        string "--"
  79                                        string boundary
  80                     anyChar
  81          crlf
  82          return body
  83
  84
  85 partToFormData :: Part -> FormData
  86 partToFormData part@(Part _ body)
  87     = let name  = partName part
  88           fName = partFileName part
  89       in
  90         FormData {
  91           fdName     = name
  92         , fdFileName = fName
  93         , fdContent  = body
  94         }
  95
  96
  97 partName :: Part -> String
  98 partName = getName' . getContDispoFormData
  99     where
 100       getName' :: ContDispo -> String
 101       getName' dispo@(ContDispo _ dParams)
 102           = case find ((== "name") . map toLower . fst) dParams of
 103               Just (_, name) -> name
 104               Nothing
 105                   -> abortPurely BadRequest []
 106                      (Just $ "form-data without name: " ++ show dispo)
 107
 108
 109 partFileName :: Part -> Maybe String
 110 partFileName = getFileName' . getContDispoFormData
 111     where
 112       getFileName' :: ContDispo -> Maybe String
 113       getFileName' (ContDispo _ dParams)
 114           = do (_, fileName) <- find ((== "filename") . map toLower . fst) dParams
 115                return fileName
 116
 117 getContDispoFormData :: Part -> ContDispo
 118 getContDispoFormData part
 119     = let dispo@(ContDispo dType _) = getContDispo part
 120       in
 121         if map toLower dType == "form-data" then
 122             dispo
 123         else
 124             abortPurely BadRequest []
 125             (Just $ "Content-Disposition type is not form-data: " ++ dType)
 126
 127
 128 getContDispo :: Part -> ContDispo
 129 getContDispo part
 130     = case getHeader (C8.pack "Content-Disposition") part of
 131         Nothing
 132             -> abortPurely BadRequest []
 133                (Just "There is a part without Content-Disposition in the multipart/form-data.")
 134         Just dispoStr
 135             -> case parse contDispoP (L8.fromChunks [dispoStr]) of
 136                  (# Success dispo, _ #)
 137                      -> dispo
 138                  (# _, _ #)
 139                      -> abortPurely BadRequest []
 140                         (Just $ "Unparsable Content-Disposition: " ++ C8.unpack dispoStr)
 141
 142
 143 contDispoP :: Parser ContDispo
 144 contDispoP = do dispoType <- token
 145                 params    <- allowEOF $ many paramP
 146                 return $ ContDispo dispoType params
 147     where
 148       paramP :: Parser (String, String)
 149       paramP = do many lws
 150                   char ';'
 151                   many lws
 152                   name <- token
 153                   char '='
 154                   value <- token <|> quotedStr
 155                   return (name, value)