Filter.hs 11.2 KB
Newer Older
1
{-- Author: Henrik Tramberend <henrik@tramberend.de> --}
Henrik Tramberend's avatar
Henrik Tramberend committed
2 3 4
{-# LANGUAGE OverloadedStrings #-}

module Filter
5 6 7 8 9 10 11
  ( expandMacros
  , makeSlides
  , filterNotes
  , useCachedImages
  , escapeToFilePath
  , cachePandocImages
  , extractLocalImagePathes
12 13
  , renderImageVideo
  , isMacro
14
  ) where
Henrik Tramberend's avatar
Henrik Tramberend committed
15

16
import qualified Data.ByteString.Lazy.Char8 as L8
Henrik Tramberend's avatar
Henrik Tramberend committed
17 18 19 20 21
import Data.Default ()
import Data.List.Split
import qualified Data.Map as Map (Map, fromList, lookup)
import Data.Maybe
import Debug.Trace
22 23 24 25 26
import Network.HTTP.Conduit
import Network.HTTP.Simple
import Network.URI
import System.Directory
import System.FilePath
27
import System.FilePath.Posix
Henrik Tramberend's avatar
Henrik Tramberend committed
28 29
import Text.Blaze (customAttribute)
import Text.Blaze.Html.Renderer.String
30 31
import Text.Blaze.Html5 as H
       ((!), div, figure, iframe, p, source, stringTag, toValue, video)
Henrik Tramberend's avatar
Henrik Tramberend committed
32
import Text.Blaze.Html5.Attributes as A
33
       (alt, class_, height, id, src, style, title, width)
Henrik Tramberend's avatar
Henrik Tramberend committed
34 35
import Text.Pandoc.Definition ()
import Text.Pandoc.JSON
36
import Text.Pandoc.Shared
Henrik Tramberend's avatar
Henrik Tramberend committed
37 38 39 40 41 42 43 44 45 46 47
import Text.Pandoc.Walk
import Text.Printf
import Text.Read

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
48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77
embedYoutubeHtml :: [String] -> Attr -> Target -> Inline
embedYoutubeHtml args attr (vid, _) =
  RawInline (Format "html") (renderHtml html)
  where
    url =
      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
    wrapperStyle =
      printf
        "position:relative;padding-top:25px;padding-bottom:%f%%;height:0;"
        (vidHeight / vidWidth * 100.0) :: String
    iframeStyle =
      "position:absolute;top:0;left:0;width:100%;height:100%;" :: String
    figureStyle (_, _, kv) =
      foldl (\s (k, v) -> s ++ printf "%s:%s;" k v :: String) "" kv
    figureClass (_, cls, _) = unwords cls
    html =
      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" "" $
78
      H.p ""
Henrik Tramberend's avatar
Henrik Tramberend committed
79 80

youtube :: MacroFunc
81
youtube args attr target (Format f) _
82 83 84 85 86 87 88 89 90 91 92
  | f `elem` ["html", "html5", "revealjs"] = embedYoutubeHtml args attr target
youtube _ attr (vid, _) _ _ =
  Link nullAttr [Image attr [Str text] (imageUrl, "")] (videoUrl, "")
  where
    videoUrl =
      printf
        "https://www.youtube.com/embed/%s?iv_load_policy=3&disablekb=0&rel=0&modestbranding=1&autohide=1"
        vid :: String
    imageUrl =
      printf "http://img.youtube.com/vi/%s/maxresdefault.jpg" vid :: String
    text = printf "YouTube: %s" vid :: String
Henrik Tramberend's avatar
Henrik Tramberend committed
93

94
fontAwesome :: MacroFunc
95 96
fontAwesome _ _ (iconName, _) (Format f) _
  | f `elem` ["html", "html5", "revealjs"] =
97
    RawInline (Format "html") $ "<i class=\"fa fa-" ++ iconName ++ "\"></i>"
98
fontAwesome _ _ (iconName, _) _ _ = Str $ "[" ++ iconName ++ "]"
99

Henrik Tramberend's avatar
Henrik Tramberend committed
100
metaValue :: MacroFunc
101
metaValue _ _ (key, _) _ meta =
Henrik Tramberend's avatar
Henrik Tramberend committed
102 103 104
  case splitOn "." key of
    [] -> Str key
    k:ks -> lookup' ks (lookupMeta k meta)
105 106 107 108 109 110
  where
    lookup' :: [String] -> Maybe MetaValue -> Inline
    lookup' [] (Just (MetaString s)) = Str s
    lookup' [] (Just (MetaInlines i)) = Span nullAttr i
    lookup' (k:ks) (Just (MetaMap metaMap)) = lookup' ks (Map.lookup k metaMap)
    lookup' _ _ = Strikeout [Str key]
Henrik Tramberend's avatar
Henrik Tramberend committed
111 112 113 114

type MacroMap = Map.Map String MacroFunc

macroMap :: MacroMap
115
macroMap =
116
  Map.fromList [("meta", metaValue), ("youtube", youtube), ("fa", fontAwesome)]
Henrik Tramberend's avatar
Henrik Tramberend committed
117

118
readDefault :: Read a => a -> String -> a
Henrik Tramberend's avatar
Henrik Tramberend committed
119 120 121
readDefault default_ string = fromMaybe default_ (readMaybe string)

macroArg :: Int -> [String] -> String -> String
122
macroArg n args default_ =
Henrik Tramberend's avatar
Henrik Tramberend committed
123
  if length args > n
124 125
    then args !! n
    else default_
Henrik Tramberend's avatar
Henrik Tramberend committed
126 127 128 129 130 131

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

132 133 134 135
isMacro :: String -> Bool
isMacro (pre:_) = pre == ':'
isMacro _ = False

Henrik Tramberend's avatar
Henrik Tramberend committed
136 137
onlyStrings :: [Inline] -> [String]
onlyStrings = reverse . foldl only []
138 139 140
  where
    only ss (Str s) = s : ss
    only ss _ = ss
Henrik Tramberend's avatar
Henrik Tramberend committed
141

142
expand :: Inline -> Format -> Meta -> Maybe Inline
143
expand (Link attr text target) format meta =
Henrik Tramberend's avatar
Henrik Tramberend committed
144 145 146
  expand_ attr text target format meta
expand x _ _ = Just x

147 148
expand_ :: Attr -> [Inline] -> Target -> Format -> Meta -> Maybe Inline
expand_ attr text target format meta = do
149
  name:args <- parseMacro $ stringify text
150 151
  func <- Map.lookup name macroMap
  return (func args attr target format meta)
Henrik Tramberend's avatar
Henrik Tramberend committed
152

153
expandInlineMacros :: Format -> Meta -> Inline -> Inline
154
expandInlineMacros format meta inline =
Henrik Tramberend's avatar
Henrik Tramberend committed
155 156 157
  fromMaybe inline (expand inline format meta)

expandMacros :: Maybe Format -> Pandoc -> Pandoc
158
expandMacros (Just format) doc@(Pandoc meta _) =
Henrik Tramberend's avatar
Henrik Tramberend committed
159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177
  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
178
columnClass = ("", ["column"], [])
Henrik Tramberend's avatar
Henrik Tramberend committed
179 180 181

-- Splits the body of a slide into any number of columns.
splitColumns :: [Block] -> [Block]
182
splitColumns slide@(header:body) =
Henrik Tramberend's avatar
Henrik Tramberend committed
183 184 185
  let columns = splitWhen isColumnBreak body
      count = length columns
  in if count > 1
186 187 188 189 190 191 192 193 194 195 196 197 198 199
       then header :
            concatMap
              (\(column, n) ->
                 [ Div
                     ( ""
                     , [ "slide-column"
                       , printf "column-%d" n
                       , printf "columns-%d" count
                       ]
                     , [])
                     column
                 ])
              (Prelude.zip columns [(1 :: Int) ..])
       else slide
Henrik Tramberend's avatar
Henrik Tramberend committed
200 201 202
splitColumns [] = []

-- All fragment related classes from reveal.js have to be moved to the enclosing
203 204
-- DIV element. Otherwise to many fragments are produced.
fragmentRelated :: [String]
205
fragmentRelated =
206 207 208 209 210 211 212 213 214 215 216 217
  [ "fragment"
  , "grow"
  , "shrink"
  , "roll-in"
  , "fade-in"
  , "fade-out"
  , "current-visible"
  , "highlight-current-blue"
  , "highlight-red"
  , "highlight-green"
  , "highlight-blu"
  ]
Henrik Tramberend's avatar
Henrik Tramberend committed
218 219 220 221 222 223

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

wrapBoxes :: [Block] -> [Block]
wrapBoxes (header:body) = header : concatMap wrap boxes
224 225 226 227 228 229 230 231
  where
    boxes = split (keepDelimsL $ whenElt isBoxDelim) body
    wrap (Header 2 (id_, cls, kvs) text:blocks) =
      [ Div
          (id_ ++ "-box", "box" : cls, [])
          (Header 2 (id_, deFragment cls, kvs) text : blocks)
      ]
    wrap box = box
Henrik Tramberend's avatar
Henrik Tramberend committed
232 233 234 235 236
wrapBoxes [] = []

-- Wrap headers with class notes into a DIV and promote all header attributes
-- to the DIV.
wrapNoteRevealjs :: [Block] -> [Block]
237 238
wrapNoteRevealjs slide@(Header 1 (id_, cls, kvs) inlines:body)
  | "notes" `elem` cls = [Div (id_, cls, kvs) slide]
Henrik Tramberend's avatar
Henrik Tramberend committed
239 240 241 242 243
wrapNoteRevealjs slide = slide

-- Wrap headers with class notes into a DIV and promote all header attributes
-- to the DIV.
wrapNoteBeamer :: [Block] -> [Block]
244
wrapNoteBeamer slide@(Header 1 (_, cls, _) _:_)
Henrik Tramberend's avatar
Henrik Tramberend committed
245 246 247
  | "notes" `elem` cls = [Div nullAttr slide]
wrapNoteBeamer slide = slide

248
mapSlides :: ([Block] -> [Block]) -> Pandoc -> Pandoc
Henrik Tramberend's avatar
Henrik Tramberend committed
249
mapSlides func (Pandoc meta blocks) = Pandoc meta (concatMap func slides)
250 251
  where
    slides = split (keepDelimsL $ whenElt isSlideHeader) blocks
Henrik Tramberend's avatar
Henrik Tramberend committed
252 253

makeSlides :: Maybe Format -> Pandoc -> Pandoc
254
makeSlides (Just (Format "revealjs")) =
Henrik Tramberend's avatar
Henrik Tramberend committed
255 256
  walk (mapSlides splitColumns) .
  walk (mapSlides wrapBoxes) . walk (mapSlides wrapNoteRevealjs)
257
makeSlides (Just (Format "beamer")) =
Henrik Tramberend's avatar
Henrik Tramberend committed
258 259
  walk (mapSlides splitColumns) .
  walk (mapSlides wrapBoxes) . walk (mapSlides wrapNoteBeamer)
260
makeSlides _ = Prelude.id
Henrik Tramberend's avatar
Henrik Tramberend committed
261 262 263 264

-- 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]
265
filterSlides slide@(Header 1 (_, cls, _) _:_)
Henrik Tramberend's avatar
Henrik Tramberend committed
266 267
  | "notes" `elem` cls = slide
