filter.hs 10.3 KB
Newer Older
Henrik Tramberend's avatar
Henrik Tramberend committed
1
2
3
4
{-# LANGUAGE OverloadedStrings #-}

module Filter
       (expandMacros, makeSlides, filterNotes, useCachedImages,
5
        escapeToFilePath, cachePandocImages, extractLocalImagePathes)
Henrik Tramberend's avatar
Henrik Tramberend committed
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
       where

import Data.Default ()
import Data.List.Split
import qualified Data.Map as Map (Map, fromList, lookup)
import Data.Maybe
import Debug.Trace
import Text.Blaze (customAttribute)
import Text.Blaze.Html.Renderer.String
import Text.Blaze.Html5 as H (div, figure, iframe, p, toValue, (!))
import Text.Blaze.Html5.Attributes as A
       (class_, height, src, style, width)
import Text.Pandoc.Definition ()
import Text.Pandoc.JSON
import Text.Pandoc.Walk
import Text.Printf
import Text.Read
import System.Directory
import System.FilePath
import qualified Data.ByteString.Char8 as B
import qualified Data.ByteString.Lazy as LB
import qualified Data.ByteString.Lazy.Char8 as L8
import Network.HTTP.Conduit
import Network.HTTP.Simple
import Network.URI

type MacroFunc = [String] -> Attr -> Target -> Format -> Meta -> Inline

-- iframe resizing, see:
-- https://css-tricks.com/NetMag/FluidWidthVideo/Article-FluidWidthVideo.php
-- YouTube links: iv_load_policy=3 disables annotations, rel=0 disables related
-- videos. See:
-- https://developers.google.com/youtube/player_parameters?hl=de#IFrame_Player_API
embedYoutubeHtml
  :: [String] -> Attr -> Target -> Inline
41
embedYoutubeHtml args attr (vid,_) =
Henrik Tramberend's avatar
Henrik Tramberend committed
42
43
  RawInline (Format "HTML")
            (renderHtml html)
44
  where url =
Henrik Tramberend's avatar
Henrik Tramberend committed
45
46
47
48
49
50
          printf "https://www.youtube.com/embed/%s?iv_load_policy=3&disablekb=1&rel=0&modestbranding=1&autohide=1"
                 vid :: String
        vidWidthStr = macroArg 0 args "560"
        vidHeightStr = macroArg 1 args "315"
        vidWidth = readDefault 560.0 vidWidthStr :: Float
        vidHeight = readDefault 315.0 vidHeightStr :: Float
51
        wrapperStyle =
Henrik Tramberend's avatar
Henrik Tramberend committed
52
53
          printf "position:relative;padding-top:25px;padding-bottom:%f%%;height:0;"
                 (vidHeight / vidWidth * 100.0) :: String
54
        iframeStyle =
Henrik Tramberend's avatar
Henrik Tramberend committed
55
          "position:absolute;top:0;left:0;width:100%;height:100%;" :: String
56
        figureStyle (_,_,kv) =
Henrik Tramberend's avatar
Henrik Tramberend committed
57
58
          foldl (\s (k,v) -> s ++ printf "%s:%s;" k v :: String) "" kv
        figureClass (_,cls,_) = unwords cls
59
        html =
Henrik Tramberend's avatar
Henrik Tramberend committed
60
61
62
63
64
65
66
67
68
69
70
71
          H.figure ! class_ (toValue (figureClass attr)) !
          style (toValue (figureStyle attr)) $
          H.div ! style (toValue wrapperStyle) $
          iframe ! style (toValue iframeStyle) ! width (toValue vidWidthStr) !
          height (toValue vidHeightStr) !
          src (toValue url) !
          customAttribute "frameborder" "0" !
          customAttribute "allowfullscreen" "" $
          p ""

youtube :: MacroFunc
youtube args attr target (Format "html") _ = embedYoutubeHtml args attr target
72
youtube args attr target (Format "revealjs") _ =
Henrik Tramberend's avatar
Henrik Tramberend committed
73
  embedYoutubeHtml args attr target
74
youtube _ attr (vid,_) _ _ =
Henrik Tramberend's avatar
Henrik Tramberend committed
75
76
77
78
79
  Link nullAttr
       [Image attr
              [Str text]
              (imageUrl,"")]
       (videoUrl,"")
80
  where videoUrl =
Henrik Tramberend's avatar
Henrik Tramberend committed
81
82
          printf "https://www.youtube.com/embed/%s?iv_load_policy=3&disablekb=0&rel=0&modestbranding=1&autohide=1"
                 vid :: String
83
        imageUrl =
Henrik Tramberend's avatar
Henrik Tramberend committed
84
85
86
87
          printf "http://img.youtube.com/vi/%s/maxresdefault.jpg" vid :: String
        text = printf "YouTube: %s" vid :: String

metaValue :: MacroFunc
88
metaValue _ _ (key,_) _ meta =
Henrik Tramberend's avatar
Henrik Tramberend committed
89
90
91
92
93
94
95
  case splitOn "." key of
    [] -> Str key
    k:ks -> lookup' ks (lookupMeta k meta)
  where lookup'
          :: [String] -> Maybe MetaValue -> Inline
        lookup' [] (Just (MetaString s)) = Str s
        lookup' [] (Just (MetaInlines i)) = Span nullAttr i
96
        lookup' (k:ks) (Just (MetaMap metaMap)) =
Henrik Tramberend's avatar
Henrik Tramberend committed
97
98
99
100
101
102
103
104
105
106
107
108
109
          lookup' ks (Map.lookup k metaMap)
        lookup' _ _ = Strikeout [Str key]

type MacroMap = Map.Map String MacroFunc

macroMap :: MacroMap
macroMap = Map.fromList [("meta",metaValue),("youtube",youtube)]

readDefault :: Read a
            => a -> String -> a
readDefault default_ string = fromMaybe default_ (readMaybe string)

macroArg :: Int -> [String] -> String -> String
110
macroArg n args default_ =
Henrik Tramberend's avatar
Henrik Tramberend committed
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
  if length args > n
     then args !! n
     else default_

parseMacro :: String -> Maybe [String]
parseMacro (pre:invocation)
  | pre == ':' = Just (words invocation)
parseMacro _ = Nothing

onlyStrings :: [Inline] -> [String]
onlyStrings = reverse . foldl only []
  where only ss (Str s) = s : ss
        only ss _ = ss

expand
  :: Inline -> Format -> Meta -> Maybe Inline
127
expand (Image attr text target) format meta =
Henrik Tramberend's avatar
Henrik Tramberend committed
128
  expand_ attr text target format meta
129
expand (Link attr text target) format meta =
Henrik Tramberend's avatar
Henrik Tramberend committed
130
131
132
133
134
  expand_ attr text target format meta
expand x _ _ = Just x

expand_
  :: Attr -> [Inline] -> Target -> Format -> Meta -> Maybe Inline
135
expand_ attr text target format meta =
Henrik Tramberend's avatar
Henrik Tramberend committed
136
137
138
139
140
141
  do name:args <- (parseMacro . unwords . onlyStrings) text
     func <- Map.lookup name macroMap
     return (func args attr target format meta)

expandInlineMacros
  :: Format -> Meta -> Inline -> Inline
142
expandInlineMacros format meta inline =
Henrik Tramberend's avatar
Henrik Tramberend committed
143
144
145
  fromMaybe inline (expand inline format meta)

expandMacros :: Maybe Format -> Pandoc -> Pandoc
146
expandMacros (Just format) doc@(Pandoc meta _) =
Henrik Tramberend's avatar
Henrik Tramberend committed
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
  walk (expandInlineMacros format meta) doc
expandMacros _ doc = doc

isSlideHeader :: Block -> Bool
isSlideHeader (Header level _ _) = level == 1
isSlideHeader _ = False

isBoxDelim :: Block -> Bool
isBoxDelim (Header level _ _) = level >= 2
isBoxDelim HorizontalRule = True
isBoxDelim _ = False

-- Column break is either "###" or "---"
isColumnBreak :: Block -> Bool
isColumnBreak (Header level _ _) = level == 3
isColumnBreak HorizontalRule = True
isColumnBreak _ = False

columnClass :: Attr
columnClass = ("",["column"],[])

-- Splits the body of a slide into any number of columns.
splitColumns :: [Block] -> [Block]
170
splitColumns slide@(header:body) =
Henrik Tramberend's avatar
Henrik Tramberend committed
171
172
173
174
  let columns = splitWhen isColumnBreak body
      count = length columns
  in if count > 1
        then header :
175
             concatMap (\(column,n) ->
Henrik Tramberend's avatar
Henrik Tramberend committed
176
177
178
179
180
181
182
183
184
185
186
187
188
                          [Div (""
                               ,["slide-column"
                                ,printf "column-%d" n
                                ,printf "columns-%d" count]
                               ,[])
                               column])
                       (Prelude.zip columns
                                    [(1 :: Int) ..])
        else slide
splitColumns [] = []

-- All fragment related classes from reveal.js have to be moved to the enclosing
-- DIV element. Otherwise to many fragments are produced.fragmentRelated :: [String]
189
fragmentRelated =
Henrik Tramberend's avatar
Henrik Tramberend committed
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
  ["fragment"
  ,"grow"
  ,"shrink"
  ,"roll-in"
  ,"fade-in"
  ,"fade-out"
  ,"current-visible"
  ," highlight-current-blue"
  ,"highlight-red"
  ,"highlight-green"
  ,"highlight-blu"]

deFragment :: [String] -> [String]
deFragment = filter (`notElem` fragmentRelated)

wrapBoxes :: [Block] -> [Block]
wrapBoxes (header:body) = header : concatMap wrap boxes
  where boxes = split (keepDelimsL $ whenElt isBoxDelim) body
208
        wrap (Header 2 (id_,cls,kvs) text:blocks) =
Henrik Tramberend's avatar
Henrik Tramberend committed
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
          [Div (id_ ++ "-box","box" : cls,[])
               (Header 2 (id_,deFragment cls,kvs) text : blocks)]
        wrap box = box
wrapBoxes [] = []

-- Wrap headers with class notes into a DIV and promote all header attributes
-- to the DIV.
wrapNoteRevealjs :: [Block] -> [Block]
wrapNoteRevealjs slide@(Header 1 (id_,cls,kvs) inlines:body)
  | "notes" `elem` cls = [Div (id_,cls,kvs) slide]
wrapNoteRevealjs slide = slide

-- Wrap headers with class notes into a DIV and promote all header attributes
-- to the DIV.
wrapNoteBeamer :: [Block] -> [Block]
wrapNoteBeamer slide@(Header 1 (_,cls,_) _:_)
  | "notes" `elem` cls = [Div nullAttr slide]
wrapNoteBeamer slide = slide

mapSlides
  :: ([Block] -> [Block]) -> Pandoc -> Pandoc
mapSlides func (Pandoc meta blocks) = Pandoc meta (concatMap func slides)
  where slides = split (keepDelimsL $ whenElt isSlideHeader) blocks

makeSlides :: Maybe Format -> Pandoc -> Pandoc
234
makeSlides (Just (Format "revealjs")) =
Henrik Tramberend's avatar
Henrik Tramberend committed
235
236
  walk (mapSlides splitColumns) .
  walk (mapSlides wrapBoxes) . walk (mapSlides wrapNoteRevealjs)
237
makeSlides (Just (Format "beamer")) =
Henrik Tramberend's avatar
Henrik Tramberend committed
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
  walk (mapSlides splitColumns) .
  walk (mapSlides wrapBoxes) . walk (mapSlides wrapNoteBeamer)
makeSlides _ = id

-- Only consider slides that have the 'notes' class in their header. In all
-- others pick only the boxes that are tagged as notes.
filterSlides :: [Block] -> [Block]
filterSlides slide@(Header 1 (_,cls,_) _:_)
  | "notes" `elem` cls = slide
filterSlides (_:body) = concatMap filter boxes
  where boxes = split (keepDelimsL $ whenElt isBoxDelim) body
        filter box@(Header _ (_,cls,_) _:_)
          | "notes" `elem` cls = box
        filter _ = []
filterSlides _ = []

filterNotes :: Maybe Format -> Pandoc -> Pandoc
filterNotes (Just (Format _)) = walk (mapSlides filterSlides)
filterNotes _ = id

escapeToFilePath :: String -> FilePath
escapeToFilePath = map repl
260
  where repl c =
Henrik Tramberend's avatar
Henrik Tramberend committed
261
262
263
264
          if c `elem` [':','!','/']
             then '|'
             else c

265
266
useCachedImages :: FilePath -> Inline -> IO Inline
useCachedImages cacheDir img@(Image (ident,cls,values) inlines (url,title)) =
Henrik Tramberend's avatar
Henrik Tramberend committed
267
268
269
270
271
272
273
  do let cached = cacheDir </> escapeToFilePath url
     exists <- doesFileExist cached
     if exists
        then return (Image (ident,"cached" : cls,values)
                           inlines
                           (cached,title))
        else return img
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
useCachedImages _ inline = return inline

localImagePath :: Inline -> [FilePath]
localImagePath (Image _ _ (url, _)) = if isHttpUri url then [] else [url]
localImagePath _ = []

extractLocalImagePathes :: Pandoc -> [FilePath]
extractLocalImagePathes pandoc =
  Text.Pandoc.Walk.query localImagePath pandoc

isHttpUri :: String -> Bool
isHttpUri url =
  case parseURI url of
    Just uri -> uriScheme uri `elem` ["http:","https:"]
    Nothing -> False
Henrik Tramberend's avatar
Henrik Tramberend committed
289
290

cachePandocImages
291
292
293
294
295
296
  :: FilePath -> Inline -> IO Inline
cachePandocImages base img@(Image _ _ (url,_))
  | isHttpUri url =
    do cacheImageIO url base
       return img
  | otherwise = return img
Henrik Tramberend's avatar
Henrik Tramberend committed
297

298
cachePandocImages _ inline = return inline
Henrik Tramberend's avatar
Henrik Tramberend committed
299
300

-- | Download the image behind the URI and save it locally. Return the path of
301
-- the cached file relative to the base directory.
Henrik Tramberend's avatar
Henrik Tramberend committed
302
cacheImageIO
303
304
305
306
  :: String -> FilePath -> IO ()
cacheImageIO uri cacheDir =
  do request <- parseRequest uri
     result <- httpLBS $ request
Henrik Tramberend's avatar
Henrik Tramberend committed
307
     let body = getResponseBody result
308
309
310
     let cacheFile = cacheDir </> escapeToFilePath uri
     createDirectoryIfMissing True cacheDir
     L8.writeFile cacheFile body