diff --git a/src/Network/Wai/Serve/Applications.hs b/src/Network/Wai/Serve/Applications.hs index bc1f46f08b4304a7b7426245969a323092d402c1..31fb9fecc040ca8d863c7f595f9d6cb09241a0c7 100644 --- a/src/Network/Wai/Serve/Applications.hs +++ b/src/Network/Wai/Serve/Applications.hs @@ -26,22 +26,29 @@ import Network.Wai.Application.Static ( defaultWebAppSettings , staticApp ) import Network.Wai.Middleware.Vhost ( redirectTo ) -import WaiAppStatic.Types ( MaxAge(MaxAgeSeconds) +import WaiAppStatic.Types ( MaxAge(..) , toPiece ) +import Network.Wai.Serve.Types ( CacheControlConfig(..) ) + -- | An application for static websites. -- -- It serves files from the provided path. It defaults to `_site` which is the -- default location for Hakyll websites. -staticSite :: Maybe FilePath -> Application -> Application -staticSite path site404handler = staticApp +staticSite + :: Maybe CacheControlConfig -> Maybe FilePath -> Application -> Application +staticSite cacheControl path site404handler = staticApp (defaultWebAppSettings . fromString $ fromMaybe "_site" path) { ssIndices = mapMaybe (toPiece . pack) ["index.html"] , ssRedirectToIndex = False , ssAddTrailingSlash = True , ss404Handler = Just site404handler - , ssMaxAge = MaxAgeSeconds 604801 + --, ssMaxAge = MaxAgeSeconds 604801 + , ssMaxAge = case cacheControl of + Nothing -> NoMaxAge + Just (CacheSeconds x) -> MaxAgeSeconds x + Just CacheForever -> MaxAgeForever } -- | Handler for redirecting requests to the root of the site. diff --git a/src/Network/Wai/Serve/Main.hs b/src/Network/Wai/Serve/Main.hs index 4989a36a4e8bed8399a3eda1896305c051415558..ee0e1184d037bca3af4749976e17e3d821eae9b4 100644 --- a/src/Network/Wai/Serve/Main.hs +++ b/src/Network/Wai/Serve/Main.hs @@ -86,6 +86,7 @@ serve' :: (MonadIO m, MonadBaseControl IO m) => ServeConfiguration -> m () serve' config = runStdoutLoggingT $ do let baseMiddleware = config ^. #middleware let site = staticSite + (config ^. #cacheControl) (config ^. #path) (case config ^. #notFoundHandler of NotFoundIndex -> redirectHome diff --git a/src/Network/Wai/Serve/Types.hs b/src/Network/Wai/Serve/Types.hs index 93f37c7653616819df02c9aed6172fc946d0e676..d255dd1a5142a4ba434c450d871a4efb92f01fab 100644 --- a/src/Network/Wai/Serve/Types.hs +++ b/src/Network/Wai/Serve/Types.hs @@ -19,6 +19,7 @@ module Network.Wai.Serve.Types , MiddlewareConfig(..) , NotFoundHandlerConfig(..) , ServeException(..) + , CacheControlConfig(..) , -- * Miscellaneous types Domain , Stage(..) @@ -63,8 +64,7 @@ instance Semigroup MiddlewareStack where instance Monoid MiddlewareStack where mempty = MiddlewareStack [] -instance FromJSON MiddlewareStack where - parseJSON = genericParseJSON defaultOptions +instance FromJSON MiddlewareStack -- | The development stage an application is executing in. -- @@ -76,8 +76,7 @@ instance FromJSON MiddlewareStack where -- data Stage = Development | Staging | Production deriving (Show, Generic, Read) -instance FromJSON Stage where - parseJSON = genericParseJSON defaultOptions +instance FromJSON Stage -- | The configuration for the server process. -- @@ -98,6 +97,8 @@ data ServeConfiguration = ServeConfiguration , path :: Maybe FilePath -- | Optional 404 handler (Defaults to redirecting to /). , notFoundHandler :: NotFoundHandlerConfig + -- | Defines the behavior of the Cache-Control header + , cacheControl :: Maybe CacheControlConfig } deriving (Generic) instance Default ServeConfiguration where @@ -106,18 +107,24 @@ instance Default ServeConfiguration where , port = 9119 , path = Nothing , notFoundHandler = NotFoundIndex + , cacheControl = Nothing } -instance FromJSON ServeConfiguration where - parseJSON = genericParseJSON defaultOptions +instance FromJSON ServeConfiguration + +data CacheControlConfig + = CacheSeconds Int + | CacheForever + deriving (Generic, Show) + +instance FromJSON CacheControlConfig data NotFoundHandlerConfig = NotFoundIndex | NotFoundPath Text deriving (Generic) -instance FromJSON NotFoundHandlerConfig where - parseJSON = genericParseJSON defaultOptions +instance FromJSON NotFoundHandlerConfig data DynamicStageConfiguration = DynamicStageConfiguration { -- | The current stage. This selects which transformer is used before @@ -153,8 +160,7 @@ data StageConfiguration = StageConfiguration , prod :: ServeConfiguration } deriving (Generic) -instance FromJSON StageConfiguration where - parseJSON = genericParseJSON defaultOptions +instance FromJSON StageConfiguration -- | The configuration for the TLS/HTTPS server. data TLSConfiguration = TLSConfiguration @@ -173,8 +179,7 @@ data TLSConfiguration = TLSConfiguration , port :: Int } deriving (Generic) -instance FromJSON TLSConfiguration where - parseJSON = genericParseJSON defaultOptions +instance FromJSON TLSConfiguration data MiddlewareConfig = LoggerMiddleware @@ -187,5 +192,4 @@ data MiddlewareConfig | DeindexifyMiddleware deriving (Generic) -instance FromJSON MiddlewareConfig where - parseJSON = genericParseJSON defaultOptions +instance FromJSON MiddlewareConfig