diff --git a/CONTRIBUTORS b/CONTRIBUTORS --- a/CONTRIBUTORS +++ b/CONTRIBUTORS @@ -9,3 +9,4 @@ Jurriën Stutterheim Jasper Van der Jeugt Bryan O'Sullivan +Koz Ross diff --git a/cbits/timefuncs.c b/cbits/timefuncs.c --- a/cbits/timefuncs.c +++ b/cbits/timefuncs.c @@ -10,9 +10,13 @@ } +// When given invalid input, returns 0. time_t c_parse_http_time(char* s) { + if (s == NULL) return 0; struct tm dest; - strptime(s, "%a, %d %b %Y %H:%M:%S GMT", &dest); + if (strptime(s, "%a, %d %b %Y %H:%M:%S GMT", &dest) == NULL) { + return 0; + } return timegm(&dest); } diff --git a/snap-core.cabal b/snap-core.cabal --- a/snap-core.cabal +++ b/snap-core.cabal @@ -1,5 +1,5 @@ name: snap-core -version: 1.0.4.2 +version: 1.0.5.0 synopsis: Snap: A Haskell Web Framework (core interfaces and types) description: @@ -35,8 +35,8 @@ bug-reports: https://github.com/snapframework/snap-core/issues category: Web, Snap, IO-Streams Tested-With: GHC == 7.4.2, GHC == 7.6.3, GHC == 7.8.4, GHC == 7.10.3, - GHC == 8.0.2, GHC == 8.2.2, GHC == 8.4.4, GHC == 8.6.3, - GHC == 8.8.3, GHC == 8.10.1 + GHC == 8.0.2, GHC == 8.2.2, GHC == 8.4.4, GHC == 8.6.5, + GHC == 8.8.4, GHC == 8.10.7, GHC == 9.0.2, GHC == 9.2.1 extra-source-files: test/TestSuite.hs, @@ -112,6 +112,7 @@ Snap.Internal.Debug, Snap.Internal.Http.Types, Snap.Internal.Parsing, + Snap.Internal.Util.FileServe, Snap.Test, Snap.Types.Headers, Snap.Util.CORS, @@ -125,15 +126,14 @@ Snap.Internal.Routing, Snap.Internal.Test.RequestBuilder, Snap.Internal.Test.Assertions, - Snap.Internal.Util.FileServe, Snap.Internal.Util.FileUploads build-depends: HUnit >= 1.2 && < 2, - attoparsec >= 0.12 && < 0.14, + attoparsec >= 0.12 && < 0.15, base >= 4 && < 5, - bytestring >= 0.9 && < 0.11, + bytestring >= 0.9 && < 0.12, bytestring-builder >= 0.10.4 && < 0.11, case-insensitive >= 1.1 && < 1.3, containers >= 0.3 && < 1.0, @@ -148,7 +148,7 @@ readable >= 0.1 && < 0.4, regex-posix >= 0.95 && < 1, text >= 0.11 && < 1.3, - time >= 1.0 && < 1.11, + time >= 1.0 && < 1.14, transformers >= 0.3 && < 0.6, transformers-base >= 0.4 && < 0.5, unix-compat >= 0.3 && < 0.6, @@ -184,7 +184,7 @@ if impl(ghc >= 8.0) ghc-options: -Wcompat -Wnoncanonical-monad-instances -Wnoncanonical-monadfail-instances else - build-depends: fail == 4.9.*, semigroups == 0.18.* + build-depends: fail == 4.9.*, semigroups >= 0.18 && < 0.20 if flag(network-uri) -- Leaving network-uri-2.7.0.0 out for now because it is marked deprecated @@ -194,7 +194,12 @@ build-depends: network-uri >= 2.5 && < 2.6, network >= 2.3 && < 2.6 + if impl(ghc >= 7.6) + build-depends: unix-compat >= 0.3 && < 0.6 + else + build-depends: unix-compat >= 0.3 && < 0.5.3 + Test-suite testsuite hs-source-dirs: src test Type: exitcode-stdio-1.0 @@ -291,7 +296,7 @@ if impl(ghc >= 8.0) ghc-options: -Wcompat -Wnoncanonical-monad-instances -Wnoncanonical-monadfail-instances else - build-depends: fail == 4.9.*, semigroups == 0.18.* + build-depends: fail == 4.9.*, semigroups >= 0.18 && < 0.20 other-extensions: BangPatterns, diff --git a/src/Snap/Internal/Http/Types.hs b/src/Snap/Internal/Http/Types.hs --- a/src/Snap/Internal/Http/Types.hs +++ b/src/Snap/Internal/Http/Types.hs @@ -1235,6 +1235,8 @@ ------------------------------------------------------------------------------ -- | Converts an HTTP timestamp into a 'CTime'. -- +-- If the given time string is unparseable, this function will return 0. +-- -- Example: -- -- @ diff --git a/src/Snap/Internal/Parsing.hs b/src/Snap/Internal/Parsing.hs --- a/src/Snap/Internal/Parsing.hs +++ b/src/Snap/Internal/Parsing.hs @@ -27,7 +27,15 @@ import Data.Maybe (Maybe (..), maybe) import Data.Monoid (Monoid (mconcat, mempty), (<>)) import Data.Word (Word8) -import GHC.Exts (Int (I#), uncheckedShiftRL#, word2Int#) +import GHC.Exts ( Int (I#) + , word2Int# +#if MIN_VERSION_base(4,16,0) + , uncheckedShiftRLWord8# + , word8ToWord# +#else + , uncheckedShiftRL# +#endif + ) import GHC.Word (Word8 (..)) import Prelude (Bool (..), Either (..), Enum (fromEnum, toEnum), Eq (..), Num (..), Ord (..), String, and, any, concatMap, elem, error, filter, flip, foldr, fst, id, map, not, otherwise, show, snd, ($), ($!), (&&), (++), (.), (||)) import Snap.Internal.Http.Types (Cookie (Cookie)) @@ -437,6 +445,9 @@ !hi = toDigit $ (c .&. 0xf0) `shiftr` 4 shiftr (W8# a#) (I# b#) = I# (word2Int# (uncheckedShiftRL# a# b#)) +#if MIN_VERSION_base(4,16,0) + uncheckedShiftRL# a# b# = word8ToWord# (uncheckedShiftRLWord8# a# b#) +#endif ------------------------------------------------------------------------------ diff --git a/src/Snap/Internal/Test/RequestBuilder.hs b/src/Snap/Internal/Test/RequestBuilder.hs --- a/src/Snap/Internal/Test/RequestBuilder.hs +++ b/src/Snap/Internal/Test/RequestBuilder.hs @@ -19,6 +19,7 @@ , evalHandler , evalHandlerM , get + , head , postMultipart , postRaw , postUrlEncoded @@ -52,6 +53,7 @@ import qualified Data.Map as Map import qualified Data.Vector as V import Data.Word (Word8) +import Prelude hiding (head) import Snap.Core (Cookie (Cookie), Method (DELETE, GET, HEAD, POST, PUT), MonadSnap, Params, Request (rqContentLength, rqContextPath, rqCookies, rqHeaders, rqHostName, rqIsSecure, rqMethod, rqParams, rqPathInfo, rqPostParams, rqQueryParams, rqQueryString, rqURI, rqVersion), Response, Snap, deleteHeader, formatHttpTime, getHeader, parseUrlEncoded, printUrlEncoded, runSnap) import Snap.Internal.Core (evalSnap, fixupResponse) import Snap.Internal.Http.Types (Request (Request, rqBody), Response (rspBody, rspContentLength), rspBodyToEnum) @@ -707,6 +709,30 @@ setQueryString params setRequestPath uri +------------------------------------------------------------------------------ +-- | Builds an HTTP \"HEAD\" request with the given query parameters. +-- +-- Example: +-- +-- @ +-- ghci> :set -XOverloadedStrings +-- ghci> import qualified "Data.Map" as M +-- ghci> 'buildRequest' $ 'head' \"\/foo\/bar\" (M.fromList ("param0", ["baz", "quux"])]) +-- HEAD \/foo\/bar?param0=baz¶m0=quux HTTP\/1.1 +-- host: localhost +-- +-- sn="localhost" c=127.0.0.1:60000 s=127.0.0.1:8080 ctx=\/ clen=n\/a +-- params: param0: ["baz","quux"] +-- @ +-- @since 1.0.4.3 +head :: MonadIO m => + ByteString -- ^ request path + -> Params -- ^ request's form parameters + -> RequestBuilder m () +head uri params = do + setRequestType . RequestWithRawBody HEAD $ "" + setQueryString params + setRequestPath uri ------------------------------------------------------------------------------ -- | Builds an HTTP \"DELETE\" request with the given query parameters. diff --git a/src/Snap/Internal/Util/FileServe.hs b/src/Snap/Internal/Util/FileServe.hs --- a/src/Snap/Internal/Util/FileServe.hs +++ b/src/Snap/Internal/Util/FileServe.hs @@ -24,6 +24,7 @@ , serveFileAs -- * Internal functions , decodeFilePath + , checkRangeReq ) where ------------------------------------------------------------------------------ diff --git a/src/Snap/Test.hs b/src/Snap/Test.hs --- a/src/Snap/Test.hs +++ b/src/Snap/Test.hs @@ -19,6 +19,7 @@ -- *** Convenience functions for generating common types of HTTP requests , get + , head , postUrlEncoded , postMultipart , put diff --git a/test/Snap/Test/Tests.hs b/test/Snap/Test/Tests.hs --- a/test/Snap/Test/Tests.hs +++ b/test/Snap/Test/Tests.hs @@ -18,7 +18,7 @@ import Data.Text (Text) import Data.Time.Clock (getCurrentTime) import Prelude (Bool (True, False), IO, Int, Maybe (Just, Nothing), Monad (..), Ord (..), const, fail, fromIntegral, return, seq, show, ($), ($!), (*), (.)) -import Snap.Core (Cookie (Cookie, cookieExpires), Method (DELETE, GET, Method, PATCH, POST, PUT), Request (rqContentLength, rqContextPath, rqIsSecure, rqMethod, rqParams, rqPathInfo, rqPostParams, rqQueryParams, rqQueryString, rqURI, rqVersion), Snap, expireCookie, extendTimeout, getCookie, getHeader, getParam, logError, readCookie, redirect, runSnap, terminateConnection, writeBS) +import Snap.Core (Cookie (Cookie, cookieExpires), Method (DELETE, GET, HEAD, Method, PATCH, POST, PUT), Request (rqContentLength, rqContextPath, rqIsSecure, rqMethod, rqParams, rqPathInfo, rqPostParams, rqQueryParams, rqQueryString, rqURI, rqVersion), Snap, expireCookie, extendTimeout, getCookie, getHeader, getParam, logError, readCookie, redirect, runSnap, terminateConnection, writeBS) import Snap.Internal.Http.Types (Request (..), Response (rspCookies)) import qualified Snap.Internal.Http.Types as T import Snap.Internal.Test.RequestBuilder (FileData (FileData), MultipartParam (Files, FormData), RequestBuilder, RequestType (DeleteRequest, GetRequest, MultipartPostRequest, RequestWithRawBody, UrlEncodedPostRequest), addCookies, addHeader, buildRequest, delete, evalHandler, get, postMultipart, postRaw, postUrlEncoded, put, requestToString, responseToString, runHandler, setContentType, setHeader, setHttpVersion, setQueryStringRaw, setRequestPath, setRequestType, setSecure) @@ -103,6 +103,9 @@ request7 <- buildRequest $ setRequestType $ RequestWithRawBody PATCH "bar" assertEqual "setRequestType/7/Method" PATCH (rqMethod request7) + + request8 <- buildRequest $ setRequestType $ RequestWithRawBody HEAD "" + assertEqual "setRequestType/8/Method" HEAD (rqMethod request8) where rt4 = MultipartPostRequest [ ("foo", FormData ["foo"]) diff --git a/test/Snap/Util/CORS/Tests.hs b/test/Snap/Util/CORS/Tests.hs --- a/test/Snap/Util/CORS/Tests.hs +++ b/test/Snap/Util/CORS/Tests.hs @@ -1,5 +1,6 @@ {-# OPTIONS_GHC -fno-warn-warnings-deprecations #-} +{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} module Snap.Util.CORS.Tests (tests) where @@ -7,7 +8,13 @@ ------------------------------------------------------------------------------ import Data.ByteString.Char8 (ByteString) import Data.CaseInsensitive (CI (..)) +#if !MIN_VERSION_base(4,8,0) +import Data.Functor ((<$>)) +#endif import qualified Data.HashSet as HashSet +import qualified Data.Set as Set +import qualified Data.Text as Text +import qualified Data.Text.Encoding as Text import Snap.Core (Method (..), getHeader, Response(..)) import Snap.Test (RequestBuilder, runHandler, setHeader, setRequestType, RequestType(..), setRequestPath) import Snap.Util.CORS (applyCORS,CORSOptions(..),defaultOptions,HashableMethod(..)) @@ -60,7 +67,7 @@ opts $ return () checkAllowOrigin (Just origin) r checkAllowCredentials (Just "true") r - checkAllowHeaders (Just "X-STUFF, Content-Type") r + checkAllowHeaders (Just "Content-Type, X-STUFF") r checkAllowMethods (Just "GET") r --------------------------------------------------------- s <- runHandler (mkMethReq OPTIONS @@ -97,7 +104,12 @@ checkExposeHeaders = checkHeader "Access-Control-Expose-Headers" checkAllowHeaders :: Maybe ByteString -> Response -> Assertion -checkAllowHeaders = checkHeader "Access-Control-Allow-Headers" +checkAllowHeaders v r = + assertEqual "Header Access-Control-Allow-Headers" + (getSet <$> v) + (getSet <$> getHeader "Access-Control-Allow-Headers" r) + where + getSet = Set.fromList . Text.splitOn ", " . Text.decodeUtf8 checkAllowMethods :: Maybe ByteString -> Response -> Assertion checkAllowMethods = checkHeader "Access-Control-Allow-Methods" diff --git a/test/Snap/Util/GZip/Tests.hs b/test/Snap/Util/GZip/Tests.hs --- a/test/Snap/Util/GZip/Tests.hs +++ b/test/Snap/Util/GZip/Tests.hs @@ -23,7 +23,7 @@ import Snap.Test.Common (coverTypeableInstance, expectException, expectExceptionH, liftQ) import Snap.Util.GZip (BadAcceptEncodingException, noCompression, withCompression) import qualified System.IO.Streams as Streams -import System.Random (Random (randomIO)) +import System.Random (randomIO) import Test.Framework (Test) import Test.Framework.Providers.HUnit (testCase) import Test.Framework.Providers.QuickCheck2 (testProperty)