From 3125503adcc49e06bb400ea14a10b203f987b790 Mon Sep 17 00:00:00 2001
From: Jade Lovelace <software@lfcode.ca>
Date: Sun, 2 Oct 2022 13:37:42 -0700
Subject: [PATCH] Implement search suggestions so the OpenSearch XML we ship
 works

---
 src/Action/Server.hs | 37 +++++++++++++++++++++++++++++++++++++
 1 file changed, 37 insertions(+)

diff --git a/src/Action/Server.hs b/src/Action/Server.hs
index f623d7d8..8a45f04d 100644
--- a/src/Action/Server.hs
+++ b/src/Action/Server.hs
@@ -26,6 +26,8 @@ import General.Str
 import qualified Data.ByteString.Char8 as BS
 import qualified Data.ByteString.Lazy.Char8 as LBS
 import qualified Data.Map as Map
+import qualified Data.Text as T
+import qualified Data.Vector as V
 import System.Time.Extra
 import Data.Time.Clock
 import Data.Time.Calendar
@@ -120,6 +122,10 @@ replyServer log local links haddock store cdn home htmlDir scope Input{..} = cas
                 Just "text" -> pure $ OutputJSON $ JSON.toEncoding $ map unHTMLTarget filteredResults
                 Just f -> pure $ OutputFail $ lbstrPack $ "Format mode " ++ f ++ " not (currently) supported"
                 Nothing -> pure $ OutputJSON $ JSON.toEncoding filteredResults
+            Just "suggest" -> let
+                filteredResults = take 25 results
+              in pure . OutputJSON $
+                   toOpenSearchJSON (unwords qSearch) filteredResults
             Just m -> pure $ OutputFail $ lbstrPack $ "Mode " ++ m ++ " not (currently) supported"
     ["plugin","jquery.js"] -> OutputFile <$> JQuery.file
     ["plugin","jquery.flot.js"] -> OutputFile <$> Flot.file Flot.Flot
@@ -250,6 +256,37 @@ showURL _ (Just _) x = "haddock/" ++ dropPrefix "file:///" x
 showURL True _ (stripPrefix "file:///" -> Just x) = "file/" ++ x
 showURL _ _ x = x
 
+-- | Turns a list of Targets into OpenSearch JSON.
+--
+--   OpenSearch specifies a somewhat odd JSON format for suggestions: one
+--   top-level heterogeneous array like so:
+--   @
+--   [QueryString, Completions, Descriptions, QueryURLs]
+--   @
+--
+--   See the archived documentation at
+--   <https://github.com/dewitt/opensearch/blob/master/mediawiki/Specifications/OpenSearch/Extensions/Suggestions/1.1/Draft%201.wiki>
+toOpenSearchJSON :: String -> [Target] -> JSON.Encoding
+toOpenSearchJSON query targets =
+    JSON.foldable [
+        JSON.String . T.pack $ query,
+        JSON.Array completions,
+        -- this is optional, but easy to provide
+        JSON.Array descriptions,
+        -- this is optional, and browsers seem to entirely ignore it
+        JSON.Array mempty
+        ]
+    where
+    (completions, descriptions)
+        = V.unzip $ go <$> V.fromList targets
+    jsonString = JSON.String . T.pack
+    go Target{..} = let
+        in (jsonString . nameFor $ targetItem, jsonString . unHTML $ targetDocs)
+    nameFor item
+        | Just (pre,x) <- stripInfix "<s0>" item
+        , Just (name,post) <- stripInfix "</s0>" x = name
+        | otherwise = item
+
 
 -------------------------------------------------------------
 -- DISPLAY AN ITEM (bold keywords etc)