Commit ee2ff226 authored by Armin Bernstetter's avatar Armin Bernstetter
Browse files

improved decker pdf. index.html does not show pdfs if not available (currently...

improved decker pdf. index.html does not show pdfs if not available (currently shows only when refreshed via decker html or server. needs to be fixed)
parent 7d510317
...@@ -49,6 +49,14 @@ main = do ...@@ -49,6 +49,14 @@ main = do
let indexSource = (directories ^. project) </> "index.md" let indexSource = (directories ^. project) </> "index.md"
let index = (directories ^. public) </> "index.html" let index = (directories ^. public) </> "index.html"
let cruft = ["index.md.generated", "log", "//.shake", "generated", "code"] let cruft = ["index.md.generated", "log", "//.shake", "generated", "code"]
let pdfMsg =
"\n# Make sure you have run 'decker html' first.\n" ++
"# To use 'decker pdf' or 'decker pdf-decks', Google Chrome has to be installed.\n" ++
"# Windows: Follow the Google Chrome installer instructions.\n" ++
"# MacOS: Follow the Google Chrome installer instructions.\n" ++
"\tGoogle Chrome.app has to be located in either /Applications/Google Chrome.app or /Users/<username>/Applications/Google Chrome.app\n" ++
"\tAlternatively you can add 'chrome' to $PATH.\n" ++
"# Linux: 'chrome' has to be on $PATH.\n"
-- --
runDecker $ runDecker $
-- --
...@@ -75,10 +83,12 @@ main = do ...@@ -75,10 +83,12 @@ main = do
allHtmlA >>= need allHtmlA >>= need
-- --
phony "pdf" $ do phony "pdf" $ do
putNormal pdfMsg
need ["index"] need ["index"]
allPdfA >>= need allPdfA >>= need
-- --
phony "pdf-decks" $ do phony "pdf-decks" $ do
putNormal pdfMsg
need ["index"] need ["index"]
decksPdfA >>= need decksPdfA >>= need
-- --
...@@ -119,13 +129,17 @@ main = do ...@@ -119,13 +129,17 @@ main = do
"//*-deck.pdf" %> \out -> do "//*-deck.pdf" %> \out -> do
let src = replaceSuffix "-deck.pdf" "-deck.html" out let src = replaceSuffix "-deck.pdf" "-deck.html" out
need [src] need [src]
putNormal $ src ++ " -> " ++ out putNormal $ "Started: " ++ src ++ " -> " ++ out
runHttpServer serverPort directories Nothing runHttpServer serverPort directories Nothing
-- decktape [serverUrl </> makeRelative (directories ^. public) src, out] -- decktape [serverUrl </> makeRelative (directories ^. public) src, out]
liftIO $ result <-
liftIO $
launchChrome launchChrome
(serverUrl </> makeRelative (directories ^. public) src) (serverUrl </> makeRelative (directories ^. public) src)
out out
case result of
Right msg -> putNormal msg
Left msg -> error msg
-- --
priority 2 $ priority 2 $
"//*-handout.html" %> \out -> do "//*-handout.html" %> \out -> do
......
...@@ -100,7 +100,7 @@ library: ...@@ -100,7 +100,7 @@ library:
source-dirs: src-win source-dirs: src-win
exposed-modules: "System.Decker.OS" exposed-modules: "System.Decker.OS"
else: else:
source-dirs: src-mac source-dirs: src-unix
exposed-modules: "System.Decker.OS" exposed-modules: "System.Decker.OS"
- condition: flag(preextractedresources) - condition: flag(preextractedresources)
cpp-options: "-DPREEXTRACTEDRESOURCES" cpp-options: "-DPREEXTRACTEDRESOURCES"
......
...@@ -22,30 +22,41 @@ preextractedResourceFolder = do ...@@ -22,30 +22,41 @@ preextractedResourceFolder = do
exep <- getExecutablePath exep <- getExecutablePath
return $ joinPath [(takeDirectory exep), "..", "Resources", "resource"] return $ joinPath [(takeDirectory exep), "..", "Resources", "resource"]
-- Look for chromium executable on $PATH -- Look for chrome executable on $PATH
chromeExecutable :: IO String chromeExecutable :: IO (Either String String)
chromeExecutable = do chromeExecutable = do
chrium <- findExecutable "chromium"
chr <- findExecutable "chrome" chr <- findExecutable "chrome"
case (chrium, chr) of case chr of
(Just c, _) -> return c Just c -> return $ Right c
(_, Just c) -> return c Nothing ->
(Nothing, Nothing) -> return $
error Left
"Neither chrome nor chromium are on $PATH. Please make sure Google Chrome is installed to use 'decker pdf'." "'chrome' is not on $PATH. Please make sure 'chrome' is pointing to your Google Chrome installation."
chrome :: IO String -- Check for MacOS standard installation locations
-- /Applications/Google Chrome.app
-- /Users/<username>/Applications/Google Chrome.app
chrome :: IO (Either String String)
chrome = do chrome = do
localExists <- localChrome >>= \h -> doesFileExist h localExists <- localChrome >>= \h -> doesFileExist h
globalExists <- doesFileExist chromeLocation globalExists <- doesFileExist chromeLocation
if globalExists if globalExists
then return chromeCommand then return $ Right chromeCommand
else if localExists else if localExists
then localChromeCommand then localChromeCommand
else chromeExecutable else do
exe <- chromeExecutable
case exe of
Right c -> return $ Right c
Left msg ->
return $
Left
("MacOS: Google Chrome.app was not found in /Applications or /User/<username>/Applications. Please install Google Chrome.\n" ++
"Generic Unix: " ++ msg)
where where
localChrome = fmap (\h -> h ++ chromeLocation) getHomeDirectory localChrome = fmap (\h -> h ++ chromeLocation) getHomeDirectory
localChromeCommand = fmap (\h -> h ++ chromeCommand) getHomeDirectory localChromeCommand =
fmap (\h -> Right (h ++ chromeCommand)) getHomeDirectory
chromeLocation = chromeLocation =
"/Applications/Google Chrome.app/Contents/MacOS/Google Chrome" "/Applications/Google Chrome.app/Contents/MacOS/Google Chrome"
chromeCommand = chromeCommand =
......
...@@ -22,5 +22,6 @@ preextractedResourceFolder = do ...@@ -22,5 +22,6 @@ preextractedResourceFolder = do
exep <- getExecutablePath exep <- getExecutablePath
return $ joinPath [(takeDirectory exep), "..", "resource"] return $ joinPath [(takeDirectory exep), "..", "resource"]
chrome :: IO String -- start chrome from cmd
chrome = return "start chrome" chrome :: IO (Either String String)
chrome = return $ Right "start chrome"
module Pdf module Pdf
( getDirs ( launchChrome
, launchChrome
) where ) where
import System.Decker.OS import System.Decker.OS
...@@ -40,47 +39,31 @@ TODO: ...@@ -40,47 +39,31 @@ TODO:
require that chrome or chromium is on path require that chrome or chromium is on path
-} -}
getDirs :: IO ()
getDirs
-- dirs <- getXdgDirectoryList
= do
home <- getHomeDirectory
print home
let apps = "/Applications"
contents <- listDirectory apps
print contents
-- This will be what is imported from the OS module
-- chrome :: FilePath
-- chrome = "/Applications/Google\\ Chrome.app/Contents/MacOS/Google\\ Chrome"
pdfPath = "test.pdf"
pdfOption :: FilePath -> [Char] pdfOption :: FilePath -> [Char]
pdfOption path = "--print-to-pdf=" ++ path pdfOption path = "--print-to-pdf=" ++ path
modifySrc :: FilePath -> FilePath modifySrc :: FilePath -> FilePath
modifySrc path = path ++ "?print-pdf#/" modifySrc path = path ++ "?print-pdf#/"
-- if isSuffixOf ".html" path
-- then Just $ path ++ "?print-pdf#/"
-- else Nothing
chromeOptions :: FilePath -> FilePath -> [String] chromeOptions :: FilePath -> FilePath -> [String]
chromeOptions src out = chromeOptions src out =
["--headless", "--disable-gpu", pdfOption out, modifySrc src] ["--headless", "--disable-gpu", pdfOption out, modifySrc src]
launchChrome :: FilePath -> FilePath -> IO () launchChrome :: FilePath -> FilePath -> IO (Either String String)
launchChrome src out = do launchChrome src out = do
command <- chrome command <- chrome
let options = unwords (chromeOptions src out) let options = unwords (chromeOptions src out)
-- print options -- print options
(_, _, _, ph) <- case command of
createProcess Left msg -> return $ Left msg
-- (proc chrome ["--headless", "--disable-gpu", pdfOption out, modifySrc src]) Right cmd -> do
(shell $ command ++ " " ++ options) (_, _, _, ph) <-
code <- waitForProcess ph createProcess (shell $ cmd ++ " " ++ options) {std_err = CreatePipe}
case code of code <- waitForProcess ph
ExitFailure _ -> case code of
error ExitFailure _ ->
("Error: Google Chrome is most likely not installed." ++ return $
" Make sure Google Chrome is installed to use 'decker pdf'.") Left
ExitSuccess -> putStrLn $ "completed:" ++ src ++ " -> " ++ out ("Google Chrome is most likely not installed. " ++
"Please install Google Chrome to use 'decker pdf' or 'decker pdf-decks'")
ExitSuccess -> return $ Right ("Completed: " ++ src ++ " -> " ++ out)
...@@ -137,6 +137,9 @@ writeIndexLists out baseUrl = do ...@@ -137,6 +137,9 @@ writeIndexLists out baseUrl = do
let decks = (zip (_decks ts) (_decksPdf ts)) let decks = (zip (_decks ts) (_decksPdf ts))
let handouts = (zip (_handouts ts) (_handoutsPdf ts)) let handouts = (zip (_handouts ts) (_handoutsPdf ts))
let pages = (zip (_pages ts) (_pagesPdf ts)) let pages = (zip (_pages ts) (_pagesPdf ts))
decksLinks <- mapM makeLink decks
handoutsLinks <- mapM makeLink handouts
pagesLinks <- mapM makeLink pages
liftIO $ liftIO $
writeFile out $ writeFile out $
unlines unlines
...@@ -145,19 +148,26 @@ writeIndexLists out baseUrl = do ...@@ -145,19 +148,26 @@ writeIndexLists out baseUrl = do
, "subtitle: " ++ dirs ^. project , "subtitle: " ++ dirs ^. project
, "---" , "---"
, "# Slide decks" , "# Slide decks"
, unlines $ map makeLink decks , unlines $ decksLinks
, "# Handouts" , "# Handouts"
, unlines $ map makeLink handouts , unlines $ handoutsLinks
, "# Supporting Documents" , "# Supporting Documents"
, unlines $ map makeLink pages , unlines $ pagesLinks
] ]
where where
makeLink (html, pdf) = makeLink (html, pdf) = do
printf pdfExists <- doesFileExist pdf
"- [%s <i class='fab fa-html5'></i>](%s) [<i class='fas fa-file-pdf'></i>](%s)" if pdfExists then
(takeFileName html) return $ printf
(makeRelative baseUrl html) "- [%s <i class='fab fa-html5'></i>](%s) [<i class='fas fa-file-pdf'></i>](%s)"
(makeRelative baseUrl pdf) (takeFileName html)
(makeRelative baseUrl html)
(makeRelative baseUrl pdf)
else
return $ printf
"- [%s <i class='fab fa-html5'></i>](%s)"
(takeFileName html)
(makeRelative baseUrl html)
-- | Fixes pandoc escaped # markup in mustache template {{}} markup. -- | Fixes pandoc escaped # markup in mustache template {{}} markup.
fixMustacheMarkup :: B.ByteString -> T.Text fixMustacheMarkup :: B.ByteString -> T.Text
......
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