999b17d · typeable/wai

warp/Network/Wai/Handler/Warp.hs+11−1

compare with master

unifiedsplit

@@ -95,6 +95,8 @@ module Network.Wai.Handler.Warp (

95 , InvalidRequest (..)

96 -- * Utilities

97 , pauseTimeout

98+ , FileInfo(..)

99+ , getFileInfo

98 -- * Internal

100 -- * Internal

99 -- | The following APIs will be removed in Warp 3.2.0. Please use ones exported from Network.Wai.Handler.Warp.Internal.

101 -- | The following APIs will be removed in Warp 3.2.0. Please use ones exported from Network.Wai.Handler.Warp.Internal.

100

102

@@ -136,7 +138,7 @@ module Network.Wai.Handler.Warp (

136 , module Network.Wai.Handler.Warp.Timeout

138 , module Network.Wai.Handler.Warp.Timeout

137 ) where

139 ) where

138

140

139−import Control.Exception (SomeException)

141+import Control.Exception (SomeException, throwIO)

140import Data.ByteString (ByteString)

142import Data.ByteString (ByteString)

141import Data.Maybe (fromMaybe)

143import Data.Maybe (fromMaybe)

142import Data.Streaming.Network (HostPreference)

144import Data.Streaming.Network (HostPreference)

@@ -145,6 +147,7 @@ import Network.Socket (SockAddr)

145import Network.Wai (Request, Response, vault)

147import Network.Wai (Request, Response, vault)

146import Network.Wai.Handler.Warp.Buffer

148import Network.Wai.Handler.Warp.Buffer

147import Network.Wai.Handler.Warp.Date

149import Network.Wai.Handler.Warp.Date

150+import Network.Wai.Handler.Warp.FileInfoCache

148import Network.Wai.Handler.Warp.FdCache

151import Network.Wai.Handler.Warp.FdCache

149import Network.Wai.Handler.Warp.Header

152import Network.Wai.Handler.Warp.Header

150import Network.Wai.Handler.Warp.Request

153import Network.Wai.Handler.Warp.Request

@@ -371,3 +374,10 @@ setHTTP2Disabled y = y { settingsHTTP2Enabled = False }

371-- Since 3.0.10

374-- Since 3.0.10

372pauseTimeout :: Request -> IO ()

375pauseTimeout :: Request -> IO ()

373pauseTimeout = fromMaybe (return ()) . Vault.lookup pauseTimeoutKey . vault

376pauseTimeout = fromMaybe (return ()) . Vault.lookup pauseTimeoutKey . vault

377+

378+-- | Getting file information from the inside cache.

379+-- If file information is not available, an IO error is thrown.

380+--

381+-- Since 3.1.10

382+getFileInfo :: Request -> FilePath -> IO FileInfo

383+getFileInfo = fromMaybe (\_ -> throwIO (userError "getFileInfo")) . Vault.lookup getFileInfoKey . vault

warp/Network/Wai/Handler/Warp/Date.hs+18−14

@@ -5,6 +5,9 @@ module Network.Wai.Handler.Warp.Date (

5 , getDate

6 , DateCache

7 , GMTDate

8+#if WINDOWS

9+ , uToH

10+#endif

8 ) where

11 ) where

9

12

10#if __GLASGOW_HASKELL__ < 709

13#if __GLASGOW_HASKELL__ < 709

@@ -12,16 +15,13 @@ import Control.Applicative

12#endif

15#endif

13import Control.AutoUpdate (defaultUpdateSettings, updateAction, mkAutoUpdate)

16import Control.AutoUpdate (defaultUpdateSettings, updateAction, mkAutoUpdate)

14import Data.ByteString.Char8

17import Data.ByteString.Char8

18+import Network.HTTP.Date

15

19

16#if WINDOWS

20#if WINDOWS

17−import Data.Time (formatTime, getCurrentTime)

21+import Data.Time (UTCTime, formatTime, getCurrentTime)

18−# if MIN_VERSION_time(1,5,0)

22+import Data.Time.Clock.POSIX (posixSecondsToUTCTime, utcTimeToPOSIXSeconds)

19−import Data.Time (defaultTimeLocale)

23+import Foreign.C.Types (CTime(..))

20−# else

21−import System.Locale (defaultTimeLocale)

22−# endif

23#else

24#else

24−import Network.HTTP.Date

25import System.Posix (epochTime)

26#endif

27

@@ -36,17 +36,21 @@ withDateCache :: (DateCache -> IO a) -> IO a

36withDateCache action = initialize >>= action

37

38initialize :: IO DateCache

39−initialize = mkAutoUpdate defaultUpdateSettings { updateAction = getCurrentGMTDate }

