54 lines
2.2 KiB
Haskell
54 lines
2.2 KiB
Haskell
-- SPDX-FileCopyrightText: 2022-2025 Sarah Vaupel <sarah.vaupel@uniworx.systems>, 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 compatibility
|
|
fileName = (<.> unpack ext)
|
|
. unpack
|
|
. decodeUtf8
|
|
. Base64.encodeUnpadded
|
|
. (convert :: Digest (SHAKE256 144) -> ByteString)
|
|
. runConduitPure
|
|
$ C.sourceLazy content .| sinkHash
|