{-# LANGUAGE CPP, OverloadedStrings #-}
-- | Serve static files, subject to a policy that can filter or
--   modify incoming URIs. The flow is:
--
--   incoming request URI ==> policies ==> exists? ==> respond
--
--   If any of the polices fail, or the file doesn't
--   exist, then the middleware gives up and calls the inner application.
--   If the file is found, the middleware chooses a content type based
--   on the file extension and returns the file contents as the response.
module Network.Wai.Middleware.Static
    ( -- * Middlewares
      static, staticPolicy, unsafeStaticPolicy
    , static', staticPolicy', unsafeStaticPolicy'
    , staticWithOptions, staticPolicyWithOptions, unsafeStaticPolicyWithOptions
    , -- * Options
      Options, cacheContainer, mimeTypes, defaultOptions
    , -- * Cache Control
      CachingStrategy(..), FileMeta(..), initCaching, CacheContainer
    , -- * Policies
      Policy, (<|>), (>->), policy, predicate
    , addBase, addSlash, contains, hasPrefix, hasSuffix, noDots, isNotAbsolute, only
    , -- * Utilities
      tryPolicy
    , -- * MIME types
      getMimeType
    ) where

import Caching.ExpiringCacheMap.HashECM (newECMIO, lookupECM, CacheSettings(..), consistentDuration)
import Control.Monad
import qualified Crypto.Hash.SHA1 as SHA1
import qualified Data.ByteString.Base16 as Base16
import qualified Data.List as L
#if !(MIN_VERSION_base(4,11,0))
import Data.Semigroup (Semigroup(..))
#endif
import Data.Time
import Data.Time.Clock.POSIX
import Network.HTTP.Types
import Network.Mime (MimeType, defaultMimeLookup)
import Network.Wai
import System.Directory (doesFileExist, getModificationTime)
-- 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

-- | Take an incoming URI and optionally modify or filter it.
--   The result will be treated as a filepath.
newtype Policy = Policy { Policy -> FilePath -> Maybe FilePath
tryPolicy :: String -> Maybe FilePath -- ^ Run a policy
                        }

-- | Options for 'staticWithOptions' 'Middleware'.
--
-- Options can be set using record syntax on 'defaultOptions' with the fields below.
data Options = Options { Options -> CacheContainer
cacheContainer :: CacheContainer -- ^ Cache container to use
                       , Options -> FilePath -> Method
mimeTypes :: FilePath -> MimeType -- ^ Compute MimeType from file name
                       }

-- | Default options.
--
-- @
-- 'Options'
-- { 'cacheContainer' = 'CacheContainerEmpty' -- no caching
-- , 'mimeTypes'      = 'getMimeType'         -- use 'defaultMimeLookup' from 'Network.Mime'
-- }
-- @
defaultOptions :: Options
defaultOptions :: Options
defaultOptions = Options { cacheContainer :: CacheContainer
cacheContainer = CacheContainer
CacheContainerEmpty, mimeTypes :: FilePath -> Method
mimeTypes = FilePath -> Method
getMimeType }

-- | A cache strategy which should be used to
-- serve content matching a policy. Meta information is cached for a maxium of
-- 100 seconds before being recomputed.
data CachingStrategy
   -- | Do not send any caching headers
   = NoCaching
   -- | Send common caching headers for public (non dynamic) static files
   | PublicStaticCaching
   -- | Compute caching headers using the user specified function.
   -- See <http://www.mobify.com/blog/beginners-guide-to-http-cache-headers/> for a detailed guide
   | CustomCaching (FileMeta -> RequestHeaders)

-- | Note:
--   '(<>)' == @>->@ (policy sequencing)
instance Semigroup Policy where
    Policy
p1 <> :: Policy -> Policy -> Policy
<> Policy
p2 = (FilePath -> Maybe FilePath) -> Policy
policy (Maybe FilePath
-> (FilePath -> Maybe FilePath) -> Maybe FilePath -> Maybe FilePath
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Maybe FilePath
forall a. Maybe a
Nothing (Policy -> FilePath -> Maybe FilePath
tryPolicy Policy
p2) (Maybe FilePath -> Maybe FilePath)
-> (FilePath -> Maybe FilePath) -> FilePath -> Maybe FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Policy -> FilePath -> Maybe FilePath
tryPolicy Policy
p1)

-- | Note:
--   'mempty' == @policy Just@ (the always accepting policy)
--   'mappend' == @>->@ (policy sequencing)
instance Monoid Policy where
    mempty :: Policy
mempty  = (FilePath -> Maybe FilePath) -> Policy
policy FilePath -> Maybe FilePath
forall a. a -> Maybe a
Just
    mappend :: Policy -> Policy -> Policy
mappend = Policy -> Policy -> Policy
forall a. Semigroup a => a -> a -> a
(<>)

-- | Lift a function into a 'Policy'
policy :: (String -> Maybe String) -> Policy
policy :: (FilePath -> Maybe FilePath) -> Policy
policy = (FilePath -> Maybe FilePath) -> Policy
Policy

-- | Lift a predicate into a 'Policy'
predicate :: (String -> Bool) -> Policy
predicate :: (FilePath -> Bool) -> Policy
predicate FilePath -> Bool
p = (FilePath -> Maybe FilePath) -> Policy
policy (\FilePath
s -> if FilePath -> Bool
p FilePath
s then FilePath -> Maybe FilePath
forall a. a -> Maybe a
Just FilePath
s else Maybe FilePath
forall a. Maybe a
Nothing)

-- | Sequence two policies. They are run from left to right. (Note: this is `mappend`)
infixr 5 >->
(>->) :: Policy -> Policy -> Policy
>-> :: Policy -> Policy -> Policy
(>->) = Policy -> Policy -> Policy
forall a. Semigroup a => a -> a -> a
(<>)

-- | Choose between two policies. If the first fails, run the second.
infixr 4 <|>
(<|>) :: Policy -> Policy -> Policy
Policy
p1 <|> :: Policy -> Policy -> Policy
<|> Policy
p2 = (FilePath -> Maybe FilePath) -> Policy
policy (\FilePath
s -> Maybe FilePath
-> (FilePath -> Maybe FilePath) -> Maybe FilePath -> Maybe FilePath
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Policy -> FilePath -> Maybe FilePath
tryPolicy Policy
p2 FilePath
s) FilePath -> Maybe FilePath
forall a. a -> Maybe a
Just (Policy -> FilePath -> Maybe FilePath
tryPolicy Policy
p1 FilePath
s))

