Some Caching & minor

src/Handler/Common.hs

@@ -1,17 +1,10 @@
 -- | Common handler functions.
 module Handler.Common where
 
-import Data.FileEmbed (embedFile)
+import Import
-import Import hiding (embedFile)
 
--- These handlers embed files in the executable at compile time to avoid a
+getFaviconR :: Handler ()
--- runtime dependency, and for efficiency.
+getFaviconR = redirectWith movedPermanently301 $ StaticR favicon_ico
 
-getFaviconR :: Handler TypedContent
+getRobotsR :: Handler ()
-getFaviconR = do cacheSeconds $ 60 * 60 * 24 * 30 -- cache for a month
+getRobotsR = redirectWith movedPermanently301 $ StaticR robots_txt
-                 return $ TypedContent "image/x-icon"
-                        $ toContent $(embedFile "static/favicon.ico")
-
-getRobotsR :: Handler TypedContent
-getRobotsR = return $ TypedContent typePlain
-                    $ toContent $(embedFile "static/robots.txt")

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
+  let
-    Nothing -> do
+    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
+  (lastUpdated, healthReport) <- maybe handleMissing return healthReport'
-      rContent <- selectRep $ do
+  interval <- getsYesod $ view _appHealthCheckInterval
-        provideRep $
+  instanceId <- getsYesod appInstanceID
-          siteLayoutMsg MsgHealthReport $ do
-            setTitleI MsgHealthReport
-            let HealthReport{..} = healthReport
-            [whamlet|
-              $newline never
-              <dl .deflist>
-                <dt .deflist__dt>_{MsgHealthMatchingClusterConfig}
-                <dd .deflist__dd>#{boolSymbol healthMatchingClusterConfig}
-                $maybe httpReachable <- healthHTTPReachable
-                  <dt .deflist__dt>_{MsgHealthHTTPReachable}
-                  <dd .deflist__dd>#{boolSymbol httpReachable}
-                $maybe ldapAdmins <- healthLDAPAdmins
-                  <dt .deflist__dt>_{MsgHealthLDAPAdmins}
-                  <dd .deflist__dd>#{textPercent ldapAdmins}
-                $maybe smtpConnect <- healthSMTPConnect
-                  <dt .deflist__dt>_{MsgHealthSMTPConnect}
-                  <dd .deflist__dd>#{boolSymbol smtpConnect}
-                $maybe widgetMemcached <- healthWidgetMemcached
-                  <dt .deflist__dt>_{MsgHealthWidgetMemcached}
-                  <dd .deflist__dd>#{boolSymbol widgetMemcached}
-            |]
-        provideJson healthReport
-        provideRep . return . Builder.toLazyText $ Aeson.encodePrettyToTextBuilder healthReport
 
-      interval <- getsYesod $ view _appHealthCheckInterval
+  setWeakEtagHashable (instanceId, lastUpdated)
-      expiresAt $ interval `addUTCTime` lastUpdated
+  expiresAt $ interval `addUTCTime` lastUpdated
-      addHeader "Last-Modified" $ formatRFC1123 lastUpdated
+  setLastModified lastUpdated
-      let
+  
-        status 
+  let status 
-          | HealthSuccess <- classifyHealthReport healthReport
+        | HealthSuccess <- classifyHealthReport healthReport
-          = ok200
+        = ok200
-          | otherwise
+        | otherwise
-          = internalServerError500
+        = internalServerError500
-      sendResponseStatus status rContent
+  sendResponseStatus status <=< selectRep $ do
+    provideRep . siteLayoutMsg MsgHealthReport $ do
+      setTitleI MsgHealthReport
+      let HealthReport{..} = healthReport
+      [whamlet|
+        $newline never
+        <dl .deflist>
+          <dt .deflist__dt>_{MsgHealthMatchingClusterConfig}
+          <dd .deflist__dd>#{boolSymbol healthMatchingClusterConfig}
+          $maybe httpReachable <- healthHTTPReachable
+            <dt .deflist__dt>_{MsgHealthHTTPReachable}
+            <dd .deflist__dd>#{boolSymbol httpReachable}
+          $maybe ldapAdmins <- healthLDAPAdmins
+            <dt .deflist__dt>_{MsgHealthLDAPAdmins}
+            <dd .deflist__dd>#{textPercent ldapAdmins}
+          $maybe smtpConnect <- healthSMTPConnect
+            <dt .deflist__dt>_{MsgHealthSMTPConnect}
+            <dd .deflist__dd>#{boolSymbol smtpConnect}
+          $maybe widgetMemcached <- healthWidgetMemcached
+            <dt .deflist__dt>_{MsgHealthWidgetMemcached}
+            <dd .deflist__dd>#{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

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

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 ]