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