1 {-# LANGUAGE GeneralizedNewtypeDeriving #-} 2 {-# LANGUAGE OverloadedStrings #-} 3 {-# LANGUAGE TypeSynonymInstances #-} 4 {-# LANGUAGE NoMonomorphismRestriction #-} 5 {-# OPTIONS_GHC -fno-warn-orphans #-} 6 7 module Text.Templating.Heist.Tests 8 ( tests 9 , quickRender 10 ) where 11 12 ------------------------------------------------------------------------------ 13 import Blaze.ByteString.Builder 14 import Control.Monad.State 15 import Data.ByteString.Char8 (ByteString) 16 import qualified Data.ByteString.Char8 as B 17 import qualified Data.ByteString.Lazy.Char8 as L 18 import qualified Data.Map as Map 19 import Data.Maybe 20 import Data.Monoid 21 import qualified Data.Text as T 22 import qualified Data.Text.Encoding as T 23 import Data.Text (Text) 24 import System.IO.Unsafe 25 import Test.Framework (Test) 26 import Test.Framework.Providers.HUnit 27 import Test.Framework.Providers.QuickCheck2 28 import qualified Test.HUnit as H 29 import Test.QuickCheck 30 import Test.QuickCheck.Monadic 31 32 33 ------------------------------------------------------------------------------ 34 import Text.Templating.Heist 35 import Text.Templating.Heist.Internal 36 import Text.Templating.Heist.Types 37 import Text.Templating.Heist.Splices.Apply 38 import Text.Templating.Heist.Splices.Ignore 39 import Text.Templating.Heist.Splices.Markdown 40 import qualified Text.XmlHtml as X 41 import qualified Text.XmlHtml.Cursor as X 42 43 44 ------------------------------------------------------------------------------ 45 tests :: [Test] 46 tests = [ testProperty "heist/simpleBind" simpleBindTest 47 , testProperty "heist/simpleApply" simpleApplyTest 48 , testCase "heist/stateMonoid" monoidTest 49 , testCase "heist/templateAdd" addTest 50 , testCase "heist/hasTemplate" hasTemplateTest 51 , testCase "heist/getDoc" getDocTest 52 , testCase "heist/load" loadTest 53 , testCase "heist/fsLoad" fsLoadTest 54 , testCase "heist/renderNoName" renderNoNameTest 55 , testCase "heist/doctype" doctypeTest 56 , testCase "heist/attributeSubstitution" attrSubstTest 57 , testCase "heist/bindAttribute" bindAttrTest 58 , testCase "heist/markdown" markdownTest 59 , testCase "heist/title_expansion" titleExpansion 60 , testCase "heist/textarea_expansion" textareaExpansion 61 , testCase "heist/div_expansion" divExpansion 62 , testCase "heist/bind_param" bindParam 63 , testCase "heist/markdownText" markdownTextTest 64 , testCase "heist/apply" applyTest 65 , testCase "heist/ignore" ignoreTest 66 , testCase "heist/lookupTemplateContext" lookupTemplateTest 67 ] 68 69 70 ------------------------------------------------------------------------------ 71 simpleBindTest :: Property 72 simpleBindTest = monadicIO $ forAllM arbitrary prop 73 where 74 prop :: Bind -> PropertyM IO () 75 prop bind = do 76 let template = buildBindTemplate bind 77 let result = buildResult bind 78 79 spliceResult <- run $ evalTemplateMonad (runNodeList template) 80 (X.TextNode "") 81 emptyTemplateState 82 assert $ result == spliceResult 83 84 85 ------------------------------------------------------------------------------ 86 simpleApplyTest :: Property 87 simpleApplyTest = monadicIO $ forAllM arbitrary prop 88 where 89 prop :: Apply -> PropertyM IO () 90 prop apply = do 91 let correct = calcCorrect apply 92 result <- run $ calcResult apply 93 assert $ correct == result 94 95 96 ------------------------------------------------------------------------------ 97 monoidTest :: IO () 98 monoidTest = do 99 H.assertBool "left monoid identity" $ mempty `mappend` es == es 100 H.assertBool "right monoid identity" $ es `mappend` mempty == es 101 where es = emptyTemplateState :: TemplateState IO 102 103 104 ------------------------------------------------------------------------------ 105 addTest :: IO () 106 addTest = do 107 H.assertEqual "lookup test" (Just []) $ 108 fmap (X.docContent . dfDoc . fst) $ lookupTemplate "aoeu" ts 109 110 H.assertEqual "splice touched" 0 $ Map.size (_spliceMap ts) 111 112 where 113 ts = addTemplate "aoeu" [] Nothing (mempty::TemplateState IO) 114 115 116 ------------------------------------------------------------------------------ 117 hasTemplateTest :: H.Assertion 118 hasTemplateTest = do 119 ets <- loadT "templates" 120 let tm = either (error "Error loading templates") _templateMap ets 121 let ts = setTemplates tm emptyTemplateState :: TemplateState IO 122 H.assertBool "hasTemplate ts" (hasTemplate "index" ts) 123 124 125 ------------------------------------------------------------------------------ 126 getDocTest :: H.Assertion 127 getDocTest = do 128 d <- getDoc "bkteoar" 129 H.assertBool "non-existent doc" $ isLeft d 130 f <- getDoc "templates/index.tpl" 131 H.assertBool "index doc" $ not $ isLeft f 132 133 134 ------------------------------------------------------------------------------ 135 loadTest :: H.Assertion 136 loadTest = do 137 ets <- loadT "templates" 138 either (error "Error loading templates") 139 (\ts -> do let tm = _templateMap ts 140 H.assertBool "loadTest size" $ Map.size tm == 21 141 ) ets 142 143 144 ------------------------------------------------------------------------------ 145 fsLoadTest :: H.Assertion 146 fsLoadTest = do 147 ets <- loadT "templates" 148 let tm = either (error "Error loading templates") _templateMap ets 149 let ts = setTemplates tm emptyTemplateState :: TemplateState IO 150 let f = g ts 151 152 f isNothing "abc/def/xyz" 153 f isJust "a" 154 f isJust "bar/a" 155 f isJust "/bar/a" 156 157 where 158 g ts p n = H.assertBool ("loading template " ++ n) $ p $ 159 lookupTemplate (B.pack n) ts 160 161 ------------------------------------------------------------------------------ 162 renderNoNameTest :: H.Assertion 163 renderNoNameTest = do 164 ets <- loadT "templates" 165 either (error "Error loading templates") 166 (\ts -> do t <- renderTemplate ts "" 167 H.assertBool "renderNoName" $ isNothing t 168 ) ets 169 170 171 ------------------------------------------------------------------------------ 172 doctypeTest :: H.Assertion 173 doctypeTest = do 174 ets <- loadT "templates" 175 let ts = either (error "Error loading templates") id ets 176 Just (indexDoc, indexMIME) <- renderTemplate ts "index" 177 H.assertBool "doctype test index" $ isJust $ X.docType $ 178 fromRight $ (X.parseHTML "index") $ toByteString $ indexDoc 179 Just (iocDoc, iocMIME) <- renderTemplate ts "ioc" 180 H.assertBool "doctype test ioc" $ isJust $ X.docType $ 181 fromRight $ (X.parseHTML "index") $ toByteString $ iocDoc 182 where fromRight (Right x) = x 183 fromRight (Left s) = error s 184 185 ------------------------------------------------------------------------------ 186 attrSubstTest :: H.Assertion 187 attrSubstTest = do 188 ets <- loadT "templates" 189 let ts = either (error "Error loading templates") id ets 190 check (setTs "meaning_of_everything" ts) "pre_meaning_of_everything_post" 191 check ts "pre__post" 192 193 where 194 setTs val = bindSplice "foo" (return [X.TextNode val]) 195 check ts str = do 196 Just (resDoc, resMIME) <- renderTemplate ts "attrs" 197 H.assertBool ("attr subst " ++ (show str)) $ not $ B.null $ 198 snd $ B.breakSubstring str $ toByteString $ resDoc 199 H.assertBool ("attr subst foo") $ not $ B.null $ 200 snd $ B.breakSubstring "$(foo)" $ toByteString $ resDoc 201 202 203 ------------------------------------------------------------------------------ 204 bindAttrTest :: H.Assertion 205 bindAttrTest = do 206 ets <- loadT "templates" 207 let ts = either (error "Error loading templates") id ets 208 check ts "<div id=\'zzzzz\'" 209 210 where 211 check ts str = do 212 Just (resDoc, resMIME) <- renderTemplate ts "bind-attrs" 213 H.assertBool ("attr subst " ++ (show str)) $ not $ B.null $ 214 snd $ B.breakSubstring str $ toByteString $ resDoc 215 H.assertBool ("attr subst bar") $ B.null $ 216 snd $ B.breakSubstring "$(bar)" $ toByteString $ resDoc 217 218 219 ------------------------------------------------------------------------------ 220 htmlExpected :: ByteString 221 htmlExpected = "<div class=\'markdown\'><p>This <em>is</em> a test.</p></div>" 222 223 224 ------------------------------------------------------------------------------ 225 -- | Markdown test on a file 226 markdownTest :: H.Assertion 227 markdownTest = renderTest "markdown" htmlExpected 228 229 230 -- | Render a template and assert that it matches an expected result 231 renderTest :: ByteString -- ^ template name 232 -> ByteString -- ^ expected result 233 -> H.Assertion 234 renderTest templateName expectedResult = do 235 ets <- loadT "templates" 236 let ts = either (error "Error loading templates") id ets 237 238 check ts expectedResult 239 240 where 241 check ts str = do 242 Just (doc, _) <- renderTemplate ts templateName 243 let result = B.filter (/= '\n') (toByteString doc) 244 H.assertEqual ("Should match " ++ (show str)) str result 245 246 247 ------------------------------------------------------------------------------ 248 -- | Expansion of a bound name inside a title-tag 249 titleExpansion :: H.Assertion 250 titleExpansion = renderTest "title_expansion" "<title>foo</title>" 251 252 253 ------------------------------------------------------------------------------ 254 -- | Expansion of a bound name inside a textarea-tag 255 textareaExpansion :: H.Assertion 256 textareaExpansion = renderTest "textarea_expansion" "<textarea>foo</textarea>" 257 258 259 ------------------------------------------------------------------------------ 260 -- | Expansion of a bound name inside a div-tag 261 divExpansion :: H.Assertion 262 divExpansion = renderTest "div_expansion" "<div>foo</div>" 263 264 265 ------------------------------------------------------------------------------ 266 -- | Handling of <content> and bound parameters in a bonud tag. 267 bindParam :: H.Assertion 268 bindParam = renderTest "bind_param" "<li>Hi there world</li>" 269 270 271 ------------------------------------------------------------------------------ 272 -- | Markdown test on supplied text 273 markdownTextTest :: H.Assertion 274 markdownTextTest = do 275 result <- evalTemplateMonad markdownSplice 276 (X.TextNode "This *is* a test.") 277 emptyTemplateState 278 H.assertEqual "Markdown text" htmlExpected 279 (B.filter (/= '\n') $ toByteString $ 280 X.render (X.HtmlDocument X.UTF8 Nothing result)) 281 282 283 ------------------------------------------------------------------------------ 284 applyTest :: H.Assertion 285 applyTest = do 286 let es = emptyTemplateState :: TemplateState IO 287 res <- evalTemplateMonad applyImpl 288 (X.Element "apply" [("template", "nonexistant")] []) es 289 290 H.assertEqual "apply nothing" [] res 291 292 293 ------------------------------------------------------------------------------ 294 ignoreTest :: H.Assertion 295 ignoreTest = do 296 let es = emptyTemplateState :: TemplateState IO 297 res <- evalTemplateMonad ignoreImpl 298 (X.Element "ignore" [("tag", "ignorable")] 299 [X.TextNode "This should be ignored"]) es 300 H.assertEqual "<ignore> tag" [] res 301 302 303 --localTSTest :: H.Assertion 304 --localTSTest = do 305 -- let es = emptyTemplateState :: TemplateState IO 306 307 lookupTemplateTest = do 308 ts <- loadTS "templates" 309 let k = do 310 setContext ["foo"] 311 getsTS $ lookupTemplate "/user/menu" 312 res <- runTemplateMonad k (X.TextNode "") ts 313 H.assertBool "lookup context test" $ isJust $ fst res 314 315 316 ------------------------------------------------------------------------------ 317 -- Utility functions 318 319 isLeft :: Either a b -> Bool 320 isLeft (Left _) = True 321 isLeft (Right _) = False 322 323 324 ------------------------------------------------------------------------------ 325 loadT :: String -> IO (Either String (TemplateState IO)) 326 loadT s = loadTemplates s emptyTemplateState 327 328 329 ------------------------------------------------------------------------------ 330 loadTS :: FilePath -> IO (TemplateState IO) 331 loadTS baseDir = do 332 etm <- loadTemplates baseDir emptyTemplateState 333 return $ either error id etm 334 335 336 ------------------------------------------------------------------------------ 337 identStartChar :: [Char] 338 identStartChar = ['a'..'z'] 339 340 341 ------------------------------------------------------------------------------ 342 identChar :: [Char] 343 identChar = '_' : identStartChar 344 345 346 ------------------------------------------------------------------------------ 347 textGen :: Gen [Char] 348 textGen = listOf $ elements ((replicate 5 ' ') ++ identStartChar) 349 350 351 ------------------------------------------------------------------------------ 352 limitedDepth :: Int -> Gen X.Node 353 limitedDepth 0 = liftM (X.TextNode . T.pack) textGen 354 limitedDepth n = 355 oneof [ liftM (X.TextNode . T.pack) textGen 356 , liftM3 X.Element arbitrary 357 (liftM (take 2) arbitrary) 358 (liftM (take 3) $ listOf $ limitedDepth (n - 1)) 359 ] 360 361 362 ------------------------------------------------------------------------------ 363 -- | Returns the number of unique insertion points in the tree. 364 -- If h = insertAt f n g", the following property holds: 365 -- insSize h == (insSize f) + (insSize g) - 1 366 insSize :: [X.Node] -> Int 367 insSize ns = 1 + (sum $ map nodeSize ns) 368 where nodeSize (X.TextNode _) = 1 369 nodeSize (X.Element _ _ c) = 1 + (insSize c) 370 371 372 ------------------------------------------------------------------------------ 373 insertAt :: [X.Node] -> Int -> [X.Node] -> [X.Node] 374 insertAt elems 0 ns = elems ++ ns 375 insertAt elems _ [] = elems 376 insertAt elems n list = maybe [] X.topNodes $ 377 evalState (processNode elems $ fromJust $ X.fromNodes list) n 378 379 380 ------------------------------------------------------------------------------ 381 move :: Insert () 382 move = modify (\x -> x - 1) 383 384 385 ------------------------------------------------------------------------------ 386 processNode :: [X.Node] -> X.Cursor -> Insert (Maybe X.Cursor) 387 processNode elems loc = 388 liftM2 mplus (move >> goDown loc) (move >> goRight loc) 389 390 where 391 goDown l = 392 case X.current l of 393 X.TextNode _ -> modify (+1) >> return Nothing 394 X.Element _ _ _ -> doneCheck (X.insertManyFirstChild elems) 395 X.firstChild 396 l 397 398 goRight = doneCheck (Just . X.insertManyRight elems) X.right 399 400 doneCheck insertFunc next l = do 401 s <- get 402 if s == 0 403 then return $ insertFunc l 404 else maybe (return Nothing) (processNode elems) $ next l 405 406 407 ------------------------------------------------------------------------------ 408 -- | Reloads the templates from disk and renders the specified 409 -- template. (Old convenience code.) 410 quickRender :: FilePath -> ByteString -> IO (Maybe ByteString) 411 quickRender baseDir name = do 412 ts <- loadTS baseDir 413 res <- renderTemplate ts name 414 return (fmap (toByteString . fst) res) 415 416 417 ------------------------------------------------------------------------------ 418 newtype Name = Name { unName :: Text } deriving (Show) 419 420 instance Arbitrary Name where 421 arbitrary = do 422 x <- elements identStartChar 423 n <- choose (4,10) 424 rest <- vectorOf n $ elements identChar 425 return $ Name $ T.pack (x:rest) 426 427 instance Arbitrary X.Node where 428 arbitrary = limitedDepth 3 429 shrink (X.TextNode _) = [] 430 shrink (X.Element _ [] []) = [] 431 shrink (X.Element n [] (_:cs)) = [X.Element n [] cs] 432 shrink (X.Element n (_:as) []) = [X.Element n as []] 433 shrink (X.Element n as cs) = [X.Element n as (tail cs), X.Element n (tail as) cs] 434 435 instance Arbitrary T.Text where 436 arbitrary = liftM unName arbitrary 437 438 -- 439 -- Code for inserting nodes into any point of a tree 440 -- 441 type Insert a = State Int a 442 443 444 ------------------------------------------------------------------------------ 445 -- <bind> tests 446 447 -- Data type encapsulating the parameters for a bind operation 448 data Bind = Bind 449 { _bindElemName :: Name 450 , _bindChildren :: [X.Node] 451 , _bindDoc :: [X.Node] 452 , _bindPos :: Int 453 , _bindRefPos :: Int 454 } -- deriving (Show) 455 456 457 instance Arbitrary Bind where 458 arbitrary = do 459 name <- arbitrary 460 kids <- liftM (take 3) arbitrary 461 doc <- liftM (take 5) arbitrary 462 let s = insSize doc 463 loc <- choose (0, s - 1) 464 loc2 <- choose (0, s - loc - 1) 465 return $ Bind name kids doc loc loc2 466 shrink (Bind e [c] (_:ds) p r) = [Bind e [c] ds p r] 467 shrink (Bind e (_:cs) d p r) = [Bind e cs d p r] 468 shrink _ = [] 469 470 471 instance Show Bind where 472 show b@(Bind e c d p r) = unlines 473 [ "\n" 474 , "Bind element name: " ++ (show e) 475 , "Bind pos: " ++ (show p) 476 , "Bind ref pos: " ++ (show r) 477 , "Bind document:" 478 , L.unpack $ L.concat $ map formatNode d 479 , "Bind children:" 480 , L.unpack $ L.concat $ map formatNode c 481 , "Result:" 482 , L.unpack $ L.concat $ map formatNode $ buildResult b 483 , "Splice result:" 484 , L.unpack $ L.concat $ map formatNode $ unsafePerformIO $ 485 evalTemplateMonad (runNodeList $ buildBindTemplate b) 486 (X.TextNode "") emptyTemplateState 487 , "Template:" 488 , L.unpack $ L.concat $ map formatNode $ buildBindTemplate b 489 ] 490 where 491 formatNode n = toLazyByteString $ X.render 492 $ X.HtmlDocument X.UTF8 Nothing [n] 493 494 ------------------------------------------------------------------------------ 495 buildNode :: Text -> Text -> Bind -> X.Node 496 buildNode tag attr (Bind s c _ _ _) = X.Element tag [(attr, unName s)] c 497 498 499 ------------------------------------------------------------------------------ 500 buildBind :: Bind -> X.Node 501 buildBind = buildNode "bind" "tag" 502 503 504 ------------------------------------------------------------------------------ 505 empty :: Text -> X.Node 506 empty n = X.Element n [] [] 507 508 509 ------------------------------------------------------------------------------ 510 buildBindTemplate :: Bind -> [X.Node] 511 buildBindTemplate s@(Bind n _ d b r) = 512 insertAt [empty $ unName $ n] pos $ withBind 513 where bind = [buildBind s] 514 bindSize = insSize bind 515 withBind = insertAt bind b d 516 pos = b + bindSize - 1 + r 517 518 519 ------------------------------------------------------------------------------ 520 buildResult :: Bind -> [X.Node] 521 buildResult (Bind _ c d b r) = insertAt c (b + r) d 522 523 524 ------------------------------------------------------------------------------ 525 -- <apply> tests 526 527 data Apply = Apply 528 { _applyName :: Name 529 , _applyCaller :: [X.Node] 530 , _applyCallee :: Template 531 , _applyChildren :: [X.Node] 532 , _applyPos :: Int 533 } deriving (Show) 534 535 536 instance Arbitrary Apply where 537 arbitrary = do 538 name <- arbitrary 539 kids <- liftM (take 3) $ listOf $ limitedDepth 2 540 caller <- liftM (take 5) arbitrary 541 callee <- liftM (take 1) $ listOf $ limitedDepth 3 542 let s = insSize caller 543 loc <- choose (0, s - 1) 544 return $ Apply name caller callee kids loc 545 546 547 ------------------------------------------------------------------------------ 548 buildApplyCaller :: Apply -> [X.Node] 549 buildApplyCaller (Apply name caller _ kids pos) = 550 insertAt [X.Element "apply" [("template", unName name)] kids] pos caller 551 552 553 ------------------------------------------------------------------------------ 554 calcCorrect :: Apply -> [X.Node] 555 calcCorrect (Apply _ caller callee _ pos) = insertAt callee pos caller 556 557 558 ------------------------------------------------------------------------------ 559 calcResult :: (MonadIO m) => Apply -> m [X.Node] 560 calcResult apply@(Apply name _ callee _ _) = 561 evalTemplateMonad (runNodeList $ buildApplyCaller apply) 562 (X.TextNode "") ts 563 564 where ts = setTemplates (Map.singleton [T.encodeUtf8 $ unName name] 565 (DocumentFile (X.HtmlDocument X.UTF8 Nothing callee) 566 Nothing)) 567 emptyTemplateState 568 569 570 571 {- 572 -- The beginning of some future tests for hook functions. 573 574 p :: ByteString -> Node 575 p t = X.Element "p" [] [X.Text t] 576 577 hookG :: Monad m => ByteString -> Template -> m Template 578 hookG str t = return $ (p str) : t 579 580 onLoad = hookG "Inserted on load" 581 preRun = hookG "Inserted on preRun" 582 postRun = hookG "Inserted on postRun" 583 584 ts :: IO (Either String (TemplateState IO)) 585 ts = loadTemplates "test/templates" $ 586 foldr ($) (emptyTemplateState ".") 587 [setOnLoadHook onLoad 588 ,setPreRunHook preRun 589 ,setPostRunHook postRun 590 ] 591 592 r name etm = do 593 let ts = either (error "Danger Will Robinson!") id etm 594 ns <- runNodeList ts name 595 return $ (Just . formatList') =<< ns 596 -} 597 598 599 {- 600 - Convenience code for manual ghci experimentation 601 -} 602 603 --html :: [Node] -> Node 604 --html c = X.Element "html" [] [hhead, body c] 605 --hhead :: Node 606 --hhead = X.Element "head" [] [title, X.Element "script" [] []] 607 --title :: Node 608 --title = X.Element "title" [] [X.Text "Test Page"] 609 --body :: [Node] -> Node 610 --body = X.Element "body" [] 611 -- 612 --para :: Int -> Node 613 --para n = X.Element "p" [] [X.Text $ B.pack $ "This is paragraph " ++ show n] 614 --para2 :: B.ByteString -> Node 615 --para2 c = X.Element "p" [] [X.Text c] 616 --para3 :: Node 617 --para3 = X.Element "p" [] [X.Text "AHA!"] 618 -- 619 --foo :: Int -> [Node] 620 --foo n = insertAt [X.Element "NEW" [] []] n [html [para 1, para 2]] 621 -- 622 --tdoc :: [Node] 623 --tdoc = [para 1, para 2, para 3, para 4] 624 -- 625 --bindElem :: [Node] -> Int -> Int -> Bind 626 --bindElem = Bind (Name "mytag") [para2 "bound paragraph"] 627 -- 628 --addBind :: Bind -> [Node] -> [Node] 629 --addBind b = insertAt [buildBind b] 0 . insertAt [empty $ unName $ _bindElemName b] 2 630 -- 631 --prn :: Node -> IO () 632 --prn = L.putStrLn . formatNode 633 --runTests :: IO () 634 --runTests = defaultMain tests 635