queryFromURI should be stricter

felko · Apr 18, 2020 · 9eb34bd · 9eb34bd
1 parent a7c63ab
commit 9eb34bd
Show file tree

Hide file tree

Showing 5 changed files with 28 additions and 18 deletions.
diff --git a/src/Neuron/CLI/Types.hs b/src/Neuron/CLI/Types.hs
@@ -2,6 +2,7 @@
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE RecordWildCards #-}
 {-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE ViewPatterns #-}
 {-# LANGUAGE NoImplicitPrelude #-}
 
 module Neuron.CLI.Types
@@ -116,4 +117,8 @@ commandParser defaultNotesDir = do
       ribServe <- Rib.Cli.serveOption
       pure RibConfig {..}
     uriReader =
-      eitherReader $ bimap displayException Z.queryFromURI . URI.mkURI . toText
+      eitherReader $ \(toText -> s) -> case URI.mkURI s of
+        Right uri ->
+          first toString $ Z.queryFromURI uri
+        Left e ->
+          Left $ displayException e
diff --git a/src/Neuron/Zettelkasten/Link.hs b/src/Neuron/Zettelkasten/Link.hs
@@ -28,7 +28,7 @@ data ZLink
     ZLink_QueryZettels Connection LinkTheme [Query]
   deriving (Eq, Show)
 
-mkZLink :: MarkdownLink -> Maybe ZLink
+mkZLink :: HasCallStack => MarkdownLink -> Maybe ZLink
 mkZLink MarkdownLink {markdownLinkUri = uri, markdownLinkText = linkText} =
   -- NOTE: We should probably drop the 'cf' variants in favour of specifying
   -- the connection type as a query param or something.
@@ -42,9 +42,9 @@ mkZLink MarkdownLink {markdownLinkUri = uri, markdownLinkText = linkText} =
       let zid = parseZettelID linkText
        in Just $ ZLink_ConnectZettel OrdinaryConnection zid
     Just "zquery" ->
-      Just $ ZLink_QueryZettels Folgezettel (linkThemeFromURI uri) (queryFromURI uri)
+      Just $ ZLink_QueryZettels Folgezettel (linkThemeFromURI uri) (either error id $ queryFromURI uri)
     Just "zcfquery" ->
-      Just $ ZLink_QueryZettels OrdinaryConnection (linkThemeFromURI uri) (queryFromURI uri)
+      Just $ ZLink_QueryZettels OrdinaryConnection (linkThemeFromURI uri) (either error id $ queryFromURI uri)
     _ -> do
       let uriS = URI.render uri
       guard $ uriS == linkText

diff --git a/src/Neuron/Zettelkasten/Query.hs b/src/Neuron/Zettelkasten/Query.hs
@@ -1,15 +1,16 @@
+{-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE RecordWildCards #-}
 {-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE TupleSections #-}
 {-# LANGUAGE ViewPatterns #-}
 {-# LANGUAGE NoImplicitPrelude #-}
 
 -- | Queries to the Zettel store
 module Neuron.Zettelkasten.Query where
 
+import Control.Monad.Except
 import qualified Data.Map.Strict as Map
 import Lucid
 import Neuron.Zettelkasten.Store
@@ -43,14 +44,17 @@ instance ToHtml [Query] where
 
 type QueryResults = [Zettel]
 
-queryFromURI :: URI.URI -> [Query]
+queryFromURI :: MonadError Text m => URI.URI -> m [Query]
 queryFromURI uri =
-  flip mapMaybe (URI.uriQuery uri) $ \case
-    URI.QueryParam (URI.unRText -> key) (URI.unRText -> val) ->
-      case key of
-        "tag" -> Just $ Query_ZettelsByTag (TagPattern $ toString val)
+  case fmap URI.unRText (URI.uriScheme uri) of
+    Just proto | proto `elem` ["zquery", "zcfquery"] ->
+      pure $ flip mapMaybe (URI.uriQuery uri) $ \case
+        URI.QueryParam (URI.unRText -> key) (URI.unRText -> val) ->
+          case key of
+            "tag" -> Just $ Query_ZettelsByTag (TagPattern $ toString val)
+            _ -> Nothing
         _ -> Nothing
-    _ -> Nothing
+    _ -> throwError "Bad URI (expected: zquery: or zcfquery:)"
 
 matchQuery :: Zettel -> Query -> Bool
 matchQuery Zettel {..} = \case

diff --git a/test/Neuron/Zettelkasten/LinkSpec.hs b/test/Neuron/Zettelkasten/LinkSpec.hs
@@ -51,11 +51,11 @@ zLinkCases =
     ),
     ( "zquery: link",
       (Right (".", "zquery://search?tag=science")),
-      Just $ ZLink_QueryZettels Folgezettel LinkTheme_Default [ByTag $ TagPattern "science"]
+      Just $ ZLink_QueryZettels Folgezettel LinkTheme_Default [Query_ZettelsByTag $ TagPattern "science"]
     ),
     ( "zcfquery: link, with link theme",
       (Right (".", "zcfquery://search?tag=science&linkTheme=withDate")),
-      Just $ ZLink_QueryZettels OrdinaryConnection LinkTheme_WithDate [ByTag $ TagPattern "science"]
+      Just $ ZLink_QueryZettels OrdinaryConnection LinkTheme_WithDate [Query_ZettelsByTag $ TagPattern "science"]
     ),
     ( "normal link",
       (Left "https://www.google.com"),

diff --git a/test/Neuron/Zettelkasten/QuerySpec.hs b/test/Neuron/Zettelkasten/QuerySpec.hs
@@ -18,14 +18,15 @@ spec =
     it "Parse all zettels URI" $
       parseQueryString "zquery://search" `shouldBe` Right []
     it "Parse single tag" $
-      parseQueryString "zquery://search?tag=foo" `shouldBe` Right [ByTag $ TagPattern "foo"]
+      parseQueryString "zquery://search?tag=foo" `shouldBe` Right [Query_ZettelsByTag $ TagPattern "foo"]
     it "Parse hierarchical tag" $ do
-      parseQueryString "zquery://search?tag=foo/bar" `shouldBe` Right [ByTag $ TagPattern "foo/bar"]
+      parseQueryString "zquery://search?tag=foo/bar" `shouldBe` Right [Query_ZettelsByTag $ TagPattern "foo/bar"]
     it "Parse tag pattern" $ do
-      parseQueryString "zquery://search?tag=foo/**/bar/*/baz" `shouldBe` Right [ByTag $ TagPattern "foo/**/bar/*/baz"]
+      parseQueryString "zquery://search?tag=foo/**/bar/*/baz" `shouldBe` Right [Query_ZettelsByTag $ TagPattern "foo/**/bar/*/baz"]
     it "Parse multiple tags" $
       parseQueryString "zquery://search?tag=foo&tag=bar"
-        `shouldBe` Right [ByTag $ TagPattern "foo", ByTag $ TagPattern "bar"]
+        `shouldBe` Right [Query_ZettelsByTag $ TagPattern "foo", Query_ZettelsByTag $ TagPattern "bar"]
   where
+    parseQueryString :: Text -> Either Text [Query]
     parseQueryString =
-      bimap displayException queryFromURI . mkURI
+      either (Left . toText . displayException) queryFromURI . mkURI