Merge pull request #819 from tsoding/817

(#817) Escape special org-mode characters while rendering gist documents

Author: rexim

HyperNerd.cabal

@@ -107,6 +107,7 @@ executable HyperNerd
                      , Schedule
                      , Bot.Asciify
                      , Free
+                     , OrgMode
 
   -- LANGUAGE extensions used by modules in this package.
   other-extensions:    OverloadedStrings
@@ -224,6 +225,8 @@ test-suite HyperNerdTest
                      , Bot.FridayTest
                      , Bot.ExprTest
                      , Bot.GitHub
+                     , OrgMode
+                     , OrgModeTest
                      , Data.Maybe.Extra
                      , Data.Time.Extra
                      , Data.Time.ExtraTest

src/Bot/Friday.hs

@@ -32,6 +32,7 @@ import Data.Time
 import Effect
 import Entity
 import HyperNerd.Comonad
+import OrgMode
 import Property
 import Reaction
 import Regexp
@@ -240,20 +241,21 @@ videoCountCommand =
 
 renderQueue :: [FridayVideo] -> T.Text
 renderQueue queue@(FridayVideo {fridayVideoAuthor = user}:_) =
-  T.unlines $
-  ([qmb|** {user}
-
-        Video Count {length queue}
-
-        |] :) $
-  map
-    (\video ->
-       let ytId = fromMaybe "dQw4w9WgXcQ" $ ytLinkId $ fridayVideoName video
-        in [qms||{fridayVideoDate video}
-                |{fridayVideoAuthor video}
-                |{fridayVideoName video}
-                |[[https://img.youtube.com/vi/{ytId}/default.jpg]]||])
-    queue
+  [qmb|** {user}
+
+        Video Count {length queue}\n\n
+        |] <>
+  renderTable
+    ["Date", "Submitter", "Video", "Thumbnail"]
+    (map
+       (\video ->
+          let ytId = fromMaybe "dQw4w9WgXcQ" $ ytLinkId $ fridayVideoName video
+           in [ [qms|{fridayVideoDate video}|]
+              , [qms|{fridayVideoAuthor video}|]
+              , [qms|{fridayVideoName video}|]
+              , [qms|[[https://img.youtube.com/vi/{ytId}/default.jpg]]|]
+              ])
+       queue)
 renderQueue [] = ""
 
 renderQueues :: Maybe T.Text -> VideoQueues -> T.Text

src/Bot/Help.hs

@@ -20,6 +20,7 @@ import Data.Proxy
 import qualified Data.Text as T
 import Effect
 import Entity
+import OrgMode
 import Property
 import Reaction
 import Text.InterpolatedString.QM
@@ -73,28 +74,31 @@ refreshHelpGistId =
   Reaction replyMessage
 
 gistRenderCommandTable :: CommandTable -> T.Text
-gistRenderCommandTable =
-  ([qms|* Builtin Commands\n{header}\n|-\n|] <>) .
-  T.unlines . map renderRow . M.toList
+gistRenderCommandTable commandTable = [qms|* Builtin Commands\n{table}\n|]
   where
-    header :: T.Text
-    header = "|Name|Description|Location|"
-    renderRow :: (T.Text, BuiltinCommand) -> T.Text
-    renderRow (name, command) =
-      [qms||{name}|{bcDescription command}|{location}||]
-      where
-        location :: T.Text
-        location = [qms|[[{bcGitHubLocation command}][Source↗]]|]
+    table :: T.Text
+    table =
+      renderTable ["Name", "Description", "Location"] $
+      map
+        (\(name, command) ->
+           [ name
+           , bcDescription command
+           , [qms|[[{bcGitHubLocation command}][Source↗]]|]
+           ]) $
+      M.toList commandTable
 
 gistRenderCustomCommandsTable :: [Entity CustomCommand] -> T.Text
-gistRenderCustomCommandsTable =
-  ([qms|* Custom commands\n{header}\n|-\n|] <>) .
-  T.unlines . map (renderRow . entityPayload)
+gistRenderCustomCommandsTable customCommands =
+  [qms|* Custom commands\n{table}\n|]
   where
-    header :: T.Text
-    header = "|Name|Definition|%times|"
-    renderRow (CustomCommand name message times) =
-      [qms||{name}|{message}|{times}||]
+    table :: T.Text
+    table =
+      renderTable ["Name", "Definition", "%times"] $
+      map
+        ((\(CustomCommand name message times) ->
+            [name, message, T.pack $ show times]) .
+         entityPayload)
+        customCommands
 
 refreshHelpGist :: CommandTable -> GistId -> Effect ()
 refreshHelpGist commandTable gistId = do

src/OrgMode.hs

@@ -0,0 +1,22 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module OrgMode
+  ( renderTable
+  ) where
+
+import Data.List
+import qualified Data.Text as T
+
+charEscapeList :: String
+charEscapeList = "|"
+
+renderTable :: [T.Text] -> [[T.Text]] -> T.Text
+renderTable header rows =
+  T.unlines ([renderRow header, "|-"] <> map (renderRow . normalizeRow) rows)
+  where
+    normalizeRow row = take (length header) (row ++ repeat "")
+    renderRow :: [T.Text] -> T.Text
+    renderRow columns =
+      "|" <> T.concat (intersperse "|" $ map escapeColumn columns) <> "|"
+    escapeColumn :: T.Text -> T.Text
+    escapeColumn = T.filter $ not . (`elem` charEscapeList)

test/OrgModeTest.hs

@@ -0,0 +1,34 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module OrgModeTest
+  ( spec
+  ) where
+
+import OrgMode
+import Test.HUnit
+
+spec :: Test
+spec =
+  TestLabel "Rendering OrgMode table" $
+  TestCase $
+  assertEqual
+    ""
+    "|hello|world|foo|\n\
+     \|-\n\
+     \|1|2|3|\n\
+     \|1|2|3|\n\
+     \|1|2||\n\
+     \|1|||\n\
+     \||||\n\
+     \|1|2|3|\n\
+     \|~|||\n" $
+  renderTable
+    ["hello", "world", "foo"]
+    [ ["1", "2", "3"]
+    , ["1", "2", "3"]
+    , ["1", "2"]
+    , ["1"]
+    , []
+    , ["1", "2", "3", "4", "5"]
+    , ["|~"]
+    ]

test/Test.hs

@@ -18,6 +18,7 @@ import qualified Bot.PollTest
 import qualified Bot.TwitchTest
 import qualified CommandTest
 import qualified Data.Time.ExtraTest
+import qualified OrgModeTest
 import qualified Sqlite.EntityPersistenceTest
 import System.Exit
 import Test.HUnit
@@ -36,6 +37,7 @@ main = do
       , CommandTest.spec
       , Sqlite.EntityPersistenceTest.spec
       , Data.Time.ExtraTest.spec
+      , OrgModeTest.spec
       ]
   if errors results + failures results == 0
     then exitSuccess