snap-core 1.0.2.1 → 1.0.3.0

raw patch · 12 files changed

+918/−155 lines, 12 filesdep +faildep +semigroupsdep ~basedep ~containersPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: fail, semigroups

Dependency ranges changed: base, containers

API changes (from Hackage documentation)

Files

• snap-core.cabal +15/−1
• src/Snap/Internal/Core.hs +9/−8
• src/Snap/Internal/Http/Types.hs +7/−7
• src/Snap/Internal/Parsing.hs +27/−7
• src/Snap/Internal/Routing.hs +22/−18
• src/Snap/Internal/Util/FileUploads.hs +392/−63
• src/Snap/Util/FileUploads.hs +18/−2
• src/Snap/Util/Proxy.hs +10/−16
• test/Snap/Internal/Parsing/Tests.hs +12/−1
• test/Snap/Util/CORS/Tests.hs +109/−0
• test/Snap/Util/FileUploads/Tests.hs +270/−7
• test/Snap/Util/Proxy/Tests.hs +27/−25

@@ -1,5 +1,5 @@ name:           snap-core-version:        1.0.2.1+version:        1.0.3.0 synopsis:       Snap: A Haskell Web Framework (core interfaces and types)  description:@@ -177,6 +177,12 @@   else     ghc-options: -Wall -fwarn-tabs +  -- See https://ghc.haskell.org/trac/ghc/wiki/Migration/8.0#base-4.9.0.0+  if impl(ghc >= 8.0)+    ghc-options: -Wcompat -Wnoncanonical-monad-instances -Wnoncanonical-monadfail-instances+  else+    build-depends: fail == 4.9.*, semigroups == 0.18.*+   if flag(network-uri)     build-depends: network-uri >= 2.6 && < 2.7,                    network     >= 2.6 && < 2.7@@ -206,6 +212,7 @@     Snap.Internal.Parsing,     Snap.Test,     Snap.Types.Headers,+    Snap.Util.CORS,     Snap.Util.FileServe,     Snap.Util.FileUploads,     Snap.Util.GZip,@@ -225,6 +232,7 @@     Snap.Test.Common,     Snap.Test.Tests,     Snap.Types.Headers.Tests,+    Snap.Util.CORS.Tests,     Snap.Util.FileServe.Tests,     Snap.Util.FileUploads.Tests,     Snap.Util.GZip.Tests,@@ -273,6 +281,12 @@    ghc-options: -Wall -fwarn-tabs -funbox-strict-fields -threaded                -fno-warn-unused-do-bind++  -- See https://ghc.haskell.org/trac/ghc/wiki/Migration/8.0#base-4.9.0.0+  if impl(ghc >= 8.0)+    ghc-options: -Wcompat -Wnoncanonical-monad-instances -Wnoncanonical-monadfail-instances+  else+    build-depends: fail == 4.9.*, semigroups == 0.18.*    other-extensions:     BangPatterns,

@@ -91,6 +91,7 @@ import           Control.Applicative                (Alternative ((<|>), empty), Applicative ((<*>), pure), (<$>)) import           Control.Exception.Lifted           (ErrorCall (..), Exception, Handler (..), SomeException (..), catch, catches, mask, onException, throwIO) import           Control.Monad                      (Functor (..), Monad (..), MonadPlus (..), ap, liftM, unless, (=<<))+import qualified Control.Monad.Fail                 as Fail import           Control.Monad.Base                 (MonadBase (..)) import           Control.Monad.IO.Class             (MonadIO (..)) import           Control.Monad.Trans.Control        (MonadBaseControl (..))@@ -305,20 +306,20 @@ ------------------------------------------------------------------------------ instance Monad Snap where     (>>=)  = snapBind-    return = snapReturn-    fail   = snapFail+#if !MIN_VERSION_base(4,8,0)+    -- pre-AMP+    return = pure+    {-# INLINE return #-}+#endif+    fail   = Fail.fail +instance Fail.MonadFail Snap where+    fail   = snapFail  ------------------------------------------------------------------------------ snapBind :: Snap a -> (a -> Snap b) -> Snap b snapBind m f = Snap $ \sk fk st -> unSnap m (\a st' -> unSnap (f a) sk fk st') fk st {-# INLINE snapBind #-}---snapReturn :: a -> Snap a-snapReturn = pure-{-# INLINE snapReturn #-}-  snapFail :: String -> Snap a snapFail !_ = Snap $ \_ fk st -> fk PassOnProcessing st

@@ -101,9 +101,9 @@ -- -- @ -- ghci> import qualified "Snap.Types.Headers" as H--- ghci> 'addHeader' "Host" "localhost" H.'empty'+-- ghci> 'addHeader' \"Host\" "localhost" H.'empty' -- H {unH = [("host","localhost")]}--- ghci> 'addHeader' "Host" "127.0.0.1" it+-- ghci> 'addHeader' \"Host\" "127.0.0.1" it -- H {unH = [("host","localhost,127.0.0.1")]} -- @ addHeader :: (HasHeaders a) => CI ByteString -> ByteString -> a -> a@@ -118,9 +118,9 @@ -- -- @ -- ghci> import qualified "Snap.Types.Headers" as H--- ghci> 'setHeader' "Host" "localhost" H.'empty'+-- ghci> 'setHeader' \"Host\" "localhost" H.'empty' -- H {unH = [(\"host\",\"localhost\")]}--- ghci> setHeader "Host" "127.0.0.1" it+-- ghci> setHeader \"Host\" "127.0.0.1" it -- H {unH = [("host","127.0.0.1")]} -- @ setHeader :: (HasHeaders a) => CI ByteString -> ByteString -> a -> a@@ -134,7 +134,7 @@ -- -- @ -- ghci> import qualified "Snap.Types.Headers" as H--- ghci> 'getHeader' "Host" $ 'setHeader' "Host" "localhost" H.'empty'+-- ghci> 'getHeader' \"Host\" $ 'setHeader' \"Host\" "localhost" H.'empty' -- Just "localhost" -- @ getHeader :: (HasHeaders a) => CI ByteString -> a -> Maybe ByteString@@ -149,7 +149,7 @@ -- -- @ -- ghci> import qualified "Snap.Types.Headers" as H--- ghci> 'listHeaders' $ 'setHeader' "Host" "localhost" H.'empty'+-- ghci> 'listHeaders' $ 'setHeader' \"Host\" "localhost" H.'empty' -- [("host","localhost")] -- @ listHeaders :: (HasHeaders a) => a -> [(CI ByteString, ByteString)]@@ -163,7 +163,7 @@ -- -- @ -- ghci> import qualified "Snap.Types.Headers" as H--- ghci> 'deleteHeader' "Host" $ 'setHeader' "Host" "localhost" H.'empty'+-- ghci> 'deleteHeader' \"Host\" $ 'setHeader' \"Host\" "localhost" H.'empty' -- H {unH = []} -- @ deleteHeader :: (HasHeaders a) => CI ByteString -> a -> a

@@ -160,12 +160,22 @@ -- unhelpfully, the spec mentions "old-style" cookies that don't have quotes -- around the value. wonderful. pWord :: Parser ByteString-pWord = pQuotedString <|> (takeWhile (/= ';'))+pWord = pWord' isRFCText   ------------------------------------------------------------------------------+pWord' :: (Char -> Bool) -> Parser ByteString+pWord' charPred = pQuotedString' charPred <|> (takeWhile (/= ';'))+++------------------------------------------------------------------------------ pQuotedString :: Parser ByteString-pQuotedString = q *> quotedText <* q+pQuotedString = pQuotedString' isRFCText+++------------------------------------------------------------------------------+pQuotedString' :: (Char -> Bool) -> Parser ByteString+pQuotedString' charPred = q *> quotedText <* q   where     quotedText = (S.concat . L.toChunks . toLazyByteString) <$> f mempty @@ -177,7 +187,7 @@                , pure soFar' ]      q      = char '"'-    qdtext = matchAll [ isRFCText, (/= '"'), (/= '\\') ]+    qdtext = matchAll [ charPred, (/= '"'), (/= '\\') ]   ------------------------------------------------------------------------------@@ -211,11 +221,16 @@  ------------------------------------------------------------------------------ pParameter :: Parser (ByteString, ByteString)-pParameter = parser <?> "pParameter"+pParameter = pParameter' isRFCText+++------------------------------------------------------------------------------+pParameter' :: (Char -> Bool) -> Parser (ByteString, ByteString)+pParameter' valueCharPred = parser <?> "pParameter'"   where     parser = do         key <- pToken <* skipSpace-        val <- liftM trim (char '=' *> skipSpace *> pWord)+        val <- liftM trim (char '=' *> skipSpace *> pWord' valueCharPred)         return $! (trim key, val)  @@ -227,14 +242,19 @@  ------------------------------------------------------------------------------ pValueWithParameters :: Parser (ByteString, [(CI ByteString, ByteString)])-pValueWithParameters = parser <?> "pValueWithParameters"+pValueWithParameters =  pValueWithParameters' isRFCText+++------------------------------------------------------------------------------+pValueWithParameters' :: (Char -> Bool) -> Parser (ByteString, [(CI ByteString, ByteString)])+pValueWithParameters' valueCharPred = parser <?> "pValueWithParameters'"   where     parser = do         value  <- liftM trim (skipSpace *> takeWhile (/= ';'))         params <- many' pParam         endOfInput         return (value, map (first CI.mk) params)-    pParam = skipSpace *> char ';' *> skipSpace *> pParameter+    pParam = skipSpace *> char ';' *> skipSpace *> pParameter' valueCharPred   ------------------------------------------------------------------------------

