From 48080639b110485dd9e4ed41f6e4c25e5e106960 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Wed, 5 Dec 2018 13:50:46 +0100 Subject: [PATCH] Memcached integration for widgets --- config/settings.yml | 12 +++++- package.yaml | 1 + routes | 2 +- src/Application.hs | 18 +++++++-- src/Foundation.hs | 67 ++++++++++++++----------------- src/Handler/Common.hs | 6 +-- src/Import/NoFoundation.hs | 2 +- src/Settings.hs | 44 +++++++++++++++++++- src/Settings/StaticFiles.hs | 24 +++++++---- stack.yaml | 4 ++ {embedded => static}/favicon.ico | Bin {embedded => static}/robots.txt | 0 12 files changed, 125 insertions(+), 55 deletions(-) rename {embedded => static}/favicon.ico (100%) rename {embedded => static}/robots.txt (100%) diff --git a/config/settings.yml b/config/settings.yml index f3243a773..2ff396932 100644 --- a/config/settings.yml +++ b/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 diff --git a/package.yaml b/package.yaml index 0aa2b1269..4bc841965 100644 --- a/package.yaml +++ b/package.yaml @@ -111,6 +111,7 @@ dependencies: - xss-sanitize - text-metrics - pkcs7 + - memcached-binary other-extensions: - GeneralizedNewtypeDeriving diff --git a/routes b/routes index a84d2842e..4508cb781 100644 --- a/routes +++ b/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 diff --git a/src/Application.hs b/src/Application.hs index 90792b4f5..cdf4d9ecc 100644 --- a/src/Application.hs +++ b/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 diff --git a/src/Foundation.hs b/src/Foundation.hs index 8577ae9fd..0dc658312 100644 --- a/src/Foundation.hs +++ b/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. diff --git a/src/Handler/Common.hs b/src/Handler/Common.hs index 390b041e1..54eddd1c3 100644 --- a/src/Handler/Common.hs +++ b/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") diff --git a/src/Import/NoFoundation.hs b/src/Import/NoFoundation.hs index 94c8ffbd2..9b0c591f8 100644 --- a/src/Import/NoFoundation.hs +++ b/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 diff --git a/src/Settings.hs b/src/Settings.hs index 9b4e48541..c042b9e39 100644 --- a/src/Settings.hs +++ b/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" diff --git a/src/Settings/StaticFiles.hs b/src/Settings/StaticFiles.hs index c8021d3a5..c7bd88255 100644 --- a/src/Settings/StaticFiles.hs +++ b/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] diff --git a/stack.yaml b/stack.yaml index bd108cdef..6ae2e45d6 100644 --- a/stack.yaml +++ b/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 diff --git a/embedded/favicon.ico b/static/favicon.ico similarity index 100% rename from embedded/favicon.ico rename to static/favicon.ico diff --git a/embedded/robots.txt b/static/robots.txt similarity index 100% rename from embedded/robots.txt rename to static/robots.txt