refactor: revisit static file embedding
remove memcached-based static caching, serve static files directly from binary embedding, remove frontend bundler entrypoint and widget generation (directly add js/css in siteLayout)
This commit is contained in:
parent
494be2d8dd
commit
d4f264dc18
@ -27,7 +27,6 @@ import Auth.Dummy
|
||||
import qualified Foundation.Yesod.Session as UniWorX
|
||||
import qualified Foundation.Yesod.Middleware as UniWorX
|
||||
import qualified Foundation.Yesod.ErrorHandler as UniWorX
|
||||
import qualified Foundation.Yesod.StaticContent as UniWorX
|
||||
import qualified Foundation.Yesod.Persist as UniWorX
|
||||
import qualified Foundation.Yesod.Auth as UniWorX
|
||||
|
||||
@ -91,9 +90,8 @@ instance Yesod UniWorX where
|
||||
isAuthorized :: HasCallStack => Route UniWorX -> Bool -> HandlerFor UniWorX AuthResult
|
||||
isAuthorized r w = runDBRead $ evalAccess r w
|
||||
|
||||
-- TODO: replace memcached-based static-content caching with basic addStaticContent
|
||||
addStaticContent = UniWorX.addStaticContent
|
||||
-- addStaticContent = embedStaticContent appStatic StaticR Right -- TODO: minify on production builds
|
||||
-- TODO: minify on production builds using ifdef DEVELOP instead of bundler-based minify
|
||||
addStaticContent = embedStaticContent appStatic StaticR Right
|
||||
|
||||
fileUpload _site _length = FileUploadMemory lbsBackEnd
|
||||
|
||||
|
||||
@ -487,9 +487,10 @@ siteLayout' overrideHeading widget = do
|
||||
frontendI18n = toJSON (mr :: FrontendMessage -> Text)
|
||||
frontendDatetimeLocale <- toJSON <$> selectLanguage frontendDatetimeLocales
|
||||
|
||||
pc' <- widgetToPageContent $ do
|
||||
bundlerLinks_main StaticR
|
||||
bundlerLinks_polyfill StaticR
|
||||
pc <- widgetToPageContent $ do
|
||||
addScript $ StaticR main_js
|
||||
addStylesheet $ StaticR main_css
|
||||
addScript $ StaticR polyfill_js
|
||||
toWidget $(juliusFile "templates/i18n.julius")
|
||||
whenIsJust currentApproot' $ \currentApproot ->
|
||||
toWidget $(juliusFile "templates/approot.julius")
|
||||
@ -505,7 +506,6 @@ siteLayout' overrideHeading widget = do
|
||||
| otherwise -> CssBuilder . LTB.fromLazyText $ "[data-uw-field-display=\"" <> fromStrict hpSecret <> "\"]{/*display:none!important*/}"
|
||||
|
||||
$(widgetFile "default-layout")
|
||||
let pc = pc'{ pageHead = pageHead pc' <> [hamlet|<link rel=stylesheet href=foobar>|] } -- TODO replace href
|
||||
withUrlRenderer $(hamletFile "templates/default-layout-wrapper.hamlet")
|
||||
|
||||
|
||||
|
||||
@ -1,53 +0,0 @@
|
||||
-- SPDX-FileCopyrightText: 2022 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Sarah Vaupel <sarah.vaupel@ifi.lmu.de>
|
||||
--
|
||||
-- SPDX-License-Identifier: AGPL-3.0-or-later
|
||||
|
||||
module Foundation.Yesod.StaticContent
|
||||
( addStaticContent
|
||||
) where
|
||||
|
||||
import Import.NoFoundation hiding (addStaticContent)
|
||||
|
||||
import Foundation.Type
|
||||
|
||||
import qualified Database.Memcached.Binary.IO as Memcached
|
||||
|
||||
import qualified Data.ByteString.Lazy as Lazy
|
||||
import qualified Data.ByteString.Base64.URL as Base64 (encodeUnpadded)
|
||||
import Data.ByteArray (convert)
|
||||
import Crypto.Hash (SHAKE256)
|
||||
import Crypto.Hash.Conduit (sinkHash)
|
||||
import Data.Bits (Bits(zeroBits))
|
||||
|
||||
import qualified Data.Conduit.Combinators as C
|
||||
|
||||
|
||||
addStaticContent :: Text
|
||||
-> Text
|
||||
-> Lazy.ByteString
|
||||
-> HandlerFor UniWorX (Maybe (Either Text (Route UniWorX, [(Text, Text)])))
|
||||
addStaticContent ext _mime content = do
|
||||
UniWorX{appWidgetMemcached, appSettings'} <- getYesod
|
||||
for ((,) <$> appWidgetMemcached <*> appWidgetMemcachedConf appSettings') $ \(mConn, WidgetMemcachedConf{ widgetMemcachedConf = MemcachedConf { memcachedExpiry }, widgetMemcachedBaseUrl }) -> do
|
||||
let expiry = maybe 0 ceiling memcachedExpiry
|
||||
touch = liftIO $ Memcached.touch expiry (encodeUtf8 $ pack fileName) mConn
|
||||
addItem = liftIO $ Memcached.add zeroBits expiry (encodeUtf8 $ pack fileName) content mConn
|
||||
absoluteLink = unpack widgetMemcachedBaseUrl </> fileName
|
||||
catchIf Memcached.isKeyNotFound touch . const $
|
||||
handleIf Memcached.isKeyExists (const $ return ()) addItem
|
||||
return . Left $ pack absoluteLink
|
||||
where
|
||||
-- Generate a unique filename based on the content itself, this is used
|
||||
-- for deduplication so a collision resistant hash function is required
|
||||
--
|
||||
-- SHA-3 (SHAKE256) seemed to be a future-proof choice
|
||||
--
|
||||
-- Length of hash is 144 bits ~~instead of MD5's 128, so as to avoid
|
||||
-- padding after base64-conversion~~ for backwards compatability
|
||||
fileName = (<.> unpack ext)
|
||||
. unpack
|
||||
. decodeUtf8
|
||||
. Base64.encodeUnpadded
|
||||
. (convert :: Digest (SHAKE256 144) -> ByteString)
|
||||
. runConduitPure
|
||||
$ C.sourceLazy content .| sinkHash
|
||||
@ -7,16 +7,14 @@
|
||||
-- prevents rebuilds if files change, that are not directly used (like
|
||||
-- webpack bundles)
|
||||
module Settings.StaticFiles
|
||||
( bundlerLinks_main, bundlerLinks_polyfill
|
||||
, embeddedStatic
|
||||
( embeddedStatic
|
||||
, main_js, main_css, polyfill_js
|
||||
, module Yesod.EmbeddedStatic
|
||||
) where
|
||||
|
||||
import ClassyPrelude.Yesod
|
||||
|
||||
import Settings (appStaticDir, appBundlerEntrypoints, compileTimeAppSettings)
|
||||
import Settings.StaticFiles.Generator
|
||||
import Settings.StaticFiles.Bundler
|
||||
import Settings (appStaticDir, compileTimeAppSettings)
|
||||
import Yesod.EmbeddedStatic
|
||||
|
||||
-- This generates easy references to files in the static directory at compile time,
|
||||
@ -34,5 +32,4 @@ import Yesod.EmbeddedStatic
|
||||
#define DEV_BOOL False
|
||||
#endif
|
||||
|
||||
mkEmbeddedStatic DEV_BOOL "embeddedStatic" . pure . staticGenerator $ appStaticDir compileTimeAppSettings
|
||||
mkBundlerEntrypoints (appBundlerEntrypoints compileTimeAppSettings) (pure staticGenerator) $ appStaticDir compileTimeAppSettings
|
||||
mkEmbeddedStatic DEV_BOOL "embeddedStatic" . pure . embedDir $ appStaticDir compileTimeAppSettings
|
||||
@ -1,92 +0,0 @@
|
||||
-- SPDX-FileCopyrightText: 2022-2024 Sarah Vaupel <sarah.vaupel@uniworx.de>, Gregor Kleen <gregor.kleen@ifi.lmu.de>
|
||||
--
|
||||
-- SPDX-License-Identifier: AGPL-3.0-or-later
|
||||
|
||||
module Settings.StaticFiles.Bundler
|
||||
( mkBundlerEntrypoints
|
||||
) where
|
||||
|
||||
import ClassyPrelude
|
||||
|
||||
import Language.Haskell.TH
|
||||
import Language.Haskell.TH.Syntax hiding (Lift(..))
|
||||
import qualified Language.Haskell.TH.Syntax as TH (Lift(..))
|
||||
|
||||
import qualified Data.Aeson as Aeson
|
||||
|
||||
import qualified Data.Map as Map
|
||||
|
||||
import Yesod.Core (Route, MonadLogger, MonadWidget, HandlerSite, logDebugS, logErrorS)
|
||||
import Yesod.EmbeddedStatic (EmbeddedStatic)
|
||||
import Yesod.EmbeddedStatic.Types
|
||||
import Network.Mime (MimeType)
|
||||
|
||||
import Control.Lens.Indexed (iforM)
|
||||
|
||||
import Control.Monad.Writer.Class (MonadWriter(..))
|
||||
import Control.Monad.Trans.Writer.Lazy (execWriterT)
|
||||
|
||||
import System.FilePath (makeRelative)
|
||||
|
||||
import Text.Shakespeare.Text (st)
|
||||
|
||||
import Utils ()
|
||||
import Data.Containers.ListUtils
|
||||
|
||||
|
||||
mkBundlerEntrypoints :: FilePath -- ^ Path to manifest (json)
|
||||
-> [FilePath -> Generator]
|
||||
-> FilePath -- ^ Path to static dir
|
||||
-> DecsQ
|
||||
mkBundlerEntrypoints manifest mkGen stDir = do
|
||||
addDependentFile manifest
|
||||
entrypoints <- decodeManifest manifest
|
||||
|
||||
staticEntries <- concat <$> mapM ($ stDir) mkGen
|
||||
|
||||
fmap (concat . Map.elems) . iforM entrypoints $ \entrypoint files -> do
|
||||
entries <- execWriterT . forM_ files $ \file -> do
|
||||
let fileEntries = filter (\entry -> makeRelative stDir (ebLocation entry) == file) staticEntries
|
||||
forM_ fileEntries $ \entry -> case ebHaskellName entry of
|
||||
Nothing -> lift . reportWarning $ concat
|
||||
[ "Entry “"
|
||||
, ebLocation entry
|
||||
, "” of file “"
|
||||
, file
|
||||
, "” of bundler entrypoint “"
|
||||
, entrypoint
|
||||
, "” has no haskellName"
|
||||
]
|
||||
Just n -> tell $ pure (n, ebMimeType entry)
|
||||
|
||||
let entryName = mkName $ "bundlerEntrypoint_" <> entrypoint
|
||||
widgetName = mkName $ "bundlerLinks_" <> entrypoint
|
||||
|
||||
staticR <- newName "staticR"
|
||||
sequence
|
||||
[ sigD entryName [t|[(Route EmbeddedStatic, MimeType)]|]
|
||||
, funD entryName
|
||||
[ clause [] (normalB . listE . map (\(n, mime) -> tupE [varE n, TH.lift mime]) $ nubOrdOn fst entries) []
|
||||
]
|
||||
, sigD widgetName [t|forall m. (MonadLogger m, MonadWidget m) => (Route EmbeddedStatic -> Route (HandlerSite m)) -> m ()|]
|
||||
, funD widgetName
|
||||
[ clause [varP staticR] (normalB [e|
|
||||
do
|
||||
$logDebugS "siteLayout" $ tshow $(varE entryName)
|
||||
forM_ $(varE entryName) $ \(sRoute, mime) ->
|
||||
let ctEq = (==) `on` simpleContentType
|
||||
in if
|
||||
| mime `ctEq` "text/css"
|
||||
-> addStylesheet $ $(varE staticR) sRoute
|
||||
| mime `ctEq` "application/javascript"
|
||||
-> addScript $ $(varE staticR) sRoute
|
||||
| otherwise
|
||||
-> $logErrorS "siteLayout" [st|Unknown mime type in bundle: #{tshow mime}|]
|
||||
|]) []
|
||||
]
|
||||
]
|
||||
|
||||
decodeManifest :: FilePath -> Q (Map String (Map String FilePath))
|
||||
decodeManifest manifest' = liftIO (Aeson.eitherDecodeFileStrict manifest') >>= \case
|
||||
Left exc -> error $ "Encountered error while decoding manifest: " ++ exc
|
||||
Right res -> return res
|
||||
@ -1,73 +0,0 @@
|
||||
-- SPDX-FileCopyrightText: 2022 Gregor Kleen <gregor.kleen@ifi.lmu.de>
|
||||
--
|
||||
-- SPDX-License-Identifier: AGPL-3.0-or-later
|
||||
|
||||
module Settings.StaticFiles.Generator
|
||||
( staticGenerator
|
||||
) where
|
||||
|
||||
import ClassyPrelude
|
||||
import Yesod.EmbeddedStatic.Types
|
||||
import Yesod.EmbeddedStatic
|
||||
|
||||
import System.FilePath
|
||||
import System.Directory.Tree
|
||||
import Network.Mime
|
||||
|
||||
import Language.Haskell.TH
|
||||
import Language.Haskell.TH.Syntax
|
||||
|
||||
import qualified Data.ByteString as BS
|
||||
import qualified Data.ByteString.Lazy as LBS
|
||||
|
||||
import qualified Text.Sass.Compilation as Sass
|
||||
import Text.Sass.Options
|
||||
|
||||
import Data.Default
|
||||
|
||||
import qualified Data.Foldable as Fold
|
||||
|
||||
import Settings.Mime
|
||||
|
||||
import Control.Monad.Fail
|
||||
|
||||
|
||||
staticGenerator :: FilePath -> Generator
|
||||
staticGenerator staticDir = do
|
||||
dirTree' <- runIO $ readDirectoryWith toEntries staticDir
|
||||
Fold.forM_ (fst <$> zipPaths dirTree') addDependentFile
|
||||
return . Fold.fold $ dirTree dirTree'
|
||||
where
|
||||
toEntries :: FilePath -- ^ Absolute path
|
||||
-> IO [Entry]
|
||||
toEntries loc = compile (mimeLookup $ pack loc) (makeRelative staticDir loc) loc
|
||||
|
||||
compile :: MimeType
|
||||
-> Location -- ^ Relative location
|
||||
-> FilePath -- ^ Absolute filepath
|
||||
-> IO [Entry]
|
||||
compile "text/x-scss" sassLoc fp = return . pure $ def
|
||||
{ ebHaskellName = Just $ pathToName sassLoc
|
||||
, ebLocation
|
||||
, ebMimeType = "text/css"
|
||||
, ebProductionContent = either (fail <=< Sass.errorMessage) (return . LBS.fromStrict) =<< Sass.compileFile fp def
|
||||
, ebDevelReload = [| either (fail <=< Sass.errorMessage) (return . LBS.fromStrict) =<< Sass.compileFile $(litE $ stringL fp) def |]
|
||||
}
|
||||
where
|
||||
ebLocation = sassLoc -<.> "css"
|
||||
compile "text/x-sass" sassLoc fp = return . pure $ def
|
||||
{ ebHaskellName = Just $ pathToName sassLoc
|
||||
, ebLocation
|
||||
, ebMimeType = "text/css"
|
||||
, ebProductionContent = either (fail <=< Sass.errorMessage) (return . LBS.fromStrict) =<< Sass.compileFile fp (def { sassIsIndentedSyntax = True })
|
||||
, ebDevelReload = [| either (fail <=< Sass.errorMessage) (return . LBS.fromStrict) =<< Sass.compileFile $(litE $ stringL fp) (def { sassIsIndentedSyntax = True }) |]
|
||||
}
|
||||
where
|
||||
ebLocation = sassLoc -<.> "css"
|
||||
compile ebMimeType ebLocation fp = return . pure $ def
|
||||
{ ebHaskellName = Just $ pathToName ebLocation
|
||||
, ebLocation
|
||||
, ebMimeType
|
||||
, ebProductionContent = LBS.fromStrict <$> BS.readFile fp
|
||||
, ebDevelReload = [| LBS.fromStrict <$> BS.readFile $(litE $ stringL fp) |]
|
||||
}
|
||||
Loading…
Reference in New Issue
Block a user