@@ -25,6 +25,8 @@ #if !MIN_VERSION_base(4,8,0) import           Data.Monoid              (Monoid (..)) #endif+import           Data.Semigroup           (Semigroup (..))+ ------------------------------------------------------------------------------  ------------------------------------------------------------------------------@@ -52,15 +54,14 @@   -------------------------------------------------------------------------------instance Monoid (Route a m) where-    mempty = NoRoute -    mappend NoRoute r = r+instance Semigroup (Route a m) where+    NoRoute <> r = r -    mappend l@(Action a) r = case r of+    l@(Action a) <> r = case r of       (Action a')       -> Action (a <|> a')-      (Capture p r' fb) -> Capture p r' (mappend fb l)-      (Dir _ _)         -> mappend (Dir H.empty l) r+      (Capture p r' fb) -> Capture p r' (fb <> l)+      (Dir _ _)         -> Dir H.empty l <> r       NoRoute           -> l      -- Whenever we're unioning two Captures and their capture variables@@ -68,28 +69,31 @@     --   1. Prefer whichever route is longer     --   2. Else, prefer whichever has the earliest non-capture     --   3. Else, prefer the right-hand side-    mappend l@(Capture p r' fb) r = case r of-      (Action _)           -> Capture p r' (mappend fb r)+    l@(Capture p r' fb) <> r = case r of+      (Action _)           -> Capture p r' (fb <> r)       (Capture p' r'' fb')-              | p == p'    -> Capture p (mappend r' r'') (mappend fb fb')-              | rh' > rh'' -> Capture p r' (mappend fb r)-              | rh' < rh'' -> Capture p' r'' (mappend fb' l)-              | en' < en'' -> Capture p r' (mappend fb r)-              | otherwise  -> Capture p' r'' (mappend fb' l)+              | p == p'    -> Capture p (r' <> r'') (fb <> fb')+              | rh' > rh'' -> Capture p r' (fb <> r)+              | rh' < rh'' -> Capture p' r'' (fb' <> l)+              | en' < en'' -> Capture p r' (fb <> r)+              | otherwise  -> Capture p' r'' (fb' <> l)         where           rh'  = routeHeight r'           rh'' = routeHeight r''           en'  = routeEarliestNC r' 1           en'' = routeEarliestNC r'' 1-      (Dir rm fb')         -> Dir rm (mappend fb' l)+      (Dir rm fb')         -> Dir rm (fb' <> l)       NoRoute              -> l -    mappend l@(Dir rm fb) r = case r of-      (Action _)      -> Dir rm (mappend fb r)-      (Capture _ _ _) -> Dir rm (mappend fb r)-      (Dir rm' fb')   -> Dir (H.unionWith mappend rm rm') (mappend fb fb')+    (<>) l@(Dir rm fb) r = case r of+      (Action _)      -> Dir rm (fb <> r)+      (Capture _ _ _) -> Dir rm (fb <> r)+      (Dir rm' fb')   -> Dir (H.unionWith (<>) rm rm') (fb <> fb')       NoRoute         -> l +instance Monoid (Route a m) where+    mempty = NoRoute+    mappend = (<>)  ------------------------------------------------------------------------------ routeHeight :: Route a m -> Int

