From d37a8c5f1b6dd88c1ebe5310161c16a0c463defb Mon Sep 17 00:00:00 2001
From: stuebinm
Date: Sun, 14 Jun 2026 15:58:44 +0200
Subject: bahnhof-name: fix handling of / in request path

before, slashes in station names could not be handled, as they are split
during parsing of the incoming request to see if the last (really the
second) part was /gleis or /tracks.

Now, instead the list is un-snoc'd, and then if the last part is not one
that requires special handling, we fall through to treating it as a
station name.
---
 app/Main.hs | 67 +++++++++++++++++++++++++++++++------------------------------
 1 file changed, 34 insertions(+), 33 deletions(-)

diff --git a/app/Main.hs b/app/Main.hs
index 0c004d5..132e132 100644
--- a/app/Main.hs
+++ b/app/Main.hs
@@ -86,45 +86,18 @@ app :: AppData -> Application
 app AppData{..} request respond = mkAnswer >>= (respond . toResponse)
   where
     mkAnswer :: IO Answer
-    mkAnswer = case filter (/= mempty) (pathInfo request) of
-      [] -> pure helptext
-      ["favicon.ico"] -> pure Notfound
-      ["cache"] -> do
+    mkAnswer = case unsnoc (filter (/= mempty) (pathInfo request)) of
+      Nothing -> pure helptext
+      Just ([], "favicon.ico") -> pure Notfound
+      Just ([], "cache") -> do
         cache <- readTVarIO platformCache
         now <- getCurrentTime
         M.toList cache
           & fmap (\(ril100, (age, _)) -> (T.pack . show) (unRil100 ril100, now `diffUTCTime` age))
           & T.unlines
           & (pure . Plaintext)
-      [query]
-        | not (T.any isLower query) && host `elem` ["leitpunkt"]
-          -> lookupName query leitpunktMap
-            >>= (`lookupCode` ril100map)
-            & maybeAnswer Plaintext & pure
-        | not (T.any isLower query) && host `elem` ["rnv"]
-          -> lookupCode (RnvId query) rnvMap
-            & maybeAnswer Plaintext & pure
-        | not (T.any isLower query)
-          -> lookupCode (Ril100 query) ril100map
-            & maybeAnswer Plaintext & pure
-        | host `elem` ["leitpunkt"]
-          -> pure $ case findStationName query ril100set of
-            None -> Notfound
-            Exact (_,match) -> lookupName match ril100map
-              >>= (`lookupCode` leitpunktMap)
-              & maybeAnswer Plaintext
-            Fuzzy (_,match) -> Redirect (leitpunktBaseUrl <> "/" <> match)
-        | host `elem` ["rnv"]
-          -> lookupName query rnvMap
-            & maybeAnswer (Plaintext . unRnv) & pure
-        | otherwise
-          -> pure $ case findStationName query ril100set of
-            None -> Notfound
-            Exact (_,match) -> lookupName match ril100map
-              & maybeAnswer (Plaintext . unRil100)
-            Fuzzy (_,match) -> Redirect (ril100BaseUrl <> "/" <> match)
-      [query, segment] | segment `elem` ["gleis", "track", "tracks", "gleise", "platform", "platforms", "fetch"]
-        -> case queriedRil100 query of
+      Just (query, segment) | segment `elem` ["gleis", "track", "tracks", "gleise", "platform", "platforms", "fetch"]
+        -> case queriedRil100 (T.intercalate "/" query) of
         None -> pure Notfound
         Fuzzy url -> pure (Redirect (T.intercalate "/" [url, segment]))
         Exact ril100 -> do
@@ -209,6 +182,34 @@ app AppData{..} request respond = mkAnswer >>= (respond . toResponse)
                               & T.intercalate " "
                             mkAnchor p inner =
                               "<a href=\"https://osm.org/"<>osmType p<>"/"<>osmId p<>"\">"<>inner<>"</a>"
+      Just _
+        | not (T.any isLower query) && host `elem` ["leitpunkt"]
+          -> lookupName query leitpunktMap
+            >>= (`lookupCode` ril100map)
+            & maybeAnswer Plaintext & pure
+        | not (T.any isLower query) && host `elem` ["rnv"]
+          -> lookupCode (RnvId query) rnvMap
+            & maybeAnswer Plaintext & pure
+        | not (T.any isLower query)
+          -> lookupCode (Ril100 query) ril100map
+            & maybeAnswer Plaintext & pure
+        | host `elem` ["leitpunkt"]
+          -> pure $ case findStationName query ril100set of
+            None -> Notfound
+            Exact (_,match) -> lookupName match ril100map
+              >>= (`lookupCode` leitpunktMap)
+              & maybeAnswer Plaintext
+            Fuzzy (_,match) -> Redirect (leitpunktBaseUrl <> "/" <> match)
+        | host `elem` ["rnv"]
+          -> lookupName query rnvMap
+            & maybeAnswer (Plaintext . unRnv) & pure
+        | otherwise
+          -> pure $ case findStationName query ril100set of
+            None -> Notfound
+            Exact (_,match) -> lookupName match ril100map
+              & maybeAnswer (Plaintext . unRil100)
+            Fuzzy (_,match) -> Redirect (ril100BaseUrl <> "/" <> match)
+         where query = T.intercalate "/" (pathInfo request)
       _ -> pure Notfound
     queriedRil100 :: Text -> MatchResult Ril100 Text
     queriedRil100 query = if
-- 
cgit v1.2.3