filterSlides (_:body) = concatMap filter boxes
268 269 270 271 272
  where
    boxes = split (keepDelimsL $ whenElt isBoxDelim) body
    filter box@(Header _ (_, cls, _) _:_)
      | "notes" `elem` cls = box
    filter _ = []
Henrik Tramberend's avatar
Henrik Tramberend committed
273 274 275 276
filterSlides _ = []

filterNotes :: Maybe Format -> Pandoc -> Pandoc
filterNotes (Just (Format _)) = walk (mapSlides filterSlides)
277
filterNotes _ = Prelude.id
Henrik Tramberend's avatar
Henrik Tramberend committed
278 279 280

escapeToFilePath :: String -> FilePath
escapeToFilePath = map repl
281 282 283 284 285
  where
    repl c =
      if c `elem` [':', '!', '/']
        then '|'
        else c
Henrik Tramberend's avatar
Henrik Tramberend committed
286

287
useCachedImages :: FilePath -> Inline -> IO Inline
288 289 290 291 292 293
useCachedImages cacheDir img@(Image (ident, cls, values) inlines (url, title)) = do
  let cached = cacheDir </> escapeToFilePath url
  exists <- doesFileExist cached
  if exists
    then return (Image (ident, "cached" : cls, values) inlines (cached, title))
    else return img