-- | Add a base path to the URI
--
-- > staticPolicy (addBase "/home/user/files")
--
-- GET \"foo\/bar\" looks for \"\/home\/user\/files\/foo\/bar\"
--
addBase :: String -> Policy
addBase :: FilePath -> Policy
addBase FilePath
b = (FilePath -> Maybe FilePath) -> Policy
policy (FilePath -> Maybe FilePath
forall a. a -> Maybe a
Just (FilePath -> Maybe FilePath)
-> (FilePath -> FilePath) -> FilePath -> Maybe FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (FilePath
b FilePath -> FilePath -> FilePath
FP.</>))

-- | Add an initial slash to to the URI, if not already present.
--
-- > staticPolicy addSlash
--
-- GET \"foo\/bar\" looks for \"\/foo\/bar\"
addSlash :: Policy
addSlash :: Policy
addSlash = (FilePath -> Maybe FilePath) -> Policy
policy FilePath -> Maybe FilePath
slashOpt
    where slashOpt :: FilePath -> Maybe FilePath
slashOpt s :: FilePath
s@(Char
'/':FilePath
_) = FilePath -> Maybe FilePath
forall a. a -> Maybe a
Just FilePath
s
          slashOpt FilePath
s         = FilePath -> Maybe FilePath
forall a. a -> Maybe a
Just (Char
'/'Char -> FilePath -> FilePath
forall a. a -> [a] -> [a]
:FilePath
s)

