1{-# LANGUAGE CPP #-}
2{-# LANGUAGE ViewPatterns #-}
3
4#ifdef FILE_EMBED
5{-# LANGUAGE TemplateHaskell #-}
6#endif
7
8module General.Template(runTemplate) where
9
10import System.FilePath.Posix
11import Control.Exception.Extra
12import Data.Char
13import Data.Time
14import System.IO.Unsafe
15import Development.Shake.Internal.Paths
16import qualified Data.ByteString.Lazy.Char8 as LBS
17import qualified Language.Javascript.DGTable as DGTable
18import qualified Language.Javascript.Flot as Flot
19import qualified Language.Javascript.JQuery as JQuery
20
21#ifdef FILE_EMBED
22import Data.FileEmbed
23import Language.Haskell.TH.Syntax ( runIO )
24#endif
25
26{- HLINT ignore "Redundant bracket" -} -- a result of CPP expansion
27
28-- Very hard to abstract over TH, so we do it with CPP
29#ifdef FILE_EMBED
30#define FILE(x) (pure (LBS.fromStrict $(embedFile =<< runIO (x))))
31#else
32#define FILE(x) (LBS.readFile =<< (x))
33#endif
34
35libraries :: [(String, IO LBS.ByteString)]
36libraries =
37    [("jquery.js",            FILE(JQuery.file))
38    ,("jquery.dgtable.js",    FILE(DGTable.file))
39    ,("jquery.flot.js",       FILE(Flot.file Flot.Flot))
40    ,("jquery.flot.stack.js", FILE(Flot.file Flot.FlotStack))
41    ]
42
43
44-- | Template Engine. Perform the following replacements on a line basis:
45--
46-- * <script src="foo"></script> ==> <script>[[foo]]</script>
47--
48-- * <link href="foo" rel="stylesheet" type="text/css" /> ==> <style type="text/css">[[foo]]</style>
49runTemplate :: (FilePath -> IO LBS.ByteString) -> LBS.ByteString -> IO LBS.ByteString
50runTemplate ask = lbsMapLinesIO f
51    where
52        link = LBS.pack "<link href=\""
53        script = LBS.pack "<script src=\""
54
55        f x | Just file <- lbsStripPrefix script y = do res <- grab file; pure $ LBS.pack "<script>\n" `LBS.append` res `LBS.append` LBS.pack "\n</script>"
56            | Just file <- lbsStripPrefix link y = do res <- grab file; pure $ LBS.pack "<style type=\"text/css\">\n" `LBS.append` res `LBS.append` LBS.pack "\n</style>"
57            | otherwise = pure x
58            where
59                y = LBS.dropWhile isSpace x
60                grab = asker . takeWhile (/= '\"') . LBS.unpack
61
62        asker o@(splitFileName -> ("lib/",x)) =
63            case lookup x libraries of
64                Nothing -> errorIO $ "Template library, unknown library: " ++ o
65                Just act -> act
66
67        asker "shake.js" = readDataFileHTML "shake.js"
68        asker "data/metadata.js" = do
69            time <- getCurrentTime
70            pure $ LBS.pack $
71                "var version = " ++ show shakeVersionString ++
72                "\nvar generated = " ++ show (formatTime defaultTimeLocale (iso8601DateFormat (Just "%H:%M:%S")) time)
73        asker x = ask x
74
75-- Perform a mapM on each line and put the result back together again
76lbsMapLinesIO :: (LBS.ByteString -> IO LBS.ByteString) -> LBS.ByteString -> IO LBS.ByteString
77-- If we do the obvious @fmap LBS.unlines . mapM f@ then all the monadic actions are run on all the lines
78-- before it starts producing the lazy result, killing streaming and having more stack usage.
79-- The real solution (albeit with too many dependencies for something small) is a streaming library,
80-- but a little bit of unsafePerformIO does the trick too.
81lbsMapLinesIO f = pure . LBS.unlines . map (unsafePerformIO . f) . LBS.lines
82
83
84---------------------------------------------------------------------
85-- COMPATIBILITY
86
87-- available in bytestring-0.10.8.0, GHC 8.0 and above
88-- alternative implementation below
89lbsStripPrefix :: LBS.ByteString -> LBS.ByteString -> Maybe LBS.ByteString
90lbsStripPrefix prefix text = if a == prefix then Just b else Nothing
91    where (a,b) = LBS.splitAt (LBS.length prefix) text
92