294 295 296
useCachedImages _ inline = return inline

localImagePath :: Inline -> [FilePath]
297 298 299 300
localImagePath (Image _ _ (url, _)) =
  if isHttpUri url
    then []
    else [url]
301 302 303
localImagePath _ = []

extractLocalImagePathes :: Pandoc -> [FilePath]
304
extractLocalImagePathes pandoc = Text.Pandoc.Walk.query localImagePath pandoc
305 306 307 308

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

312 313 314 315 316
cachePandocImages :: FilePath -> Inline -> IO Inline
cachePandocImages base img@(Image _ _ (url, _))
  | isHttpUri url = do
    cacheImageIO url base
    return img
317 318
  | otherwise = return img
cachePandocImages _ inline = return inline
Henrik Tramberend's avatar
Henrik Tramberend committed
319

320
-- | Downloads the image behind the URI and saves it locally. Returns the path of
321
-- the cached file relative to the base directory.
322 323 324 325 326 327 328 329
cacheImageIO :: String -> FilePath -> IO ()
cacheImageIO uri cacheDir = do
  request <- parseRequest uri
  result <- httpLBS request
  let body = getResponseBody result
  let cacheFile = cacheDir </> escapeToFilePath uri
  createDirectoryIfMissing True cacheDir
  L8.writeFile cacheFile body
330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349

-- File extensions that signify video content.
videoExtensions =
  [".mp4", ".webm", ".ogg", ".avi", ".dv", ".mp2", ".mov", ".qt"]

-- Renders an image with a video reference to a video tag in raw HTML. Faithfully
-- transfers attributes to the video tag.
renderImageVideo :: Inline -> Inline
renderImageVideo image@(Image (ident, cls, values) inlines (url, tit)) =
  if takeExtension url `elem` videoExtensions
    then RawInline (Format "html") (renderHtml videoTag)
    else image
  where
    appendAttr element (key, value) =
      element ! customAttribute (stringTag key) (toValue value)
    videoTag =
      foldl appendAttr video values ! A.id (toValue ident) !
      class_ (toValue $ unwords cls) !
      alt (toValue $ stringify inlines) !
      title (toValue tit) $ do source ! src (toValue url)