-- | Accept only URIs with given suffix
hasSuffix :: String -> Policy
hasSuffix :: FilePath -> Policy
hasSuffix = (FilePath -> Bool) -> Policy
predicate ((FilePath -> Bool) -> Policy)
-> (FilePath -> FilePath -> Bool) -> FilePath -> Policy
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> FilePath -> Bool
forall a. Eq a => [a] -> [a] -> Bool
L.isSuffixOf

-- | Accept only URIs with given prefix
hasPrefix :: String -> Policy
hasPrefix :: FilePath -> Policy
hasPrefix = (FilePath -> Bool) -> Policy
predicate ((FilePath -> Bool) -> Policy)
-> (FilePath -> FilePath -> Bool) -> FilePath -> Policy
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> FilePath -> Bool
forall a. Eq a => [a] -> [a] -> Bool
L.isPrefixOf

-- | Accept only URIs containing given string
contains :: String -> Policy
contains :: FilePath -> Policy
contains = (FilePath -> Bool) -> Policy
predicate ((FilePath -> Bool) -> Policy)
-> (FilePath -> FilePath -> Bool) -> FilePath -> Policy
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> FilePath -> Bool
forall a. Eq a => [a] -> [a] -> Bool
L.isInfixOf

-- | Reject URIs containing \"..\"
noDots :: Policy
noDots :: Policy
noDots = (FilePath -> Bool) -> Policy
predicate (Bool -> Bool
not (Bool -> Bool) -> (FilePath -> Bool) -> FilePath -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> FilePath -> Bool
forall a. Eq a => [a] -> [a] -> Bool
L.isInfixOf FilePath
"..")

-- | Reject URIs that are absolute paths
isNotAbsolute :: Policy
isNotAbsolute :: Policy
isNotAbsolute = (FilePath -> Bool) -> Policy
predicate ((FilePath -> Bool) -> Policy) -> (FilePath -> Bool) -> Policy
forall a b. (a -> b) -> a -> b
$ Bool -> Bool
not (Bool -> Bool) -> (FilePath -> Bool) -> FilePath -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> Bool
FP.isAbsolute

-- | Use URI as the key to an association list, rejecting those not found.
-- The policy result is the matching value.
--
-- > staticPolicy (only [("foo/bar", "/home/user/files/bar")])
--
-- GET \"foo\/bar\" looks for \"\/home\/user\/files\/bar\"
-- GET \"baz\/bar\" doesn't match anything
--
only :: [(String, String)] -> Policy
only :: [(FilePath, FilePath)] -> Policy
only [(FilePath, FilePath)]
al = (FilePath -> Maybe FilePath) -> Policy
policy ((FilePath -> [(FilePath, FilePath)] -> Maybe FilePath)
-> [(FilePath, FilePath)] -> FilePath -> Maybe FilePath
forall a b c. (a -> b -> c) -> b -> a -> c
flip FilePath -> [(FilePath, FilePath)] -> Maybe FilePath
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup [(FilePath, FilePath)]
al)

-- | Serve static files out of the application root (current directory).
-- If file is found, it is streamed to the client and no further middleware is run. Disables caching.
--
-- Note: for security reasons, this uses the 'noDots' and 'isNotAbsolute' policy by default.
static :: Middleware
static :: Middleware
static = Policy -> Middleware
staticPolicy Policy
forall a. Monoid a => a
mempty

-- | Serve static files out of the application root (current directory).
-- If file is found, it is streamed to the client and no further middleware is run. Allows a 'CachingStrategy'.
--
-- Note: for security reasons, this uses the 'noDots' and 'isNotAbsolute' policy by default.
{-# DEPRECATED static'
    [ "Use 'staticWithOptions' instead. "
    , "This function will be removed in the next major release."
    ] #-}
static' :: CacheContainer -> Middleware
static' :: CacheContainer -> Middleware
static' CacheContainer
cc = CacheContainer -> Policy -> Middleware
staticPolicy' CacheContainer
cc Policy
forall a. Monoid a => a
mempty

-- | Serve static files out of the application root (current directory).
-- If file is found, it is streamed to the client and no further middleware is run. Takes 'Options'.
--
-- Note: for security reasons, this uses the 'noDots' and 'isNotAbsolute' policy by default.
staticWithOptions :: Options -> Middleware
staticWithOptions :: Options -> Middleware
staticWithOptions Options
options = Options -> Policy -> Middleware
staticPolicyWithOptions Options
options Policy
forall a. Monoid a => a
mempty

-- | Serve static files subject to a 'Policy'. Disables caching.
--
-- Note: for security reasons, this uses the 'noDots' and 'isNotAbsolute' policy by default.
staticPolicy :: Policy -> Middleware
staticPolicy :: Policy -> Middleware
staticPolicy = CacheContainer -> Policy -> Middleware
staticPolicy' (Options -> CacheContainer
cacheContainer Options
defaultOptions)

