1 {-# LANGUAGE BangPatterns #-} 2 {-# LANGUAGE CPP #-} 3 {-# LANGUAGE DeriveDataTypeable #-} 4 {-# LANGUAGE ExistentialQuantification #-} 5 {-# LANGUAGE FlexibleContexts #-} 6 {-# LANGUAGE OverloadedStrings #-} 7 {-# LANGUAGE ScopedTypeVariables #-} 8 9 module Snap.Internal.Util.FileUploads 10 ( -- * Functions 11 handleFileUploads 12 , handleMultipart 13 , PartProcessor 14 15 -- * Uploaded parts 16 , PartInfo(..) 17 , PartDisposition(..) 18 , toPartDisposition 19 20 -- ** Policy 21 -- *** General upload policy 22 , UploadPolicy(..) 23 , defaultUploadPolicy 24 , doProcessFormInputs 25 , setProcessFormInputs 26 , getMaximumFormInputSize 27 , setMaximumFormInputSize 28 , getMaximumNumberOfFormInputs 29 , setMaximumNumberOfFormInputs 30 , getMinimumUploadRate 31 , setMinimumUploadRate 32 , getMinimumUploadSeconds 33 , setMinimumUploadSeconds 34 , getUploadTimeout 35 , setUploadTimeout 36 37 -- *** Per-file upload policy 38 , PartUploadPolicy(..) 39 , disallow 40 , allowWithMaximumSize 41 42 -- * Exceptions 43 , FileUploadException(..) 44 , fileUploadExceptionReason 45 , BadPartException(..) 46 , PolicyViolationException(..) 47 ) where 48 49 ------------------------------------------------------------------------------ 50 import Control.Applicative (Alternative ((<|>)), Applicative ((*>), (<*), pure)) 51 import Control.Arrow (Arrow (first)) 52 import Control.Exception.Lifted (Exception, SomeException (..), bracket, catch, fromException, mask, throwIO, toException) 53 import qualified Control.Exception.Lifted as E (try) 54 import Control.Monad (Functor (fmap), Monad ((>>=), return), MonadPlus (mzero), guard, liftM, sequence, void, when, (>=>)) 55 import Data.Attoparsec.ByteString.Char8 (Parser, isEndOfLine, string, takeWhile) 56 import qualified Data.Attoparsec.ByteString.Char8 as Atto (try) 57 import Data.ByteString.Char8 (ByteString) 58 import qualified Data.ByteString.Char8 as S 59 import Data.ByteString.Internal (c2w) 60 import qualified Data.CaseInsensitive as CI (mk) 61 import Data.Int (Int, Int64) 62 import Data.List (concat, find, map, (++)) 63 import qualified Data.Map as Map (insertWith', size) 64 import Data.Maybe (Maybe (..), fromMaybe, isJust, maybe) 65 import Data.Text (Text) 66 import qualified Data.Text as T (concat, pack, unpack) 67 import qualified Data.Text.Encoding as TE (decodeUtf8) 68 import Data.Typeable (Typeable, cast) 69 import Prelude (Bool (..), Double, Either (..), Eq (..), FilePath, IO, Ord (..), Show (..), String, const, either, flip, fst, id, max, not, otherwise, snd, ($), ($!), (.), (^), (||)) 70 import Snap.Core (HasHeaders (headers), Headers, MonadSnap, Request (rqParams, rqPostParams), getHeader, getRequest, getTimeoutModifier, putRequest, runRequestBody) 71 import Snap.Internal.Parsing (crlf, fullyParse, pContentTypeWithParameters, pHeaders, pValueWithParameters) 72 import qualified Snap.Types.Headers as H (fromList) 73 import System.Directory (removeFile) 74 import System.FilePath ((</>)) 75 import System.IO (BufferMode (NoBuffering), Handle, hClose, hSetBuffering) 76 import System.IO.Streams (InputStream, MatchInfo (..), TooManyBytesReadException, search) 77 import qualified System.IO.Streams as Streams 78 import System.IO.Streams.Attoparsec (parseFromStream) 79 import System.PosixCompat.Temp (mkstemp) 80 ------------------------------------------------------------------------------ 81 82 ------------------------------------------------------------------------------ 83 -- | Reads uploaded files into a temporary directory and calls a user handler 84 -- to process them. 85 -- 86 -- Note: /THE REQUEST MUST BE CORRECTLY ENCODED/. If the request's 87 -- @Content-type@ is not \"@multipart/formdata@\", this function skips 88 -- processing using 'pass'. 89 -- 90 -- Given a temporary directory, global and file-specific upload policies, and a 91 -- user handler, this function consumes a request body uploaded with 92 -- @Content-type: multipart/form-data@. Each file is read into the temporary 93 -- directory, and is then passed to the user handler. After the user handler 94 -- runs (but before the 'Response' body is streamed to the client), the files 95 -- are deleted from disk; so if you want to retain or use the uploaded files in 96 -- the generated response, you need to move or otherwise process them. 97 -- 98 -- The argument passed to the user handler is a tuple: 99 -- 100 -- > (PartInfo, Either PolicyViolationException FilePath) 101 -- 102 -- The first half of this tuple is a 'PartInfo', which contains the 103 -- information the client browser sent about the given upload part (like 104 -- filename, content-type, etc). The second half of this tuple is an 'Either' 105 -- stipulating that either: 106 -- 107 -- 1. the file was rejected on a policy basis because of the provided 108 -- 'PartUploadPolicy' handler 109 -- 110 -- 2. the file was accepted and exists at the given path. 111 -- 112 -- /Exceptions/ 113 -- 114 -- If the client's upload rate passes below the configured minimum (see 115 -- 'setMinimumUploadRate' and 'setMinimumUploadSeconds'), this function 116 -- terminates the connection. This setting is there to protect the server 117 -- against slowloris-style denial of service attacks. 118 -- 119 -- If the given 'UploadPolicy' stipulates that you wish form inputs to be 120 -- placed in the 'rqParams' parameter map (using 'setProcessFormInputs'), and 121 -- a form input exceeds the maximum allowable size, this function will throw a 122 -- 'PolicyViolationException'. 123 -- 124 -- If an uploaded part contains MIME headers longer than a fixed internal 125 -- threshold (currently 32KB), this function will throw a 'BadPartException'. 126 127 handleFileUploads :: 128 (MonadSnap m) => 129 FilePath -- ^ temporary directory 130 -> UploadPolicy -- ^ general upload policy 131 -> (PartInfo -> PartUploadPolicy) -- ^ per-part upload policy 132 -> (PartInfo -> Either PolicyViolationException FilePath -> IO a) 133 -- ^ user handler (see function 134 -- description) 135 -> m [a] 136 handleFileUploads tmpdir uploadPolicy partPolicy partHandler = 137 handleMultipart uploadPolicy go 138 139 where 140 go partInfo stream = maybe disallowed takeIt mbFs 141 where 142 ctText = partContentType partInfo 143 fnText = fromMaybe "" $ partFileName partInfo 144 145 ct = TE.decodeUtf8 ctText 146 fn = TE.decodeUtf8 fnText 147 148 (PartUploadPolicy mbFs) = partPolicy partInfo 149 150 takeIt maxSize = do 151 str' <- Streams.throwIfProducesMoreThan maxSize stream 152 fileReader tmpdir partHandler partInfo str' `catch` tooMany maxSize 153 154 tooMany maxSize (_ :: TooManyBytesReadException) = do 155 partHandler partInfo 156 (Left $ 157 PolicyViolationException $ 158 T.concat [ "File \"" 159 , fn 160 , "\" exceeded maximum allowable size " 161 , T.pack $ show maxSize ]) 162 163 disallowed = 164 partHandler partInfo 165 (Left $ 166 PolicyViolationException $ 167 T.concat [ "Policy disallowed upload of file \"" 168 , fn 169 , "\" with content-type \"" 170 , ct 171 , "\"" ] ) 172 173 174 ------------------------------------------------------------------------------ 175 -- | A type alias for a function that will process one of the parts of a 176 -- @multipart/form-data@ HTTP request body. 177 type PartProcessor a = PartInfo -> InputStream ByteString -> IO a 178 179 180 ------------------------------------------------------------------------------ 181 -- | Given an upload policy and a function to consume uploaded \"parts\", 182 -- consume a request body uploaded with @Content-type: multipart/form-data@. 183 -- 184 -- Note: /THE REQUEST MUST BE CORRECTLY ENCODED/. If the request's 185 -- @Content-type@ is not \"@multipart/formdata@\", this function skips 186 -- processing using 'pass'. 187 -- 188 -- Most users will opt for the higher-level 'handleFileUploads', which writes 189 -- to temporary files, rather than 'handleMultipart'. This function should be 190 -- chosen, however, if you need to stream uploaded files directly to your own 191 -- processing function: e.g. to a database or a remote service via RPC. 192 -- 193 -- If the client's upload rate passes below the configured minimum (see 194 -- 'setMinimumUploadRate' and 'setMinimumUploadSeconds'), this function 195 -- terminates the connection. This setting is there to protect the server 196 -- against slowloris-style denial of service attacks. 197 -- 198 -- /Exceptions/ 199 -- 200 -- If the given 'UploadPolicy' stipulates that you wish form inputs to be 201 -- placed in the 'rqParams' parameter map (using 'setProcessFormInputs'), and 202 -- a form input exceeds the maximum allowable size, this function will throw a 203 -- 'PolicyViolationException'. 204 -- 205 -- If an uploaded part contains MIME headers longer than a fixed internal 206 -- threshold (currently 32KB), this function will throw a 'BadPartException'. 207 -- 208 handleMultipart :: 209 (MonadSnap m) => 210 UploadPolicy -- ^ global upload policy 211 -> PartProcessor a -- ^ part processor 212 -> m [a] 213 handleMultipart uploadPolicy origPartHandler = do 214 hdrs <- liftM headers getRequest 215 let (ct, mbBoundary) = getContentType hdrs 216 217 tickleTimeout <- liftM (. max) getTimeoutModifier 218 let bumpTimeout = tickleTimeout $ uploadTimeout uploadPolicy 219 220 let partHandler = if doProcessFormInputs uploadPolicy 221 then captureVariableOrReadFile 222 (getMaximumFormInputSize uploadPolicy) 223 origPartHandler 224 else \x y -> liftM File $ origPartHandler x y 225 226 -- not well-formed multipart? bomb out. 227 guard (ct == "multipart/form-data") 228 229 boundary <- maybe (throwIO $ BadPartException 230 "got multipart/form-data without boundary") 231 return 232 mbBoundary 233 234 -- RateTooSlowException will be caught and properly dealt with by 235 -- runRequestBody 236 captures <- runRequestBody (proc bumpTimeout boundary partHandler) 237 procCaptures captures id 238 239 where 240 -------------------------------------------------------------------------- 241 uploadRate = minimumUploadRate uploadPolicy 242 uploadSecs = minimumUploadSeconds uploadPolicy 243 maxFormVars = maximumNumberOfFormInputs uploadPolicy 244 245 -------------------------------------------------------------------------- 246 proc bumpTimeout boundary partHandler = 247 Streams.throwIfTooSlow bumpTimeout uploadRate uploadSecs >=> 248 internalHandleMultipart boundary partHandler 249 250 -------------------------------------------------------------------------- 251 procCaptures [] dl = return $! dl [] 252 procCaptures ((File x):xs) dl = procCaptures xs (dl . (x:)) 253 procCaptures ((Capture k v):xs) dl = do 254 rq <- getRequest 255 when (Map.size (rqPostParams rq) >= maxFormVars) 256 $ throwIO . PolicyViolationException 257 $ T.concat [ "number of form inputs exceeded maximum of " 258 , T.pack $ show maxFormVars ] 259 putRequest $ modifyParams (ins k v) rq 260 procCaptures xs dl 261 262 -------------------------------------------------------------------------- 263 ins k v = Map.insertWith' (flip (++)) k [v] 264 265 -------------------------------------------------------------------------- 266 modifyParams f r = r { rqPostParams = f $ rqPostParams r 267 , rqParams = f $ rqParams r 268 } 269 270 271 ------------------------------------------------------------------------------ 272 -- | Represents the disposition type specified via the @Content-Disposition@ 273 -- header field. See <https://www.ietf.org/rfc/rfc1806.txt RFC 1806>. 274 data PartDisposition = 275 DispositionAttachment -- ^ @Content-Disposition: attachment@. 276 | DispositionFile -- ^ @Content-Disposition: file@. 277 | DispositionFormData -- ^ @Content-Disposition: form-data@. 278 | DispositionOther ByteString -- ^ Any other value. 279 deriving (Eq, Show) 280 281 282 ------------------------------------------------------------------------------ 283 -- | 'PartInfo' contains information about a \"part\" in a request uploaded 284 -- with @Content-type: multipart/form-data@. 285 data PartInfo = 286 PartInfo 287 { partFieldName :: !ByteString 288 -- ^ Field name associated with this part (i.e., the name specified with 289 -- @\<input name=\"partFieldName\" ...@). 290 , partFileName :: !(Maybe ByteString) 291 -- ^ Name of the uploaded file. 292 , partContentType :: !ByteString 293 -- ^ Content type of this part. 294 , partDisposition :: !PartDisposition 295 -- ^ Disposition type of this part. See 'PartDisposition'. 296 , partHeaders :: !(Headers) 297 -- ^ Remaining headers associated with this part. 298 } 299 deriving (Show) 300 301 302 ------------------------------------------------------------------------------ 303 toPartDisposition :: ByteString -> PartDisposition 304 toPartDisposition s | s == "attachment" = DispositionAttachment 305 | s == "file" = DispositionFile 306 | s == "form-data" = DispositionFormData 307 | otherwise = DispositionOther s 308 309 310 ------------------------------------------------------------------------------ 311 -- | All of the exceptions defined in this package inherit from 312 -- 'FileUploadException', so if you write 313 -- 314 -- > foo `catch` \(e :: FileUploadException) -> ... 315 -- 316 -- you can catch a 'BadPartException', a 'PolicyViolationException', etc. 317 data FileUploadException = forall e . (ExceptionWithReason e, Show e) => 318 WrappedFileUploadException e 319 deriving (Typeable) 320 321 322 ------------------------------------------------------------------------------ 323 class Exception e => ExceptionWithReason e where 324 exceptionReason :: e -> Text 325 326 327 ------------------------------------------------------------------------------ 328 instance Show FileUploadException where 329 show (WrappedFileUploadException e) = show e 330 331 332 ------------------------------------------------------------------------------ 333 instance Exception FileUploadException 334 335 336 ------------------------------------------------------------------------------ 337 -- | Human-readable error message corresponding to the 'FileUploadException'. 338 fileUploadExceptionReason :: FileUploadException -> Text 339 fileUploadExceptionReason (WrappedFileUploadException e) = exceptionReason e 340 341 342 ------------------------------------------------------------------------------ 343 uploadExceptionToException :: ExceptionWithReason e => e -> SomeException 344 uploadExceptionToException = toException . WrappedFileUploadException 345 346 347 ------------------------------------------------------------------------------ 348 uploadExceptionFromException :: ExceptionWithReason e => SomeException -> Maybe e 349 uploadExceptionFromException x = do 350 WrappedFileUploadException e <- fromException x 351 cast e 352 353 354 ------------------------------------------------------------------------------ 355 -- | Thrown when a part is invalid in some way (e.g. the headers are too large). 356 data BadPartException = BadPartException { 357 -- | Human-readable error message corresponding to the 'BadPartException'. 358 badPartExceptionReason :: Text 359 } 360 deriving (Typeable) 361 362 instance Exception BadPartException where 363 toException = uploadExceptionToException 364 fromException = uploadExceptionFromException 365 366 instance ExceptionWithReason BadPartException where 367 exceptionReason (BadPartException e) = T.concat ["Bad part: ", e] 368 369 instance Show BadPartException where 370 show = T.unpack . exceptionReason 371 372 373 ------------------------------------------------------------------------------ 374 -- | Thrown when an 'UploadPolicy' or 'PartUploadPolicy' is violated. 375 data PolicyViolationException = PolicyViolationException { 376 -- | Human-readable error message corresponding to the 377 -- 'PolicyViolationException'. 378 policyViolationExceptionReason :: Text 379 } deriving (Typeable) 380 381 instance Exception PolicyViolationException where 382 toException e@(PolicyViolationException _) = 383 uploadExceptionToException e 384 fromException = uploadExceptionFromException 385 386 instance ExceptionWithReason PolicyViolationException where 387 exceptionReason (PolicyViolationException r) = 388 T.concat ["File upload policy violation: ", r] 389 390 instance Show PolicyViolationException where 391 show (PolicyViolationException s) = "File upload policy violation: " 392 ++ T.unpack s 393 394 395 ------------------------------------------------------------------------------ 396 -- | 'UploadPolicy' controls overall policy decisions relating to 397 -- @multipart/form-data@ uploads, specifically: 398 -- 399 -- * whether to treat parts without filenames as form input (reading them into 400 -- the 'rqParams' map) 401 -- 402 -- * because form input is read into memory, the maximum size of a form input 403 -- read in this manner, and the maximum number of form inputs 404 -- 405 -- * the minimum upload rate a client must maintain before we kill the 406 -- connection; if very low-bitrate uploads were allowed then a Snap server 407 -- would be vulnerable to a trivial denial-of-service using a 408 -- \"slowloris\"-type attack 409 -- 410 -- * the minimum number of seconds which must elapse before we start killing 411 -- uploads for having too low an upload rate. 412 -- 413 -- * the amount of time we should wait before timing out the connection 414 -- whenever we receive input from the client. 415 data UploadPolicy = UploadPolicy { 416 processFormInputs :: Bool 417 , maximumFormInputSize :: Int64 418 , maximumNumberOfFormInputs :: Int 419 , minimumUploadRate :: Double 420 , minimumUploadSeconds :: Int 421 , uploadTimeout :: Int 422 } 423 424 425 ------------------------------------------------------------------------------ 426 -- | A reasonable set of defaults for upload policy. The default policy is: 427 -- 428 -- [@maximum form input size@] 128kB 429 -- 430 -- [@maximum number of form inputs@] 10 431 -- 432 -- [@minimum upload rate@] 1kB/s 433 -- 434 -- [@seconds before rate limiting kicks in@] 10 435 -- 436 -- [@inactivity timeout@] 20 seconds 437 -- 438 defaultUploadPolicy :: UploadPolicy 439 defaultUploadPolicy = UploadPolicy True maxSize maxNum minRate minSeconds tout 440 where 441 maxSize = 2^(17::Int) 442 maxNum = 10 443 minRate = 1000 444 minSeconds = 10 445 tout = 20 446 447 448 ------------------------------------------------------------------------------ 449 -- | Does this upload policy stipulate that we want to treat parts without 450 -- filenames as form input? 451 doProcessFormInputs :: UploadPolicy -> Bool 452 doProcessFormInputs = processFormInputs 453 454 455 ------------------------------------------------------------------------------ 456 -- | Set the upload policy for treating parts without filenames as form input. 457 setProcessFormInputs :: Bool -> UploadPolicy -> UploadPolicy 458 setProcessFormInputs b u = u { processFormInputs = b } 459 460 461 ------------------------------------------------------------------------------ 462 -- | Get the maximum size of a form input which will be read into our 463 -- 'rqParams' map. 464 getMaximumFormInputSize :: UploadPolicy -> Int64 465 getMaximumFormInputSize = maximumFormInputSize 466 467 468 ------------------------------------------------------------------------------ 469 -- | Set the maximum size of a form input which will be read into our 470 -- 'rqParams' map. 471 setMaximumFormInputSize :: Int64 -> UploadPolicy -> UploadPolicy 472 setMaximumFormInputSize s u = u { maximumFormInputSize = s } 473 474 475 ------------------------------------------------------------------------------ 476 -- | Get the maximum size of a form input which will be read into our 477 -- 'rqParams' map. 478 getMaximumNumberOfFormInputs :: UploadPolicy -> Int 479 getMaximumNumberOfFormInputs = maximumNumberOfFormInputs 480 481 482 ------------------------------------------------------------------------------ 483 -- | Set the maximum size of a form input which will be read into our 484 -- 'rqParams' map. 485 setMaximumNumberOfFormInputs :: Int -> UploadPolicy -> UploadPolicy 486 setMaximumNumberOfFormInputs s u = u { maximumNumberOfFormInputs = s } 487 488 489 ------------------------------------------------------------------------------ 490 -- | Get the minimum rate (in /bytes\/second/) a client must maintain before 491 -- we kill the connection. 492 getMinimumUploadRate :: UploadPolicy -> Double 493 getMinimumUploadRate = minimumUploadRate 494 495 496 ------------------------------------------------------------------------------ 497 -- | Set the minimum rate (in /bytes\/second/) a client must maintain before 498 -- we kill the connection. 499 setMinimumUploadRate :: Double -> UploadPolicy -> UploadPolicy 500 setMinimumUploadRate s u = u { minimumUploadRate = s } 501 502 503 ------------------------------------------------------------------------------ 504 -- | Get the amount of time which must elapse before we begin enforcing the 505 -- upload rate minimum 506 getMinimumUploadSeconds :: UploadPolicy -> Int 507 getMinimumUploadSeconds = minimumUploadSeconds 508 509 510 ------------------------------------------------------------------------------ 511 -- | Set the amount of time which must elapse before we begin enforcing the 512 -- upload rate minimum 513 setMinimumUploadSeconds :: Int -> UploadPolicy -> UploadPolicy 514 setMinimumUploadSeconds s u = u { minimumUploadSeconds = s } 515 516 517 ------------------------------------------------------------------------------ 518 -- | Get the \"upload timeout\". Whenever input is received from the client, 519 -- the connection timeout is set this many seconds in the future. 520 getUploadTimeout :: UploadPolicy -> Int 521 getUploadTimeout = uploadTimeout 522 523 524 ------------------------------------------------------------------------------ 525 -- | Set the upload timeout. 526 setUploadTimeout :: Int -> UploadPolicy -> UploadPolicy 527 setUploadTimeout s u = u { uploadTimeout = s } 528 529 530 ------------------------------------------------------------------------------ 531 -- | Upload policy can be set on an \"general\" basis (using 'UploadPolicy'), 532 -- but handlers can also make policy decisions on individual files\/parts 533 -- uploaded. For each part uploaded, handlers can decide: 534 -- 535 -- * whether to allow the file upload at all 536 -- 537 -- * the maximum size of uploaded files, if allowed 538 data PartUploadPolicy = PartUploadPolicy (Maybe Int64) 539 540 541 ------------------------------------------------------------------------------ 542 -- | Disallows the file to be uploaded. 543 disallow :: PartUploadPolicy 544 disallow = PartUploadPolicy Nothing 545 546 547 ------------------------------------------------------------------------------ 548 -- | Allows the file to be uploaded, with maximum size /n/. 549 allowWithMaximumSize :: Int64 -> PartUploadPolicy 550 allowWithMaximumSize = PartUploadPolicy . Just 551 552 553 ------------------------------------------------------------------------------ 554 -- private exports follow. FIXME: organize 555 ------------------------------------------------------------------------------ 556 557 ------------------------------------------------------------------------------ 558 captureVariableOrReadFile :: 559 Int64 -- ^ maximum size of form input 560 -> PartProcessor a -- ^ file reading code 561 -> PartProcessor (Capture a) 562 captureVariableOrReadFile maxSize fileHandler partInfo stream = 563 if isFile 564 then liftM File $ fileHandler partInfo stream 565 else variable `catch` handler 566 567 where 568 isFile = isJust (partFileName partInfo) || 569 partDisposition partInfo == DispositionFile 570 571 variable = do 572 x <- liftM S.concat $ 573 Streams.throwIfProducesMoreThan maxSize stream >>= Streams.toList 574 return $! Capture fieldName x 575 576 fieldName = partFieldName partInfo 577 578 handler (_ :: TooManyBytesReadException) = 579 throwIO $ PolicyViolationException $ 580 T.concat [ "form input '" 581 , TE.decodeUtf8 fieldName 582 , "' exceeded maximum permissible size (" 583 , T.pack $ show maxSize 584 , " bytes)" ] 585 586 587 ------------------------------------------------------------------------------ 588 data Capture a = Capture ByteString ByteString 589 | File a 590 591 592 ------------------------------------------------------------------------------ 593 fileReader :: FilePath 594 -> (PartInfo -> Either PolicyViolationException FilePath -> IO a) 595 -> PartProcessor a 596 fileReader tmpdir partProc partInfo input = 597 withTempFile tmpdir "snap-upload-" $ \(fn, h) -> do 598 hSetBuffering h NoBuffering 599 output <- Streams.handleToOutputStream h 600 Streams.connect input output 601 hClose h 602 partProc partInfo $ Right fn 603 604 605 ------------------------------------------------------------------------------ 606 internalHandleMultipart :: 607 ByteString -- ^ boundary value 608 -> (PartInfo -> InputStream ByteString -> IO a) -- ^ part processor 609 -> InputStream ByteString 610 -> IO [a] 611 internalHandleMultipart !boundary clientHandler !stream = go 612 where 613 -------------------------------------------------------------------------- 614 go = do 615 -- swallow the first boundary 616 _ <- parseFromStream (parseFirstBoundary boundary) stream 617 bmstream <- search (fullBoundary boundary) stream 618 liftM concat $ processParts goPart bmstream 619 620 -------------------------------------------------------------------------- 621 pBoundary !b = Atto.try $ do 622 _ <- string "--" 623 string b 624 625 -------------------------------------------------------------------------- 626 fullBoundary !b = S.concat ["\r\n", "--", b] 627 pLine = takeWhile (not . isEndOfLine . c2w) <* eol 628 parseFirstBoundary !b = pBoundary b <|> (pLine *> parseFirstBoundary b) 629 630 631 -------------------------------------------------------------------------- 632 takeHeaders !str = hdrs `catch` handler 633 where 634 hdrs = do 635 str' <- Streams.throwIfProducesMoreThan mAX_HDRS_SIZE str 636 liftM toHeaders $ parseFromStream pHeadersWithSeparator str' 637 638 handler (_ :: TooManyBytesReadException) = 639 throwIO $ BadPartException "headers exceeded maximum size" 640 641 -------------------------------------------------------------------------- 642 goPart !str = do 643 hdrs <- takeHeaders str 644 645 -- are we using mixed? 646 let (contentType, mboundary) = getContentType hdrs 647 let (fieldName, fileName, disposition) = getFieldHeaderInfo hdrs 648 649 if contentType == "multipart/mixed" 650 then maybe (throwIO $ BadPartException $ 651 "got multipart/mixed without boundary") 652 (processMixed fieldName str) 653 mboundary 654 else do 655 let info = PartInfo fieldName fileName contentType disposition hdrs 656 liftM (:[]) $ clientHandler info str 657 658 659 -------------------------------------------------------------------------- 660 processMixed !fieldName !str !mixedBoundary = do 661 -- swallow the first boundary 662 _ <- parseFromStream (parseFirstBoundary mixedBoundary) str 663 bm <- search (fullBoundary mixedBoundary) str 664 processParts (mixedStream fieldName) bm 665 666 667 -------------------------------------------------------------------------- 668 mixedStream !fieldName !str = do 669 hdrs <- takeHeaders str 670 671 let (contentType, _) = getContentType hdrs 672 let (_, fileName, disposition) = getFieldHeaderInfo hdrs 673 674 let info = PartInfo fieldName fileName contentType disposition hdrs 675 clientHandler info str 676 677 678 ------------------------------------------------------------------------------ 679 getContentType :: Headers 680 -> (ByteString, Maybe ByteString) 681 getContentType hdrs = (contentType, boundary) 682 where 683 contentTypeValue = fromMaybe "text/plain" $ 684 getHeader "content-type" hdrs 685 686 eCT = fullyParse contentTypeValue pContentTypeWithParameters 687 (!contentType, !params) = either (const ("text/plain", [])) id eCT 688 689 boundary = findParam "boundary" params 690 691 692 ------------------------------------------------------------------------------ 693 getFieldHeaderInfo :: Headers -> (ByteString, Maybe ByteString, PartDisposition) 694 getFieldHeaderInfo hdrs = (fieldName, fileName, disposition) 695 where 696 contentDispositionValue = fromMaybe "unknown" $ 697 getHeader "content-disposition" hdrs 698 699 eDisposition = fullyParse contentDispositionValue pValueWithParameters 700 701 (!dispositionType, dispositionParameters) = 702 either (const ("unknown", [])) id eDisposition 703 704 disposition = toPartDisposition dispositionType 705 706 fieldName = fromMaybe "" $ findParam "name" dispositionParameters 707 708 fileName = findParam "filename" dispositionParameters 709 710 711 ------------------------------------------------------------------------------ 712 findParam :: (Eq a) => a -> [(a, b)] -> Maybe b 713 findParam p = fmap snd . find ((== p) . fst) 714 715 716 ------------------------------------------------------------------------------ 717 partStream :: InputStream MatchInfo -> IO (InputStream ByteString) 718 partStream st = Streams.makeInputStream go 719 720 where 721 go = do 722 s <- Streams.read st 723 return $! s >>= f 724 725 f (NoMatch s) = return s 726 f _ = mzero 727 728 729 730 731 ------------------------------------------------------------------------------ 732 -- | Assuming we've already identified the boundary value and split the input 733 -- up into parts which match and parts which don't, run the given 'ByteString' 734 -- InputStream over each part and grab a list of the resulting values. 735 -- 736 -- TODO/FIXME: fix description 737 processParts :: (InputStream ByteString -> IO a) 738 -> InputStream MatchInfo 739 -> IO [a] 740 processParts partFunc stream = go id 741 where 742 part pStream = do 743 isLast <- parseFromStream pBoundaryEnd pStream 744 745 if isLast 746 then return Nothing 747 else do 748 !x <- partFunc pStream 749 Streams.skipToEof pStream 750 return $! Just x 751 752 go !soFar = partStream stream >>= 753 part >>= 754 maybe (return $ soFar []) (\x -> go (soFar . (x:))) 755 756 pBoundaryEnd = (eol *> pure False) <|> (string "--" *> pure True) 757 758 759 ------------------------------------------------------------------------------ 760 eol :: Parser ByteString 761 eol = (string "\n") <|> (string "\r\n") 762 763 764 ------------------------------------------------------------------------------ 765 pHeadersWithSeparator :: Parser [(ByteString,ByteString)] 766 pHeadersWithSeparator = pHeaders <* crlf 767 768 769 ------------------------------------------------------------------------------ 770 toHeaders :: [(ByteString,ByteString)] -> Headers 771 toHeaders kvps = H.fromList kvps' 772 where 773 kvps' = map (first CI.mk) kvps 774 775 776 ------------------------------------------------------------------------------ 777 mAX_HDRS_SIZE :: Int64 778 mAX_HDRS_SIZE = 32768 779 780 781 ------------------------------------------------------------------------------ 782 withTempFile :: FilePath 783 -> String 784 -> ((FilePath, Handle) -> IO a) 785 -> IO a 786 withTempFile tmpl temp handler = 787 mask $ \restore -> bracket make cleanup (restore . handler) 788 789 where 790 make = mkstemp $ tmpl </> (temp ++ "XXXXXXX") 791 cleanup (fp,h) = sequence $ map gobble [hClose h, removeFile fp] 792 793 t :: IO z -> IO (Either SomeException z) 794 t = E.try 795 796 gobble = void . t