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

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

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