add search.xml

1 files changed, 15 insertions, 1 deletions

diff --git a/src/Main.hs b/src/Main.hs
index feb199b..54e6e20 100644
--- a/src/Main.hs
+++ b/src/Main.hs
@@ -6,11 +6,13 @@ module Main (main) where
 import Yesod
 import Network.Wai.Handler.Warp
 import Data.Function ((&))
+import Data.Functor ((<&>))
 
 import qualified Data.ByteString as BS
 
 import Bangs
 import BangState
+import Config
 
 data Search = Search {
     bangState :: BangState
@@ -20,6 +22,7 @@ mkYesod "Search" [parseRoutes|
 /           HomeR GET
 /bangs.json BangsR GET
 /submitBang SubmitR POST
+/search.xml OpenSearchR GET
 |]
 
 instance Yesod Search where
@@ -32,7 +35,7 @@ getBangsR :: Handler TypedContent
 getBangsR = do
     bangsAccessor <- lookupHeader "accept-encoding" >>= \case
         Just ae | "br" `BS.isInfixOf` ae -> do
-            addHeader "transfer-encoding" "br"
+            addHeader "content-encoding" "br"
             return getBangsBrotli
         _ -> do
             return getBangsJSON
@@ -43,6 +46,17 @@ getBangsR = do
 postSubmitR :: Handler String
 postSubmitR = return "TODO"
 
+getOpenSearchR :: Handler TypedContent
+getOpenSearchR = do
+    url <- lookupGetParam "default" <&> \case
+        Nothing -> baseUrl <> "/#{searchTerms}"
+        Just b  -> baseUrl <> "/#" <> b <> "#{searchTerms}"
+
+    return
+        $ TypedContent "application/opensearchdescription+xml"
+        $ toContent
+        $ makeOpenSearch url
+
 main :: IO ()
 main = do
     s <- Search