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