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)

src/Foundation/Instances.hs

@@ -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
+    -- TODO: minify on production builds using ifdef DEVELOP instead of bundler-based minify
-    addStaticContent = UniWorX.addStaticContent
+    addStaticContent = embedStaticContent appStatic StaticR Right
-    -- addStaticContent = embedStaticContent appStatic StaticR Right -- TODO: minify on production builds
 
     fileUpload _site _length = FileUploadMemory lbsBackEnd
 

src/Foundation/SiteLayout.hs

@@ -487,9 +487,10 @@ siteLayout' overrideHeading widget = do
     frontendI18n = toJSON (mr :: FrontendMessage -> Text)
   frontendDatetimeLocale <- toJSON <$> selectLanguage frontendDatetimeLocales
 
-  pc' <- widgetToPageContent $ do
+  pc <- widgetToPageContent $ do
-      bundlerLinks_main StaticR
+      addScript $ StaticR main_js
-      bundlerLinks_polyfill StaticR
+      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")
 
   

src/Foundation/Yesod/StaticContent.hs

@@ -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

src/Settings/StaticFiles.hs

@@ -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     (appStaticDir, compileTimeAppSettings)
-import Settings.StaticFiles.Generator
-import Settings.StaticFiles.Bundler
 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
+mkEmbeddedStatic DEV_BOOL "embeddedStatic" . pure . embedDir $ appStaticDir compileTimeAppSettings
-mkBundlerEntrypoints (appBundlerEntrypoints compileTimeAppSettings) (pure staticGenerator) $ appStaticDir compileTimeAppSettings

src/Settings/StaticFiles/Bundler.hs

@@ -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

src/Settings/StaticFiles/Generator.hs

@@ -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) |]
-  }