diff --git a/src/Handler/Common.hs b/src/Handler/Common.hs index 54eddd1c3..de1e706e0 100644 --- a/src/Handler/Common.hs +++ b/src/Handler/Common.hs @@ -1,17 +1,10 @@ -- | Common handler functions. module Handler.Common where -import Data.FileEmbed (embedFile) -import Import hiding (embedFile) +import Import --- These handlers embed files in the executable at compile time to avoid a --- runtime dependency, and for efficiency. +getFaviconR :: Handler () +getFaviconR = redirectWith movedPermanently301 $ StaticR favicon_ico -getFaviconR :: Handler TypedContent -getFaviconR = do cacheSeconds $ 60 * 60 * 24 * 30 -- cache for a month - return $ TypedContent "image/x-icon" - $ toContent $(embedFile "static/favicon.ico") - -getRobotsR :: Handler TypedContent -getRobotsR = return $ TypedContent typePlain - $ toContent $(embedFile "static/robots.txt") +getRobotsR :: Handler () +getRobotsR = redirectWith movedPermanently301 $ StaticR robots_txt diff --git a/src/Handler/Health.hs b/src/Handler/Health.hs index f3d5b4007..872ab3410 100644 --- a/src/Handler/Health.hs +++ b/src/Handler/Health.hs @@ -13,55 +13,58 @@ import qualified Data.UUID as UUID getHealthR :: Handler TypedContent getHealthR = do healthReport' <- liftIO . readTVarIO =<< getsYesod appHealthReport - case healthReport' of - Nothing -> do + let + handleMissing = do interval <- getsYesod $ round . (* 1e6) . toRational . view _appHealthCheckInterval reportStore <- getsYesod appHealthReport waitResult <- threadDelay interval `race` atomically (readTVar reportStore >>= guard . is _Just) case waitResult of Left () -> fail "System is not generating HealthReports" Right _ -> redirect HealthR - Just (lastUpdated, healthReport) -> do - rContent <- selectRep $ do - provideRep $ - siteLayoutMsg MsgHealthReport $ do - setTitleI MsgHealthReport - let HealthReport{..} = healthReport - [whamlet| - $newline never -
-
_{MsgHealthMatchingClusterConfig} -
#{boolSymbol healthMatchingClusterConfig} - $maybe httpReachable <- healthHTTPReachable -
_{MsgHealthHTTPReachable} -
#{boolSymbol httpReachable} - $maybe ldapAdmins <- healthLDAPAdmins -
_{MsgHealthLDAPAdmins} -
#{textPercent ldapAdmins} - $maybe smtpConnect <- healthSMTPConnect -
_{MsgHealthSMTPConnect} -
#{boolSymbol smtpConnect} - $maybe widgetMemcached <- healthWidgetMemcached -
_{MsgHealthWidgetMemcached} -
#{boolSymbol widgetMemcached} - |] - provideJson healthReport - provideRep . return . Builder.toLazyText $ Aeson.encodePrettyToTextBuilder healthReport + (lastUpdated, healthReport) <- maybe handleMissing return healthReport' + interval <- getsYesod $ view _appHealthCheckInterval + instanceId <- getsYesod appInstanceID - interval <- getsYesod $ view _appHealthCheckInterval - expiresAt $ interval `addUTCTime` lastUpdated - addHeader "Last-Modified" $ formatRFC1123 lastUpdated - let - status - | HealthSuccess <- classifyHealthReport healthReport - = ok200 - | otherwise - = internalServerError500 - sendResponseStatus status rContent + setWeakEtagHashable (instanceId, lastUpdated) + expiresAt $ interval `addUTCTime` lastUpdated + setLastModified lastUpdated + + let status + | HealthSuccess <- classifyHealthReport healthReport + = ok200 + | otherwise + = internalServerError500 + sendResponseStatus status <=< selectRep $ do + provideRep . siteLayoutMsg MsgHealthReport $ do + setTitleI MsgHealthReport + let HealthReport{..} = healthReport + [whamlet| + $newline never +
+
_{MsgHealthMatchingClusterConfig} +
#{boolSymbol healthMatchingClusterConfig} + $maybe httpReachable <- healthHTTPReachable +
_{MsgHealthHTTPReachable} +
#{boolSymbol httpReachable} + $maybe ldapAdmins <- healthLDAPAdmins +
_{MsgHealthLDAPAdmins} +
#{textPercent ldapAdmins} + $maybe smtpConnect <- healthSMTPConnect +
_{MsgHealthSMTPConnect} +
#{boolSymbol smtpConnect} + $maybe widgetMemcached <- healthWidgetMemcached +
_{MsgHealthWidgetMemcached} +
#{boolSymbol widgetMemcached} + |] + provideJson healthReport + provideRep . return . Builder.toLazyText $ Aeson.encodePrettyToTextBuilder healthReport getInstanceR :: Handler TypedContent getInstanceR = do instanceInfo@(clusterId, instanceId) <- getsYesod $ (,) <$> appClusterID <*> appInstanceID + + setWeakEtagHashable (clusterId, instanceId) + selectRep $ do provideRep $ siteLayoutMsg MsgInstanceIdentification $ do diff --git a/src/Ldap/Client/Pool.hs b/src/Ldap/Client/Pool.hs index dbd5189e9..6682d7c98 100644 --- a/src/Ldap/Client/Pool.hs +++ b/src/Ldap/Client/Pool.hs @@ -92,12 +92,10 @@ createLdapPool host port stripes timeoutConn (round . (* 1e6) -> timeoutAct) lim go Nothing ldap withTimeout $ do - $logInfoS "Ldap" "Opening new connection" - setup <- newEmptyTMVarIO void . fork . flip runLoggingT logFunc $ do - $logDebugS "LdapExecutor" "Starting" + $logInfoS "LdapExecutor" "Starting" res <- liftIO . Ldap.with host port $ flip runLoggingT logFunc . go (Just setup) case res of Left exc -> do diff --git a/src/Utils.hs b/src/Utils.hs index 7084ecbcb..bb2efad89 100644 --- a/src/Utils.hs +++ b/src/Utils.hs @@ -17,6 +17,7 @@ import qualified Data.CaseInsensitive as CI import qualified Data.ByteString as BS import qualified Data.ByteString.Lazy as LBS import qualified Data.Text as Text +import qualified Data.Text.Encoding as Text import Utils.DB as Utils import Utils.TH as Utils @@ -72,6 +73,12 @@ import Data.Ratio ((%)) import qualified Data.Binary as Binary +import qualified Data.ByteString.Base64.URL as Base64 (encode) + +import Network.Wai (requestMethod) + +import Data.Time.Clock + {-# ANN choice ("HLint: ignore Use asum" :: String) #-} @@ -657,7 +664,7 @@ instance Finite CustomHeader nullaryPathPiece ''CustomHeader (intercalate "-" . drop 1 . splitCamel) lookupCustomHeader :: (MonadHandler m, PathPiece result) => CustomHeader -> m (Maybe result) -lookupCustomHeader ident = (>>= fromPathPiece . decodeUtf8) <$> lookupHeader (CI.mk . encodeUtf8 $ toPathPiece ident) +lookupCustomHeader ident = (=<<) (fromPathPiece <=< either (const Nothing) Just . Text.decodeUtf8') <$> lookupHeader (CI.mk . encodeUtf8 $ toPathPiece ident) hasCustomHeader :: MonadHandler m => CustomHeader -> m Bool hasCustomHeader ident = isJust <$> lookupHeader (CI.mk . encodeUtf8 $ toPathPiece ident) @@ -756,3 +763,27 @@ cachedHere :: Q Exp cachedHere = do loc <- location [e| cachedBy (toStrict $ Binary.encode loc) |] + +hashToText :: Hashable a => a -> Text +hashToText = decodeUtf8 . Base64.encode . toStrict . Binary.encode . hash + +setEtagHashable, setWeakEtagHashable :: (MonadHandler m, Hashable a) => a -> m () +setEtagHashable = setEtag . hashToText +setWeakEtagHashable = setEtag . hashToText + +setLastModified :: (MonadHandler m, MonadLogger m) => UTCTime -> m () +setLastModified lastModified = do + rMethod <- requestMethod <$> waiRequest + + when (rMethod `elem` safeMethods) $ do + ifModifiedSince <- (=<<) (parseTimeM True defaultTimeLocale "%a, %d %b %Y %X %Z" . unpack <=< either (const Nothing) Just . Text.decodeUtf8') <$> lookupHeader "If-Modified-Since" + $logDebugS "LastModified" $ tshow (lastModified, ifModifiedSince) + when (maybe False ((lastModified <=) . addUTCTime precision) ifModifiedSince) $ + notModified + + addHeader "Last-Modified" $ formatRFC1123 lastModified + where + precision :: NominalDiffTime + precision = 1 + + safeMethods = [ methodGet, methodHead, methodOptions ]