-- | Serve static files subject to a 'Policy' using a specified 'CachingStrategy'
--
-- Note: for security reasons, this uses the 'noDots' and 'isNotAbsolute' policy by default.
{-# DEPRECATED staticPolicy'
    [ "Use 'staticPolicyWithOptions' instead. "
    , "This function will be removed in the next major release."
    ] #-}
staticPolicy' :: CacheContainer -> Policy -> Middleware
staticPolicy' :: CacheContainer -> Policy -> Middleware
staticPolicy' CacheContainer
cc 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

-- | Serve static files subject to a 'Policy' using specified 'Options'
--
-- Note: for security reasons, this uses the 'noDots' and 'isNotAbsolute' policy by default.
staticPolicyWithOptions :: Options -> Policy -> Middleware
staticPolicyWithOptions :: Options -> Policy -> Middleware
staticPolicyWithOptions Options
options 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

-- | Serve static files subject to a 'Policy'. Unlike 'static' and 'staticPolicy', this
-- has no policies enabled by default and is hence insecure. Disables caching.
unsafeStaticPolicy :: Policy -> Middleware
unsafeStaticPolicy :: Policy -> Middleware
unsafeStaticPolicy = CacheContainer -> Policy -> Middleware
unsafeStaticPolicy' (Options -> CacheContainer
cacheContainer Options
defaultOptions)

