Added File-Detection to Media
This commit is contained in:
parent
7e4094539d
commit
621f4a5c65
GPG Key ID:
057D94F356F41E25
206
app/Media.hs
206
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
|
||||
--
|
||||
--
|
||||
-- - `{#audio}`
|
||||
-- - `{#video}`
|
||||
-- - `{#img}`
|
||||
-- - `{#svg}`
|
||||
-- - `{#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"
|
||||
|
||||
@ -19,6 +19,7 @@ executable media
|
||||
ghc-options: -threaded -rtsopts -with-rtsopts=-N
|
||||
build-depends: base
|
||||
, pandoc-types
|
||||
, filepath
|
||||
default-language: Haskell2010
|
||||
|
||||
executable styling
|
||||
|
||||
Loading…
Reference in New Issue
Block a user