<commit_before>{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE FlexibleContexts #-}

module BlogTest
    ( blogSpecs
    ) where

import TestImport

import Data.Text.Encoding
import qualified Data.Map as M
import qualified Text.XML as XML
import qualified Text.HTML.DOM as HTML

blogSpecs :: Spec
blogSpecs = do
    let postBlog route stmts = [marked|
            get200 route

            [ form ] <- htmlQuery "form"

            let getAttrs = XML.elementAttributes . XML.documentRoot . HTML.parseLBS

            withStatus 303 True $ request $ do
                addToken
                setMethod "POST"
                let route' = maybe (Left route) Right $ M.lookup "action" $ getAttrs form
                either setUrl setUrl route'
                addPostParam "mode" "post"
                stmts
        |]

        previewBlog route stmts = [marked|
            get200 route

            [ form ] <- htmlQuery "form"

            let getAttrs = XML.elementAttributes . XML.documentRoot . HTML.parseLBS

            withStatus 200 False $ request $ do
                addToken
                setMethod "POST"
                maybe (setUrl route) setUrl $ M.lookup "action" $ getAttrs form

                addPostParam "mode" "preview"
                stmts
        |]

    ydescribe "blog" $ do
        yit "previews blog post" $ [marked|
            loginAs AdminUser

            get200 $ ProjectBlogR "snowdrift"
            htmlNoneContain ".blog-post" "Above fold."
            htmlNoneContain ".blog-post" "Below fold."

            previewBlog (NewBlogPostR "snowdrift") $ do
                byLabel "Title for this blog post" "Test"
                byLabel "Handle for the URL" "test"
                byLabel "Content" "Above fold.\n***\nBelow fold."

            bodyContains "Above fold."
            bodyContains "Below fold."
        |]

        yit "posts blog post" $ [marked|
            loginAs AdminUser

            get200 $ ProjectBlogR "snowdrift"
            htmlNoneContain ".blog-post" "Above fold."
            htmlNoneContain ".blog-post" "Below fold."

            postBlog (NewBlogPostR "snowdrift") $ do
                byLabel "Title for this blog post" "Test"
                byLabel "Handle for the URL" "test"
                byLabel "Content" "Above fold.\n***\nBelow fold."

            Just route <- extractLocation

            get200 $ decodeUtf8 route

            htmlAnyContain ".blog-post-top" "Above fold."
            htmlNoneContain ".blog-post-top" "Below fold."

            get $ BlogPostR "snowdrift" "test"

            htmlAnyContain ".blog-post" "Above fold."
            htmlAnyContain ".blog-post" "Below fold."

            get200 $ ProjectBlogR "snowdrift"
            htmlAnyContain ".blog-post-top" "Above fold."
            htmlNoneContain ".blog-post-top" "Below fold."
        |]<commit_msg>Refactor<commit_after>{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE FlexibleContexts #-}

module BlogTest
    ( blogSpecs
    ) where

import TestImport

import Data.Text.Encoding
import qualified Data.Map as M
import qualified Text.XML as XML
import qualified Text.HTML.DOM as HTML

blogSpecs :: Spec
blogSpecs = do
    let getAttrs = XML.elementAttributes . XML.documentRoot . HTML.parseLBS
        blogRoute = NewBlogPostR "snowdrift"
    ydescribe "blog" $ do
        yit "previews blog post" $ [marked|
            loginAs AdminUser

            get200 $ ProjectBlogR "snowdrift"
            htmlNoneContain ".blog-post" "Above fold."
            htmlNoneContain ".blog-post" "Below fold."

            get200 blogRoute

            [ form ] <- htmlQuery "form"

            withStatus 200 False $ request $ do
                addToken
                setMethod "POST"
                maybe (setUrl blogRoute) setUrl $ M.lookup "action" $ getAttrs form

                addPostParam "mode" "preview"
                byLabel "Title for this blog post" "Test"
                byLabel "Handle for the URL" "test"
                byLabel "Content" "Above fold.\n***\nBelow fold."

            bodyContains "Above fold."
            bodyContains "Below fold."
        |]

        yit "posts blog post" $ [marked|
            loginAs AdminUser

            get200 $ ProjectBlogR "snowdrift"
            htmlNoneContain ".blog-post" "Above fold."
            htmlNoneContain ".blog-post" "Below fold."

            get200 blogRoute

            [ form ] <- htmlQuery "form"

            withStatus 303 True $ request $ do
                addToken
                setMethod "POST"
                let route' = maybe (Left blogRoute) Right $ M.lookup "action" $ getAttrs form
                either setUrl setUrl route'
                addPostParam "mode" "post"
                byLabel "Title for this blog post" "Test"
                byLabel "Handle for the URL" "test"
                byLabel "Content" "Above fold.\n***\nBelow fold."

            Just route <- extractLocation

            get200 $ decodeUtf8 route
            htmlAnyContain ".blog-post-top" "Above fold."
            htmlNoneContain ".blog-post-top" "Below fold."

            get $ BlogPostR "snowdrift" "test"
            htmlAnyContain ".blog-post" "Above fold."
            htmlAnyContain ".blog-post" "Below fold."

            get200 $ ProjectBlogR "snowdrift"
            htmlAnyContain ".blog-post-top" "Above fold."
            htmlNoneContain ".blog-post-top" "Below fold."
        |]
{'fraction_non_alphanumeric': 0.0896539027982327, 'fraction_numerical': 0.009204712812960236, 'mean_word_length': 1.6962779156327543, 'pattern_counts': {'":': 0, '<': 9, '<?xml version=': 0, '>': 3, 'https://': 0, 'lorem ipsum': 0, 'www.': 0, 'xml': 0}, 'pii_count': 0, 'substrings_counts': 0, 'word_list_counts': {'cursed_substrings.json': 0, 'profanity_word_list.json': 0, 'sexual_word_list.json': 0, 'zh_pornsignals.json': 0}}
{'dir': 'git-commits-cleaned', 'id': '2711033', 'n_tokens_mistral': 1622, 'n_tokens_neox': 1456, 'n_words': 445}