Decker.hs 8.25 KB
Newer Older
1
{-- Author: Henrik Tramberend <henrik@tramberend.de> --}
2
import Common
3 4
import Exception
import External
5
import Flags (hasPreextractedResources)
6
import Pdf
7 8 9 10 11
import Project
import Resources
import Shake
import Utilities

12
import Control.Exception
13
import Control.Lens ((^.))
14
import Control.Monad (when)
15
import Control.Monad.Extra
Henrik Tramberend's avatar
Henrik Tramberend committed
16
import Data.Aeson
17 18 19 20
import Data.IORef ()
import Data.List
import Data.Maybe
import Data.String ()
Henrik Tramberend's avatar
Henrik Tramberend committed
21
import Data.Version
22 23
import Development.Shake
import Development.Shake.FilePath
24
import GHC.Conc (numCapabilities)
25
import System.Decker.OS (defaultProvisioning)
Henrik Tramberend's avatar
Henrik Tramberend committed
26
import System.Directory (createDirectoryIfMissing, createFileLink, removeFile)
27
import System.Environment.Blank
28
import System.FilePath ()
29
import Text.Groom
30
import qualified Text.Mustache as M ()
Henrik Tramberend's avatar
Henrik Tramberend committed
31 32
import Text.Pandoc
import Text.Pandoc.Definition
33
import Text.Printf
Henrik Tramberend's avatar
Henrik Tramberend committed
34

35
main :: IO ()
Henrik Tramberend's avatar
Henrik Tramberend committed
36
main = do
37 38
  when isDevelopmentVersion $
    printf
39
      "WARNING: You are running a development build of decker (version: %s, branch: %s, commit: %s, tag: %s). Please be sure that you know what you're doing.\n"
40 41 42 43
      deckerVersion
      deckerGitBranch
      deckerGitCommitId
      deckerGitVersionTag
44
  extractResources
45
  directories <- projectDirectories
46
  --
Henrik Tramberend's avatar
Henrik Tramberend committed
47
  let serverPort = 8888
48
  let serverUrl = "http://localhost:" ++ (show serverPort)
49 50
  let indexSource = (directories ^. project) </> "index.md"
  let index = (directories ^. public) </> "index.html"
Henrik Tramberend's avatar
Henrik Tramberend committed
51
  let cruft = ["index.md.generated", "log", "//.shake", "generated", "code"]
52
  let pdfMsg =
53
        "\n# To use 'decker pdf' or 'decker pdf-decks', Google Chrome has to be installed.\n" ++
54 55 56 57 58
        "# 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"
59 60
  --
  runDecker $
61
  --
62 63
   do
    want ["html"]
64
    --
Henrik Tramberend's avatar
Henrik Tramberend committed
65
    phony "version" $ do
66
      putNormal $
67 68 69 70 71
        "decker version " ++
        deckerVersion ++
        " (branch: " ++
        deckerGitBranch ++
        ", commit: " ++
72
        deckerGitCommitId ++ ", tag: " ++ deckerGitVersionTag ++ ")"
Henrik Tramberend's avatar
Henrik Tramberend committed
73 74
      putNormal $ "pandoc version " ++ pandocVersion
      putNormal $ "pandoc-types version " ++ showVersion pandocTypesVersion
75
    --
76
    phony "decks" $ do
77
      need ["index"]
78
      decksA >>= need
79
    --
80
    phony "html" $ do
81 82
      need ["index"]
      allHtmlA >>= need
83
    --
84
    phony "pdf" $ do
85
      putNormal pdfMsg
86 87
      need ["index"]
      allPdfA >>= need
88
    --
89
    phony "pdf-decks" $ do
90
      putNormal pdfMsg
91 92
      need ["index"]
      decksPdfA >>= need
93
    --
94 95
    phony "watch" $ do
      need ["html"]
96
      watchChangesAndRepeat
97
    --
98 99
    phony "open" $ do
      need ["html"]
100
      openBrowser index
101
    --
102
    phony "server" $ do
103
      need ["watch"]
104
      runHttpServer serverPort directories Nothing
105
    --
106
    phony "example" $ liftIO writeExampleProject
107
    --
108
    phony "sketch-pad-index" $ do
109
      indicesA >>= need
110 111
      indicesA >>=
        writeSketchPadIndex ((directories ^. public) </> "sketch-pad.yaml")
112
    --
113
    phony "index" $ need ["support", index]
114
    --
115 116 117
    priority 2 $
      "//*-deck.html" %> \out -> do
        src <- calcSource "-deck.html" "-deck.md" out
118 119 120 121 122 123 124 125
        let ind = replaceSuffix "-deck.html" "-deck-index.yaml" out
        markdownToHtmlDeck src out ind
    --
    priority 2 $
      "//*-deck-index.yaml" %> \ind -> do
        src <- calcSource "-deck-index.yaml" "-deck.md" ind
        let out = replaceSuffix "-deck-index.yaml" "-deck.html" ind
        markdownToHtmlDeck src out ind
126
    --
127 128 129 130
    priority 2 $
      "//*-deck.pdf" %> \out -> do
        let src = replaceSuffix "-deck.pdf" "-deck.html" out
        need [src]
131
        putNormal $ "Started: " ++ src ++ " -> " ++ out
