From 621f4a5c657a1c13981e849af4e5ccc97e947728 Mon Sep 17 00:00:00 2001
From: Stefan Dresselhaus <sdressel@techfak.uni-bielefeld.de>
Date: Thu, 27 Jul 2017 16:41:24 +0200
Subject: [PATCH] Added File-Detection to Media

---
 app/Media.hs              | 206 +++++++++++++++++++++++++-------------
 pandoc-slide-filter.cabal |   1 +
 2 files changed, 140 insertions(+), 67 deletions(-)

diff --git a/app/Media.hs b/app/Media.hs
index e2a71c8..9b3a4ac 100644
--- a/app/Media.hs
+++ b/app/Media.hs
@@ -4,82 +4,154 @@
 import Text.Pandoc.JSON
 import Control.Exception
 import Data.Monoid ((<>))
-import Data.List (partition)
+import Data.List (partition, elem)
+import System.FilePath
 
 main :: IO ()
 main = toJSONFilter media
 
-media :: Inline -> IO [Inline]
-media (Image ("audio",att,att') [] (filename,_))   = return $ [toHtml $ "<audio " <> unwords direct <> " src=\"" <> filename <> "\"" <> attToString ("",css,att') <> ">"]
-                                                                ++ [toHtml"</audio>"]
-                                                        where
-                                                                (direct, css) = classToPlain att
-media (Image ("audio",att,att') alt (filename,_))   = return $ [toHtml $ "<figure><audio " <> unwords direct <> " src=\"" <> filename <> "\"" <> attToString ("",css,att') <> "></audio>"]
-                                                                ++ [toHtml $ "<figcaption>"]
-                                                                ++ alt
-                                                                ++ [toHtml $ "</figcaption></figure>"]
-                                                        where
-                                                                (direct, css) = classToPlain att
---no description of video
-media (Image ("video", att, att') [] (filename,_))  = return $ [toHtml $ "<video " <> unwords direct <> " src=\"" <> filename <> "\"" <> attToString ("",css,att') <> "></video>"]
-                                                        where
-                                                                (direct, css) = classToPlain att
---with description of video
-media (Image ("video", att, att') alt (filename,_)) = return $ [toHtml $ "<figure>"]
-                                                                ++ [toHtml $ "<video " <> unwords direct <> " src=\"" <> filename <> "\"" <> attToString ("",css,att') <> "></video>"]
-                                                                ++ [toHtml $ "<figcaption>"]
-                                                                ++ alt
-                                                                ++ [toHtml $ "</figcaption></figure>"]
-                                                        where
-                                                                (direct, css) = classToPlain att
---no description of image
-media (Image ("img", att, att') [] (filename,_))  = return $ [toHtml $ "<figure>"]
-                                                              ++ [toHtml $ "<img " <> unwords direct <> " src=\"" <> filename <> "\"" <> attToString ("",css,att') <> "></img>"]
-                                                              ++ [toHtml $ "</figure>"]
-                                                        where
-                                                                (direct, css) = classToPlain att
---with description of image
-media (Image ("img", att, att') alt (filename,_)) = return $ [toHtml $ "<figure>"]
-                                                                ++ [toHtml $ "<img " <> unwords direct <> " src=\"" <> filename <> "\"" <> attToString ("",css,att') <> "></img>"]
-                                                                ++ [toHtml $ "<figcaption>"]
-                                                                ++ alt
-                                                                ++ [toHtml $ "</figcaption></figure>"]
-                                                        where
-                                                                (direct, css) = classToPlain att
-media (Image ("svg", att, att') [] (filename,_))  = handle (\(fileerror :: IOException) -> return [toHtml $ "Could not read file: " <> filename <> "<br />" <> show fileerror]) $
-                                                    do
-                                                        svg <- readFile filename
-                                                        return $ [toHtml $ "<figure " <> unwords direct <> " " <> attToString ("", css, att') <> ">"] -- use attributes on figure, as svg gets dumped in..
-                                                              ++ [toHtml $ svg]
-                                                              ++ [toHtml $ "</figure>"]
-                                                        where
-                                                                (direct, css) = classToPlain att
-media (Image ("svg", att, att') alt (filename,_))  = handle (\(fileerror :: IOException) -> return $ [toHtml $ "Could not read file: " <> filename <> "<br />" <> show filename]) $
-                                                     do
-                                                        svg <- readFile filename
-                                                        return $ [toHtml $ "<figure " <> unwords direct <> " " <> attToString ("", css, att') <> ">"] -- use attributes on figure, as svg gets dumped in..
-                                                              ++ [toHtml $ svg]
-                                                              ++ [toHtml $ "<figcaption>"]
-                                                              ++ alt
-                                                              ++ [toHtml $ "</figcaption></figure>"]
-                                                        where
-                                                                (direct, css) = classToPlain att
-media (Image ("demo", att, att') [] (filename,_))  = return $ [toHtml $ "<iframe " <> unwords direct <> " src=\"" <> filename <> "?plugin\"" <> attToString ("", css, att') <> "></iframe>"]
-                                                        where
-                                                                (direct, css) = classToPlain att
-media (Image ("demo", att, att') alt (filename,_))  = return $ [toHtml $ "<figure>"]
-                                                              ++ [toHtml $ "<iframe " <> unwords direct <> " src=\"" <> filename <> "?plugin\"" <> attToString ("", css, att') <> "></iframe>"]
-                                                              ++ [toHtml $ "<figcaption>"]
-                                                              ++ alt
-                                                              ++ [toHtml $ "</figcaption></figure>"]
-                                                        where
-                                                                (direct, css) = classToPlain att
+-- | File-extensions that should be treated as audio
+audioExt :: [String]
+audioExt = ["mp3","aac"]
 
+-- | File-extensions that should be treated as video
+videoExt :: [String]
+videoExt = [ "avi"
+           , "mp4"
+           , "mov"
+           ]
+
+-- | File-extensions that should be treated as image
+imgExt :: [String]
+imgExt = 
+  [ "jpg"
+  , "jpeg"
+  , "png"
+  , "gif"
+  , "tif"
+  , "tiff"
+  , "bmp"
+  ]
+
+-- | File-extensions that should be treated as demo and will be included
+-- in an iframe.
+demoExt :: [String]
+demoExt = ["html", "htm"]
+
+-- | main media-plugin.
+--
+-- Will convert the following syntax
+--
+-- 
+-- - `![](foo.aac){#audio}`
+-- - `![](foo.mp4){#video}`
+-- - `![](foo.png){#img}`
+-- - `![](foo.svg){#svg}`
+-- - `![](foo.html){#demo}`
+--
+-- HTML-id's maybe ommitted if the file-extension is in whitelist.
+--
+-- If a type is detected by extension a custom id (not matching the extension)
+-- will be preserved.
+--
+media :: Inline -> IO [Inline]
+--audio
+media (Image (id',att,att') [] (filename,_))
+  | id' == "audio" || (takeExtension filename `elem` audioExt)
+    = return $ [toHtml $ "<audio " <> unwords direct <> " src=\"" <> filename <> "\"" <> attToString (idFilter "audio" id',css,att') <> "></audio>"]
+      where
+        (direct, css) = classToPlain att
+media (Image (id',att,att') alt (filename,_))
+  | id' == "audio" || (takeExtension filename `elem` audioExt)
+    = return $ [toHtml $ "<figure><audio " <> unwords direct <> " src=\"" <> filename <> "\"" <> attToString (idFilter "audio" id',css,att') <> "></audio>"]
+            ++ [toHtml $ "<figcaption>"]
+            ++ alt
+            ++ [toHtml $ "</figcaption></figure>"]
+      where
+        (direct, css) = classToPlain att
+--videos
+media (Image (id', att, att') [] (filename,_))
+  | id' == "video" || (takeExtension filename `elem` videoExt)
+    = return $ [toHtml $ "<video " <> unwords direct <> " src=\"" <> filename <> "\"" <> attToString (idFilter "video" id',css,att') <> "></video>"]
+      where
+        (direct, css) = classToPlain att
+media (Image (id', att, att') alt (filename,_))
+  | id' == "video" || (takeExtension filename `elem` videoExt)
+     = return $ [toHtml $ "<figure>"]
+             ++ [toHtml $ "<video " <> unwords direct <> " src=\"" <> filename <> "\"" <> attToString (idFilter "video" id',css,att') <> "></video>"]
+             ++ [toHtml $ "<figcaption>"]
+             ++ alt
+             ++ [toHtml $ "</figcaption></figure>"]
+       where
+         (direct, css) = classToPlain att
+--images
+media (Image (id', att, att') [] (filename,_))
+  | id' == "img" || (takeExtension filename `elem` imgExt)
+    = return $ [toHtml $ "<figure>"]
+            ++ [toHtml $ "<img " <> unwords direct <> " src=\"" <> filename <> "\"" <> attToString (idFilter "img" id',css,att') <> "></img>"]
+            ++ [toHtml $ "</figure>"]
+      where
+        (direct, css) = classToPlain att
+media (Image (id', att, att') alt (filename,_))
+  | id' == "img" || (takeExtension filename `elem` imgExt)
+    = return $ [toHtml $ "<figure>"]
+            ++ [toHtml $ "<img " <> unwords direct <> " src=\"" <> filename <> "\"" <> attToString (idFilter "img" id',css,att') <> "></img>"]
+            ++ [toHtml $ "<figcaption>"]
+            ++ alt
+            ++ [toHtml $ "</figcaption></figure>"]
+      where
+        (direct, css) = classToPlain att
+--load svg and dump it in
+media (Image (id', att, att') [] (filename,_))
+  | id' == "svg" || (takeExtension filename == "svg")
+    = handle (\(fileerror :: IOException) -> return [toHtml $ "Could not read file: " <> filename <> "<br />" <> show fileerror]) $
+                do
+                  svg <- readFile filename
+                  return $ [toHtml $ "<figure " <> unwords direct <> " " <> attToString (idFilter "svg" id', css, att') <> ">"] -- use attributes on figure, as svg gets dumped in..
+                        ++ [toHtml $ svg]
+                        ++ [toHtml $ "</figure>"]
+      where
+        (direct, css) = classToPlain att
+media (Image (id', att, att') alt (filename,_))
+  | id' == "svg" || (takeExtension filename == "svg")
+    = handle (\(fileerror :: IOException) -> return $ [toHtml $ "Could not read file: " <> filename <> "<br />" <> show filename]) $
+                do
+                  svg <- readFile filename
+                  return $ [toHtml $ "<figure " <> unwords direct <> " " <> attToString (idFilter "svg" id', css, att') <> ">"] -- use attributes on figure, as svg gets dumped in..
+                        ++ [toHtml $ svg]
+                        ++ [toHtml $ "<figcaption>"]
+                        ++ alt
+                        ++ [toHtml $ "</figcaption></figure>"]
+      where
+        (direct, css) = classToPlain att
+--html-demos etc. as IFrames
+media (Image (id', att, att') [] (filename,_))
+  | id' == "demo" || (takeExtension filename `elem` demoExt)
+    = return $ [toHtml $ "<iframe " <> unwords direct <> " src=\"" <> filename <> "?plugin\"" <> attToString (idFilter "demo" id', css, att') <> "></iframe>"]
+      where
+        (direct, css) = classToPlain att
+media (Image (id', att, att') alt (filename,_))
+  | id' == "demo" || (takeExtension filename `elem` demoExt)
+    = return $ [toHtml $ "<figure>"]
+            ++ [toHtml $ "<iframe " <> unwords direct <> " src=\"" <> filename <> "?plugin\"" <> attToString (idFilter "demo" id', css, att') <> "></iframe>"]
+            ++ [toHtml $ "<figcaption>"]
+            ++ alt
+            ++ [toHtml $ "</figcaption></figure>"]
+      where
+        (direct, css) = classToPlain att
+-- if not matched
 media x = return [x]
 
 
 attToString :: Attr -> String
-attToString (ident, classes, kvpairs) = ident <> " class=\"" <> unwords classes <> "\" " <> unwords ((\(k,v) -> k <> "=\"" <> v <> "\"") <$> kvpairs)
+attToString ("", classes, kvpairs) = "class=\"" <> unwords classes <> "\" " <> unwords ((\(k,v) -> k <> "=\"" <> v <> "\"") <$> kvpairs)
+attToString (id', classes, kvpairs) = "id=\"" <> id'  <> "\" class=\"" <> unwords classes <> "\" " <> unwords ((\(k,v) -> k <> "=\"" <> v <> "\"") <$> kvpairs)
+
+
+idFilter :: String -> String -> String
+idFilter a b
+  | a == b    = ""
+  | otherwise = a
 
 classToPlain :: [String] -> ([String],[String])
 classToPlain = partition (`elem` [ "data-autoplay"
diff --git a/pandoc-slide-filter.cabal b/pandoc-slide-filter.cabal
index b9f0a90..1d3d65b 100644
--- a/pandoc-slide-filter.cabal
+++ b/pandoc-slide-filter.cabal
@@ -19,6 +19,7 @@ executable media
   ghc-options:         -threaded -rtsopts -with-rtsopts=-N
   build-depends:       base
                      , pandoc-types
+                     , filepath
   default-language:    Haskell2010
 
 executable styling