39+initialize = mkAutoUpdate defaultUpdateSettings {

40+ updateAction = formatHTTPDate <$> getCurrentHTTPDate

41+ }

40

42

41−-- | Getting 'GMTDate' based on 'DateCache'.

43+-- | Getting current 'GMTDate' based on 'DateCache'.

42getDate :: DateCache -> IO GMTDate

44getDate :: DateCache -> IO GMTDate

43getDate = id

45getDate = id

44

46

45−getCurrentGMTDate :: IO GMTDate

46#ifdef WINDOWS

47#ifdef WINDOWS

47−getCurrentGMTDate = formatDate <$> getCurrentTime

48+uToH :: UTCTime -> HTTPDate

48− where

49+uToH = epochTimeToHTTPDate . CTime . truncate . utcTimeToPOSIXSeconds

49− formatDate = pack . formatTime defaultTimeLocale "%a, %d %b %Y %H:%M:%S GMT"

50+

51+getCurrentHTTPDate :: IO HTTPDate

52+getCurrentHTTPDate = uToH <$> getCurrentTime

50#else

53#else

54+getCurrentHTTPDate :: IO HTTPDate

51−getCurrentGMTDate = formatHTTPDate . epochTimeToHTTPDate <$> epochTime

55+getCurrentHTTPDate = epochTimeToHTTPDate <$> epochTime

52#endif

56#endif

warp/Network/Wai/Handler/Warp/FileInfoCache.hsnew file+86

@@ -0,0 +1,86 @@

1+{-# LANGUAGE RecordWildCards, CPP #-}

2+

3+module Network.Wai.Handler.Warp.FileInfoCache (

4+ -- * Types

5+ FileInfo(..)

6+ -- * Starter

7+ , fileCacheInit

8+ ) where

9+

10+import Control.Exception as E

11+import Control.Reaper

12+import Data.ByteString (ByteString)

13+import Data.HashMap.Strict (HashMap)

14+import qualified Data.HashMap.Strict as M

15+import Network.HTTP.Date

16+import System.PosixCompat.Files

17+

18+#if WINDOWS

19+import Data.Time (UTCTime)

20+import Network.Wai.Handler.Warp.Date (uToH)

21+#endif

22+

23+data FileInfo = FileInfo {

24+ fileInfoName :: !FilePath

25+ , fileInfoSize :: !Integer

26+ , fileInfoTime :: !HTTPDate -- ^ Modification time

27+ , fileInfoDate :: !ByteString -- ^ Modification time in the GMT format

28+ } deriving (Eq, Show)

29+

30+data Entry = Negative | Positive FileInfo

31+type Cache = HashMap FilePath Entry

32+type FileCache = Reaper Cache (FilePath,Entry)

33+

34+fileInfo :: FileCache -> FilePath -> IO FileInfo

35+fileInfo reaper@Reaper{..} path = do

36+ cache <- reaperRead

37+ case M.lookup path cache of

38+ Just Negative -> throwIO (userError "fileInfo")

39+ Just (Positive x) -> return x

40+ Nothing -> register reaper path `E.onException` negative reaper path

41+

42+register :: FileCache -> FilePath -> IO FileInfo

43+register reaper path = do

44+ fs <- getFileStatus path -- file access

45+ let regular = not (isDirectory fs)

46+ readable = fileMode fs `intersectFileModes` ownerReadMode /= 0

47+ if regular && readable then

48+ positive reaper fs path

49+ else

50+ throwIO (userError "go to negative")

51+

52+positive :: FileCache -> FileStatus -> FilePath -> IO FileInfo

53+positive Reaper{..} fs path = do

54+ reaperAdd (path,entry)

55+ return info

56+ where

57+ info = FileInfo {

58+ fileInfoName = path

59+ , fileInfoSize = size fs

60+ , fileInfoTime = time

61+ , fileInfoDate = formatHTTPDate time

62+ }

63+ size = fromIntegral . fileSize

64+ time = epochTimeToHTTPDate (modificationTime fs)

65+ entry = Positive info

66+

67+negative :: FileCache -> FilePath -> IO FileInfo

68+negative Reaper{..} path = do

69+ reaperAdd (path,Negative)

70+ throwIO (userError "fileInfo")

71+

72+----------------------------------------------------------------

73+

74+fileCacheInit :: IO (FilePath -> IO FileInfo)

75+fileCacheInit = mkReaper settings >>= return . fileInfo

76+ where

77+ settings = defaultReaperSettings {

78+ reaperAction = override

79+ , reaperDelay = 10000000 -- 10 seconds -- hard-coding: fixme

80+ , reaperCons = uncurry M.insert

81+ , reaperNull = M.null

82+ , reaperEmpty = M.empty

83+ }

84+

85+override :: Cache -> IO (Cache -> Cache)

86+override _ = return $ const M.empty

warp/Network/Wai/Handler/Warp/Request.hs+6

@@ -7,6 +7,7 @@ module Network.Wai.Handler.Warp.Request (

7 recvRequest

8 , headerLines

9 , pauseTimeoutKey

10+ , getFileInfoKey

10 ) where

11 ) where

