From 32512db3cba291e9c860f85a089490e557572529 Mon Sep 17 00:00:00 2001
From: Gregor Kleen <kleen@cip.ifi.lmu.de>
Date: Tue, 30 Apr 2019 20:34:31 +0200
Subject: [PATCH] healthWidgetMemcached

---
 src/Jobs/HealthReport.hs | 22 +++++++++++++++++++++-
 src/Model/Types.hs       |  3 +++
 2 files changed, 24 insertions(+), 1 deletion(-)

diff --git a/src/Jobs/HealthReport.hs b/src/Jobs/HealthReport.hs
index 1e8cfa4b9..d1edc5faf 100644
--- a/src/Jobs/HealthReport.hs
+++ b/src/Jobs/HealthReport.hs
@@ -15,7 +15,7 @@ import qualified Data.ByteArray as ByteArray
 
 import Utils.Lens
 
-import Network.HTTP.Simple (httpJSON)
+import Network.HTTP.Simple (httpJSON, httpLBS)
 import qualified Network.HTTP.Simple as HTTP
 
 import qualified Database.Esqueleto as E
@@ -35,6 +35,7 @@ generateHealthReport
     <*> Concurrently httpReachable
     <*> Concurrently ldapAdmins
     <*> Concurrently smtpConnect
+    <*> Concurrently widgetMemcached
   
 matchingClusterConfig :: Handler Bool
 -- ^ Can the cluster configuration be read from the database and does it match our configuration?
@@ -117,3 +118,22 @@ smtpConnect = do
       _   -> do 
         $logErrorS "Mail" $ "NOOP failed: " <> tshow response
         return False
+
+
+widgetMemcached :: Handler (Maybe Bool)
+widgetMemcached = do
+  memcachedConn <- getsYesod appWidgetMemcached
+  for memcachedConn $ \_memcachedConn' -> do
+    let ext = "bin"
+        mimeType = "application/octet-stream"
+    content <- pack . take 256 <$> liftIO getRandoms
+    staticLink <- addStaticContent ext mimeType content
+    case staticLink of
+      Just (Left url) -> do
+        baseRequest <- HTTP.parseRequest $ unpack url
+        httpManager <- getsYesod appHttpManager
+        let httpRequest = baseRequest
+              & HTTP.setRequestManager httpManager
+        (== content) . responseBody <$> httpLBS httpRequest
+      _other -> return False
+      
diff --git a/src/Model/Types.hs b/src/Model/Types.hs
index 0e0cb2884..50335333d 100644
--- a/src/Model/Types.hs
+++ b/src/Model/Types.hs
@@ -939,6 +939,8 @@ data HealthReport = HealthReport
     -- Is `Nothing` if LDAP is not configured or no users are school admins
   , healthSMTPConnect :: Maybe Bool
     -- ^ Can we connect to the SMTP server and say @NOOP@?
+  , healthWidgetMemcached :: Maybe Bool
+    -- ^ Can we store values in memcached and retrieve them via HTTP?
   } deriving (Eq, Ord, Read, Show, Generic, Typeable)
 
 deriveJSON defaultOptions
@@ -970,6 +972,7 @@ classifyHealthReport HealthReport{..} = getMin . execWriter $ do -- Construction
   unless (fromMaybe True healthHTTPReachable) . tell $ Min HealthFailure
   unless (maybe True (> 0) healthLDAPAdmins) . tell $ Min HealthFailure
   unless (fromMaybe True healthSMTPConnect) . tell $ Min HealthFailure
+  unless (fromMaybe True healthWidgetMemcached) . tell $ Min HealthFailure
 
 
 -- Type synonyms