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