Memcached integration for widgets

config/settings.yml

@@ -34,7 +34,6 @@ log-settings:
   minimum-level: "_env:LOGLEVEL:warn"
   destination:   "_env:LOGDEST:stderr"
 
-
 # Debugging
 auth-dummy-login:  "_env:DUMMY_LOGIN:false"
 allow-deprecated:  "_env:ALLOW_DEPRECATED:false"
@@ -80,7 +79,16 @@ smtp:
   pool:
     stripes: "_env:SMTPSTRIPES:1"
     timeout: "_env:SMTPTIMEOUT:20"
-    limit: "_env:SMTPLIMIT:10"
+    limit:   "_env:SMTPLIMIT:10"
+
+widget-memcached:
+  host:       "_env:MEMCACHEDHOST:"
+  port:       "_env:MEMCACHEDPORT:11211"
+  auth:       []
+  limit:      "_env:MEMCACHEDLIMIT:10"
+  timeout:    "_env:MEMCACHEDTIMEOUT:20"
+  base-url:   "_env:MEMCACHEDROOT:"
+  expiration: "_env:MEMCACHEDEXPIRATION:3600"
 
 user-defaults:
   max-favourites:   12

package.yaml

@@ -111,6 +111,7 @@ dependencies:
   - xss-sanitize
   - text-metrics
   - pkcs7
+  - memcached-binary
 
 other-extensions:
   - GeneralizedNewtypeDeriving

routes

@@ -26,7 +26,7 @@
 --    !deprecated  -- like free, but logs and gives a warning; entirely disabled in production
 --    !development -- like free, but only for development builds
 
-/static StaticR Static appStatic                              !free
+/static StaticR EmbeddedStatic appStatic                      !free
 /auth   AuthR   Auth   getAuth                                !free
 
 /favicon.ico FaviconR GET                                     !free

src/Application.hs

@@ -69,6 +69,8 @@ import Data.Proxy
 import qualified Data.Aeson as Aeson
 
 import System.Exit (exitFailure)
+
+import qualified Database.Memcached.Binary.IO as Memcached
   
 -- Import all relevant handler modules here.
 -- (HPack takes care to add new modules to our cabal file nowadays.)
@@ -125,7 +127,7 @@ makeFoundation appSettings@AppSettings{..} = do
         (tVar, ) <$> fork (updateLogger initialSettings)
     appLogger <- over _2 fst <$> allocate mkLogger' (\(tVar, tId) -> killThread tId >> (readTVarIO tVar >>= rmLoggerSet . loggerSet))
 
-    appStatic <- liftIO $ bool static staticDevel appMutableStatic appStaticDir
+    let appStatic = embeddedStatic
 
     appInstanceID <- liftIO $ maybe UUID.nextRandom (either readInstanceIDFile return) appInitialInstanceID
 
@@ -137,7 +139,7 @@ makeFoundation appSettings@AppSettings{..} = do
     -- logging function. To get out of this loop, we initially create a
     -- temporary foundation without a real connection pool, get a log function
     -- from there, and then create the real foundation.
-    let mkFoundation appConnPool appSmtpPool appCryptoIDKey appSessionKey appSecretBoxKey = UniWorX {..}
+    let mkFoundation appConnPool appSmtpPool appCryptoIDKey appSessionKey appSecretBoxKey appWidgetMemcached = UniWorX {..}
         -- The UniWorX {..} syntax is an example of record wild cards. For more
         -- information, see:
         -- https://ocharles.org.uk/blog/posts/2014-12-04-record-wildcards.html
@@ -147,6 +149,7 @@ makeFoundation appSettings@AppSettings{..} = do
           (error "cryptoIDKey forced in tempFoundation")
           (error "sessionKey forced in tempFoundation")
           (error "secretBoxKey forced in tempFoundation")
+          (error "widgetMemcached forced in tempFoundation")
         logFunc loc src lvl str = do
           f <- messageLoggerSource tempFoundation <$> readTVarIO (snd appLogger)
           f loc src lvl str
@@ -157,6 +160,8 @@ makeFoundation appSettings@AppSettings{..} = do
 
       smtpPool <- traverse createSmtpPool appSmtpConf
 
+      appWidgetMemcached <- traverse createWidgetMemcached appWidgetMemcachedConf
+
       -- Create the database connection pool
       sqlPool <- createPostgresqlPool
         (pgConnStr  appDatabaseConf)
