filter.hs 10.5 KB
Newer Older
Henrik Tramberend's avatar
Henrik Tramberend committed
1 2
{-- Author: Henrik Tramberend <henrik@tramberend.de> --} 

Henrik Tramberend's avatar
Henrik Tramberend committed
3 4 5 6
{-# LANGUAGE OverloadedStrings #-}

module Filter
       (expandMacros, makeSlides, filterNotes, useCachedImages,
7
        escapeToFilePath, cachePandocImages, extractLocalImagePathes)
Henrik Tramberend's avatar
Henrik Tramberend committed
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 41 42
       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
43
embedYoutubeHtml args attr (vid,_) =
44
  RawInline (Format "html")
Henrik Tramberend's avatar
Henrik Tramberend committed
45
            (renderHtml html)
46
  where url =
Henrik Tramberend's avatar
Henrik Tramberend committed
47 48 49 50 51 52
          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
53
        wrapperStyle =
Henrik Tramberend's avatar
Henrik Tramberend committed
54 55
          printf "position:relative;padding-top:25px;padding-bottom:%f%%;height:0;"
                 (vidHeight / vidWidth * 100.0) :: String
56
        iframeStyle =
Henrik Tramberend's avatar
Henrik Tramberend committed
57
          "position:absolute;top:0;left:0;width:100%;height:100%;" :: String
58
        figureStyle (_,_,kv) =
Henrik Tramberend's avatar
Henrik Tramberend committed
59 60
          foldl (\s (k,v) -> s ++ printf "%s:%s;" k v :: String) "" kv
        figureClass (_,cls,_) = unwords cls
61
        html =
Henrik Tramberend's avatar
Henrik Tramberend committed
62 63 64 65 66 67 68 69 70 71 72
          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
73 74
youtube args attr target (Format f) _
  | f `elem` ["html","html5","revealjs"] = embedYoutubeHtml args attr target
75
youtube _ attr (vid,_) _ _ =
Henrik Tramberend's avatar
Henrik Tramberend committed
76 77 78 79 80
  Link nullAttr
       [Image attr
              [Str text]
              (imageUrl,"")]
       (videoUrl,"")
81
  where videoUrl =
Henrik Tramberend's avatar
Henrik Tramberend committed
82 83
          printf "https://www.youtube.com/embed/%s?iv_load_policy=3&disablekb=0&rel=0&modestbranding=1&autohide=1"
                 vid :: String
84
        imageUrl =
Henrik Tramberend's avatar
Henrik Tramberend committed
85 86 87
          printf "http://img.youtube.com/vi/%s/maxresdefault.jpg" vid :: String
        text = printf "YouTube: %s" vid :: String

88 89 90 91 92 93
fontAwesome :: MacroFunc
fontAwesome _ _ (iconName,_) (Format f) _
  | f `elem` ["html","html5","revealjs"] =
    RawInline (Format "html") $ "<i class=\"fa fa-" ++ iconName ++ "\"></i>"
fontAwesome _ _ (iconName,_) _ _ = Str $ "[" ++ iconName ++ "]"

Henrik Tramberend's avatar
Henrik Tramberend committed
94
metaValue :: MacroFunc
95
metaValue _ _ (key,_) _ meta =
Henrik Tramberend's avatar
Henrik Tramberend committed
96 97 98 99 100 101 102
  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
103
        lookup' (k:ks) (Just (MetaMap metaMap)) =
Henrik Tramberend's avatar
Henrik Tramberend committed
104 105 106 107 108 109
          lookup' ks (Map.lookup k metaMap)
        lookup' _ _ = Strikeout [Str key]

type MacroMap = Map.Map String MacroFunc

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

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

macroArg :: Int -> [String] -> String -> String
118
macroArg n args default_ =
Henrik Tramberend's avatar
Henrik Tramberend committed
119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134
  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
135
expand (Link attr text target) format meta =
Henrik Tramberend's avatar
Henrik Tramberend committed
136 137 138 139 140
  expand_ attr text target format meta
expand x _ _ = Just x

expand_
  :: Attr -> [Inline] -> Target -> Format -> Meta -> Maybe Inline
141
expand_ attr text target format meta =
Henrik Tramberend's avatar
Henrik Tramberend committed
142 143 144 145 146 147
  do name:args <- (parseMacro . unwords . onlyStrings) text
     func <- Map.lookup name macroMap
     return (func args attr target format meta)

expandInlineMacros
  :: Format -> Meta -> Inline -> Inline
148
expandInlineMacros format meta inline =
Henrik Tramberend's avatar
Henrik Tramberend committed
149 150 151
  fromMaybe inline (expand inline format meta)

expandMacros :: Maybe Format -> Pandoc -> Pandoc
152
expandMacros (Just format) doc@(Pandoc meta _) =
Henrik Tramberend's avatar
Henrik Tramberend committed
153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175
  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]
176
splitColumns slide@(header:body) =
Henrik Tramberend's avatar
Henrik Tramberend committed
177 178 179 180
  let columns = splitWhen isColumnBreak body
      count = length columns
  in if count > 1
        then header :
181
             concatMap (\(column,n) ->
Henrik Tramberend's avatar
Henrik Tramberend committed
182 183 184 185 186 187 188 189 190 191 192 193 194
                          [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]
195
fragmentRelated =
Henrik Tramberend's avatar
Henrik Tramberend committed
196 197 198 199 200 201 202
  ["fragment"
  ,"grow"
  ,"shrink"
  ,"roll-in"
  ,"fade-in"
  ,"fade-out"
  ,"current-visible"
Henrik Tramberend's avatar
Henrik Tramberend committed
203
  ,"highlight-current-blue"
Henrik Tramberend's avatar
Henrik Tramberend committed
204 205 206 207 208 209 210 211 212 213
  ,"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
214
        wrap (Header 2 (id_,cls,kvs) text:blocks) =
Henrik Tramberend's avatar
Henrik Tramberend committed
215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239
          [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
240
makeSlides (Just (Format "revealjs")) =
Henrik Tramberend's avatar
Henrik Tramberend committed
241 242
  walk (mapSlides splitColumns) .
  walk (mapSlides wrapBoxes) . walk (mapSlides wrapNoteRevealjs)
243
makeSlides (Just (Format "beamer")) =
Henrik Tramberend's avatar
Henrik Tramberend committed
244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265
  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
266
  where repl c =
Henrik Tramberend's avatar
Henrik Tramberend committed
267 268 269 270
          if c `elem` [':','!','/']
             then '|'
             else c

271 272
useCachedImages :: FilePath -> Inline -> IO Inline
useCachedImages cacheDir img@(Image (ident,cls,values) inlines (url,title)) =
Henrik Tramberend's avatar
Henrik Tramberend committed
273 274 275 276 277 278 279
  do let cached = cacheDir </> escapeToFilePath url
     exists <- doesFileExist cached
     if exists
        then return (Image (ident,"cached" : cls,values)
                           inlines
                           (cached,title))
        else return img
280 281 282 283 284 285 286 287 288 289 290 291 292 293 294
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
295 296

cachePandocImages
297 298 299 300 301 302
  :: 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
303

304
cachePandocImages _ inline = return inline
Henrik Tramberend's avatar
Henrik Tramberend committed
305 306

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