<commit_before>{-# LANGUAGE RecordWildCards #-}

module Model.Markdown where

import Import

import qualified Data.ByteString.Char8      as BS
import qualified Data.Text                  as T
import           Data.Text.Encoding
import           Text.Regex.TDFA
import           Text.Regex.TDFA.ByteString
import           Text.Pandoc
import           Yesod.Markdown (Markdown (..))

import Model.Discussion


-- TODO: we should probably put together some standard sets of these transforms for use in various places, rather than assembling ad-hoc

fixLinks :: Text -> DiscussionOn -> Text -> Handler Text
fixLinks project' discussion_on line' = do
    render <- getUrlRender

    let Right pattern = compile defaultCompOpt defaultExecOpt $ mconcat
            [ "(\\[[^]]*\\])" -- link
            , "\\("
            , "(" -- _
                , "c/([0-9]+)" -- comment
                , "|"
                , "([a-z]+:)?" -- project
                , "([a-z0-9-]+)" -- page
            , ")"
            , "([a-z0-9/#-]*)?" -- path
            , "\\)"
            ] 

        project = encodeUtf8 project'

        expand_match (pre, _, post, matches) = pre <> build_link matches <> parse post

        build_link [link, _, comment, "", "", path] =
            let comment_id :: CommentId
                comment_id = fromMaybe (error "bad comment id") $ fromPathPiece $ decodeUtf8 comment

             in mconcat
                    [ link
                    , "("
                        , let route = encodeUtf8 $ render $ case discussion_on of
                                DiscussionOnProject (Entity _ Project{..}) -> ProjectCommentR projectHandle comment_id
                                DiscussionOnWikiPage (Entity _ WikiPage{..}) -> WikiCommentR project' wikiPageTarget comment_id
                                DiscussionOnUser (Entity user_id _) -> UserCommentR user_id comment_id

                           in route <> path
                    , ")"
                    ]

        build_link [link, _, "", proj, page, path] =
            mconcat
                [ link
                , "("
                    , "/p/" <> if BS.null proj then project else BS.init proj
                    , "/w/" <> page <> path
                , ")"
                ]

        build_link [_, content, _, _, _] = error $ "strange match: " <> show content
        build_link _ = error $ "strange match"

        parse str = either error (maybe str expand_match) (regexec pattern str)

        line = encodeUtf8 line'
    return $ decodeUtf8 $ parse line


linkTickets :: Text -> Handler Text
linkTickets line' = do
    let Right pattern = compile defaultCompOpt defaultExecOpt "\\<SD-([0-9][0-9]*)" -- TODO word boundaries?
        getLinkForTicketComment :: TicketId -> Handler (Maybe Text)
        getLinkForTicketComment ticket_id = do
            info <- runDB $ select $ from $ \ (ticket `InnerJoin` comment `LeftOuterJoin` page `LeftOuterJoin` project) -> do
                on_ $ project ?. ProjectId ==. page ?. WikiPageProject
                on_ $ page ?. WikiPageDiscussion ==. just (comment ^. CommentDiscussion)
                on_ $ ticket ^. TicketComment ==. comment ^. CommentId
                where_ $ ticket ^. TicketId ==. val ticket_id

                return
                    ( comment ^. CommentId
                    , project ?. ProjectHandle
                    , page ?. WikiPageTarget
                    )

            case map unwrapValues info of
                [] -> return Nothing
                (Key (PersistInt64 comment_id), Just handle, Just target) : _ -> return $ Just $ mconcat
                    [ "/p/", handle, "/w/", target, "/c/",  T.pack (show comment_id) ]

                _ -> error "Unexpected result for ticket reference"

        parse _   (Left err) = error err
        parse str (Right Nothing) = return str
        parse _   (Right (Just (pre, _, post, [ticket_number]))) = do
            $(logError) $ T.pack $ show $  T.unpack $ decodeUtf8 ticket_number
            maybe_link <- getLinkForTicketComment $ Key $ PersistInt64 $ read $ T.unpack $ decodeUtf8 ticket_number
            rest <- parse post (regexec pattern post)
            return $ mconcat
                [ pre
                , "[SD-" <> ticket_number <> "]"
                , case maybe_link of
                    Nothing -> ""
                    Just link -> mconcat [ "(", encodeUtf8 link, ")" ]
                ] <> rest

        parse _ (Right (Just _)) = error "strange match"

        line = encodeUtf8 line'
     in fmap decodeUtf8 $ parse line (regexec pattern line)

renderMarkdown :: Markdown -> Handler Html
renderMarkdown = renderMarkdownWith return

renderMarkdownWith :: (Text -> Handler Text) -> Markdown -> Handler Html
renderMarkdownWith transform (Markdown markdown) = do
    let ls = T.lines markdown

    ls' <- mapM (transform <=< linkTickets) ls

    return $ writeHtml def { writerEmailObfuscation = NoObfuscation } $ readMarkdown def $ T.unpack $ T.unlines ls'


markdownWidget :: Markdown -> Widget
markdownWidget = markdownWidgetWith return
<commit_msg>Markdown translation generating HTML5 again<commit_after>{-# LANGUAGE RecordWildCards #-}

module Model.Markdown where

import Import

import qualified Data.ByteString.Char8      as BS
import qualified Data.Text                  as T
import           Data.Text.Encoding
import           Text.Regex.TDFA
import           Text.Regex.TDFA.ByteString
import           Text.Pandoc
import           Yesod.Markdown (Markdown (..))

import Model.Discussion


-- TODO: we should probably put together some standard sets of these transforms for use in various places, rather than assembling ad-hoc

fixLinks :: Text -> DiscussionOn -> Text -> Handler Text
fixLinks project' discussion_on line' = do
    render <- getUrlRender

    let Right pattern = compile defaultCompOpt defaultExecOpt $ mconcat
            [ "(\\[[^]]*\\])" -- link
            , "\\("
            , "(" -- _
                , "c/([0-9]+)" -- comment
                , "|"
                , "([a-z]+:)?" -- project
                , "([a-z0-9-]+)" -- page
            , ")"
            , "([a-z0-9/#-]*)?" -- path
            , "\\)"
            ] 

        project = encodeUtf8 project'

        expand_match (pre, _, post, matches) = pre <> build_link matches <> parse post

        build_link [link, _, comment, "", "", path] =
            let comment_id :: CommentId
                comment_id = fromMaybe (error "bad comment id") $ fromPathPiece $ decodeUtf8 comment

             in mconcat
                    [ link
                    , "("
                        , let route = encodeUtf8 $ render $ case discussion_on of
                                DiscussionOnProject (Entity _ Project{..}) -> ProjectCommentR projectHandle comment_id
                                DiscussionOnWikiPage (Entity _ WikiPage{..}) -> WikiCommentR project' wikiPageTarget comment_id
                                DiscussionOnUser (Entity user_id _) -> UserCommentR user_id comment_id

                           in route <> path
                    , ")"
                    ]

        build_link [link, _, "", proj, page, path] =
            mconcat
                [ link
                , "("
                    , "/p/" <> if BS.null proj then project else BS.init proj
                    , "/w/" <> page <> path
                , ")"
                ]

        build_link [_, content, _, _, _] = error $ "strange match: " <> show content
        build_link _ = error $ "strange match"

        parse str = either error (maybe str expand_match) (regexec pattern str)

        line = encodeUtf8 line'
    return $ decodeUtf8 $ parse line


linkTickets :: Text -> Handler Text
linkTickets line' = do
    let Right pattern = compile defaultCompOpt defaultExecOpt "\\<SD-([0-9][0-9]*)" -- TODO word boundaries?
        getLinkForTicketComment :: TicketId -> Handler (Maybe Text)
        getLinkForTicketComment ticket_id = do
            info <- runDB $ select $ from $ \ (ticket `InnerJoin` comment `LeftOuterJoin` page `LeftOuterJoin` project) -> do
                on_ $ project ?. ProjectId ==. page ?. WikiPageProject
                on_ $ page ?. WikiPageDiscussion ==. just (comment ^. CommentDiscussion)
                on_ $ ticket ^. TicketComment ==. comment ^. CommentId
                where_ $ ticket ^. TicketId ==. val ticket_id

                return
                    ( comment ^. CommentId
                    , project ?. ProjectHandle
                    , page ?. WikiPageTarget
                    )

            case map unwrapValues info of
                [] -> return Nothing
                (Key (PersistInt64 comment_id), Just handle, Just target) : _ -> return $ Just $ mconcat
                    [ "/p/", handle, "/w/", target, "/c/",  T.pack (show comment_id) ]

                _ -> error "Unexpected result for ticket reference"

        parse _   (Left err) = error err
        parse str (Right Nothing) = return str
        parse _   (Right (Just (pre, _, post, [ticket_number]))) = do
            $(logError) $ T.pack $ show $  T.unpack $ decodeUtf8 ticket_number
            maybe_link <- getLinkForTicketComment $ Key $ PersistInt64 $ read $ T.unpack $ decodeUtf8 ticket_number
            rest <- parse post (regexec pattern post)
            return $ mconcat
                [ pre
                , "[SD-" <> ticket_number <> "]"
                , case maybe_link of
                    Nothing -> ""
                    Just link -> mconcat [ "(", encodeUtf8 link, ")" ]
                ] <> rest

        parse _ (Right (Just _)) = error "strange match"

        line = encodeUtf8 line'
     in fmap decodeUtf8 $ parse line (regexec pattern line)

renderMarkdown :: Markdown -> Handler Html
renderMarkdown = renderMarkdownWith return

renderMarkdownWith :: (Text -> Handler Text) -> Markdown -> Handler Html
renderMarkdownWith transform (Markdown markdown) = do
    let ls = T.lines markdown

    ls' <- mapM (transform <=< linkTickets) ls

    return $ writeHtml def
        { writerEmailObfuscation = NoObfuscation
        , writerHtml5 = True
        } $ readMarkdown def $ T.unpack $ T.unlines ls'


markdownWidget :: Markdown -> Widget
markdownWidget = markdownWidgetWith return

{'fraction_non_alphanumeric': 0.10517124284466867, 'fraction_numerical': 0.00504511497040846, 'mean_word_length': 1.6642543292840528, 'pattern_counts': {'":': 0, '<': 39, '<?xml version=': 0, '>': 61, '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': '7174054', 'n_tokens_mistral': 2893, 'n_tokens_neox': 2658, 'n_words': 802}