-- | Serve static files subject to a 'Policy'. Unlike 'static' and 'staticPolicy', this
-- has no policies enabled by default, and is hence insecure. Also allows to set a 'CachingStrategy'.
{-# DEPRECATED unsafeStaticPolicy'
    [ "Use 'unsafeStaticPolicyWithOptions' instead. "
    , "This function will be removed in the next major release."
    ] #-}
unsafeStaticPolicy' :: CacheContainer -> Policy -> Middleware
unsafeStaticPolicy' :: CacheContainer -> Policy -> Middleware
unsafeStaticPolicy' CacheContainer
cc = Options -> Policy -> Middleware
unsafeStaticPolicyWithOptions (Options
defaultOptions { cacheContainer = cc })

-- | Serve static files subject to a 'Policy'. Unlike 'staticWithOptions' and 'staticPolicyWithOptions',
-- this has no policies enabled by default and is hence insecure. Takes 'Options'.
unsafeStaticPolicyWithOptions :: Options -> Policy -> Middleware
unsafeStaticPolicyWithOptions :: Options -> Policy -> Middleware
unsafeStaticPolicyWithOptions Options
options Policy
p Application
app Request
req Response -> IO ResponseReceived
callback =
    IO ResponseReceived
-> (FilePath -> IO ResponseReceived)
-> Maybe FilePath
-> IO ResponseReceived
forall b a. b -> (a -> b) -> Maybe a -> b
maybe IO ResponseReceived
serveUpstream FilePath -> IO ResponseReceived
tryStaticFile Maybe FilePath
mCandidateFile
    where
      serveUpstream :: IO ResponseReceived
      serveUpstream :: IO ResponseReceived
serveUpstream = Application
app Request
req Response -> IO ResponseReceived
callback

      tryStaticFile :: FilePath -> IO ResponseReceived
      tryStaticFile :: FilePath -> IO ResponseReceived
tryStaticFile FilePath
fp = do
          Bool
exists <- FilePath -> IO Bool
doesFileExist FilePath
fp
          if Bool
exists
                  then case Options -> CacheContainer
cacheContainer Options
options of
                         CacheContainer
CacheContainerEmpty ->
                             FilePath -> [(HeaderName, Method)] -> IO ResponseReceived
sendFile FilePath
fp []
                         CacheContainer FilePath -> IO FileMeta
_ CachingStrategy
NoCaching ->
                             FilePath -> [(HeaderName, Method)] -> IO ResponseReceived
sendFile FilePath
fp []
                         CacheContainer FilePath -> IO FileMeta
getFileMeta CachingStrategy
strategy ->
                             do FileMeta
fileMeta <- FilePath -> IO FileMeta
getFileMeta FilePath
fp
                                if FileMeta -> Maybe Method -> Maybe Method -> Bool
checkNotModified FileMeta
fileMeta (HeaderName -> Maybe Method
readHeader HeaderName
"If-Modified-Since") (HeaderName -> Maybe Method
readHeader HeaderName
"If-None-Match")
                                then FileMeta -> CachingStrategy -> IO ResponseReceived
sendNotModified FileMeta
fileMeta CachingStrategy
strategy
                                else FilePath -> [(HeaderName, Method)] -> IO ResponseReceived
sendFile FilePath
fp (FileMeta -> CachingStrategy -> [(HeaderName, Method)]
computeHeaders FileMeta
fileMeta CachingStrategy
strategy)
                  else IO ResponseReceived
serveUpstream

      mCandidateFile :: Maybe FilePath
      mCandidateFile :: Maybe FilePath
mCandidateFile =
          Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard Bool
isHeadOrGet Maybe () -> Maybe FilePath -> Maybe FilePath
forall a b. Maybe a -> Maybe b -> Maybe b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>>
          (Policy -> FilePath -> Maybe FilePath
tryPolicy Policy
p (FilePath -> Maybe FilePath) -> FilePath -> Maybe FilePath
forall a b. (a -> b) -> a -> b
$ Text -> FilePath
T.unpack (Text -> FilePath) -> Text -> FilePath
forall a b. (a -> b) -> a -> b
$ Text -> [Text] -> Text
T.intercalate Text
"/" ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$ Request -> [Text]
pathInfo Request
req)
          where
            method :: Method
            method :: Method
method = Request -> Method
requestMethod Request
req

            isHeadOrGet :: Bool
            isHeadOrGet :: Bool
isHeadOrGet = Method
method Method -> Method -> Bool
forall a. Eq a => a -> a -> Bool
== Method
methodHead Bool -> Bool -> Bool
|| Method
method Method -> Method -> Bool
forall a. Eq a => a -> a -> Bool
== Method
methodGet

      readHeader :: HeaderName -> Maybe Method
readHeader HeaderName
header =
          HeaderName -> [(HeaderName, Method)] -> Maybe Method
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup HeaderName
header ([(HeaderName, Method)] -> Maybe Method)
-> [(HeaderName, Method)] -> Maybe Method
forall a b. (a -> b) -> a -> b
$ Request -> [(HeaderName, Method)]
requestHeaders Request
req
      checkNotModified :: FileMeta -> Maybe Method -> Maybe Method -> Bool
checkNotModified FileMeta
fm Maybe Method
modSince Maybe Method
etag =
          [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
or [ Method -> Maybe Method
forall a. a -> Maybe a
Just (FileMeta -> Method
fm_lastModified FileMeta
fm) Maybe Method -> Maybe Method -> Bool
forall a. Eq a => a -> a -> Bool
== Maybe Method
modSince
             , Method -> Maybe Method
forall a. a -> Maybe a
Just (FileMeta -> Method
fm_etag FileMeta
fm) Maybe Method -> Maybe Method -> Bool
forall a. Eq a => a -> a -> Bool
== Maybe Method
etag
             ]
      computeHeaders :: FileMeta -> CachingStrategy -> [(HeaderName, Method)]
computeHeaders FileMeta
fm CachingStrategy
cs =
          case CachingStrategy
cs of
            CachingStrategy
NoCaching -> []
            CachingStrategy
PublicStaticCaching ->
                [ (HeaderName
"Cache-Control", Method
"no-transform,public,max-age=300,s-maxage=900")
                , (HeaderName
"Last-Modified", FileMeta -> Method
fm_lastModified FileMeta
fm)
                , (HeaderName
"ETag", FileMeta -> Method
fm_etag FileMeta
fm)
                , (HeaderName
"Vary", Method
"Accept-Encoding")
                ]
            CustomCaching FileMeta -> [(HeaderName, Method)]
f -> FileMeta -> [(HeaderName, Method)]
f FileMeta
fm
      sendNotModified :: FileMeta -> CachingStrategy -> IO ResponseReceived
sendNotModified FileMeta
fm CachingStrategy
cs =
          do let cacheHeaders :: [(HeaderName, Method)]
cacheHeaders = FileMeta -> CachingStrategy -> [(HeaderName, Method)]
computeHeaders FileMeta
fm CachingStrategy
cs
             Response -> IO ResponseReceived
callback (Response -> IO ResponseReceived)
-> Response -> IO ResponseReceived
forall a b. (a -> b) -> a -> b
$ Status -> [(HeaderName, Method)] -> ByteString -> Response
responseLBS Status
status304 [(HeaderName, Method)]
cacheHeaders ByteString
BSL.empty
      sendFile :: FilePath -> [(HeaderName, Method)] -> IO ResponseReceived
sendFile FilePath
fp [(HeaderName, Method)]
extraHeaders =
          do let basicHeaders :: [(HeaderName, Method)]
basicHeaders =
                     [ (HeaderName
"Content-Type", Options -> FilePath -> Method
mimeTypes Options
options FilePath
fp)
                     ]
                 headers :: [(HeaderName, Method)]
headers =
                     [(HeaderName, Method)]
basicHeaders [(HeaderName, Method)]
-> [(HeaderName, Method)] -> [(HeaderName, Method)]
forall a. [a] -> [a] -> [a]
++ [(HeaderName, Method)]
extraHeaders
             Response -> IO ResponseReceived
callback (Response -> IO ResponseReceived)
-> Response -> IO ResponseReceived
forall a b. (a -> b) -> a -> b
$ Status
-> [(HeaderName, Method)] -> FilePath -> Maybe FilePart -> Response
responseFile Status
status200 [(HeaderName, Method)]
headers FilePath
fp Maybe FilePart
forall a. Maybe a
Nothing

-- | Container caching file meta information. Create using 'initCaching'
data CacheContainer
    = CacheContainerEmpty
    | CacheContainer (FilePath -> IO FileMeta) CachingStrategy

-- | Meta information about a file to calculate cache headers
data FileMeta
   = FileMeta
   { FileMeta -> Method
fm_lastModified :: !BS.ByteString
   , FileMeta -> Method
fm_etag :: !BS.ByteString
   , FileMeta -> FilePath
fm_fileName :: FilePath
   } deriving (Int -> FileMeta -> FilePath -> FilePath
[FileMeta] -> FilePath -> FilePath
FileMeta -> FilePath
(Int -> FileMeta -> FilePath -> FilePath)
-> (FileMeta -> FilePath)
-> ([FileMeta] -> FilePath -> FilePath)
-> Show FileMeta
forall a.
(Int -> a -> FilePath -> FilePath)
-> (a -> FilePath) -> ([a] -> FilePath -> FilePath) -> Show a
$cshowsPrec :: Int -> FileMeta -> FilePath -> FilePath
showsPrec :: Int -> FileMeta -> FilePath -> FilePath
$cshow :: FileMeta -> FilePath
show :: FileMeta -> FilePath
$cshowList :: [FileMeta] -> FilePath -> FilePath
showList :: [FileMeta] -> FilePath -> FilePath
Show, FileMeta -> FileMeta -> Bool
(FileMeta -> FileMeta -> Bool)
-> (FileMeta -> FileMeta -> Bool) -> Eq FileMeta
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: FileMeta -> FileMeta -> Bool
== :: FileMeta -> FileMeta -> Bool
$c/= :: FileMeta -> FileMeta -> Bool
/= :: FileMeta -> FileMeta -> Bool
Eq)

-- | Initialize caching. This should only be done once per application launch.
initCaching :: CachingStrategy -> IO CacheContainer
initCaching :: CachingStrategy -> IO CacheContainer
initCaching CachingStrategy
cs =
    do let cacheAccess :: Maybe s -> FilePath -> IO (Int, (Maybe s, FileMeta))
cacheAccess =
               Int
-> (Maybe s -> FilePath -> IO (Maybe s, FileMeta))
-> Maybe s
-> FilePath
-> 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 Int
100 ((Maybe s -> FilePath -> IO (Maybe s, FileMeta))
 -> Maybe s -> FilePath -> IO (Int, (Maybe s, FileMeta)))
-> (Maybe s -> FilePath -> IO (Maybe s, FileMeta))
-> Maybe s
-> FilePath
-> IO (Int, (Maybe s, FileMeta))
forall a b. (a -> b) -> a -> b
$ \Maybe s
state FilePath
fp ->
                   do FileMeta
fileMeta <- FilePath -> IO FileMeta
computeFileMeta FilePath
fp
                      (Maybe s, FileMeta) -> IO (Maybe s, FileMeta)
forall a. a -> IO a
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 a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (POSIXTime -> Int
forall b. Integral b => POSIXTime -> b
forall a b. (RealFrac a, Integral b) => a -> b
round (POSIXTime
time POSIXTime -> POSIXTime -> POSIXTime
forall a. Num a => a -> a -> a
* POSIXTime
100))
           cacheFreq :: ECMIncr
cacheFreq = ECMIncr
1
           cacheLRU :: CacheSettings
cacheLRU =
               Int -> Int -> Int -> CacheSettings
CacheWithLRUList Int
100 Int
100 Int
200
       ECM IO MVar Any HashMap FilePath FileMeta
filecache <- (Maybe Any -> FilePath -> IO (Int, (Maybe Any, FileMeta)))
-> IO Int
-> ECMIncr
-> CacheSettings
-> IO (ECM IO MVar Any HashMap FilePath 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 -> FilePath -> IO (Int, (Maybe Any, FileMeta))
forall {s}. Maybe s -> FilePath -> IO (Int, (Maybe s, FileMeta))
cacheAccess IO Int
cacheTick ECMIncr
cacheFreq CacheSettings
cacheLRU
       CacheContainer -> IO CacheContainer
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ((FilePath -> IO FileMeta) -> CachingStrategy -> CacheContainer
CacheContainer (ECM IO MVar Any HashMap FilePath FileMeta
-> FilePath -> 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 FilePath FileMeta
filecache) CachingStrategy
cs)

computeFileMeta :: FilePath -> IO FileMeta
computeFileMeta :: FilePath -> IO FileMeta
computeFileMeta FilePath
fp =
    do UTCTime
mtime <- FilePath -> IO UTCTime
getModificationTime FilePath
fp
       ByteString
ct <- FilePath -> IO ByteString
BSL.readFile FilePath
fp
       FileMeta -> IO FileMeta
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (FileMeta -> IO FileMeta) -> FileMeta -> IO FileMeta
forall a b. (a -> b) -> a -> b
$ FileMeta
                { fm_lastModified :: Method
fm_lastModified =
                      FilePath -> Method
BSC.pack (FilePath -> Method) -> FilePath -> Method
forall a b. (a -> b) -> a -> b
$ TimeLocale -> FilePath -> UTCTime -> FilePath
forall t. FormatTime t => TimeLocale -> FilePath -> t -> FilePath
formatTime TimeLocale
defaultTimeLocale FilePath
"%a, %d-%b-%Y %X %Z" UTCTime
mtime
                , fm_etag :: Method
fm_etag = Method -> Method
Base16.encode (ByteString -> Method
SHA1.hashlazy ByteString
ct)
                , fm_fileName :: FilePath
fm_fileName = FilePath
fp
                }

-- | Guess MIME type from file extension
getMimeType :: FilePath -> MimeType
getMimeType :: FilePath -> Method
getMimeType = Text -> Method
defaultMimeLookup (Text -> Method) -> (FilePath -> Text) -> FilePath -> Method
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> Text
T.pack