improve tag navigation: fix urls when tags have '+' or ':'

purs/src/Component/BMark.purs

@@ -25,7 +25,7 @@ import Halogen.HTML.Events (onSubmit, onValueChange, onChecked, onClick)
 import Halogen.HTML.Properties (ButtonType(..), InputType(..), autocomplete, checked, disabled, for, href, id, name, required, rows, target, title, type_, value)
 import Model (Bookmark)
 import Type.Proxy (Proxy(..))
-import Util (attr, class_, fromNullableStr, ifElseH, whenH, whenA)
+import Util (attr, class_, encodeTag, fromNullableStr, ifElseH, whenA, whenH)
 import Web.Event.Event (Event, preventDefault)
 
 -- | UI Events
@@ -206,7 +206,7 @@ bmark b' =
      editField :: forall a. (a -> EditField) -> a -> BAction
      editField f = BEditField <<< f
      linkToFilterSingle slug = fromNullableStr app.userR <> "/b:" <> slug
-     linkToFilterTag tag = fromNullableStr app.userR <> "/t:" <> tag
+     linkToFilterTag tag = fromNullableStr app.userR <> "/t:" <> encodeTag tag 
      shdate = toLocaleDateString bm.time 
      shdatetime = S.take 16 bm.time `append` "Z"
 

purs/src/Component/TagCloud.purs

@@ -23,7 +23,7 @@ import Halogen.HTML.Events (onClick)
 import Halogen.HTML.Properties (ButtonType(..), href, title, type_)
 import Math (log)
 import Model (TagCloud, TagCloudModeF(..), isExpanded, isRelated, setExpanded, tagCloudModeFromF)
-import Util (class_, fromNullableStr, whenH, ifElseA)
+import Util (class_, encodeTag, fromNullableStr, ifElseA, whenH)
 
 data TAction
   = TInitialize
@@ -128,15 +128,15 @@ tagcloudcomponent m' =
     <<< sortBy (comparing (S.toLower <<< fst))
     <<< F.toUnfoldable
 
-  linkToFilterTag tag = fromNullableStr app.userR <> (if S.null tag then "" else "/t:" <> tag) 
+  linkToFilterTag rest = fromNullableStr app.userR <> (if S.null rest then "" else "/t:" <> rest) 
 
   toSizedTag :: Array String -> Int -> Int -> String -> Int -> _
   toSizedTag curtags n m k v =
-    [ a [ href (linkToFilterTag k) , class_ "link tag mr1" , style] 
+    [ a [ href (linkToFilterTag (encodeTag k)), class_ "link tag mr1" , style] 
         [ text k ]
       , whenH (not (null curtags))  \_ -> if (notElem k_lower curtags)
-          then a [href (linkToFilterTag (S.joinWith "+" (cons k_lower curtags))), class_ "link mr2 tag-include"] [text "⊕"]
-          else a [href (linkToFilterTag (S.joinWith "+" (delete k_lower curtags))), class_ "link mr2 tag-exclude"] [text "⊖"]
+          then a [href (linkToFilterTag (S.joinWith "+" (map encodeTag (cons k_lower curtags)))), class_ "link mr2 tag-include"] [text "⊕"]
+          else a [href (linkToFilterTag (S.joinWith "+" (map encodeTag (delete k_lower curtags)))), class_ "link mr2 tag-exclude"] [text "⊖"]
     ]
     where
       k_lower = toLower k

purs/src/Util.purs

@@ -8,11 +8,13 @@ import Data.Foldable (for_)
 import Data.Maybe (Maybe(..), fromJust, fromMaybe, maybe)
 import Data.Nullable (Nullable, toMaybe)
 import Data.String (Pattern(..), Replacement(..), drop, replaceAll, split, take)
+import Data.String as S
 import Data.Tuple (Tuple(..), fst, snd)
 import Effect (Effect)
 import Halogen (ClassName(..))
 import Halogen.HTML as HH
 import Halogen.HTML.Properties as HP
+import JSURI (decodeURIComponent, encodeURIComponent)
 import Partial.Unsafe (unsafePartial)
 import Web.DOM (Element, Node)
 import Web.DOM.Document (toNonElementParentNode)
@@ -27,7 +29,6 @@ import Web.HTML.HTMLElement (HTMLElement)
 import Web.HTML.HTMLElement (fromElement) as HE
 import Web.HTML.Location (search)
 import Web.HTML.Window (document, location)
-import JSURI (decodeURIComponent)
 
 unsafeDecode :: String -> String
 unsafeDecode str = unsafePartial $ fromJust $ decodeURIComponent str
@@ -117,6 +118,9 @@ _mt = MaybeT
 _mt_pure :: forall a. Maybe a -> MaybeT Effect a
 _mt_pure = MaybeT <<< pure
 
+encodeTag :: String -> String
+encodeTag = fromMaybe "" <<< encodeURIComponent <<< replaceAll (Pattern "+") (Replacement "%2B")
+
 dummyAttr :: forall r i. HP.IProp r i
 dummyAttr = HP.attr (HH.AttrName "data-dummy") ""
 

src/PathPiece.hs

@@ -2,28 +2,34 @@
 
 module PathPiece where
 
-import Data.Text (splitOn)
-
+import Data.Text (breakOn, splitOn)
+import qualified Data.Text as T (replace)
 import Import.NoFoundation
 
 -- PathPiece
 
 instance PathPiece UserNameP where
   toPathPiece (UserNameP i) = "u:" <> i
   fromPathPiece s =
-    case splitOn ":" s of
-      ["u", ""] -> Nothing
-      ["u", uname] -> Just $ UserNameP uname
+    case breakOn ":" s of
+      ("u", "") -> Nothing
+      ("u", uname) -> Just $ UserNameP (drop 1 uname)
       _ -> Nothing
 
 instance PathPiece TagsP where
-  toPathPiece (TagsP tags) = "t:" <> intercalate "+" tags
+  toPathPiece (TagsP tags) = "t:" <> intercalate "+" (fmap encodeTag tags)
   fromPathPiece s =
-    case splitOn ":" s of
-      ["t", ""] -> Nothing
-      ["t", tags] -> Just $ TagsP (splitOn "+" tags)
+    case breakOn ":" s of
+      ("t", "") -> Nothing
+      ("t", tags) -> Just $ (TagsP . fmap decodeTag . splitOn "+" . drop 1) tags
       _ -> Nothing
 
+encodeTag :: Text -> Text
+encodeTag = T.replace "+" "%2B"
+
+decodeTag :: Text -> Text
+decodeTag = T.replace "%2B" "+"
+
 instance PathPiece SharedP where
   toPathPiece = \case
     SharedAll -> ""
@@ -45,9 +51,9 @@ instance PathPiece FilterP where
     "unread" -> Just FilterUnread
     "untagged" -> Just FilterUntagged
     "starred" -> Just FilterStarred
-    s -> case splitOn ":" s of
-        ["b", ""] -> Nothing
-        ["b", slug] -> Just $ FilterSingle (BmSlug slug)
+    s -> case breakOn ":" s of
+        ("b", "") -> Nothing
+        ("b", slug) -> Just $ FilterSingle (BmSlug (drop 1 slug))
         _ -> Nothing