@@ -8,7 +8,15 @@  module Snap.Internal.Util.FileUploads   ( -- * Functions-    handleFileUploads+    handleFormUploads+  , foldMultipart+  , PartFold+  , FormParam+  , FormFile (..)+  , storeAsLazyByteString+  , withTemporaryStore+    -- ** Backwards compatible API+  , handleFileUploads   , handleMultipart   , PartProcessor @@ -34,6 +42,14 @@   , getUploadTimeout   , setUploadTimeout +    -- *** File upload policy+  , FileUploadPolicy(..)+  , defaultFileUploadPolicy+  , setMaximumFileSize+  , setMaximumNumberOfFiles+  , setSkipFilesWithoutNames+  , setMaximumSkippedFileSize+     -- *** Per-file upload policy   , PartUploadPolicy(..)   , disallow@@ -47,32 +63,36 @@   ) where  -------------------------------------------------------------------------------import           Control.Applicative              (Alternative ((<|>)), Applicative ((*>), (<*), pure))+import           Control.Applicative              (Alternative ((<|>)), Applicative (pure, (*>), (<*))) import           Control.Arrow                    (Arrow (first))-import           Control.Exception.Lifted         (Exception, SomeException (..), bracket, catch, fromException, mask, throwIO, toException)+import           Control.Exception.Lifted         (Exception, SomeException (..), bracket, catch, finally, fromException, mask, throwIO, toException) import qualified Control.Exception.Lifted         as E (try)-import           Control.Monad                    (Functor (fmap), Monad ((>>=), return), MonadPlus (mzero), guard, liftM, sequence, void, when, (>=>))+import           Control.Monad                    (Functor (fmap), Monad (return, (>>=)), MonadPlus (mzero), forM_, guard, liftM, sequence, unless, void, when, (>=>))+import           Control.Monad.IO.Class           (liftIO) import           Data.Attoparsec.ByteString.Char8 (Parser, isEndOfLine, string, takeWhile) import qualified Data.Attoparsec.ByteString.Char8 as Atto (try) import           Data.ByteString.Char8            (ByteString) import qualified Data.ByteString.Char8            as S import           Data.ByteString.Internal         (c2w)+import qualified Data.ByteString.Lazy.Internal    as LB (ByteString (Empty), chunk) import qualified Data.CaseInsensitive             as CI (mk) import           Data.Int                         (Int, Int64)-import           Data.List                        (concat, find, map, (++))-import qualified Data.Map                         as Map (insertWith', size)+import qualified Data.IORef                       as IORef+import           Data.List                        (find, map, (++))+import qualified Data.Map                         as Map (insertWith') import           Data.Maybe                       (Maybe (..), fromMaybe, isJust, maybe) import           Data.Text                        (Text) import qualified Data.Text                        as T (concat, pack, unpack) import qualified Data.Text.Encoding               as TE (decodeUtf8) import           Data.Typeable                    (Typeable, cast)-import           Prelude                          (Bool (..), Double, Either (..), Eq (..), FilePath, IO, Ord (..), Show (..), String, const, either, flip, fst, id, max, not, otherwise, snd, ($), ($!), (.), (^), (||))+import           Prelude                          (Bool (..), Double, Either (..), Eq (..), FilePath, IO, Ord (..), Show (..), String, const, either, foldr, fst, id, max, not, otherwise, seq, snd, succ, ($), ($!), (.), (^), (||)) import           Snap.Core                        (HasHeaders (headers), Headers, MonadSnap, Request (rqParams, rqPostParams), getHeader, getRequest, getTimeoutModifier, putRequest, runRequestBody)-import           Snap.Internal.Parsing            (crlf, fullyParse, pContentTypeWithParameters, pHeaders, pValueWithParameters)+import           Snap.Internal.Parsing            (crlf, fullyParse, pContentTypeWithParameters, pHeaders, pValueWithParameters') import qualified Snap.Types.Headers               as H (fromList) import           System.Directory                 (removeFile) import           System.FilePath                  ((</>))-import           System.IO                        (BufferMode (NoBuffering), Handle, hClose, hSetBuffering)+import           System.IO                        (BufferMode (NoBuffering), Handle, hClose, hSetBuffering, openBinaryTempFile)+import           System.IO.Error                  (isDoesNotExistError) import           System.IO.Streams                (InputStream, MatchInfo (..), TooManyBytesReadException, search) import qualified System.IO.Streams                as Streams import           System.IO.Streams.Attoparsec     (parseFromStream)@@ -151,7 +171,7 @@             str' <- Streams.throwIfProducesMoreThan maxSize stream             fileReader tmpdir partHandler partInfo str' `catch` tooMany maxSize -        tooMany maxSize (_ :: TooManyBytesReadException) = do+        tooMany maxSize (_ :: TooManyBytesReadException) =             partHandler partInfo                         (Left $                          PolicyViolationException $@@ -172,15 +192,127 @@   ------------------------------------------------------------------------------+-- | Contents of form field of type @file@+data FormFile a = FormFile+    { formFileName  :: !ByteString+         -- ^ Name of a field+    , formFileValue :: a+         -- ^ Result of storing file+    } deriving (Eq, Ord, Show)++data UploadState a = UploadState+     { numUploadedFiles :: !Int+     , uploadedFiles :: !([FormFile a] -> [FormFile a])+     }++-- | Processes form data and calls provided storage function on+-- file parts.+--+-- You can use this together with 'withTemporaryStore', 'storeAsLazyByteString'+-- or provide your own callback to store uploaded files.+--+-- If you need to process uploaded file mime type or file name, do it in the+-- store callback function.+--+-- See also 'foldMultipart'.+--+-- Example using with small files which can safely be stored in memory.+--+-- @+--+-- import qualified Data.ByteString.Lazy as Lazy+--+-- handleSmallFiles :: MonadSnap m => [(ByteString, ByteString, Lazy.ByteString)]+-- handleSmallFiles = handleFormUploads uploadPolicy filePolicy store+--+--   where+--     uploadPolicy = defaultUploadPolicy+--     filePolicy = setMaximumFileSize (64*1024)+--                  $ setMaximumNumberOfFiles 5+--                    defaultUploadPolicy+--     store partInfo stream = do+--        content <- storeAsLazyByteString partInfo stream+--        let+--          fileName = partFileName partInfo+--          fileMime = partContentType partInfo+--        in (fileName, fileMime, content)+-- @+--+handleFormUploads ::+       (MonadSnap m) =>+       UploadPolicy                   -- ^ general upload policy+    -> FileUploadPolicy               -- ^ Upload policy for files+    -> (PartInfo -> InputStream ByteString -> IO a)+                                      -- ^ A file storage function+    -> m ([FormParam], [FormFile a])+handleFormUploads uploadPolicy filePolicy partHandler = do+    (params, !st) <- foldMultipart uploadPolicy go (UploadState 0 id)+    return (params, uploadedFiles st [])+  where+    go !partInfo stream !st = do+        when (numUploads >= maxFiles) throwTooManyFiles++        case partFileName partInfo of+          Nothing -> onEmptyName+          Just _ -> takeIt++      where+        numUploads = numUploadedFiles st+        files = uploadedFiles st+        maxFiles = maxNumberOfFiles filePolicy+        maxFileSize = maxFileUploadSize filePolicy+        fnText = fromMaybe "" $ partFileName partInfo++        fn = TE.decodeUtf8 fnText++        takeIt = do+            str' <- Streams.throwIfProducesMoreThan maxFileSize stream+            r <- partHandler partInfo str' `catch` tooMany maxFileSize+            let f = FormFile (partFieldName partInfo) r+            return $! UploadState (succ numUploads) (files . ([f] ++) )++        skipIt maxSize = do+            str' <- Streams.throwIfProducesMoreThan maxSize stream+            !_ <- Streams.skipToEof str' `catch` tooMany maxSize+            return $! UploadState (succ numUploads) files++        onEmptyName = if skipEmptyFileName filePolicy+                      then skipIt (maxEmptyFileNameSize filePolicy)+                      else takeIt+++        throwTooManyFiles = throwIO . PolicyViolationException $ T.concat+                            ["number of files exceeded the maximum of "+                            ,T.pack (show maxFiles) ]++        tooMany maxSize (_ :: TooManyBytesReadException) =+            throwIO . PolicyViolationException $+                    T.concat [ "File \""+                             , fn+                             , "\" exceeded maximum allowable size "+                             , T.pack $ show maxSize ]+++------------------------------------------------------------------------------ -- | A type alias for a function that will process one of the parts of a--- @multipart/form-data@ HTTP request body.-type PartProcessor a = PartInfo -> InputStream ByteString -> IO a+-- @multipart/form-data@ HTTP request body with accumulator.+type PartFold a = PartInfo -> InputStream ByteString -> a -> IO a   ------------------------------------------------------------------------------ -- | Given an upload policy and a function to consume uploaded \"parts\", -- consume a request body uploaded with @Content-type: multipart/form-data@. --+-- If 'setProcessFormInputs' is 'True', then parts with disposition @form-data@+-- (a form parameter) will be processed and returned as first element of+-- resulting pair. Parts with other disposition will be fed to 'PartFold'+-- handler.+--+-- If 'setProcessFormInputs' is 'False', then parts with any disposition will+-- be fed to 'PartFold' handler and first element of returned pair will be+-- empty. In this case it is important that you limit number of form inputs+-- and sizes of inputs in your 'PartFold' handler to avoid common DOS attacks.+-- -- Note: /THE REQUEST MUST BE CORRECTLY ENCODED/. If the request's -- @Content-type@ is not \"@multipart/formdata@\", this function skips -- processing using 'pass'.@@ -198,19 +330,21 @@ -- /Exceptions/ -- -- If the given 'UploadPolicy' stipulates that you wish form inputs to be--- placed in the 'rqParams' parameter map (using 'setProcessFormInputs'), and--- a form input exceeds the maximum allowable size, this function will throw a--- 'PolicyViolationException'.+-- processed (using 'setProcessFormInputs'), and a form input exceeds the+-- maximum allowable size or the form exceeds maximum number of inputs, this+-- function will throw a 'PolicyViolationException'. -- -- If an uploaded part contains MIME headers longer than a fixed internal -- threshold (currently 32KB), this function will throw a 'BadPartException'. ---handleMultipart ::+-- /Since: 1.0.3.0/+foldMultipart ::        (MonadSnap m) =>        UploadPolicy        -- ^ global upload policy-    -> PartProcessor a     -- ^ part processor-    -> m [a]-handleMultipart uploadPolicy origPartHandler = do+    -> PartFold a          -- ^ part processor+    -> a                   -- ^ seed accumulator+    -> m ([FormParam], a)+foldMultipart uploadPolicy origPartHandler zero = do     hdrs <- liftM headers getRequest     let (ct, mbBoundary) = getContentType hdrs @@ -221,7 +355,7 @@                         then captureVariableOrReadFile                                  (getMaximumFormInputSize uploadPolicy)                                  origPartHandler-                        else \x y -> liftM File $ origPartHandler x y+                        else \x y acc -> liftM File $ origPartHandler x y acc      -- not well-formed multipart? bomb out.     guard (ct == "multipart/form-data")@@ -233,8 +367,7 @@      -- RateTooSlowException will be caught and properly dealt with by     -- runRequestBody-    captures <- runRequestBody (proc bumpTimeout boundary partHandler)-    procCaptures captures id+    runRequestBody (proc bumpTimeout boundary partHandler)    where     --------------------------------------------------------------------------@@ -245,29 +378,47 @@     --------------------------------------------------------------------------     proc bumpTimeout boundary partHandler =         Streams.throwIfTooSlow bumpTimeout uploadRate uploadSecs >=>-        internalHandleMultipart boundary partHandler+        internalFoldMultipart maxFormVars boundary partHandler zero +------------------------------------------------------------------------------+-- | A type alias for a function that will process one of the parts of a+-- @multipart/form-data@ HTTP request body without usinc accumulator.+type PartProcessor a = PartInfo -> InputStream ByteString -> IO a+++------------------------------------------------------------------------------+-- | A variant of 'foldMultipart' accumulating results into a list.+-- Also puts captured 'FormParam's into rqPostParams and rqParams maps.+--+handleMultipart ::+       (MonadSnap m) =>+       UploadPolicy        -- ^ global upload policy+    -> PartProcessor a     -- ^ part processor+    -> m [a]+handleMultipart uploadPolicy origPartHandler = do+    (captures, files) <- foldMultipart uploadPolicy partFold id+    procCaptures captures+    return $! files []++  where+    partFold info input acc = do+      x <- origPartHandler info input+      return $ acc . ([x]++)     ---------------------------------------------------------------------------    procCaptures []                 dl = return $! dl []-    procCaptures ((File x):xs)      dl = procCaptures xs (dl . (x:))-    procCaptures ((Capture k v):xs) dl = do+    procCaptures []          = pure ()+    procCaptures params = do         rq <- getRequest-        when (Map.size (rqPostParams rq) >= maxFormVars)-          $ throwIO . PolicyViolationException-          $ T.concat [ "number of form inputs exceeded maximum of "-                     , T.pack $ show maxFormVars ]-        putRequest $ modifyParams (ins k v) rq-        procCaptures xs dl+        putRequest $ modifyParams (\m -> foldr ins m params) rq      ---------------------------------------------------------------------------    ins k v = Map.insertWith' (flip (++)) k [v]+    ins (!k, !v) = Map.insertWith' (\_ ex -> (v:ex)) k [v]+         -- prepend value if key exists, since we are folding from right      --------------------------------------------------------------------------     modifyParams f r = r { rqPostParams = f $ rqPostParams r                          , rqParams     = f $ rqParams r                          } - ------------------------------------------------------------------------------ -- | Represents the disposition type specified via the @Content-Disposition@ -- header field. See <https://www.ietf.org/rfc/rfc1806.txt RFC 1806>.@@ -293,7 +444,7 @@     -- ^ Content type of this part.   , partDisposition :: !PartDisposition     -- ^ Disposition type of this part. See 'PartDisposition'.-  , partHeaders     :: !(Headers)+  , partHeaders     :: !Headers     -- ^ Remaining headers associated with this part.   }   deriving (Show)@@ -528,6 +679,80 @@   ------------------------------------------------------------------------------++-- | File upload policy, if any policy is violated then+-- 'PolicyViolationException' is thrown+data FileUploadPolicy = FileUploadPolicy+    { maxFileUploadSize    :: !Int64+    , maxNumberOfFiles     :: !Int+    , skipEmptyFileName    :: !Bool+    , maxEmptyFileNameSize :: !Int64+    }++-- | A default 'FileUploadPolicy'+--+--   [@maximum file size@]             1MB+--+--   [@maximum number of files@]       10+--+--   [@skip files without name@]       yes+--+--   [@maximum size of skipped file@]  0+--+--+defaultFileUploadPolicy :: FileUploadPolicy+defaultFileUploadPolicy = FileUploadPolicy maxFileSize maxFiles+                                           skipEmptyName maxEmptySize+  where+    maxFileSize = 1048576 -- 1MB+    maxFiles    = 10+    skipEmptyName = True+    maxEmptySize = 0++-- | Maximum size of single uploaded file.+setMaximumFileSize :: Int64 -> FileUploadPolicy -> FileUploadPolicy+setMaximumFileSize maxSize s =+    s { maxFileUploadSize = maxSize }++-- | Maximum number of uploaded files.+setMaximumNumberOfFiles :: Int -> FileUploadPolicy -> FileUploadPolicy+setMaximumNumberOfFiles maxFiles s =+    s { maxNumberOfFiles = maxFiles }++-- | Skip files with empty file names.+--+-- If set, parts without filenames will not be fed to storage function.+--+-- HTML5 form data encoding standard states that form input fields of type+-- file, without value set, are encoded same way as if file with empty body,+-- empty file name, and type @application/octet-stream@ was set as value.+--+-- You most likely want to use this with zero bytes allowed to avoid storing+-- such fields (see 'setMaximumSkippedFileSize').+--+-- By default files without names are skipped.+--+-- /Since: 1.0.3.0/+setSkipFilesWithoutNames :: Bool -> FileUploadPolicy -> FileUploadPolicy+setSkipFilesWithoutNames shouldSkip s =+    s { skipEmptyFileName = shouldSkip }++-- | Maximum size of file without name which can be skipped.+--+-- Ignored if 'setSkipFilesWithoutNames' is @False@.+--+-- If skipped file is larger than this setting then 'FileUploadException'+-- is thrown.+--+-- By default maximum file size is 0.+--+-- /Since: 1.0.3.0/+setMaximumSkippedFileSize :: Int64 -> FileUploadPolicy -> FileUploadPolicy+setMaximumSkippedFileSize maxSize s =+    s { maxEmptyFileNameSize = maxSize }+++------------------------------------------------------------------------------ -- | Upload policy can be set on an \"general\" basis (using 'UploadPolicy'), --   but handlers can also make policy decisions on individual files\/parts --   uploaded. For each part uploaded, handlers can decide:@@ -551,17 +776,77 @@   ------------------------------------------------------------------------------+-- | Stores file body in memory as Lazy ByteString.+storeAsLazyByteString :: InputStream ByteString -> IO LB.ByteString+storeAsLazyByteString !str = do+   f <- Streams.fold (\f c -> f . LB.chunk c) id str+   return $! f LB.Empty+++------------------------------------------------------------------------------+-- | Store files in a temporary directory, and clean up on function exit.+--+-- Files are safe to move until function exists.+--+-- If asynchronous exception is thrown during cleanup, temporary files may+-- remain.+--+-- @+-- uploadsHandler = withTemporaryStore "/var/tmp" "upload-" $ \store -> do+--     (inputs, files) <- handleFormUploads defaultUploadpolicy+--                                          defaultFileUploadPolicy+--                                          (const store)+--     saveFiles files+--+-- @+--+withTemporaryStore ::+    MonadSnap m+    => FilePath -- ^ temporary directory+    -> String   -- ^ file name pattern+    -> ((InputStream ByteString -> IO FilePath) -> m a)+      -- ^ Action taking store function+    -> m a+withTemporaryStore tempdir pat act = do+    ioref <- liftIO $ IORef.newIORef []+    let+      modifyIORef' ref f = do -- ghc 7.4 does not have modifyIORef'+          x <- IORef.readIORef ref+          let x' = f x+          x' `seq` IORef.writeIORef ref x'++      go input = do+          (fn, h) <- openBinaryTempFile tempdir pat+          modifyIORef' ioref (fn:)+          hSetBuffering h NoBuffering+          output <- Streams.handleToOutputStream h+          Streams.connect input output+          hClose h+          pure fn++      cleanup = liftIO $ do+          files <- IORef.readIORef ioref+          forM_ files $ \fn ->+             removeFile fn `catch` handleExists+      handleExists e = unless (isDoesNotExistError e) $ throwIO e++    act go `finally` cleanup+++------------------------------------------------------------------------------ -- private exports follow. FIXME: organize ------------------------------------------------------------------------------  ------------------------------------------------------------------------------ captureVariableOrReadFile ::        Int64                                   -- ^ maximum size of form input-    -> PartProcessor a                         -- ^ file reading code-    -> PartProcessor (Capture a)-captureVariableOrReadFile maxSize fileHandler partInfo stream =+    -> PartFold a                              -- ^ file reading code+    -> PartInfo -> InputStream ByteString+    -> a+    -> IO (Capture a)+captureVariableOrReadFile maxSize fileHandler partInfo stream acc =     if isFile-      then liftM File $ fileHandler partInfo stream+      then liftM File $ fileHandler partInfo stream acc       else variable `catch` handler    where@@ -569,7 +854,7 @@              partDisposition partInfo == DispositionFile      variable = do-        x <- liftM S.concat $+        !x <- liftM S.concat $              Streams.throwIfProducesMoreThan maxSize stream >>= Streams.toList         return $! Capture fieldName x @@ -585,7 +870,7 @@   -------------------------------------------------------------------------------data Capture a = Capture ByteString ByteString+data Capture a = Capture !ByteString !ByteString                | File a  @@ -603,19 +888,47 @@   -------------------------------------------------------------------------------internalHandleMultipart ::-       ByteString                                    -- ^ boundary value-    -> (PartInfo -> InputStream ByteString -> IO a)  -- ^ part processor+data MultipartState a = MultipartState+  { numFormVars       :: {-# UNPACK #-} !Int+  , numFormFiles      :: {-# UNPACK #-} !Int+  , capturedFields    :: !([FormParam] -> [FormParam])+  , accumulator       :: !a+  }++------------------------------------------------------------------------------+-- | A form parameter name-value pair+type FormParam = (ByteString, ByteString)++------------------------------------------------------------------------------+addCapture :: ByteString -> ByteString -> MultipartState a -> MultipartState a+addCapture !k !v !ms =+  let !kv = (k,v)+      f = capturedFields ms . ([kv]++)+      !ms' = ms { capturedFields = f+                , numFormVars = succ (numFormVars ms) }+  in ms'+++------------------------------------------------------------------------------+internalFoldMultipart ::+       Int           -- ^ max num fields+    -> ByteString                                     -- ^ boundary value+    -> (PartInfo -> InputStream ByteString -> a -> IO (Capture a))  -- ^ part processor+    -> a     -> InputStream ByteString-    -> IO [a]-internalHandleMultipart !boundary clientHandler !stream = go+    -> IO ([FormParam], a)+internalFoldMultipart !maxFormVars !boundary clientHandler !zeroAcc !stream = go   where     --------------------------------------------------------------------------+    initialState = MultipartState 0 0 id zeroAcc++    --------------------------------------------------------------------------     go = do         -- swallow the first boundary         _        <- parseFromStream (parseFirstBoundary boundary) stream         bmstream <- search (fullBoundary boundary) stream-        liftM concat $ processParts goPart bmstream+        ms <- foldParts goPart bmstream initialState+        return $ (capturedFields ms [], accumulator ms)      --------------------------------------------------------------------------     pBoundary !b = Atto.try $ do@@ -639,7 +952,7 @@             throwIO $ BadPartException "headers exceeded maximum size"      ---------------------------------------------------------------------------    goPart !str = do+    goPart !str !state = do         hdrs <- takeHeaders str          -- are we using mixed?@@ -649,30 +962,45 @@         if contentType == "multipart/mixed"           then maybe (throwIO $ BadPartException $                       "got multipart/mixed without boundary")-                     (processMixed fieldName str)+                     (processMixed fieldName str state)                      mboundary           else do               let info = PartInfo fieldName fileName contentType disposition hdrs-              liftM (:[]) $ clientHandler info str+              handlePart info str state +    --------------------------------------------------------------------------+    handlePart !info !str !ms = do+      r <- clientHandler info str (accumulator ms)+      case r of+        Capture !k !v -> do+           when (maxFormVars <= numFormVars ms) throwTooMuchVars+           return $! addCapture k v ms+        File !newAcc -> return $! ms { accumulator = newAcc+                                     , numFormFiles = succ (numFormFiles ms)+                                     } +    throwTooMuchVars =+        throwIO . PolicyViolationException+        $ T.concat [ "number of form inputs exceeded maximum of "+                   , T.pack $ show maxFormVars ]+     ---------------------------------------------------------------------------    processMixed !fieldName !str !mixedBoundary = do+    processMixed !fieldName !str !state !mixedBoundary = do         -- swallow the first boundary         _  <- parseFromStream (parseFirstBoundary mixedBoundary) str         bm <- search (fullBoundary mixedBoundary) str-        processParts (mixedStream fieldName) bm+        foldParts (mixedStream fieldName) bm state       ---------------------------------------------------------------------------    mixedStream !fieldName !str = do+    mixedStream !fieldName !str !acc = do         hdrs <- takeHeaders str          let (contentType, _)           = getContentType hdrs         let (_, fileName, disposition) = getFieldHeaderInfo hdrs          let info = PartInfo fieldName fileName contentType disposition hdrs-        clientHandler info str+        handlePart info str acc   ------------------------------------------------------------------------------@@ -696,7 +1024,7 @@     contentDispositionValue = fromMaybe "unknown" $                               getHeader "content-disposition" hdrs -    eDisposition = fullyParse contentDispositionValue pValueWithParameters+    eDisposition = fullyParse contentDispositionValue $ pValueWithParameters' (const True)      (!dispositionType, dispositionParameters) =         either (const ("unknown", [])) id eDisposition@@ -734,24 +1062,25 @@ -- InputStream over each part and grab a list of the resulting values. -- -- TODO/FIXME: fix description-processParts :: (InputStream ByteString -> IO a)+foldParts :: (InputStream ByteString -> MultipartState a -> IO (MultipartState a))              -> InputStream MatchInfo-             -> IO [a]-processParts partFunc stream = go id+             -> (MultipartState a)+             -> IO (MultipartState a)+foldParts partFunc stream = go   where-    part pStream = do+    part acc pStream = do         isLast <- parseFromStream pBoundaryEnd pStream          if isLast           then return Nothing           else do-              !x <- partFunc pStream+              !x <- partFunc pStream acc               Streams.skipToEof pStream               return $! Just x -    go !soFar = partStream stream >>=-                part >>=-                maybe (return $ soFar []) (\x -> go (soFar . (x:)))+    go !acc = do+      cap <- partStream stream >>= part acc+      maybe (return acc) go cap      pBoundaryEnd = (eol *> pure False) <|> (string "--" *> pure True) 

@@ -61,7 +61,15 @@ -- @ module Snap.Util.FileUploads   ( -- * Functions-    handleFileUploads+    handleFormUploads+  , foldMultipart+  , PartFold+  , FormParam+  , FormFile (..)+  , storeAsLazyByteString+  , withTemporaryStore+    -- ** Backwards compatible API+  , handleFileUploads   , handleMultipart   , PartProcessor @@ -91,6 +99,14 @@   , getUploadTimeout   , setUploadTimeout +    -- *** File upload policy+  , FileUploadPolicy+  , defaultFileUploadPolicy+  , setMaximumFileSize+  , setMaximumNumberOfFiles+  , setSkipFilesWithoutNames+  , setMaximumSkippedFileSize+     -- *** Per-file upload policy   , PartUploadPolicy   , disallow@@ -106,4 +122,4 @@   ) where  -import           Snap.Internal.Util.FileUploads (BadPartException (badPartExceptionReason), FileUploadException, PartDisposition (..), PartInfo (..), PartProcessor, PartUploadPolicy, PolicyViolationException (policyViolationExceptionReason), UploadPolicy, allowWithMaximumSize, defaultUploadPolicy, disallow, doProcessFormInputs, fileUploadExceptionReason, getMaximumFormInputSize, getMaximumNumberOfFormInputs, getMinimumUploadRate, getMinimumUploadSeconds, getUploadTimeout, handleFileUploads, handleMultipart, setMaximumFormInputSize, setMaximumNumberOfFormInputs, setMinimumUploadRate, setMinimumUploadSeconds, setProcessFormInputs, setUploadTimeout)+import           Snap.Internal.Util.FileUploads (BadPartException (badPartExceptionReason), FileUploadException, FileUploadPolicy, FormFile (..), FormParam, PartDisposition (..), PartFold, PartInfo (..), PartProcessor, PartUploadPolicy, PolicyViolationException (policyViolationExceptionReason), UploadPolicy, allowWithMaximumSize, defaultFileUploadPolicy, defaultUploadPolicy, disallow, doProcessFormInputs, fileUploadExceptionReason, foldMultipart, getMaximumFormInputSize, getMaximumNumberOfFormInputs, getMinimumUploadRate, getMinimumUploadSeconds, getUploadTimeout, handleFileUploads, handleFormUploads, handleMultipart, setMaximumFileSize, setMaximumFormInputSize, setMaximumNumberOfFiles, setMaximumNumberOfFormInputs, setMaximumSkippedFileSize, setMinimumUploadRate, setMinimumUploadSeconds, setProcessFormInputs, setSkipFilesWithoutNames, setUploadTimeout, storeAsLazyByteString, withTemporaryStore)

@@ -22,14 +22,11 @@  ------------------------------------------------------------------------------ import           Control.Applicative   (Alternative ((<|>)))-import           Control.Arrow         (second)-import qualified Data.ByteString.Char8 as S (break, breakEnd, drop, dropWhile, readInt, spanEnd)+import           Control.Monad         (mfilter)+import qualified Data.ByteString.Char8 as S (breakEnd, dropWhile, null, readInt, spanEnd) import           Data.Char             (isSpace)-import           Data.Maybe            (fromJust)+import           Data.Maybe            (fromMaybe) import           Snap.Core             (MonadSnap, Request (rqClientAddr, rqClientPort), getHeader, modifyRequest)-#if !MIN_VERSION_base(4,8,0)-import           Control.Applicative   ((<$>))-#endif ------------------------------------------------------------------------------  @@ -81,16 +78,13 @@                         , rqClientPort = port                         }   where-    proxyString  = getHeader "Forwarded-For"   req <|>-                   getHeader "X-Forwarded-For" req <|>-                   Just (rqClientAddr req)--    proxyAddr    = trim . snd . S.breakEnd (== ',') . fromJust $ proxyString--    trim         = fst . S.spanEnd isSpace . S.dropWhile isSpace+    extract = fst . S.spanEnd isSpace . S.dropWhile isSpace . snd . S.breakEnd (== ',') -    (ip,portStr) = second (S.drop 1) . S.break (== ':') $ proxyAddr+    ip      = fromMaybe (rqClientAddr req) $ mfilter (not . S.null) $ fmap extract $+              getHeader "Forwarded-For"   req  <|>+              getHeader "X-Forwarded-For" req -    port         = fromJust (fst <$> S.readInt portStr <|>-                             Just (rqClientPort req))+    port    = maybe (rqClientPort req) fst $ (S.readInt =<<) $ fmap extract $+              getHeader "Forwarded-Port"   req  <|>+              getHeader "X-Forwarded-Port" req {-# INLINE xForwardedFor #-}

@@ -10,7 +10,7 @@ import qualified Data.Map                         as Map (fromList) import           Data.Word                        (Word8) import           Snap.Internal.Http.Types         (Cookie (Cookie, cookieDomain, cookieExpires, cookieHttpOnly, cookieName, cookiePath, cookieSecure, cookieValue))-import           Snap.Internal.Parsing            (crlf, finish, fullyParse, fullyParse', pAvPairs, pHeaders, pQuotedString, parseCookie, parseToCompletion, parseUrlEncoded, unsafeFromHex, unsafeFromNat, pTokens)+import           Snap.Internal.Parsing            (crlf, finish, fullyParse, fullyParse', pAvPairs, pHeaders, pQuotedString, pQuotedString', parseCookie, parseToCompletion, parseUrlEncoded, unsafeFromHex, unsafeFromNat, pTokens) import           Snap.Test.Common                 (expectExceptionH) import           System.Random                    (Random (random, randomR)) import           Test.Framework                   (Test)@@ -24,6 +24,7 @@         , testCookie         , testHeaderParse         , testQuotedString+        , testQuotedString'         , testUnsafeFromHex         , testUnsafeFromInt         , testUrlEncoded@@ -95,6 +96,16 @@    where     txt = "\"foo\\\"bar\\\"baz\""++------------------------------------------------------------------------------+testQuotedString' :: Test+testQuotedString' = testCase "parsing/quoted-string-utf8" $ do+    let e = fullyParse qdtext $ pQuotedString' (const True)+    assertEqual "q-s" (Right txt) e++  where+    txt = "\xd1\x82\xd0\xb5\xd1\x81\xd1\x82" -- "тест" as UTF-8+    qdtext = S.concat ["\"", txt, "\""]   ------------------------------------------------------------------------------

@@ -0,0 +1,109 @@+{-# OPTIONS_GHC -fno-warn-warnings-deprecations #-}++{-# LANGUAGE OverloadedStrings #-}++module Snap.Util.CORS.Tests (tests) where++------------------------------------------------------------------------------+import           Data.ByteString.Char8          (ByteString)+import           Data.CaseInsensitive           (CI (..))+import qualified Data.HashSet                   as HashSet+import           Snap.Core                      (Method (..), getHeader, Response(..))+import           Snap.Test                      (RequestBuilder, runHandler, setHeader, setRequestType, RequestType(..), setRequestPath)+import           Snap.Util.CORS                 (applyCORS,CORSOptions(..),defaultOptions,HashableMethod(..))+import           Test.Framework                 (Test)+import           Test.Framework.Providers.HUnit (testCase)+import           Test.HUnit                     (assertEqual,Assertion)+------------------------------------------------------------------------------+++------------------------------------------------------------------------------+tests :: [Test]+tests = [ testCORSSimple+        , testCORSOptions+        ]+++                                ---------------+                                -- Constants --+                                ---------------++------------------------------------------------------------------------------+origin :: ByteString+origin = "http://origin.org"++++                                  -----------+                                  -- Tests --+                                  -----------++------------------------------------------------------------------------------+testCORSSimple :: Test+testCORSSimple = testCase "CORS/simple" $ do+    let testDefault meth = do+          r <- runHandler (mkMethReq meth) $+               applyCORS defaultOptions $ return ()+          checkAllowOrigin (Just origin) r+          checkAllowCredentials (Just "true") r+          checkExposeHeaders Nothing r+    mapM_ testDefault [GET,POST,PUT,DELETE,HEAD]++------------------------------------------------------------------------------+testCORSOptions :: Test+testCORSOptions = testCase "CORS/options" $ do+  let opts = applyCORS defaultOptions { corsAllowedMethods =+               return $ HashSet.singleton $ HashableMethod GET  }+  r <- runHandler (mkMethReq OPTIONS+                   >> setRequestMethod "GET"+                   >> setRequestHeaders "X-STUFF, Content-Type") $+       opts $ return ()+  checkAllowOrigin (Just origin) r+  checkAllowCredentials (Just "true") r+  checkAllowHeaders (Just "X-STUFF, Content-Type") r+  checkAllowMethods (Just "GET") r+  ---------------------------------------------------------+  s <- runHandler (mkMethReq OPTIONS+                   >> setRequestMethod "POST"+                   >> setRequestHeaders "X-STUFF, Content-Type") $+       opts $ return ()+  checkAllowOrigin Nothing s+  checkAllowCredentials Nothing s+  checkAllowHeaders Nothing s+  checkAllowMethods Nothing s+++                                ---------------+                                -- Functions --+                                ---------------++------------------------------------------------------------------------------+mkMethReq :: Method -> RequestBuilder IO ()+mkMethReq meth = do+  setRequestType $ RequestWithRawBody meth ""+  setRequestPath "/"+  setHeader "Origin" origin++checkHeader :: CI ByteString -> Maybe ByteString -> Response -> Assertion+checkHeader h v r = assertEqual ("Header " ++ show h) v (getHeader h r)++checkAllowOrigin :: Maybe ByteString -> Response -> Assertion+checkAllowOrigin = checkHeader "Access-Control-Allow-Origin"++checkAllowCredentials :: Maybe ByteString -> Response -> Assertion+checkAllowCredentials = checkHeader "Access-Control-Allow-Credentials"++checkExposeHeaders :: Maybe ByteString -> Response -> Assertion+checkExposeHeaders = checkHeader "Access-Control-Expose-Headers"++checkAllowHeaders :: Maybe ByteString -> Response -> Assertion+checkAllowHeaders = checkHeader "Access-Control-Allow-Headers"++checkAllowMethods :: Maybe ByteString -> Response -> Assertion+checkAllowMethods = checkHeader "Access-Control-Allow-Methods"++setRequestMethod :: ByteString -> RequestBuilder IO ()+setRequestMethod = setHeader "Access-Control-Request-Method"++setRequestHeaders :: ByteString -> RequestBuilder IO ()+setRequestHeaders = setHeader "Access-Control-Request-Headers"

@@ -7,7 +7,7 @@   ( tests ) where  -------------------------------------------------------------------------------import           Control.Applicative            (Alternative ((<|>)))+import           Control.Applicative            (Alternative ((<|>)), (<$>)) import           Control.DeepSeq                (deepseq) import           Control.Exception              (ErrorCall (..), evaluate, throwIO) import           Control.Exception.Lifted       (Exception (fromException, toException), catch, finally, throw)@@ -15,8 +15,9 @@ import           Control.Monad.IO.Class         (MonadIO (liftIO)) import           Data.ByteString                (ByteString) import qualified Data.ByteString.Char8          as S+import qualified Data.ByteString.Lazy           as L import           Data.IORef                     (atomicModifyIORef, newIORef, readIORef, writeIORef)-import           Data.List                      (foldl')+import           Data.List                      (foldl', length) import qualified Data.Map                       as Map import           Data.Maybe                     (Maybe (..), fromJust, maybe) import qualified Data.Text                      as T@@ -24,18 +25,18 @@ import           Prelude                        (Bool (..), Either (..), Eq (..), FilePath, IO, Int, Num (..), Show (..), const, either, error, filter, map, seq, snd, ($), ($!), (&&), (++), (.)) import           Snap.Internal.Core             (EscapeSnap (TerminateConnection), Snap, getParam, getPostParam, getQueryParam, runSnap) import           Snap.Internal.Http.Types       (Request (rqBody), Response, setHeader)-import           Snap.Internal.Util.FileUploads (BadPartException (..), FileUploadException (..), PartDisposition (..), PartInfo (..), PolicyViolationException (..), allowWithMaximumSize, defaultUploadPolicy, disallow, doProcessFormInputs, fileUploadExceptionReason, getMaximumNumberOfFormInputs, getMinimumUploadRate, getMinimumUploadSeconds, getUploadTimeout, handleFileUploads, setMaximumFormInputSize, setMaximumNumberOfFormInputs, setMinimumUploadRate, setMinimumUploadSeconds, setProcessFormInputs, setUploadTimeout, toPartDisposition)+import           Snap.Internal.Util.FileUploads (BadPartException (..), FileUploadException (..), FormFile (..), PartDisposition (..), PartInfo (..), PolicyViolationException (..), allowWithMaximumSize, defaultFileUploadPolicy, defaultUploadPolicy, disallow, doProcessFormInputs, fileUploadExceptionReason, foldMultipart, getMaximumNumberOfFormInputs, getMinimumUploadRate, getMinimumUploadSeconds, getUploadTimeout, handleFileUploads, handleFileUploads, handleFormUploads, setMaximumFileSize, setMaximumFormInputSize, setMaximumNumberOfFiles, setMaximumNumberOfFormInputs, setMaximumSkippedFileSize, setMinimumUploadRate, setMinimumUploadSeconds, setProcessFormInputs, setSkipFilesWithoutNames, setUploadTimeout, storeAsLazyByteString, toPartDisposition, withTemporaryStore) import qualified Snap.Test                      as Test import           Snap.Test.Common               (coverEqInstance, coverShowInstance, coverTypeableInstance, eatException, expectExceptionH, seconds, waitabit) import qualified Snap.Types.Headers             as H-import           System.Directory               (createDirectoryIfMissing, getDirectoryContents, removeDirectoryRecursive)+import           System.Directory               (createDirectoryIfMissing, doesFileExist, getDirectoryContents, removeDirectoryRecursive, removeFile) import           System.IO.Streams              (RateTooSlowException) import qualified System.IO.Streams              as Streams import           System.Mem                     (performGC) import           System.Timeout                 (timeout) import           Test.Framework                 (Test) import           Test.Framework.Providers.HUnit (testCase)-import           Test.HUnit                     (assertBool, assertEqual, assertFailure)+import           Test.HUnit                     (Assertion, assertBool, assertEqual, assertFailure) ------------------------------------------------------------------------------  @@ -47,8 +48,18 @@  ------------------------------------------------------------------------------ tests :: [Test]-tests = [ testSuccess1+tests = [ testFoldMultipart1+        , testFoldMultipart2+        , testFilePolicyViolation1+        , testFilePolicyViolation2+        , testEmptyNamePolicyViolation+        , testEmptyNameStore+        , testEmptyNameSkip+        , testTemporaryStore+        , testTemporaryStoreSafeMove+        , testSuccess1         , testSuccess2+        , testSuccessUtf8Filename         , testBadParses         , testPerPartPolicyViolation1         , testPerPartPolicyViolation2@@ -67,8 +78,219 @@         , testDisconnectionCleanup         ] +------------------------------------------------------------------------------+testFoldMultipart1 :: Test+testFoldMultipart1 = testCase "fileUploads/fold1" $+     void $ go hndl mixedTestBody +  where+    hndl :: Snap ()+    hndl = do+        (params, files) <- foldMultipart defaultUploadPolicy  hndl' []++        let fileMap = foldl' f Map.empty files+        liftIO $ assertEqual "2 params returned" 2 (length params)+        let [p1, p2] = params++        liftIO $ do+            let Just (a1, a2, a3) = Map.lookup "file1.txt" fileMap+            let Just (b1, b2, b3) = Map.lookup "file2.gif" fileMap+            assertEqual "file1 contents"+                        ("text/plain", file1Contents)+                        (a1, a2)+            assertEqual "file1 header 1"+                        (Just "text/plain")+                        (H.lookup "content-type" a3)+            assertEqual "file1 header 2"+                        (Just "attachment; filename=\"file1.txt\"")+                        (H.lookup "content-disposition" a3)++            assertEqual "file2 contents"+                        ("image/gif", file2Contents)+                        (b1, b2)+            assertEqual "file2 header 1"+                        (Just "image/gif")+                        (H.lookup "content-type" b3)+            assertEqual "file2 header 2"+                        (Just "attachment; filename=\"file2.gif\"")+                        (H.lookup "content-disposition" b3)++            assertEqual "field1 contents"+                        ("field1", formContents1)+                        p1++            assertEqual "field2 contents"+                        ("field2", formContents2)+                        p2++    f mp (fn, ct, x, hdrs) = Map.insert fn (ct,x,hdrs) mp++    hndl' partInfo istream acc = do+       let+         fn = fromJust $ partFileName partInfo+         ct = partContentType partInfo+         hdrs = partHeaders partInfo+       body <- S.concat <$> Streams.toList istream+       return (acc ++ [(fn, ct, body, hdrs)])+++ ------------------------------------------------------------------------------+testFoldMultipart2 :: Test+testFoldMultipart2 = testCase "fileUploads/fold2" $+    void $ go hndl mixedTestBody+  where+    policy = setProcessFormInputs False defaultUploadPolicy++    hndl = do+        (fields, fileCount) <- foldMultipart policy hndl' (0::Int)++        liftIO $ do+             assertEqual "num params" 4 fileCount+             assertEqual "num processed" 0 (length fields)++    hndl' !_ !_ !acc = return $ acc + 1++++------------------------------------------------------------------------------+testFilePolicyViolation1 :: Test+testFilePolicyViolation1 = testCase "fileUploads/filePolicyViolation1" $+     assertThrows (go hndl mixedTestBody) h+  where+    h e = assertIsFileSizeException e++    hndl = handleFormUploads defaultUploadPolicy+             (setMaximumFileSize 0 defaultFileUploadPolicy)+             (const storeAsLazyByteString)++++------------------------------------------------------------------------------+testFilePolicyViolation2 :: Test+testFilePolicyViolation2 = testCase "fileUploads/filePolicyViolation2" $+     assertThrows (go hndl mixedTestBody) h+  where+    h (PolicyViolationException r) =+        assertBool "correct exception"+                   (T.isInfixOf "number of files exceeded the maximum" r)++    hndl = handleFormUploads defaultUploadPolicy+             (setMaximumNumberOfFiles 0 defaultFileUploadPolicy)+             (const storeAsLazyByteString)+++------------------------------------------------------------------------------+testEmptyNamePolicyViolation :: Test+testEmptyNamePolicyViolation = testCase "fileUploads/emptyNamePolicyViolation" $+     assertThrows (go hndl noFileNameTestBody) h+  where+    h e = assertIsFileSizeException e++    hndl = handleFormUploads defaultUploadPolicy+             (setSkipFilesWithoutNames True defaultFileUploadPolicy)+             (const storeAsLazyByteString)+++------------------------------------------------------------------------------+assertIsFileSizeException :: PolicyViolationException -> Assertion+assertIsFileSizeException (PolicyViolationException r) =+    assertBool "file size exception"+        (T.isInfixOf "File" r &&+          T.isInfixOf "exceeded maximum allowable size" r)+++------------------------------------------------------------------------------+testEmptyNameStore :: Test+testEmptyNameStore = testCase "fileUploads/emptyNameStore" $+     void $ go hndl noFileNameTestBody+  where+    hndl = do+      (inputs, files) <- handleFormUploads defaultUploadPolicy+                         (setSkipFilesWithoutNames False defaultFileUploadPolicy)+                         (const storeAsLazyByteString)+      liftIO $ do+         assertEqual "got both files" 2 (length files)+         let [f1, f2] = files+         assertEqual "file1 contents"+                     (FormFile "files" $ L.fromChunks [file1Contents])+                     f1+         assertEqual "file2 contents"+                     (FormFile "files" $ L.fromChunks [file2Contents])+                     f2+         assertEqual "inputs present" 2 (length inputs)+      return ()+++------------------------------------------------------------------------------+testEmptyNameSkip :: Test+testEmptyNameSkip = testCase "fileUploads/emptyNameSkip" $+     void $ go hndl noFileNameTestBody+  where+    hndl = do+      (inputs, files) <- handleFormUploads defaultUploadPolicy+                         (  setMaximumSkippedFileSize 4000+                          . setSkipFilesWithoutNames True+                          $ defaultFileUploadPolicy )+                         (const storeAsLazyByteString)+      liftIO $ do+         assertEqual "files skipped" 0 (length files)+         assertEqual "inputs present" 2 (length inputs)+      return ()+++------------------------------------------------------------------------------+testTemporaryStore :: Test+testTemporaryStore = testCase "fileUploads/temporaryStore" $+     harness "tempdir1" hndl mixedTestBody+  where+    hndl = do+      (fn1, fn2) <- withTemporaryStore "tempdir1" "upload" $ \store -> do+          (inputs, files) <- handleFormUploads defaultUploadPolicy+                                               defaultFileUploadPolicy+                                               (const store)+          liftIO $ do+             assertEqual "num files" 2 (length files)+             assertEqual "inputs present" 2 (length inputs)+             let [FormFile name1 fn1, FormFile name2 fn2] = files+             fc1 <- liftIO $ S.readFile fn1+             fc2 <- liftIO $ S.readFile fn2++             assertEqual "file1 content"+                         ("files", file1Contents)+                         (name1, fc1)++             assertEqual "file2 content"+                         ("files", file2Contents)+                         (name2, fc2)+             return (fn1, fn2)+      liftIO $ do+        ex1 <- doesFileExist fn1+        ex2 <- doesFileExist fn2+        assertEqual "file1 deleted" False ex1+        assertEqual "file2 deleted" False ex2+++------------------------------------------------------------------------------+testTemporaryStoreSafeMove :: Test+testTemporaryStoreSafeMove = testCase "fileUploads/temporaryStoreSafeMove" $+     harness "tempdir1" hndl mixedTestBody+  where+    hndl = do+      -- should not throw+      withTemporaryStore "tempdir1" "upload" $ \store -> do+          (_, files) <- handleFormUploads defaultUploadPolicy+                                               defaultFileUploadPolicy+                                               (const store)+          liftIO $ do+             assertEqual "num files" 2 (length files)+             let [FormFile _ fn1, FormFile _ fn2] = files+             removeFile fn1+             removeFile fn2++++------------------------------------------------------------------------------ testSuccess1 :: Test testSuccess1 = testCase "fileUploads/success1" $                harness tmpdir hndl mixedTestBody@@ -80,7 +302,7 @@         xs <- handleFileUploads tmpdir                                 defaultUploadPolicy                                 (const $ allowWithMaximumSize 300000)-                               hndl'+                                hndl'          let fileMap = foldl' f Map.empty xs         p1  <- getParam "field1"@@ -153,7 +375,25 @@      hndl' !ref !_ !_ = atomicModifyIORef ref (\x -> (x+1, ())) + ------------------------------------------------------------------------------+testSuccessUtf8Filename :: Test+testSuccessUtf8Filename = testCase "fileUploads/utf8-filename" $+                          harness tmpdir hndl utf8FilenameBody +  where+    tmpdir = "tempdir3"++    hndl = do+        xs <- handleFileUploads tmpdir+                                defaultUploadPolicy+                                (const $ allowWithMaximumSize 300000)+                                hndl'++        liftIO $ assertEqual "filename" [filenameUtf8] xs++    hndl' pinfo _ = return $ fromJust $ partFileName pinfo++ ------------------------------------------------------------------------------ testBadParses :: Test testBadParses = testCase "fileUploads/badParses" $ do@@ -673,6 +913,9 @@ file2Contents :: ByteString file2Contents = "... contents of file2.gif ..." +filenameUtf8 :: ByteString+filenameUtf8 =  "\xd1\x82\xd0\xb5\xd1\x81\xd1\x82.png" -- "тест.png" as UTF-8+ boundaryValue :: ByteString boundaryValue = "fkjldsakjfdlsafldksjf" @@ -934,3 +1177,23 @@           , "content-disposition: form-data; name=\"field2\"\r\n"           , "fdjkljflsdkjfsd"           ]+++------------------------------------------------------------------------------+utf8FilenameBody :: ByteString+utf8FilenameBody =+    S.concat+         [ "--"+         , boundaryValue+         , crlf+         , "Content-Disposition: form-data; name=\"file\"; filename=\""+         , filenameUtf8+         , "\"\r\n"+         , "Content-Type: image/png\r\n"+         , crlf+         , file2Contents+         , crlf+         , "--"+         , boundaryValue+         , "--\r\n"+         ]

@@ -48,15 +48,15 @@ ------------------------------------------------------------------------------ testNoProxy :: Test testNoProxy = testCase "proxy/no-proxy" $ do-    a <- evalHandler (mkReq $ forwardedFor [("4.3.2.1", Nothing)])+    a <- evalHandler (mkReq $ forwardedFor ["4.3.2.1"])                      (behindProxy NoProxy reportRemoteAddr)-    p <- evalHandler (mkReq $ forwardedFor [("4.3.2.1", Nothing)])+    p <- evalHandler (mkReq $ forwardedFor ["4.3.2.1"] >> xForwardedPort [10903])                      (behindProxy NoProxy reportRemotePort)     assertEqual "NoProxy leaves request alone" initialAddr a     assertEqual "NoProxy leaves request alone" initialPort p      ---------------------------------------------------------------------------    b <- evalHandler (mkReq $ xForwardedFor [("4.3.2.1", Nothing)])+    b <- evalHandler (mkReq $ xForwardedFor ["2fe3::d4"])                      (behindProxy NoProxy reportRemoteAddr)     assertEqual "NoProxy leaves request alone" initialAddr b @@ -74,29 +74,30 @@     assertEqual "port" initialPort p      ---------------------------------------------------------------------------    (b,_) <- evalHandler (mkReq $ forwardedFor addr) handler-    assertEqual "Behind 5.6.7.8" ip b+    (b,q) <- evalHandler (mkReq $ forwardedFor [ip4]) handler+    assertEqual "Behind 5.6.7.8" ip4 b+    assertEqual "No Forwarded-Port, no port change" initialPort q      ---------------------------------------------------------------------------    (c,q) <- evalHandler (mkReq $ xForwardedFor addrs2) handler-    assertEqual "Behind 5.6.7.8" ip c-    assertEqual "port change" port q+    (c,_) <- evalHandler (mkReq $ xForwardedFor [ip4, ip6]) handler+    assertEqual "Behind 23fe::d4" ip6 c +    --------------------------------------------------------------------------+    (d,r) <- evalHandler (mkReq $ xForwardedFor [ip6, ip4] >> xForwardedPort [20202, port]) handler+    assertEqual "Behind 5.6.7.8" ip4 d+    assertEqual "port change" port r+   where     handler = behindProxy X_Forwarded_For $ do                   !a <- reportRemoteAddr                   !p <- reportRemotePort'                   return $! (a,p) -    ip      = "5.6.7.8"+    ip4     = "5.6.7.8"+    ip6     = "23fe::d4"     port    = 10101 -    addr    = [ (ip, Nothing) ] -    addr2   = [ (ip, Just port) ]-    addrs2  = [("4.3.2.1", Just 20202)] ++ addr2-- ------------------------------------------------------------------------------ testTrivials :: Test testTrivials = testCase "proxy/trivials" $ do@@ -138,25 +139,26 @@  ------------------------------------------------------------------------------ forwardedFor' :: CI ByteString              -- ^ header name-              -> [(ByteString, Maybe Int)]  -- ^ list of "forwarded-for"+              -> [ByteString]               -- ^ list of "forwarded-for"               -> RequestBuilder IO ()-forwardedFor' hdr addrs = do-    setHeader hdr out--  where-    toStr (a, Nothing) = a-    toStr (a, Just p ) = S.concat [ a, ":", S.pack $ show p ]--    out  = S.intercalate ", " $ map toStr addrs+forwardedFor' hdr addrs =+    setHeader hdr $ S.intercalate ", " addrs   -------------------------------------------------------------------------------forwardedFor :: [(ByteString, Maybe Int)]+forwardedFor :: [ByteString]              -> RequestBuilder IO () forwardedFor = forwardedFor' "Forwarded-For"   -------------------------------------------------------------------------------xForwardedFor :: [(ByteString, Maybe Int)]+xForwardedFor :: [ByteString]              -> RequestBuilder IO () xForwardedFor = forwardedFor' "X-Forwarded-For"+++------------------------------------------------------------------------------+xForwardedPort :: [Int]                     -- ^ list of "forwarded-port"+               -> RequestBuilder IO ()+xForwardedPort ports =+    setHeader "X-Forwarded-Port" $ S.intercalate ", " $ map (S.pack . show) $ ports