@@ -168,7 +173,7 @@ makeFoundation appSettings@AppSettings{..} = do
       appSessionKey <- clusterSetting (Proxy :: Proxy 'ClusterClientSessionKey) `runSqlPool` sqlPool
       appSecretBoxKey <- clusterSetting (Proxy :: Proxy 'ClusterSecretBoxKey) `runSqlPool` sqlPool
 
-      let foundation = mkFoundation sqlPool smtpPool appCryptoIDKey appSessionKey appSecretBoxKey
+      let foundation = mkFoundation sqlPool smtpPool appCryptoIDKey appSessionKey appSecretBoxKey appWidgetMemcached
 
       handleJobs foundation
 
@@ -234,6 +239,9 @@ createSmtpPool SmtpConf{ smtpPool = ResourcePoolConf{..}, .. } = do
       return conn
   liftIO $ createPool (mkConnection >>= maybe return applyAuth smtpAuth) reapConnection poolStripes poolTimeout poolLimit
 
+createWidgetMemcached :: (MonadLogger m, MonadResource m) => WidgetMemcachedConf -> m Memcached.Connection
+createWidgetMemcached WidgetMemcachedConf{widgetMemcachedConnectInfo} = snd <$> allocate (Memcached.connect widgetMemcachedConnectInfo) Memcached.close
+
 -- | Convert our foundation to a WAI Application by calling @toWaiAppPlain@ and
 -- applying some additional middlewares.
 makeApplication :: MonadIO m => UniWorX -> m Application
@@ -348,6 +356,10 @@ getApplicationRepl = do
 shutdownApp :: MonadIO m => UniWorX -> m ()
 shutdownApp app = do
   stopJobCtl app
+  liftIO $ do
+    for_ (appWidgetMemcached app) Memcached.close
+    for_ (appSmtpPool app) destroyAllResources
+    destroyAllResources $ appConnPool app
   release . fst $ appLogger app
 
 

src/Foundation.hs

@@ -6,7 +6,6 @@ module Foundation where
 import Import.NoFoundation
 import Database.Persist.Sql (ConnectionPool, runSqlPool)
 import Text.Hamlet          (hamletFile)
-import Text.Jasmine         (minifym)
 
 import qualified Web.ClientSession as ClientSession
 
@@ -18,7 +17,6 @@ import Jobs.Types
 
 import qualified Network.Wai as W (pathInfo)
 
-import Yesod.Default.Util   (addStaticContentExternal)
 import Yesod.Core.Types     (Logger)
 import qualified Yesod.Core.Unsafe as Unsafe
 import Data.CaseInsensitive (CI)
@@ -75,6 +73,9 @@ import qualified Data.Conduit.List as C
 
 import qualified Crypto.Saltine.Core.SecretBox as SecretBox
 
+import qualified Database.Memcached.Binary.IO as Memcached
+import Data.Bits (Bits(zeroBits))
+
 
 instance DisplayAble b => DisplayAble (E.CryptoID a b) where
   display = display . ciphertext
@@ -96,19 +97,20 @@ instance DisplayAble SchoolId where
 -- starts running, such as database connections. Every handler will have
 -- access to the data present here.
 data UniWorX = UniWorX
-    { appSettings     :: AppSettings
-    , appStatic       :: Static -- ^ Settings for static file serving.
-    , appConnPool     :: ConnectionPool -- ^ Database connection pool.
-    , appSmtpPool     :: Maybe SMTPPool
-    , appHttpManager  :: Manager
-    , appLogger       :: (ReleaseKey, TVar Logger)
-    , appLogSettings  :: TVar LogSettings
-    , appCryptoIDKey  :: CryptoIDKey
-    , appInstanceID   :: InstanceId
-    , appJobCtl       :: TVar (Map ThreadId (TMChan JobCtl))
-    , appCronThread   :: TMVar (ReleaseKey, ThreadId)
-    , appSessionKey   :: ClientSession.Key
-    , appSecretBoxKey :: SecretBox.Key
+    { appSettings        :: AppSettings
+    , appStatic          :: EmbeddedStatic -- ^ Settings for static file serving.
+    , appConnPool        :: ConnectionPool -- ^ Database connection pool.
+    , appSmtpPool        :: Maybe SMTPPool
+    , appWidgetMemcached :: Maybe Memcached.Connection
+    , appHttpManager     :: Manager
+    , appLogger          :: (ReleaseKey, TVar Logger)
+    , appLogSettings     :: TVar LogSettings
+    , appCryptoIDKey     :: CryptoIDKey
+    , appInstanceID      :: InstanceId
+    , appJobCtl          :: TVar (Map ThreadId (TMChan JobCtl))
+    , appCronThread      :: TMVar (ReleaseKey, ThreadId)
+    , appSessionKey      :: ClientSession.Key
+    , appSecretBoxKey    :: SecretBox.Key
     }
 
 type SMTPPool = Pool SMTPConnection
@@ -704,21 +706,15 @@ instance Yesod UniWorX where
 
     isAuthorized = evalAccess
 
-    -- This function creates static content files in the static folder
-    -- and names them based on a hash of their content. This allows
-    -- expiration dates to be set far in the future without worry of
-    -- users receiving stale content.
-    addStaticContent ext mime content = do
-        master <- getYesod
-        let staticDir = appStaticDir $ appSettings master
-        addStaticContentExternal
-            minifym
-            genFileName
-            staticDir
-            (StaticR . flip StaticRoute [])
-            ext
-            mime
-            content
+    addStaticContent ext _mime content = do
+      UniWorX{appWidgetMemcached, appSettings} <- getYesod
+      for ((,) <$> appWidgetMemcached <*> appWidgetMemcachedConf appSettings) $ \(mConn, WidgetMemcachedConf{ widgetMemcachedConnectInfo = _, .. }) -> do
+        let expiry = (maybe 0 ceiling widgetMemcachedExpiry)
+            touch = liftIO $ Memcached.touch expiry fileName mConn
+            add = liftIO $ Memcached.add zeroBits expiry fileName content mConn
+        C.catchIf Memcached.isKeyNotFound touch $ \_ ->
+          C.handleIf Memcached.isKeyExists (\_ -> return ()) add
+        return . Left $ widgetMemcachedBaseUrl <> "/" <> decodeUtf8 fileName
       where
         -- Generate a unique filename based on the content itself, this is used
         -- for deduplication so a collision resistant hash function is required
@@ -727,12 +723,11 @@ instance Yesod UniWorX where
         --
         -- Length of hash is 144 bits instead of MD5's 128, so as to avoid
         -- padding after base64-conversion
-        genFileName lbs = Text.unpack
-                        . Text.decodeUtf8
-                        . Base64.encode
-                        . (convert :: Digest (SHAKE256 144) -> ByteString)
-                        . runIdentity
-                        $ sourceList (Lazy.ByteString.toChunks lbs) $$ sinkHash
+        fileName = (<> ("." <> encodeUtf8 ext))
+                 . Base64.encode
+                 . (convert :: Digest (SHAKE256 144) -> ByteString)
+                 . runIdentity
+                 $ sourceList (Lazy.ByteString.toChunks content) $$ sinkHash
 
     -- What messages should be logged. The following includes all messages when
     -- in development, and warnings and errors in production.

src/Handler/Common.hs

@@ -2,7 +2,7 @@
 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
 -- runtime dependency, and for efficiency.
@@ -10,8 +10,8 @@ import Import
 getFaviconR :: Handler TypedContent
 getFaviconR = do cacheSeconds $ 60 * 60 * 24 * 30 -- cache for a month
                  return $ TypedContent "image/x-icon"
-                        $ toContent $(embedFile "embedded/favicon.ico")
+                        $ toContent $(embedFile "static/favicon.ico")
 
 getRobotsR :: Handler TypedContent
 getRobotsR = return $ TypedContent typePlain
-                    $ toContent $(embedFile "embedded/robots.txt")
+                    $ toContent $(embedFile "static/robots.txt")

src/Import/NoFoundation.hs

@@ -3,7 +3,7 @@ module Import.NoFoundation
     , MForm
     ) where
 
-import ClassyPrelude.Yesod    as Import hiding (formatTime, derivePersistFieldJSON, addMessage, addMessageI, (.=), MForm, Proxy, foldlM)
+import ClassyPrelude.Yesod    as Import hiding (formatTime, derivePersistFieldJSON, addMessage, addMessageI, (.=), MForm, Proxy, foldlM, static)
 import Model                  as Import
 import Model.Types.JSON       as Import
 import Model.Migration        as Import

src/Settings.hs

@@ -29,7 +29,7 @@ import           Yesod.Default.Util          (WidgetFileSettings,
                                               widgetFileReload)
 import qualified Yesod.Auth.Util.PasswordStore as PWStore
 
-import Data.Time (NominalDiffTime)
+import Data.Time (NominalDiffTime, nominalDay)
 
 import Data.Scientific (toBoundedInteger)
 import Data.Word (Word16)
@@ -47,12 +47,15 @@ import qualified Data.Char as Char
 
 import qualified Network.HaskellNet.Auth as HaskellNet (UserName, Password, AuthType(..))
 import qualified Network.Socket as HaskellNet (PortNumber(..), HostName)
+import qualified Network as Network
 
 import Network.Mail.Mime (Address)
 import Network.Mail.Mime.Instances ()
 
 import Mail (VerpMode)
 
+import qualified Database.Memcached.Binary.Types as Memcached
+
 import Model
 import Settings.Cluster
 
@@ -68,6 +71,8 @@ data AppSettings = AppSettings
     -- ^ Configuration settings for accessing the LDAP-directory
     , appSmtpConf               :: Maybe SmtpConf
     -- ^ Configuration settings for accessing a SMTP Mailserver
+    , appWidgetMemcachedConf    :: Maybe WidgetMemcachedConf
+    -- ^ Configuration settings for accessing a Memcached instance for use with `addStaticContent`
     , appRoot                   :: Maybe Text
     -- ^ Base for all generated URLs. If @Nothing@, determined
     -- from the request headers.
@@ -167,6 +172,34 @@ data SmtpConf = SmtpConf
   , smtpPool :: ResourcePoolConf
   } deriving (Show)
 
+data WidgetMemcachedConf = WidgetMemcachedConf
+  { widgetMemcachedConnectInfo :: Memcached.ConnectInfo
+  , widgetMemcachedBaseUrl     :: Text
+  , widgetMemcachedExpiry      :: Maybe NominalDiffTime
+  } deriving (Show)
+
+instance FromJSON Memcached.Auth where
+  parseJSON = Aeson.withText "Auth" $ \(Text.breakOn "@" -> (encodeUtf8 -> user, encodeUtf8 -> pw)) -> return $ Memcached.Plain user pw
+
+instance FromJSON Network.PortID where
+  parseJSON v = Network.UnixSocket <$> pSocket v <|> Network.PortNumber <$> pNumber v <|> Network.Service <$> pService v
+    where
+      pSocket = Aeson.withText "UnixSocket" $ fmap unpack . assertM' ("/" `Text.isPrefixOf`)
+      pNumber = Aeson.withScientific "PortNumber" $ maybe (fail "PortNumber ") (return . (fromIntegral :: Word16 -> Network.PortNumber)) . toBoundedInteger
+      pService = Aeson.withText "Service" $ return . unpack
+
+instance FromJSON WidgetMemcachedConf where
+  parseJSON = withObject "WidgetMemcachedConf" $ \o -> do
+    connectHost <- o .: "host"
+    connectPort <- o .: "port"
+    connectAuth <- o .: "auth"
+    numConnection <- o .: "limit"
+    connectionIdleTime <- o .: "timeout"
+    widgetMemcachedBaseUrl <- o .: "base-url"
+    widgetMemcachedExpiry <- assertM (maybe True $ \t -> 0 < t && t <= 30 * nominalDay) $ o .:? "expiration"
+    
+    return WidgetMemcachedConf{ widgetMemcachedConnectInfo = Memcached.ConnectInfo{..}, .. }
+
 data ResourcePoolConf = ResourcePoolConf
   { poolStripes :: Int
   , poolTimeout :: NominalDiffTime
@@ -284,6 +317,15 @@ instance FromJSON AppSettings where
               Ldap.Plain host -> not $ null host
         appLdapConf               <- assertM nonEmptyHost <$> o .:? "ldap"
         appSmtpConf               <- assertM (not . null . smtpHost) <$> o .:? "smtp"
+        let validWidgetMemcachedConf WidgetMemcachedConf{ widgetMemcachedConnectInfo = Memcached.ConnectInfo{..}, ..} = and
+              [ not (null connectHost) || isUnixSocket connectPort
+              , not $ null widgetMemcachedBaseUrl
+              , numConnection > 0
+              , connectionIdleTime >= 0
+              ]
+            isUnixSocket (Network.UnixSocket _) = True
+            isUnixSocket _ = False
+        appWidgetMemcachedConf    <- assertM validWidgetMemcachedConf <$> o .:? "widget-memcached"
         appRoot                   <- o .:? "approot"
         appHost                   <- fromString <$> o .: "host"
         appPort                   <- o .: "port"

src/Settings/StaticFiles.hs

@@ -1,18 +1,26 @@
-module Settings.StaticFiles where
+module Settings.StaticFiles
+  ( module Settings.StaticFiles
+  , module Yesod.EmbeddedStatic
+  ) where
+
+import ClassyPrelude
 
 import Settings     (appStaticDir, compileTimeAppSettings)
-import Yesod.Static (staticFiles)
+import Yesod.EmbeddedStatic
 
 -- This generates easy references to files in the static directory at compile time,
 -- giving you compile-time verification that referenced files exist.
 -- Warning: any files added to your static directory during run-time can't be
--- accessed this way. You'll have to use their FilePath or URL to access them.
+-- accessed this way.
 --
 -- For example, to refer to @static/js/script.js@ via an identifier, you'd use:
 --
 --     js_script_js
---
--- If the identifier is not available, you may use:
---
---     StaticFile ["js", "script.js"] []
-staticFiles (appStaticDir compileTimeAppSettings)
+
+#ifdef DEVELOPMENT
+#define DEV_BOOL True
+#else
+#define DEV_BOOL False
+#endif
+
+mkEmbeddedStatic DEV_BOOL "embeddedStatic" [embedDir $ appStaticDir compileTimeAppSettings]

stack.yaml

@@ -45,4 +45,8 @@ extra-deps:
   - quickcheck-classes-0.4.14
   - semirings-0.2.1.1
 
+  - memcached-binary-0.2.0
+
+allow-newer: true
+
 resolver: lts-10.5