Commit 0d544fdd authored by Henrik Tramberend's avatar Henrik Tramberend
Browse files

Attach resource files to decker executable in ZIP

- No more abuse of TemplateHaskell to embed files in the executable
- Speeds up compilation and linking considerably
- Uses external programs zip`, `unzip` and `cp` though
- May not work on windows
parent 71e5c188
import Distribution.Simple
main = defaultMain
{--
TODO: I cannot figure out exactly why the postReg and postInst hooks are never called. Other than that, this works.
import Codec.Archive.Zip
import qualified Data.ByteString.Lazy as B
import Data.Maybe
import Distribution.PackageDescription
import Distribution.Simple.LocalBuildInfo
import Distribution.Simple.Setup
import System.Directory
import System.FilePath.Posix
import System.IO
main = defaultMainWithHooks simpleUserHooks {postReg = appendResourcesHook}
appendResourcesHook ::
Args -> RegisterFlags -> PackageDescription -> LocalBuildInfo -> IO ()
appendResourcesHook args flags descr info = do
let deckerBuildPath =
(fromJust $ flagToMaybe $ regDistPref flags) </> "build" </> "decker" </>
"decker"
-- appendResourcesArchive deckerBuildPath
putStrLn $
"### Append the shit! " ++ "(" ++ deckerBuildPath ++ ")" ++ show flags
appendResourcesArchive :: FilePath -> IO ()
appendResourcesArchive executable = do
resourceArchive <-
withCurrentDirectory "./resource" $ do
addFilesToArchive [OptRecursive] emptyArchive ["support"]
B.appendFile executable (fromArchive resourceArchive)
--}
{-- Author: Henrik Tramberend <henrik@tramberend.de> --}
import Action
import Common
import Context
import Control.Exception
import Control.Monad ()
......@@ -11,8 +12,8 @@ import Data.String ()
import Data.Yaml.Pretty
import Development.Shake
import Development.Shake.FilePath
import Embed
import Project
import Resources
import Server
import System.Directory
import System.Exit
......@@ -25,10 +26,14 @@ import Utilities
main :: IO ()
main = do
extractResources
dirs <- projectDirectories
--
let projectDir = project dirs
let publicDir = public dirs
let supportDir = support dirs
let appDataDir = appData dirs
-- Find sources. These are formulated as actions in the Action mondad, such
-- that each new iteration rescans all possible source files.
let deckSourcesA = globA "**/*-deck.md"
......@@ -143,12 +148,15 @@ main = do
removeFilesAfter publicDir ["//"]
removeFilesAfter projectDir cruft
--
phony "help" $ liftIO $ putStr deckerHelpText
phony "help" $ do
text <- liftIO $ getResourceString "template/help-page.md"
liftIO $ putStr text
--
phony "plan" $ do
putNormal $ "project directory: " ++ projectDir
putNormal $ "public directory: " ++ publicDir
putNormal $ "support directory: " ++ supportDir
putNormal $ "application data directory: " ++ appDataDir
putNormal "meta:"
metaA >>= mapM_ putNormal
putNormal "sources:"
......@@ -156,8 +164,9 @@ main = do
putNormal "targets:"
everythingA <++> everythingPdfA >>= mapM_ putNormal
--
-- phony "support" $ writeEmbeddedFiles deckerSupportDir supportDir
phony "support" $ do
writeEmbeddedFiles deckerSupportDir supportDir
liftIO $ writeResourceFiles "support" supportDir
--
phony "publish" $ do
need ["support"]
......
......@@ -4,7 +4,7 @@ synopsis: All inclusive slide deck creation with pandoc.
description: Please see README.md
homepage: https://tramberend.beuth-hochschule.de/decker
license: OtherLicense
license-file: LICENSE
license-file: LICENSE
author: Henrik Tramberend
maintainer: tramberend@beuth-hochschule.de
copyright: 2017 Henrik Tramberend
......@@ -12,99 +12,61 @@ category: Tool
build-type: Simple
cabal-version: >=1.10
library
hs-source-dirs: src
exposed-modules: Action, Cache, Meta, Watch, Embed, Context, Utilities, Filter, Project, Common, Server
-- custom-setup
-- setup-depends: base
-- , Cabal
-- , bytestring
-- , directory
-- , filepath
executable decker
hs-source-dirs: app, src
main-is: decker.hs
other-modules: Action, Cache, Meta, Watch, Embed, Context, Utilities, Filter, Project, Common, Server, Resources, Paths_decker
ghc-options: -threaded -rtsopts -with-rtsopts=-N
build-depends: base
, Glob
, HTTP
, aeson
, random
, pandoc-types
, pandoc-citeproc
, blaze-html
, blaze-markup
, bytestring
, containers
, split
, data-default
, blaze-markup
, blaze-html
, monad-loops
, directory
, time
, shake
, process
, hashable
, extra
, filepath
, Glob
, pandoc
, pureMD5
, yaml
, mustache
, unordered-containers
, text
, file-embed
, bytestring
, network-uri
, HTTP
, filepath
, fsnotify
, hashable
, highlighting-kate
, http-conduit
, http-types
, highlighting-kate
, monad-loops
, multimap
, fsnotify
, vector
, mustache
, network-uri
, pandoc
, pandoc-citeproc
, pandoc-types
, process
, pureMD5
, random
, scientific
, transformers
, unix
, shake
, snap-core
, snap-server
, split
, text
, time
, transformers
, unix
, unordered-containers
, utf8-string
, vector
, websockets
, websockets-snap
default-language: Haskell2010
executable decker
hs-source-dirs: app
main-is: decker.hs
ghc-options: -threaded -rtsopts -with-rtsopts=-N
build-depends: base
, decker
, shake
, Glob
, file-embed
, bytestring
, directory
, filepath
, pandoc
, yaml
, mustache
default-language: Haskell2010
-- executable liveserver
-- hs-source-dirs: app
-- main-is: liveserver.hs
-- ghc-options: -threaded -rtsopts -with-rtsopts=-N
-- build-depends: base
-- , decker
-- , directory
-- , random
-- , process
-- default-language: Haskell2010
test-suite decker-test
type: exitcode-stdio-1.0
hs-source-dirs: test
main-is: Spec.hs
build-depends: base
, decker
, hspec
, filepath
, pandoc
, Glob
, yaml
, containers
, unordered-containers
, text
, neat-interpolation
, bytestring
, directory
ghc-options: -threaded -rtsopts -with-rtsopts=-N
default-language: Haskell2010
source-repository head
......
decker := $(shell stack path | grep local-install-root | sed "s/local-install-root: //")/bin/decker
zip := $(shell mktemp -u)
build:
stack build
@(cd resource; zip -qr $(zip) example support template; cat $(zip) >> $(decker); rm $(zip))
clean:
stack clean
install: build
stack install
dist: clean build
.PHONY: build clean install dist
\ No newline at end of file
......@@ -98,6 +98,7 @@ socket.onmessage = function () {
window.location.reload(true);
};
</script>
<script src="$decker-support-dir$/zepto.min.js"></script>
$for(header-includes)$
$header-includes$
$endfor$
......@@ -145,4 +146,7 @@ $endif$
</div>
</div>
</body>
<script>
Zepto('table').addClass("table table-striped table-bordered table-hover table-condensed table-responsive");
</script>
</html>
......@@ -112,6 +112,7 @@ socket.onmessage = function () {
window.location.reload(true);
};
</script>
<script src="$decker-support-dir$/zepto.min.js"></script>
$for(header-includes)$
$header-includes$
$endfor$
......@@ -159,4 +160,7 @@ $endif$
</div>
</div>
</body>
<script>
Zepto('table').addClass("table table-striped table-bordered table-hover table-condensed table-responsive");
</script>
</html>
{-- Author: Henrik Tramberend <henrik@tramberend.de> --}
module Common
( DeckerException(..)
, deckerVersion
) where
import Control.Exception
import Data.Typeable
import Data.Version (showVersion)
import Paths_decker (version)
-- | The version from the cabal file
deckerVersion :: String
deckerVersion = showVersion version
-- | Tool specific exceptions
data DeckerException
......@@ -30,4 +37,3 @@ instance Show DeckerException where
show (DecktapeException e) = "decktape.sh failed for reason: " ++ e
show RsyncUrlException =
"attributes 'destinationRsyncHost' or 'destinationRsyncPath' not defined in meta data"
......@@ -37,7 +37,7 @@ defaultActionContext :: IO ActionContext
defaultActionContext = do
files <- newIORef []
server <- newIORef Nothing
return $ ActionContext files server (ProjectDirs "" "" "" "" "")
return $ ActionContext files server (ProjectDirs "" "" "" "" "" "")
actionContextKey :: IO TypeRep
actionContextKey = do
......
......@@ -2,8 +2,7 @@
{-# LANGUAGE TemplateHaskell #-}
module Embed
( deckerVersion
, deckerHelpText
( deckerHelpText
, deckerExampleDir
, deckerSupportDir
, deckerTemplateDir
......@@ -22,9 +21,6 @@ import Data.List
import Data.List.Extra
import Data.Maybe
deckerVersion :: String
deckerVersion = trim $ B.unpack $ $(makeRelativeToProject "VERSION" >>= embedFile)
deckerExampleDir :: [(FilePath, B.ByteString)]
deckerExampleDir = $(makeRelativeToProject "resource/example" >>= embedDir)
......
......@@ -2,7 +2,7 @@
module Project
( findFile
, findLocalFile
, readResource
-- , readResource
, provisionResource
, provisionExistingResource
, copyResource
......@@ -25,13 +25,13 @@ module Project
import Common
import Control.Exception
import Control.Monad
import qualified Data.ByteString as B
import qualified Data.ByteString.Lazy as B
import Data.List
import Data.Maybe
import Debug.Trace
import Embed
import Extra
import Network.URI
import Resources
import qualified System.Directory as D
import System.FilePath
import System.Posix.Files
......@@ -98,6 +98,7 @@ data ProjectDirs = ProjectDirs
, public :: FilePath
, cache :: FilePath
, support :: FilePath
, appData :: FilePath
, log :: FilePath
} deriving (Eq, Show)
......@@ -125,8 +126,10 @@ projectDirectories = do
let publicDir = projectDir </> "public"
let cacheDir = publicDir </> "cache"
let supportDir = publicDir </> ("support" ++ "-" ++ deckerVersion)
appDataDir <- D.getXdgDirectory D.XdgData ("decker" ++ "-" ++ deckerVersion)
let logDir = projectDir </> "log"
return (ProjectDirs projectDir publicDir cacheDir supportDir logDir)
return
(ProjectDirs projectDir publicDir cacheDir supportDir appDataDir logDir)
-- Resolves a file path to a concrete verified file system path, or
-- returns Nothing if no file can be found.
......@@ -218,19 +221,20 @@ maybeFindFile dirs base path = do
Just resource -> return resource
-- Finds and reads a resource at compile time. If the resource can not be found in the
-- file system, the built-in resource map is searched. If that fails, an error os thrown.
-- file system, the built-in resource map is searched. If that fails, an error is thrown.
-- The resource is searched for in a directory named `template`.
readResource :: ProjectDirs -> FilePath -> FilePath -> IO B.ByteString
readResource dirs base path = do
let searchPath = "template" </> path
resolved <- resolveLocally dirs base path
case resolved of
Just resource -> B.readFile resource
Nothing ->
case find (\(k, b) -> k == path) deckerTemplateDir of
Nothing ->
throw $ ResourceException $ "Cannot find built-in resource: " ++ path
Just entry -> return $ snd entry
-- readResource ::
-- ProjectDirs -> FilePath -> FilePath -> IO String
-- readResource dirs base path = do
-- let searchPath = "template" </> path
-- resolved <- resolveLocally dirs base path
-- case resolved of
-- Just resource -> readFile resource
-- Nothing -> return $ getResourceString resources searchPath
-- case find (\(k, b) -> k == path) deckerTemplateDir of
-- Nothing ->
-- throw $ ResourceException $ "Cannot find built-in resource: " ++ path
-- Just entry -> return $ snd entry
-- | Copies the src to dst if src is newer or dst does not exist. Creates
-- missing directories while doing so.
......
{-- Author: Henrik Tramberend <henrik@tramberend.de> --}
module Resources
( extractResources
, getResourceString
, deckerResourceDir
, writeResourceFiles
) where
import Common
import Control.Exception
import Control.Monad
import System.Directory
import System.Environment
import System.Exit
import System.FilePath.Posix
import System.Process
deckerResourceDir :: IO FilePath
deckerResourceDir = getXdgDirectory XdgData ("decker" ++ "-" ++ deckerVersion)
getResourceString :: FilePath -> IO String
getResourceString path = do
dataDir <- deckerResourceDir
readFile (dataDir </> path)
-- Extract resources from the executable into the XDG data directory.
extractResources :: IO ()
extractResources = do
deckerExecutable <- getExecutablePath
dataDir <- deckerResourceDir
exists <- doesDirectoryExist dataDir
unless exists $ do
createDirectoryIfMissing True dataDir
(exitCode, _, _) <-
readProcessWithExitCode
"unzip"
["-qq", "-d", dataDir, deckerExecutable]
""
case exitCode of
ExitSuccess -> putStrLn $ "# resources extracted to " ++ dataDir
ExitFailure 1 -> putStrLn $ "# resources extracted to " ++ dataDir
_ ->
throw $ ResourceException "No resource zip found in decker executable."
writeResourceFiles :: FilePath -> FilePath -> IO ()
writeResourceFiles prefix destDir = do
dataDir <- deckerResourceDir
let src = dataDir </> prefix
exists <- doesDirectoryExist (destDir </> prefix)
unless exists $ callProcess "cp" ["-R", src, destDir]
......@@ -43,11 +43,11 @@ import qualified Data.Text.Encoding as E
import qualified Data.Yaml as Y
import Development.Shake
import Development.Shake.FilePath as SFP
import Embed
import Filter
import Meta
import Network.URI
import Project
import Resources
import Server
import qualified System.Directory as Dir
import System.IO as S
......@@ -84,7 +84,7 @@ runShakeInContext context options rules = do
case server of
Just handle -> reloadClients handle
Nothing -> return ()
waitForTwitchPassive files
_ <- waitForTwitchPassive files
return False
watchFiles = setFilesToWatch
......@@ -136,6 +136,9 @@ substituteMetaData text metaData = do
Right template -> M.substituteValue template metaData
Left err -> throw $ MustacheException (show err)
getTemplate :: FilePath -> Action String
getTemplate path = liftIO $ getResourceString ("template" </> path)
getRelativeSupportDir :: FilePath -> Action FilePath
getRelativeSupportDir from = do
dirs <- getProjectDirs
......@@ -151,9 +154,10 @@ markdownToHtmlDeck :: FilePath -> FilePath -> Action ()
markdownToHtmlDeck markdownFile out = do
putCurrentDocument out
supportDir <- getRelativeSupportDir out
template <- getTemplate "deck.html"
let options =
pandocWriterOpts
{ writerTemplate = Just deckTemplate
{ writerTemplate = Just template
-- , writerStandalone = True
, writerHighlight = True
-- , writerHighlightStyle = pygments
......@@ -243,11 +247,12 @@ markdownToHtmlPage :: FilePath -> FilePath -> Action ()
markdownToHtmlPage markdownFile out = do
putCurrentDocument out
supportDir <- getRelativeSupportDir out
template <- getTemplate "page.html"
let options =
pandocWriterOpts
{ writerHtml5 = True
-- , writerStandalone = True
, writerTemplate = Just pageTemplate
, writerTemplate = Just template
, writerHighlight = True
-- , writerHighlightStyle = pygments
, writerHTMLMathMethod =
......@@ -267,9 +272,10 @@ markdownToHtmlPage markdownFile out = do
markdownToPdfPage :: FilePath -> FilePath -> Action ()
markdownToPdfPage markdownFile out = do
putCurrentDocument out
template <- getTemplate "page.latex"
let options =
pandocWriterOpts
{ writerTemplate = Just pageLatexTemplate
{ writerTemplate = Just template
-- , writerStandalone = True
, writerHighlight = True
-- , writerHighlightStyle = pygments
......@@ -293,10 +299,11 @@ markdownToHtmlHandout markdownFile out = do
pandoc <- readAndPreprocessMarkdown markdownFile Handout
processed <- processPandocHandout "html" pandoc
supportDir <- getRelativeSupportDir out
template <- getTemplate "handout.html"
let options =
pandocWriterOpts
{ writerHtml5 = True
, writerTemplate = Just handoutTemplate
, writerTemplate = Just template
, writerHighlight = True
, writerHTMLMathMethod =
MathJax
......@@ -312,9 +319,10 @@ markdownToPdfHandout markdownFile out = do
putCurrentDocument out
pandoc <- readAndPreprocessMarkdown markdownFile Handout
processed <- processPandocHandout "latex" pandoc
template <- getTemplate "handout.latex"
let options =
pandocWriterOpts
{ writerTemplate = Just handoutLatexTemplate
{ writerTemplate = Just template
, writerHighlight = True
, writerCiteMethod = Citeproc
}
......@@ -518,6 +526,11 @@ writePandocString format options out pandoc = do
let writer = getPandocWriter format
writeFile' out (writer options pandoc)
writeExampleProject :: Action ()
writeExampleProject = do
liftIO $ writeResourceFiles "example" "."
{--
writeExampleProject :: Action ()
writeExampleProject = mapM_ writeOne deckerExampleDir
where
......@@ -527,7 +540,7 @@ writeExampleProject = mapM_ writeOne deckerExampleDir
liftIO $ Dir.createDirectoryIfMissing True (takeDirectory path)
liftIO $ B.writeFile path contents
putNormal $ "# create (for " ++ path ++ ")"
--}
writeEmbeddedFiles :: [(FilePath, B.ByteString)] -> FilePath -> Action ()
writeEmbeddedFiles files dir = do
exists <- doesDirectoryExist dir
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment