Decker.hs 8.16 KB
Newer Older
1
{-- Author: Henrik Tramberend <henrik@tramberend.de> --}
2
import Action
3
import Common
4
import Context
5
import Control.Exception
6
import Control.Monad (when)
7
import Control.Monad.Extra
Henrik Tramberend's avatar
Henrik Tramberend committed
8
import Data.Aeson
9 10 11 12
import Data.IORef ()
import Data.List
import Data.Maybe
import Data.String ()
Henrik Tramberend's avatar
Henrik Tramberend committed
13
import Data.Version
14 15
import Development.Shake
import Development.Shake.FilePath
16
import Exception
17
import External
18
import GHC.Conc (numCapabilities)
19
import Project
20
import Resources
Henrik Tramberend's avatar
Henrik Tramberend committed
21
import System.Directory (createDirectoryIfMissing, createFileLink, removeFile)
22
import System.FilePath ()
23
import Text.Groom
24
import qualified Text.Mustache as M ()
Henrik Tramberend's avatar
Henrik Tramberend committed
25 26
import Text.Pandoc
import Text.Pandoc.Definition
27 28
import Text.Printf ()
import Utilities
Henrik Tramberend's avatar
Henrik Tramberend committed
29

30
main :: IO ()
Henrik Tramberend's avatar
Henrik Tramberend committed
31
main = do
32
  extractResources
33
  dirs <- projectDirectories
34
  --
Henrik Tramberend's avatar
Henrik Tramberend committed
35 36 37
  let projectDir = project dirs
  let publicDir = public dirs
  let supportDir = support dirs
38
  let appDataDir = appData dirs
Henrik Tramberend's avatar
Henrik Tramberend committed
39
  let serverPort = 8888
40
  let serverUrl = "http://localhost:" ++ (show serverPort)
41 42 43 44 45 46 47 48 49 50 51 52 53 54 55
  -- 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"
  let pageSourcesA = globA "**/*-page.md"
  let allSourcesA = deckSourcesA <++> pageSourcesA
  let allMarkdownA = globA "**/*.md"
  let allImagesA = globA "**/*.png" <++> globA "**/*.jpg"
  let metaA = globA "**/*-meta.yaml"
  -- Calculate targets
  let decksA = deckSourcesA >>= calcTargets ".md" ".html"
  let decksPdfA = deckSourcesA >>= calcTargets ".md" ".pdf"
  let handoutsA = deckSourcesA >>= calcTargets "-deck.md" "-handout.html"
  let handoutsPdfA = deckSourcesA >>= calcTargets "-deck.md" "-handout.pdf"
  let pagesA = pageSourcesA >>= calcTargets ".md" ".html"
  let pagesPdfA = pageSourcesA >>= calcTargets ".md" ".pdf"
Henrik Tramberend's avatar
Henrik Tramberend committed
56
  let indexSource = project dirs </> "index.md"
57 58 59 60
  let index = publicDir </> "index.html"
  let indexA = return [index] :: Action [FilePath]
  let everythingA = decksA <++> handoutsA <++> pagesA
  let everythingPdfA = decksPdfA <++> handoutsPdfA <++> pagesPdfA
Henrik Tramberend's avatar
Henrik Tramberend committed
61
  let cruft = ["index.md.generated", "log", "//.shake", "generated", "code"]
62
  context <- makeActionContext dirs
Henrik Tramberend's avatar
Henrik Tramberend committed
63
  runShakeInContext context (options projectDir) $
64
  --
65 66
   do
    want ["html"]
67
    --
Henrik Tramberend's avatar
Henrik Tramberend committed
68
    phony "version" $ do
69 70
      putNormal $
        "decker version " ++ deckerVersion ++ " (" ++ deckerGitBranch ++ ")"
Henrik Tramberend's avatar
Henrik Tramberend committed
71 72
      putNormal $ "pandoc version " ++ pandocVersion
      putNormal $ "pandoc-types version " ++ showVersion pandocTypesVersion
73
    --
74 75
    phony "decks" $ do
      need ["support"]
76
      decksA >>= need
77
    --
78 79
    phony "html" $ do
      need ["support"]
80
      everythingA <++> indexA >>= need
81
    --
82 83
    phony "pdf" $
      decksPdfA <++> pagesPdfA <++> handoutsPdfA <++> indexA >>= need
84
    --
85
    phony "pdf-decks" $ decksPdfA <++> indexA >>= need
86
    --
87 88 89
    phony "watch" $ do
      need ["html"]
      allMarkdownA <++> metaA <++> allImagesA >>= watchFiles
90
    --
91 92
    phony "open" $ do
      need ["html"]
93
      openBrowser index
94
    --
95
    phony "server" $ do
96
      need ["watch"]
97
      runHttpServer serverPort dirs Nothing
98
    --
99
    phony "example" writeExampleProject
100
    --
101
    phony "index" $ need [index, "support"]
102
    --
103 104 105 106
    priority 2 $
      "//*-deck.html" %> \out -> do
        src <- calcSource "-deck.html" "-deck.md" out
        markdownToHtmlDeck src out
107
    --
108 109 110 111 112
    priority 2 $
      "//*-deck.pdf" %> \out -> do
        let src = replaceSuffix "-deck.pdf" "-deck.html" out
        need [src]
        putNormal $ src ++ " -> " ++ out
Henrik Tramberend's avatar
Henrik Tramberend committed
113
        runHttpServer serverPort dirs Nothing
114
        decktape [(serverUrl </> makeRelative publicDir src), out]
115
    --
116 117 118 119
    priority 2 $
      "//*-handout.html" %> \out -> do
        src <- calcSource "-handout.html" "-deck.md" out
        markdownToHtmlHandout src out
120
    --
121 122 123 124
    priority 2 $
      "//*-handout.pdf" %> \out -> do
        src <- calcSource "-handout.pdf" "-deck.md" out
        markdownToPdfHandout src out
125
    --
126 127 128 129
    priority 2 $
      "//*-page.html" %> \out -> do
        src <- calcSource "-page.html" "-page.md" out
        markdownToHtmlPage src out
130
    --
131 132 133 134
    priority 2 $
      "//*-page.pdf" %> \out -> do
        src <- calcSource "-page.pdf" "-page.md" out
        markdownToPdfPage src out
135
    --
136 137 138 139 140 141 142 143
    priority 2 $
      index %> \out -> do
        exists <- Development.Shake.doesFileExist indexSource
        let src =
              if exists
                then indexSource
                else indexSource <.> "generated"
        markdownToHtmlPage src out
144
    --
Henrik Tramberend's avatar
Henrik Tramberend committed
145
    indexSource <.> "generated" %> \out
146 147
      -- deckSources <- deckSourcesA
      -- pageSources <- pageSourcesA
Henrik Tramberend's avatar
Henrik Tramberend committed
148
     -> do
149
      decks <- decksA
150 151
      decksPdf <- decksPdfA
      pagesPdf <- pagesPdfA
152
      handouts <- handoutsA
153
      handoutsPdf <- handoutsPdfA
154
      pages <- pagesA
155 156 157
      -- let deckData =
      --      transpose [deckSources, decks, handouts, decksPdf, handoutsPdf]
      -- let pageData = transpose [pageSources, pages, pagesPdf]
158
      need $ decks ++ handouts ++ pages
159 160 161 162 163 164 165 166
      writeIndexLists
        out
        (takeDirectory index)
        (zip decks decksPdf)
        (zip handouts handoutsPdf)
        (zip pages pagesPdf)
      -- writeIndexTable out (takeDirectory index) deckData pageData
      -- writeIndex out (takeDirectory index) decks handouts pages
167
    --
168 169 170 171
    priority 2 $
      "//*.dot.svg" %> \out -> do
        let src = dropExtension out
        need [src]
172
        dot [("-o" ++ out), src]
173 174 175 176 177
    --
    priority 2 $
      "//*.gnuplot.svg" %> \out -> do
        let src = dropExtension out
        need [src]
178
        gnuplot ["-e", "set output \"" ++ out ++ "\"", src]
179
    --
Henrik Tramberend's avatar
Henrik Tramberend committed
180 181 182 183 184 185
    priority 2 $
      "//*.tex.svg" %> \out -> do
        let src = dropExtension out
        let pdf = src -<.> ".pdf"
        let dir = takeDirectory src
        need [src]
186 187
        pdflatex ["-output-directory", dir, src]
        pdf2svg [pdf, out]
188
        liftIO $ removeFile pdf
Henrik Tramberend's avatar
Henrik Tramberend committed
189
    --
190 191 192
    phony "clean" $ do
      removeFilesAfter publicDir ["//"]
      removeFilesAfter projectDir cruft
193
      when isDevelopmentVersion $ removeFilesAfter appDataDir ["//"]
194
    --
195 196 197
    phony "help" $ do
      text <- liftIO $ getResourceString "template/help-page.md"
      liftIO $ putStr text
198
    --
199
    phony "plan" $ do
200
      metaData <- readMetaDataForDir projectDir
Henrik Tramberend's avatar
Henrik Tramberend committed
201
      putNormal $ "\nproject directory: " ++ projectDir
202 203
      putNormal $ "public directory: " ++ publicDir
      putNormal $ "support directory: " ++ supportDir
204
      putNormal $ "application data directory: " ++ appDataDir
Henrik Tramberend's avatar
Henrik Tramberend committed
205
      putNormal "\nmeta:\n"
206
      metaA >>= mapM_ putNormal
Henrik Tramberend's avatar
Henrik Tramberend committed
207
      putNormal "\nsources:\n"
208
      allSourcesA >>= mapM_ putNormal
Henrik Tramberend's avatar
Henrik Tramberend committed
209
      putNormal "\ntargets:\n"
210
      everythingA <++> everythingPdfA >>= mapM_ putNormal
211 212
      putNormal "\ntop level meta data:\n"
      putNormal $ groom metaData
213
    --
214 215 216 217 218 219 220
    phony "support" $ do
      metaData <- readMetaDataForDir projectDir
      unlessM (Development.Shake.doesDirectoryExist supportDir) $ do
        liftIO $ createDirectoryIfMissing True publicDir
        case metaValueAsString "provisioning" metaData of
          Just value
            | value == show SymLink ->
221
              liftIO $ createFileLink (appDataDir </> "support") supportDir
222 223 224 225
          Just value
            | value == show Copy ->
              rsync [(appDataDir </> "support/"), supportDir]
          Nothing ->
226
            liftIO $ createFileLink (appDataDir </> "support") supportDir
227
          _ -> return ()
228
    --
229 230
    phony "check" checkExternalPrograms
    --
231 232 233 234 235 236 237 238 239 240
    phony "publish" $ do
      need ["support"]
      everythingA <++> indexA >>= need
      metaData <- readMetaDataForDir projectDir
      let host = metaValueAsString "rsync-destination.host" metaData
      let path = metaValueAsString "rsync-destination.path" metaData
      if isJust host && isJust path
        then do
          let src = publicDir ++ "/"
          let dst = intercalate ":" [fromJust host, fromJust path]
241 242
          ssh [(fromJust host), "mkdir -p", (fromJust path)]
          rsync [src, dst]
243
        else throw RsyncUrlException
244

Henrik Tramberend's avatar
Henrik Tramberend committed
245
-- | Some constants that might need tweaking
Henrik Tramberend's avatar
Henrik Tramberend committed
246 247 248
options :: FilePath -> ShakeOptions
options projectDir =
  shakeOptions
Henrik Tramberend's avatar
Henrik Tramberend committed
249 250 251 252 253
    { shakeFiles = ".shake"
    , shakeColor = True
    , shakeThreads = numCapabilities
    , shakeAbbreviations = [(projectDir ++ "/", "")]
    }