1 {-# LANGUAGE OverloadedStrings #-}
    2 module Databrary.Web.Templates
    3   ( generateTemplatesJS
    4   ) where
    5 
    6 import Control.Monad (guard, unless, forM_)
    7 import Control.Monad.IO.Class (liftIO)
    8 import qualified Data.ByteString as BS
    9 import qualified Data.ByteString.Builder as BSB
   10 import qualified Data.ByteString.Char8 as BSC
   11 import Data.Char (isSpace)
   12 import Data.Monoid ((<>))
   13 import System.IO (withFile, withBinaryFile, IOMode(ReadMode, WriteMode), hPutStrLn, hIsEOF, hFlush)
   14 import qualified Data.ByteString.Builder as B
   15 import qualified Data.ByteString.Builder.Prim as BP
   16 import Data.Word (Word8)
   17 import Data.ByteString.Internal (c2w)
   18 
   19 import Databrary.Files
   20 import Databrary.Web
   21 import Databrary.Web.Types
   22 import Databrary.Web.Files
   23 import Databrary.Web.Generate
   24 
   25 wordEscaped :: Char -> BP.BoundedPrim Word8
   26 wordEscaped q =
   27   BP.condB (== c2w q) (backslash q) $
   28   BP.condB (== c2w '\\') (backslash '\\') $
   29   BP.condB (>= c2w ' ') (BP.liftFixedToBounded BP.word8) $
   30   BP.condB (== c2w '\n') (backslash 'n') $
   31   BP.condB (== c2w '\r') (backslash 'r') $
   32   BP.condB (== c2w '\t') (backslash 't') $
   33     BP.liftFixedToBounded $ (\c -> ('\\', ('u', fromIntegral c))) BP.>$< BP.char8 BP.>*< BP.char8 BP.>*< BP.word16HexFixed
   34   where
   35   backslash c = BP.liftFixedToBounded $ const ('\\', c) BP.>$< BP.char8 BP.>*< BP.char8
   36 
   37 -- | Escape (but do not quote) a ByteString
   38 escapeByteString :: Char -> BS.ByteString -> B.Builder
   39 escapeByteString = BP.primMapByteStringBounded . wordEscaped
   40 
   41 quoteByteString :: Char -> BS.ByteString -> B.Builder
   42 quoteByteString q s = B.char8 q <> escapeByteString q s <> B.char8 q
   43 
   44 processTemplate :: RawFilePath -> (BS.ByteString -> IO ()) -> IO ()
   45 processTemplate f g = do
   46   fp <- liftIO $ unRawFilePath f
   47   withFile fp ReadMode go
   48   where
   49     go h = do
   50       e <- hIsEOF h
   51       unless e $ do
   52         l <- BS.hGetLine h
   53         g $ BSC.dropWhile isSpace l
   54         go h
   55 
   56 generateTemplatesJS :: WebGenerator
   57 generateTemplatesJS fo@(f, _) = do
   58   tl <- liftIO $ findWebFiles ".html"
   59   guard (not $ null tl)
   60   fp <- liftIO $ unRawFilePath $ webFileAbs f
   61   webRegenerate
   62     (withBinaryFile fp WriteMode $ \h -> do
   63       hPutStrLn h "app.run(['$templateCache',function(t){"
   64       forM_ tl $ \tf -> do
   65         BSB.hPutBuilder h $ BSB.string8 "t.put(" <> quoteByteString q (webFileRel tf) <> BSB.char8 ',' <> BSB.char8 q
   66         processTemplate (webFileAbs tf) $ \s -> do
   67           let j = escapeByteString q s
   68           BSB.hPutBuilder h j -- this is hanging
   69           hFlush h            -- without this!!!
   70         hPutStrLn h $ q : ");"
   71       hPutStrLn h "}]);")
   72     [] tl fo
   73   where q = '\''