{-# 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,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
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

-- | Take an incoming URI and optionally modify or filter it.
--   The result will be treated as a filepath.
newtype Policy = Policy { Policy -> String -> Maybe String
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 -> String -> MimeType
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 -> (String -> MimeType) -> Options
Options { cacheContainer :: CacheContainer
cacheContainer = CacheContainer
CacheContainerEmpty, mimeTypes :: String -> MimeType
mimeTypes = String -> MimeType
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 = (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)

-- | Note:
--   'mempty' == @policy Just@ (the always accepting policy)
--   'mappend' == @>->@ (policy sequencing)
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
(<>)

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

-- | Lift a predicate into a 'Policy'
predicate :: (String -> Bool) -> Policy
predicate :: (String -> Bool) -> Policy
predicate String -> Bool
p = (String -> Maybe String) -> Policy
policy (\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)

-- | 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 = (String -> Maybe String) -> Policy
policy (\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))

-- | 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 :: String -> Policy
addBase 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.</>))

-- | 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 = (String -> Maybe String) -> Policy
policy String -> Maybe String
slashOpt
    where slashOpt :: String -> Maybe String
slashOpt s :: String
s@(Char
'/':String
_) = String -> Maybe String
forall a. a -> Maybe a
Just String
s
          slashOpt String
s         = String -> Maybe String
forall a. a -> Maybe a
Just (Char
'/'Char -> String -> String
forall a. a -> [a] -> [a]
:String
s)

-- | Accept only URIs with given suffix
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
L.isSuffixOf

-- | Accept only URIs with given prefix
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
L.isPrefixOf

-- | Accept only URIs containing given string
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
L.isInfixOf

-- | Reject URIs containing \"..\"
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
L.isInfixOf String
"..")

-- | Reject URIs that are absolute paths
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

-- | 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 :: [(String, String)] -> Policy
only [(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)

-- | 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 :: CacheContainer
cacheContainer = 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
-> (String -> IO ResponseReceived)
-> Maybe String
-> IO ResponseReceived
forall b a. b -> (a -> b) -> Maybe a -> b
maybe IO ResponseReceived
serveUpstream String -> IO ResponseReceived
tryStaticFile Maybe String
mCandidateFile
    where
      serveUpstream :: IO ResponseReceived
      serveUpstream :: IO ResponseReceived
serveUpstream = Application
app Request
req Response -> IO ResponseReceived
callback

      tryStaticFile :: FilePath -> IO ResponseReceived
      tryStaticFile :: String -> IO ResponseReceived
tryStaticFile String
fp = do
          Bool
exists <- String -> IO Bool
doesFileExist String
fp
          if Bool
exists
                  then case Options -> CacheContainer
cacheContainer Options
options of
                         CacheContainer
CacheContainerEmpty ->
                             String -> [(HeaderName, MimeType)] -> IO ResponseReceived
sendFile String
fp []
                         CacheContainer String -> IO FileMeta
_ CachingStrategy
NoCaching ->
                             String -> [(HeaderName, MimeType)] -> IO ResponseReceived
sendFile String
fp []
                         CacheContainer String -> IO FileMeta
getFileMeta 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 HeaderName
"If-Modified-Since") (HeaderName -> Maybe MimeType
readHeader HeaderName
"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 IO ResponseReceived
serveUpstream

      mCandidateFile :: Maybe FilePath
      mCandidateFile :: Maybe String
mCandidateFile =
          Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard Bool
isHeadOrGet Maybe () -> Maybe String -> Maybe String
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>>
          (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] -> Text
forall a b. (a -> b) -> a -> b
$ Request -> [Text]
pathInfo Request
req)
          where
            method :: Method
            method :: MimeType
method = Request -> MimeType
requestMethod Request
req

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

      readHeader :: HeaderName -> Maybe MimeType
readHeader 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 FileMeta
fm Maybe MimeType
modSince 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 FileMeta
fm CachingStrategy
cs =
          case CachingStrategy
cs of
            CachingStrategy
NoCaching -> []
            CachingStrategy
PublicStaticCaching ->
                [ (HeaderName
"Cache-Control", MimeType
"no-transform,public,max-age=300,s-maxage=900")
                , (HeaderName
"Last-Modified", FileMeta -> MimeType
fm_lastModified FileMeta
fm)
                , (HeaderName
"ETag", FileMeta -> MimeType
fm_etag FileMeta
fm)
                , (HeaderName
"Vary", MimeType
"Accept-Encoding")
                ]
            CustomCaching FileMeta -> [(HeaderName, MimeType)]
f -> FileMeta -> [(HeaderName, MimeType)]
f FileMeta
fm
      sendNotModified :: FileMeta -> CachingStrategy -> IO ResponseReceived
sendNotModified FileMeta
fm 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 String
fp [(HeaderName, MimeType)]
extraHeaders =
          do let basicHeaders :: [(HeaderName, MimeType)]
basicHeaders =
                     [ (HeaderName
"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

-- | 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 -> 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)

-- | 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 -> 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 Int
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
$ \Maybe s
state 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
* 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 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 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
$ FileMeta :: 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 String
"%a, %d-%b-%Y %X %Z" UTCTime
mtime
                , fm_etag :: MimeType
fm_etag = MimeType -> MimeType
Base16.encode (ByteString -> MimeType
SHA1.hashlazy ByteString
ct)
                , fm_fileName :: String
fm_fileName = String
fp
                }

-- | Guess MIME type from file extension
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