93 lines
3.3 KiB
Haskell
93 lines
3.3 KiB
Haskell
module Settings.StaticFiles.Webpack
|
|
( mkWebpackEntrypoints
|
|
) 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.Yaml as Yaml
|
|
|
|
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 Control.Monad.Catch (MonadThrow(..))
|
|
|
|
import Utils (nubOn)
|
|
|
|
import System.FilePath (makeRelative)
|
|
|
|
import Text.Shakespeare.Text (st)
|
|
|
|
|
|
mkWebpackEntrypoints :: FilePath -- ^ Path to YAML-manifest
|
|
-> [FilePath -> Generator]
|
|
-> FilePath -- ^ Path to static dir
|
|
-> DecsQ
|
|
mkWebpackEntrypoints 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 webpack entrypoint “"
|
|
, entrypoint
|
|
, "” has no haskellName"
|
|
]
|
|
Just n -> tell $ pure (n, ebMimeType entry)
|
|
|
|
let entryName = mkName $ "webpackEntrypoint_" <> entrypoint
|
|
widgetName = mkName $ "webpackLinks_" <> 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]) $ nubOn 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 webpack bundle: #{tshow mime}|]
|
|
|]) []
|
|
]
|
|
]
|
|
where
|
|
decodeManifest :: FilePath -> Q (Map String [FilePath])
|
|
decodeManifest manifest' = do
|
|
res <- liftIO $ Yaml.decodeFileWithWarnings manifest'
|
|
case res of
|
|
Left exc -> throwM exc
|
|
Right (ws, res') -> res' <$ mapM_ (\w -> reportWarning $ "Warning while parsing webpack manifest: " <> show w) ws
|
|
|
|
|