{-# LANGUAGE CPP, OverloadedStrings #-}
module Network.Wai.Middleware.Static
(
static, staticPolicy, unsafeStaticPolicy
, static', staticPolicy', unsafeStaticPolicy'
, staticWithOptions, staticPolicyWithOptions, unsafeStaticPolicyWithOptions
,
Options, cacheContainer, mimeTypes, defaultOptions
,
CachingStrategy(..), FileMeta(..), initCaching, CacheContainer
,
Policy, (<|>), (>->), policy, predicate
, addBase, addSlash, contains, hasPrefix, hasSuffix, noDots, isNotAbsolute, only
,
tryPolicy
,
getMimeType
) where
import Caching.ExpiringCacheMap.HashECM (newECMIO, lookupECM, CacheSettings(..), consistentDuration)
import Control.Monad.Trans (liftIO)
import Data.List
#if !(MIN_VERSION_base(4,8,0))
import Data.Monoid (Monoid(..))
#endif
#if !(MIN_VERSION_base(4,11,0))
import Data.Semigroup (Semigroup(..))
#endif
import Data.Time
import Data.Time.Clock.POSIX
import Network.HTTP.Types (status200, status304)
import Network.HTTP.Types.Header (RequestHeaders)
import Network.Mime (MimeType, defaultMimeLookup)
import Network.Wai
import System.Directory (doesFileExist, getModificationTime)
#if !(MIN_VERSION_time(1,5,0))
import System.Locale
#endif
import Crypto.Hash.Algorithms
import Crypto.Hash
import Data.ByteArray.Encoding
import qualified Data.ByteString as BS
import qualified Data.ByteString.Char8 as BSC
import qualified Data.ByteString.Lazy as BSL
import qualified Data.Text as T
import qualified System.FilePath as FP
newtype Policy = Policy { Policy -> String -> Maybe String
tryPolicy :: String -> Maybe String
}
data Options = Options { Options -> CacheContainer
cacheContainer :: CacheContainer
, Options -> String -> MimeType
mimeTypes :: FilePath -> MimeType
}
defaultOptions :: Options
defaultOptions :: Options
defaultOptions = Options :: CacheContainer -> (String -> MimeType) -> Options
Options { cacheContainer :: CacheContainer
cacheContainer = CacheContainer
CacheContainerEmpty, mimeTypes :: String -> MimeType
mimeTypes = String -> MimeType
getMimeType }
data CachingStrategy
= NoCaching
| PublicStaticCaching
| CustomCaching (FileMeta -> RequestHeaders)
instance Semigroup Policy where
p1 :: Policy
p1 <> :: Policy -> Policy -> Policy
<> p2 :: Policy
p2 = (String -> Maybe String) -> Policy
policy (Maybe String
-> (String -> Maybe String) -> Maybe String -> Maybe String
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Maybe String
forall a. Maybe a
Nothing (Policy -> String -> Maybe String
tryPolicy Policy
p2) (Maybe String -> Maybe String)
-> (String -> Maybe String) -> String -> Maybe String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Policy -> String -> Maybe String
tryPolicy Policy
p1)
instance Monoid Policy where
mempty :: Policy
mempty = (String -> Maybe String) -> Policy
policy String -> Maybe String
forall a. a -> Maybe a
Just
mappend :: Policy -> Policy -> Policy
mappend = Policy -> Policy -> Policy
forall a. Semigroup a => a -> a -> a
(<>)
policy :: (String -> Maybe String) -> Policy
policy :: (String -> Maybe String) -> Policy
policy = (String -> Maybe String) -> Policy
Policy
predicate :: (String -> Bool) -> Policy
predicate :: (String -> Bool) -> Policy
predicate p :: String -> Bool
p = (String -> Maybe String) -> Policy
policy (\s :: String
s -> if String -> Bool
p String
s then String -> Maybe String
forall a. a -> Maybe a
Just String
s else Maybe String
forall a. Maybe a
Nothing)
infixr 5 >->
(>->) :: Policy -> Policy -> Policy
>-> :: Policy -> Policy -> Policy
(>->) = Policy -> Policy -> Policy
forall a. Semigroup a => a -> a -> a
(<>)
infixr 4 <|>
(<|>) :: Policy -> Policy -> Policy
p1 :: Policy
p1 <|> :: Policy -> Policy -> Policy
<|> p2 :: Policy
p2 = (String -> Maybe String) -> Policy
policy (\s :: String
s -> Maybe String
-> (String -> Maybe String) -> Maybe String -> Maybe String
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Policy -> String -> Maybe String
tryPolicy Policy
p2 String
s) String -> Maybe String
forall a. a -> Maybe a
Just (Policy -> String -> Maybe String
tryPolicy Policy
p1 String
s))
addBase :: String -> Policy
addBase :: String -> Policy
addBase b :: String
b = (String -> Maybe String) -> Policy
policy (String -> Maybe String
forall a. a -> Maybe a
Just (String -> Maybe String)
-> (String -> String) -> String -> Maybe String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String
b String -> String -> String
FP.</>))
addSlash :: Policy
addSlash :: Policy
addSlash = (String -> Maybe String) -> Policy
policy String -> Maybe String
slashOpt
where slashOpt :: String -> Maybe String
slashOpt s :: String
s@('/':_) = String -> Maybe String
forall a. a -> Maybe a
Just String
s
slashOpt s :: String
s = String -> Maybe String
forall a. a -> Maybe a
Just ('/'Char -> String -> String
forall a. a -> [a] -> [a]
:String
s)
hasSuffix :: String -> Policy
hasSuffix :: String -> Policy
hasSuffix = (String -> Bool) -> Policy
predicate ((String -> Bool) -> Policy)
-> (String -> String -> Bool) -> String -> Policy
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
isSuffixOf
hasPrefix :: String -> Policy
hasPrefix :: String -> Policy
hasPrefix = (String -> Bool) -> Policy
predicate ((String -> Bool) -> Policy)
-> (String -> String -> Bool) -> String -> Policy
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
isPrefixOf
contains :: String -> Policy
contains :: String -> Policy
contains = (String -> Bool) -> Policy
predicate ((String -> Bool) -> Policy)
-> (String -> String -> Bool) -> String -> Policy
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
isInfixOf
noDots :: Policy
noDots :: Policy
noDots = (String -> Bool) -> Policy
predicate (Bool -> Bool
not (Bool -> Bool) -> (String -> Bool) -> String -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
isInfixOf "..")
isNotAbsolute :: Policy
isNotAbsolute :: Policy
isNotAbsolute = (String -> Bool) -> Policy
predicate ((String -> Bool) -> Policy) -> (String -> Bool) -> Policy
forall a b. (a -> b) -> a -> b
$ Bool -> Bool
not (Bool -> Bool) -> (String -> Bool) -> String -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Bool
FP.isAbsolute
only :: [(String, String)] -> Policy
only :: [(String, String)] -> Policy
only al :: [(String, String)]
al = (String -> Maybe String) -> Policy
policy ((String -> [(String, String)] -> Maybe String)
-> [(String, String)] -> String -> Maybe String
forall a b c. (a -> b -> c) -> b -> a -> c
flip String -> [(String, String)] -> Maybe String
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup [(String, String)]
al)
static :: Middleware
static :: Middleware
static = Policy -> Middleware
staticPolicy Policy
forall a. Monoid a => a
mempty
{-# DEPRECATED static'
[ "Use 'staticWithOptions' instead. "
, "This function will be removed in the next major release."
] #-}
static' :: CacheContainer -> Middleware
static' :: CacheContainer -> Middleware
static' cc :: CacheContainer
cc = CacheContainer -> Policy -> Middleware
staticPolicy' CacheContainer
cc Policy
forall a. Monoid a => a
mempty
staticWithOptions :: Options -> Middleware
staticWithOptions :: Options -> Middleware
staticWithOptions options :: Options
options = Options -> Policy -> Middleware
staticPolicyWithOptions Options
options Policy
forall a. Monoid a => a
mempty
staticPolicy :: Policy -> Middleware
staticPolicy :: Policy -> Middleware
staticPolicy = CacheContainer -> Policy -> Middleware
staticPolicy' (Options -> CacheContainer
cacheContainer Options
defaultOptions)
{-# DEPRECATED staticPolicy'
[ "Use 'staticPolicyWithOptions' instead. "
, "This function will be removed in the next major release."
] #-}
staticPolicy' :: CacheContainer -> Policy -> Middleware
staticPolicy' :: CacheContainer -> Policy -> Middleware
staticPolicy' cc :: CacheContainer
cc p :: Policy
p = CacheContainer -> Policy -> Middleware
unsafeStaticPolicy' CacheContainer
cc (Policy -> Middleware) -> Policy -> Middleware
forall a b. (a -> b) -> a -> b
$ Policy
noDots Policy -> Policy -> Policy
>-> Policy
isNotAbsolute Policy -> Policy -> Policy
>-> Policy
p
staticPolicyWithOptions :: Options -> Policy -> Middleware
staticPolicyWithOptions :: Options -> Policy -> Middleware
staticPolicyWithOptions options :: Options
options p :: Policy
p = Options -> Policy -> Middleware
unsafeStaticPolicyWithOptions Options
options (Policy -> Middleware) -> Policy -> Middleware
forall a b. (a -> b) -> a -> b
$ Policy
noDots Policy -> Policy -> Policy
>-> Policy
isNotAbsolute Policy -> Policy -> Policy
>-> Policy
p
unsafeStaticPolicy :: Policy -> Middleware
unsafeStaticPolicy :: Policy -> Middleware
unsafeStaticPolicy = CacheContainer -> Policy -> Middleware
unsafeStaticPolicy' (Options -> CacheContainer
cacheContainer Options
defaultOptions)
{-# DEPRECATED unsafeStaticPolicy'
[ "Use 'unsafeStaticPolicyWithOptions' instead. "
, "This function will be removed in the next major release."
] #-}
unsafeStaticPolicy' :: CacheContainer -> Policy -> Middleware
unsafeStaticPolicy' :: CacheContainer -> Policy -> Middleware
unsafeStaticPolicy' cc :: CacheContainer
cc = Options -> Policy -> Middleware
unsafeStaticPolicyWithOptions (Options
defaultOptions { cacheContainer :: CacheContainer
cacheContainer = CacheContainer
cc })
unsafeStaticPolicyWithOptions :: Options -> Policy -> Middleware
unsafeStaticPolicyWithOptions :: Options -> Policy -> Middleware
unsafeStaticPolicyWithOptions options :: Options
options p :: Policy
p app :: Application
app req :: Request
req callback :: Response -> IO ResponseReceived
callback =
IO ResponseReceived
-> (String -> IO ResponseReceived)
-> Maybe String
-> IO ResponseReceived
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Application
app Request
req Response -> IO ResponseReceived
callback)
(\fp :: String
fp ->
do Bool
exists <- IO Bool -> IO Bool
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Bool -> IO Bool) -> IO Bool -> IO Bool
forall a b. (a -> b) -> a -> b
$ String -> IO Bool
doesFileExist String
fp
if Bool
exists
then case Options -> CacheContainer
cacheContainer Options
options of
CacheContainerEmpty ->
String -> [(HeaderName, MimeType)] -> IO ResponseReceived
sendFile String
fp []
CacheContainer _ NoCaching ->
String -> [(HeaderName, MimeType)] -> IO ResponseReceived
sendFile String
fp []
CacheContainer getFileMeta :: String -> IO FileMeta
getFileMeta strategy :: CachingStrategy
strategy ->
do FileMeta
fileMeta <- String -> IO FileMeta
getFileMeta String
fp
if FileMeta -> Maybe MimeType -> Maybe MimeType -> Bool
checkNotModified FileMeta
fileMeta (HeaderName -> Maybe MimeType
readHeader "If-Modified-Since") (HeaderName -> Maybe MimeType
readHeader "If-None-Match")
then FileMeta -> CachingStrategy -> IO ResponseReceived
sendNotModified FileMeta
fileMeta CachingStrategy
strategy
else String -> [(HeaderName, MimeType)] -> IO ResponseReceived
sendFile String
fp (FileMeta -> CachingStrategy -> [(HeaderName, MimeType)]
computeHeaders FileMeta
fileMeta CachingStrategy
strategy)
else Application
app Request
req Response -> IO ResponseReceived
callback)
(Policy -> String -> Maybe String
tryPolicy Policy
p (String -> Maybe String) -> String -> Maybe String
forall a b. (a -> b) -> a -> b
$ Text -> String
T.unpack (Text -> String) -> Text -> String
forall a b. (a -> b) -> a -> b
$ Text -> [Text] -> Text
T.intercalate "/" ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$ Request -> [Text]
pathInfo Request
req)
where
readHeader :: HeaderName -> Maybe MimeType
readHeader header :: HeaderName
header =
HeaderName -> [(HeaderName, MimeType)] -> Maybe MimeType
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup HeaderName
header ([(HeaderName, MimeType)] -> Maybe MimeType)
-> [(HeaderName, MimeType)] -> Maybe MimeType
forall a b. (a -> b) -> a -> b
$ Request -> [(HeaderName, MimeType)]
requestHeaders Request
req
checkNotModified :: FileMeta -> Maybe MimeType -> Maybe MimeType -> Bool
checkNotModified fm :: FileMeta
fm modSince :: Maybe MimeType
modSince etag :: Maybe MimeType
etag =
[Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
or [ MimeType -> Maybe MimeType
forall a. a -> Maybe a
Just (FileMeta -> MimeType
fm_lastModified FileMeta
fm) Maybe MimeType -> Maybe MimeType -> Bool
forall a. Eq a => a -> a -> Bool
== Maybe MimeType
modSince
, MimeType -> Maybe MimeType
forall a. a -> Maybe a
Just (FileMeta -> MimeType
fm_etag FileMeta
fm) Maybe MimeType -> Maybe MimeType -> Bool
forall a. Eq a => a -> a -> Bool
== Maybe MimeType
etag
]
computeHeaders :: FileMeta -> CachingStrategy -> [(HeaderName, MimeType)]
computeHeaders fm :: FileMeta
fm cs :: CachingStrategy
cs =
case CachingStrategy
cs of
NoCaching -> []
PublicStaticCaching ->
[ ("Cache-Control", "no-transform,public,max-age=300,s-maxage=900")
, ("Last-Modified", FileMeta -> MimeType
fm_lastModified FileMeta
fm)
, ("ETag", FileMeta -> MimeType
fm_etag FileMeta
fm)
, ("Vary", "Accept-Encoding")
]
CustomCaching f :: FileMeta -> [(HeaderName, MimeType)]
f -> FileMeta -> [(HeaderName, MimeType)]
f FileMeta
fm
sendNotModified :: FileMeta -> CachingStrategy -> IO ResponseReceived
sendNotModified fm :: FileMeta
fm cs :: CachingStrategy
cs =
do let cacheHeaders :: [(HeaderName, MimeType)]
cacheHeaders = FileMeta -> CachingStrategy -> [(HeaderName, MimeType)]
computeHeaders FileMeta
fm CachingStrategy
cs
Response -> IO ResponseReceived
callback (Response -> IO ResponseReceived)
-> Response -> IO ResponseReceived
forall a b. (a -> b) -> a -> b
$ Status -> [(HeaderName, MimeType)] -> ByteString -> Response
responseLBS Status
status304 [(HeaderName, MimeType)]
cacheHeaders ByteString
BSL.empty
sendFile :: String -> [(HeaderName, MimeType)] -> IO ResponseReceived
sendFile fp :: String
fp extraHeaders :: [(HeaderName, MimeType)]
extraHeaders =
do let basicHeaders :: [(HeaderName, MimeType)]
basicHeaders =
[ ("Content-Type", Options -> String -> MimeType
mimeTypes Options
options String
fp)
]
headers :: [(HeaderName, MimeType)]
headers =
[(HeaderName, MimeType)]
basicHeaders [(HeaderName, MimeType)]
-> [(HeaderName, MimeType)] -> [(HeaderName, MimeType)]
forall a. [a] -> [a] -> [a]
++ [(HeaderName, MimeType)]
extraHeaders
Response -> IO ResponseReceived
callback (Response -> IO ResponseReceived)
-> Response -> IO ResponseReceived
forall a b. (a -> b) -> a -> b
$ Status
-> [(HeaderName, MimeType)] -> String -> Maybe FilePart -> Response
responseFile Status
status200 [(HeaderName, MimeType)]
headers String
fp Maybe FilePart
forall a. Maybe a
Nothing
data CacheContainer
= CacheContainerEmpty
| CacheContainer (FilePath -> IO FileMeta) CachingStrategy
data FileMeta
= FileMeta
{ FileMeta -> MimeType
fm_lastModified :: !BS.ByteString
, FileMeta -> MimeType
fm_etag :: !BS.ByteString
, FileMeta -> String
fm_fileName :: FilePath
} deriving (Int -> FileMeta -> String -> String
[FileMeta] -> String -> String
FileMeta -> String
(Int -> FileMeta -> String -> String)
-> (FileMeta -> String)
-> ([FileMeta] -> String -> String)
-> Show FileMeta
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
showList :: [FileMeta] -> String -> String
$cshowList :: [FileMeta] -> String -> String
show :: FileMeta -> String
$cshow :: FileMeta -> String
showsPrec :: Int -> FileMeta -> String -> String
$cshowsPrec :: Int -> FileMeta -> String -> String
Show, FileMeta -> FileMeta -> Bool
(FileMeta -> FileMeta -> Bool)
-> (FileMeta -> FileMeta -> Bool) -> Eq FileMeta
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: FileMeta -> FileMeta -> Bool
$c/= :: FileMeta -> FileMeta -> Bool
== :: FileMeta -> FileMeta -> Bool
$c== :: FileMeta -> FileMeta -> Bool
Eq)
initCaching :: CachingStrategy -> IO CacheContainer
initCaching :: CachingStrategy -> IO CacheContainer
initCaching cs :: CachingStrategy
cs =
do let cacheAccess :: Maybe s -> String -> IO (Int, (Maybe s, FileMeta))
cacheAccess =
Int
-> (Maybe s -> String -> IO (Maybe s, FileMeta))
-> Maybe s
-> String
-> IO (Int, (Maybe s, FileMeta))
forall (m :: * -> *) k s v.
(Monad m, Eq k, Hashable k) =>
Int
-> (Maybe s -> k -> m (Maybe s, v))
-> Maybe s
-> k
-> m (Int, (Maybe s, v))
consistentDuration 100 ((Maybe s -> String -> IO (Maybe s, FileMeta))
-> Maybe s -> String -> IO (Int, (Maybe s, FileMeta)))
-> (Maybe s -> String -> IO (Maybe s, FileMeta))
-> Maybe s
-> String
-> IO (Int, (Maybe s, FileMeta))
forall a b. (a -> b) -> a -> b
$ \state :: Maybe s
state fp :: String
fp ->
do FileMeta
fileMeta <- String -> IO FileMeta
computeFileMeta String
fp
(Maybe s, FileMeta) -> IO (Maybe s, FileMeta)
forall (m :: * -> *) a. Monad m => a -> m a
return ((Maybe s, FileMeta) -> IO (Maybe s, FileMeta))
-> (Maybe s, FileMeta) -> IO (Maybe s, FileMeta)
forall a b. (a -> b) -> a -> b
$! (Maybe s
state, FileMeta
fileMeta)
cacheTick :: IO Int
cacheTick =
do POSIXTime
time <- IO POSIXTime
getPOSIXTime
Int -> IO Int
forall (m :: * -> *) a. Monad m => a -> m a
return (POSIXTime -> Int
forall a b. (RealFrac a, Integral b) => a -> b
round (POSIXTime
time POSIXTime -> POSIXTime -> POSIXTime
forall a. Num a => a -> a -> a
* 100))
cacheFreq :: ECMIncr
cacheFreq = 1
cacheLRU :: CacheSettings
cacheLRU =
Int -> Int -> Int -> CacheSettings
CacheWithLRUList 100 100 200
ECM IO MVar Any HashMap String FileMeta
filecache <- (Maybe Any -> String -> IO (Int, (Maybe Any, FileMeta)))
-> IO Int
-> ECMIncr
-> CacheSettings
-> IO (ECM IO MVar Any HashMap String FileMeta)
forall k s v.
(Eq k, Hashable k) =>
(Maybe s -> k -> IO (Int, (Maybe s, v)))
-> IO Int
-> ECMIncr
-> CacheSettings
-> IO (ECM IO MVar s HashMap k v)
newECMIO Maybe Any -> String -> IO (Int, (Maybe Any, FileMeta))
forall s. Maybe s -> String -> IO (Int, (Maybe s, FileMeta))
cacheAccess IO Int
cacheTick ECMIncr
cacheFreq CacheSettings
cacheLRU
CacheContainer -> IO CacheContainer
forall (m :: * -> *) a. Monad m => a -> m a
return ((String -> IO FileMeta) -> CachingStrategy -> CacheContainer
CacheContainer (ECM IO MVar Any HashMap String FileMeta -> String -> IO FileMeta
forall (m :: * -> *) k (mv :: * -> *) s v.
(Monad m, Eq k, Hashable k) =>
ECM m mv s HashMap k v -> k -> m v
lookupECM ECM IO MVar Any HashMap String FileMeta
filecache) CachingStrategy
cs)
computeFileMeta :: FilePath -> IO FileMeta
computeFileMeta :: String -> IO FileMeta
computeFileMeta fp :: String
fp =
do UTCTime
mtime <- String -> IO UTCTime
getModificationTime String
fp
ByteString
ct <- String -> IO ByteString
BSL.readFile String
fp
FileMeta -> IO FileMeta
forall (m :: * -> *) a. Monad m => a -> m a
return (FileMeta -> IO FileMeta) -> FileMeta -> IO FileMeta
forall a b. (a -> b) -> a -> b
$ $WFileMeta :: MimeType -> MimeType -> String -> FileMeta
FileMeta
{ fm_lastModified :: MimeType
fm_lastModified =
String -> MimeType
BSC.pack (String -> MimeType) -> String -> MimeType
forall a b. (a -> b) -> a -> b
$ TimeLocale -> String -> UTCTime -> String
forall t. FormatTime t => TimeLocale -> String -> t -> String
formatTime TimeLocale
defaultTimeLocale "%a, %d-%b-%Y %X %Z" UTCTime
mtime
, fm_etag :: MimeType
fm_etag = Base -> Digest SHA1 -> MimeType
forall bin bout.
(ByteArrayAccess bin, ByteArray bout) =>
Base -> bin -> bout
convertToBase Base
Base16 (ByteString -> Digest SHA1
forall a. HashAlgorithm a => ByteString -> Digest a
hashlazy ByteString
ct :: Digest SHA1)
, fm_fileName :: String
fm_fileName = String
fp
}
getMimeType :: FilePath -> MimeType
getMimeType :: String -> MimeType
getMimeType = Text -> MimeType
defaultMimeLookup (Text -> MimeType) -> (String -> Text) -> String -> MimeType
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
T.pack