11

12

12import qualified Control.Concurrent as Conc (yield)

13import qualified Control.Concurrent as Conc (yield)

@@ -21,6 +22,7 @@ import qualified Network.HTTP.Types as H

21import Network.Socket (SockAddr)

22import Network.Socket (SockAddr)

22import Network.Wai

23import Network.Wai

23import Network.Wai.Handler.Warp.Conduit

24import Network.Wai.Handler.Warp.Conduit

25+import Network.Wai.Handler.Warp.FileInfoCache

24import Network.Wai.Handler.Warp.Header

26import Network.Wai.Handler.Warp.Header

25import Network.Wai.Handler.Warp.ReadInt

27import Network.Wai.Handler.Warp.ReadInt

26import Network.Wai.Handler.Warp.RequestHeader

28import Network.Wai.Handler.Warp.RequestHeader

@@ -278,3 +280,7 @@ checkCR bs pos = if pos > 0 && 13 == S.index bs p then p else pos -- 13 is CR

278pauseTimeoutKey :: Vault.Key (IO ())

280pauseTimeoutKey :: Vault.Key (IO ())

279pauseTimeoutKey = unsafePerformIO Vault.newKey

281pauseTimeoutKey = unsafePerformIO Vault.newKey

280{-# NOINLINE pauseTimeoutKey #-}

282{-# NOINLINE pauseTimeoutKey #-}

283+

284+getFileInfoKey :: Vault.Key (FilePath -> IO FileInfo)

285+getFileInfoKey = unsafePerformIO Vault.newKey

286+{-# NOINLINE getFileInfoKey #-}

warp/warp.cabal+3−2

@@ -53,6 +53,7 @@ Library

53 , stm >= 2.3

54 , word8

55 , hashable

56+ , unordered-containers

56 if flag(network-bytestring)

57 if flag(network-bytestring)

57 Build-Depends: network >= 2.2.1.5 && < 2.2.3

58 Build-Depends: network >= 2.2.1.5 && < 2.2.3

58 , network-bytestring >= 0.1.3 && < 0.1.4

59 , network-bytestring >= 0.1.3 && < 0.1.4

@@ -65,6 +66,7 @@ Library

65 Network.Wai.Handler.Warp.Counter

66 Network.Wai.Handler.Warp.Counter

66 Network.Wai.Handler.Warp.Date

67 Network.Wai.Handler.Warp.Date

67 Network.Wai.Handler.Warp.FdCache

68 Network.Wai.Handler.Warp.FdCache

69+ Network.Wai.Handler.Warp.FileInfoCache

68 Network.Wai.Handler.Warp.HTTP2

70 Network.Wai.Handler.Warp.HTTP2

69 Network.Wai.Handler.Warp.HTTP2.EncodeFrame

71 Network.Wai.Handler.Warp.HTTP2.EncodeFrame

70 Network.Wai.Handler.Warp.HTTP2.HPACK

72 Network.Wai.Handler.Warp.HTTP2.HPACK

@@ -99,7 +101,6 @@ Library

99 if os(windows)

101 if os(windows)

100 Cpp-Options: -DWINDOWS

102 Cpp-Options: -DWINDOWS

101 Build-Depends: time

103 Build-Depends: time

102− , old-locale

103 else

104 else

104 Build-Depends: unix

105 Build-Depends: unix

105 , http-date

106 , http-date

@@ -152,7 +153,6 @@ Test-Suite spec

152 , QuickCheck

153 , QuickCheck

153 , hspec >= 1.3

154 , hspec >= 1.3

154 , time

155 , time

155− , old-locale

156 , text

157 , streaming-commons >= 0.1.10

158 , async

@@ -164,6 +164,7 @@ Test-Suite spec

164 , http2 >= 1.3

165 , word8

166 , hashable

167+ , unordered-containers

167

168

168 if (os(linux) || os(freebsd) || os(darwin)) && flag(allow-sendfilefd)

169 if (os(linux) || os(freebsd) || os(darwin)) && flag(allow-sendfilefd)

169 Cpp-Options: -DSENDFILEFD

170 Cpp-Options: -DSENDFILEFD