132
        runHttpServer serverPort directories Nothing
133 134
        result <-
          liftIO $
135 136 137
          launchChrome
            (serverUrl </> makeRelative (directories ^. public) src)
            out
138 139 140
        case result of
          Right msg -> putNormal msg
          Left msg -> error msg
141
    --
142 143 144 145
    priority 2 $
      "//*-handout.html" %> \out -> do
        src <- calcSource "-handout.html" "-deck.md" out
        markdownToHtmlHandout src out
146
    --
147 148 149 150
    priority 2 $
      "//*-handout.pdf" %> \out -> do
        src <- calcSource "-handout.pdf" "-deck.md" out
        markdownToPdfHandout src out
151
    --
152 153 154 155
    priority 2 $
      "//*-page.html" %> \out -> do
        src <- calcSource "-page.html" "-page.md" out
        markdownToHtmlPage src out
156
    --
157 158 159 160
    priority 2 $
      "//*-page.pdf" %> \out -> do
        src <- calcSource "-page.pdf" "-page.md" out
        markdownToPdfPage src out
161
    --
162 163 164 165 166 167 168 169
    priority 2 $
      index %> \out -> do
        exists <- Development.Shake.doesFileExist indexSource
        let src =
              if exists
                then indexSource
                else indexSource <.> "generated"
        markdownToHtmlPage src out
170
    --
171 172
    indexSource <.> "generated" %> \out ->
      writeIndexLists out (takeDirectory index)
173
    --
174 175 176 177
    priority 2 $
      "//*.dot.svg" %> \out -> do
        let src = dropExtension out
        need [src]
178
        dot [("-o" ++ out), src]
179 180 181 182 183
    --
    priority 2 $
      "//*.gnuplot.svg" %> \out -> do
        let src = dropExtension out
        need [src]
184
        gnuplot ["-e", "set output \"" ++ out ++ "\"", src]
185
    --
Henrik Tramberend's avatar
Henrik Tramberend committed
186 187 188 189 190 191
    priority 2 $
      "//*.tex.svg" %> \out -> do
        let src = dropExtension out
        let pdf = src -<.> ".pdf"
        let dir = takeDirectory src
        need [src]
192 193
        pdflatex ["-output-directory", dir, src]
        pdf2svg [pdf, out]
194
        liftIO $ removeFile pdf
Henrik Tramberend's avatar
Henrik Tramberend committed
195
    --
196
    phony "clean" $ do
197 198
      removeFilesAfter (directories ^. public) ["//"]
      removeFilesAfter (directories ^. project) cruft
199 200
      old <- liftIO getOldResources
      forM_ old $ \dir -> removeFilesAfter dir ["//"]
201
      when (isDevelopmentVersion && not hasPreextractedResources) $
202
        removeFilesAfter (directories ^. appData) ["//"]
203
    --
204 205 206
    phony "help" $ do
      text <- liftIO $ getResourceString "template/help-page.md"
      liftIO $ putStr text
207
    --
208 209 210 211 212
    phony "info" $ do
      putNormal $ "\nproject directory: " ++ (directories ^. project)
      putNormal $ "public directory: " ++ (directories ^. public)
      putNormal $ "support directory: " ++ (directories ^. support)
      putNormal $ "application data directory: " ++ (directories ^. appData)
Henrik Tramberend's avatar
Henrik Tramberend committed
213
      putNormal "\ntargets:\n"
214
      allHtmlA <++> allPdfA >>= mapM_ putNormal
215
      putNormal "\ntop level meta data:\n"
216
      groom <$> metaA >>= putNormal
217
    --
218
    phony "support" $ do
219 220 221
      metaData <- metaA
      unlessM (Development.Shake.doesDirectoryExist (directories ^. support)) $ do
        liftIO $ createDirectoryIfMissing True (directories ^. public)
222 223 224
        case metaValueAsString "provisioning" metaData of
          Just value
            | value == show SymLink ->
225 226 227 228
              liftIO $
              createFileLink
                ((directories ^. appData) </> "support")
                (directories ^. support)
229 230
          Just value
            | value == show Copy ->
231 232 233 234
              liftIO $
              copyDir
                ((directories ^. appData) </> "support")
                (directories ^. support)
235
          Nothing ->
236
            liftIO $
237 238 239 240 241 242 243 244 245
            case defaultProvisioning of
              SymLink ->
                createFileLink
                  ((directories ^. appData) </> "support")
                  (directories ^. support)
              _ ->
                copyDir
                  ((directories ^. appData) </> "support")
                  (directories ^. support)
246
          _ -> return ()
247
    --
248 249
    phony "check" checkExternalPrograms
    --
250
    phony "publish" $ do
251
      need ["index"]
252
      allHtmlA >>= need
253
      metaData <- metaA
254 255 256 257
      let host = metaValueAsString "rsync-destination.host" metaData
      let path = metaValueAsString "rsync-destination.path" metaData
      if isJust host && isJust path
        then do
258
          let src = (directories ^. public) ++ "/"
259
          let dst = intercalate ":" [fromJust host, fromJust path]
260 261
          ssh [(fromJust host), "mkdir -p", (fromJust path)]
          rsync [src, dst]
262
        else throw RsyncUrlException