fix names of betriebsstellen not having ü encoded properly

this was not ported from the previous gleam implementation.
update for ghc 9.6.5 (nixpkgs 24.05)
2024-07-26 19:05:44 +02:00 · 2024-06-04 20:04:18 +02:00 · 2024-01-16 01:41:34 +01:00 · 2023-12-26 01:52:00 +01:00 · 2023-12-01 12:40:07 +01:00 · 2023-11-30 19:17:12 +01:00
2 changed files with 78 additions and 31 deletions
--- a/app/Main.hs
+++ b/app/Main.hs
@ -1,3 +1,4 @@
+{-# LANGUAGE LambdaCase        #-}
 {-# LANGUAGE MultiWayIf        #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE RecordWildCards   #-}
@ -10,13 +11,13 @@ import qualified Data.ByteString.Lazy                 as LB
 import           Data.Char
 import           Data.Csv                             hiding (lookup)
 import           Data.Either
-import           Data.Function                        ((&))
+import           Data.Function                        (on, (&))
 import           Data.Functor                         ((<&>))
-import           Data.FuzzySet
-import           Data.List
+import           Data.FuzzySet.Simple
+import           Data.List                            hiding (find)
 import           Data.Map                             (Map)
 import qualified Data.Map                             as M
-import           Data.Maybe                           (fromMaybe)
+import           Data.Maybe                           (fromMaybe, mapMaybe)
 import           Data.Ord
 import           Data.Text                            (Text)
 import qualified Data.Text                            as T
@ -58,15 +59,18 @@ findStationName query set = case sorted of
    sorted = results
     & fmap (\(_, match) -> (fromIntegral . maybe 0 score . bestMatch (T.unpack query) $ T.unpack match, match))
     & sortOn (Down . fst)
-    results = get set query
+    results = find query set
    maybeHbf = filter (T.isInfixOf "Hbf" . snd) sorted

 data Platform = Platform
-  { osmType  :: Text
-  , osmId    :: Text
-  , ref      :: Maybe Text
-  , localRef :: Maybe Text
-  , osmLevel :: Maybe Text
+  { osmType         :: Text
+  , osmId           :: Text
+  , ref             :: Maybe Text
+  , localRef        :: Maybe Text
+  , osmLevel        :: Maybe Text
+  , osmPlatform     :: Maybe Text
+  , osmSection      :: Maybe Text
+  , osmPlatformEdge :: Maybe Text
  } deriving Show

 instance FromRecord Platform where
@ -76,7 +80,10 @@ instance FromRecord Platform where
      v .! 1 <*>
      v .! 2 <*>
      v .! 3 <*>
-      (v .! 4 <|> v .! 5)
+      (v .! 4 <|> v .! 5) <*>
+      v .! 6 <*>
+      v .! 7 <*>
+      v .! 8

 data Answer
  = Redirect Text
@ -107,7 +114,7 @@ app :: AppData -> Application
 app AppData{..} request respond = mkAnswer >>= (respond . toResponse)
  where
    mkAnswer :: IO Answer
-    mkAnswer = case pathInfo request of
+    mkAnswer = case filter (/= mempty) (pathInfo request) of
      [] -> pure helptext
      ["favicon.ico"] -> pure Notfound
      ["cache"] -> do
@ -118,11 +125,11 @@ app AppData{..} request respond = mkAnswer >>= (respond . toResponse)
          & T.unlines
          & (pure . Plaintext)
      [query]
-        | T.all isUpper query && host `elem` ["leitpunkt"]
+        | not (T.any isLower query) && host `elem` ["leitpunkt"]
          -> lookupName query leitpunktMap
            >>= (`lookupCode` ril100map)
            & maybeAnswer Plaintext & pure
-        | T.all isUpper query
+        | not (T.any isLower query)
          -> lookupCode (Ril100 query) ril100map
            & maybeAnswer Plaintext & pure
        | host `elem` ["leitpunkt"]
@ -141,7 +148,7 @@ app AppData{..} request respond = mkAnswer >>= (respond . toResponse)
      [query, segment] | segment `elem` ["gleis", "track", "tracks", "gleise", "platform", "platforms", "fetch"]
        -> case queriedRil100 query of
        None -> pure Notfound
-        Fuzzy url -> pure (Redirect url)
+        Fuzzy url -> pure (Redirect (T.intercalate "/" [url, segment]))
        Exact ril100 -> do
          maybeCache <- readTVarIO platformCache <&> M.lookup ril100
          now <- getCurrentTime
@ -150,13 +157,37 @@ app AppData{..} request respond = mkAnswer >>= (respond . toResponse)
              | now `diffUTCTime` age < cacheTime && segment /= "fetch" -> pure answer
            _ -> do
              let overpassQuery = " \
-                 \[out:csv(::type, ::id, ref, local_ref, level, layer;false)][timeout:25];\n\
-                 \node[~\"railway:ref|railway:ref:parent\"~\"^"<>encodeUtf8 (unRil100 ril100)<>"$\"][operator~\"^(DB |Deutsch)\"];\n\
-                 \rel[public_transport~\"stop_area|stop_area_group\"](bn) -> .a;\n\
+                 \[out:csv(::type, ::id, ref, local_ref, level, layer, platform, section, track;false)][timeout:25];\n\
+                 \nwr[~\"railway:ref|railway:ref:parent\"~\"^"<>encodeUtf8 (unRil100 ril100)<>"$\"][operator~\"^(DB|Deutsch)\"];\n\
+                 \(._;rel[public_transport~\"stop_area|stop_area_group\"](bn);) -> .a;\n\
                 \rel[public_transport~\"stop_area|stop_area_group\"](br.a) -> .b;\n\
                 \(.a;.b;);\n\
                 \nwr[railway=platform](>>);\n\
-                 \out;\n"
+                 \foreach {\n\
+                 \  ._ -> .a;\n\
+                 \  out tags;\n\
+                 \  >> -> .p;\n\
+                 \  nwr.p[\"railway\"=\"platform_edge\"][\"ref\"] -> .edges;\n\
+                 \  if (edges.count(nwr) == 0) {\n\
+                 \    >>;\n\
+                 \    node._[\"railway:platform:section\"] -> ._;\n\
+                 \    convert node platform = a.u(id()),\n\
+                 \                 section = t[\"railway:platform:section\"],\n\
+                 \                 ::id = id();\n\
+                 \    out tags;\n\
+                 \  } else {  \n\
+                 \    foreach.edges {\n\
+                 \      ._ -> .b;\n\
+                 \      >>;\n\
+                 \      node._[\"railway:platform:section\"] -> ._;\n\
+                 \      convert node platform = a.u(id()),\n\
+                 \                   section = t[\"railway:platform:section\"],\n\
+                 \                   track = b.u(t[\"ref\"]),\n\
+                 \                   ::id = id();\n\
+                 \      out tags;\n\
+                 \    }\n\
+                 \  }\n\
+                 \}\n"
              let req = "https://overpass-api.de/api/interpreter"
                    { Client.requestBody = Client.RequestBodyBS overpassQuery
                    , Client.method = "POST"}
@ -166,10 +197,9 @@ app AppData{..} request respond = mkAnswer >>= (respond . toResponse)
                Left _ -> pure Notfound
                Right (platforms :: Vector Platform) -> do
                  let answer = V.toList platforms
-                       & sortOn (maybe (-100 :: Int) (fromRight (-100) . fmap fst . T.signed T.decimal) . osmLevel)
-                       <&> renderPlatform
+                       & sortOn (maybe (0::Int) (fromRight 0 . fmap fst . T.signed T.decimal) . osmLevel)
+                       <&> renderPlatform platforms
                       & (Html . T.concat)
-                  now <- getCurrentTime
                  atomically $ do
                    cache <- readTVar platformCache
                    writeTVar platformCache (M.insert ril100 (now, answer) cache)
@ -178,16 +208,32 @@ app AppData{..} request respond = mkAnswer >>= (respond . toResponse)
                    getRef (Just ref) _       = Just ref
                    getRef Nothing (Just ref) = Just ref
                    getRef _ _                = Nothing
-                    renderPlatform Platform{..} = case getRef ref localRef of
-                      Just ref -> "<a href=\"https://osm.org/"<>osmType<>"/"<>osmId<>"\">"<>ref<>"</a><br>"
+                    renderPlatform others p = case getRef (ref p) (localRef p) of
+                      Just ref -> mkAnchor p ref<>"</a>"<>renderedSections<>"<br>"
                      Nothing -> ""
+                      where sectionGroups = others
+                              & V.filter ((== Just (osmId p)) . osmPlatform)
+                              & V.toList
+                              & groupBy ((==) `on` osmPlatformEdge)
+                            renderSectionGroup sections = if null sections then "" else sections
+                              & sortOn osmSection
+                              & mapMaybe (\p -> case osmSection p of Just s -> Just (mkAnchor p s) ; _ -> Nothing)
+                              & intersperse ","
+                              & ((osmPlatformEdge (head sections) & \case {Nothing -> ""; Just a -> a<>": "}) :)
+                              & T.concat
+                            renderedSections = if null sectionGroups then "" else sectionGroups
+                              <&> renderSectionGroup
+                              & (": " :)
+                              & T.intercalate " "
+                            mkAnchor p inner =
+                              "<a href=\"https://osm.org/"<>osmType p<>"/"<>osmId p<>"\">"<>inner<>"</a>"
      _ -> pure Notfound
    queriedRil100 :: Text -> MatchResult Ril100 Text
    queriedRil100 query = if
-        | T.all isUpper query && host `elem` ["leitpunkt"]
+        | not (T.any isLower query) && host `elem` ["leitpunkt"]
          -> lookupName query leitpunktMap
              & maybe None Exact
-        | T.all isUpper query
+        | not (T.any isLower query)
          -> Exact (Ril100 query)
        | host `elem` ["leitpunkt"]
          -> case findStationName query ril100set of
@ -246,16 +292,17 @@ main = do
  Right (betriebsstellen :: V.Vector [Text]) <-
    LB.readFile "data/DBNetz-Betriebsstellenverzeichnis-Stand2021-10.csv"
    <&> decodeWith csvOptions HasHeader
-    <&> fmap (V.filter (\line -> line !! 4 `notElem` ["BUSH", "LGR", "ÜST", "BFT", "ABZW", "BK", "AWAN", "ANST", "LGR"]))
+  let betriebsstellenFiltered = betriebsstellen
+       & V.filter (\line -> line !! 4 `notElem` ["BUSH", "LGR", "ÜST", "BFT", "ABZW", "BK", "AWAN", "ANST", "LGR"])
  Right (leitpunkte :: V.Vector [Text]) <-
    LB.readFile "data/leitpunkte.csv"
    <&> decodeWith csvOptions HasHeader

  putStrLn "building Index ..."
-  let ril100set = addMany (emptySet 5 6 False) (V.toList (V.map (!! 2) betriebsstellen))
+  let ril100set = addMany (V.toList (V.map (!! 2) betriebsstellenFiltered)) (emptySet 5 6 False)
  putStrLn (seq ril100set "done")

-  let ril100map = mkDoubleMap $ fmap (\line -> (Ril100 (line !! 1), line !! 2)) betriebsstellen
+  let ril100map = mkDoubleMap $ fmap (\line -> (Ril100 (line !! 1), T.replace "<EFBFBD>" "ü" (line !! 2))) betriebsstellen
  let leitpunktMap = mkDoubleMap $ fmap (\line -> (Ril100 (line !! 2), line !! 0)) leitpunkte

  let ril100BaseUrl = "https://ril100.bahnhof.name"
--- a/bahnhof-name.cabal
+++ b/bahnhof-name.cabal
@ -21,8 +21,8 @@ executable bahnhof-name

    main-is:          Main.hs
    hs-source-dirs:   app
-    build-depends:    base ^>=4.16.4.0
-                    , fuzzyset
+    build-depends:    base ^>=4.18
+                    , fuzzyset >= 0.3.0
                    , fuzzyfind
                    , text
                    , vector
Author	SHA1	Message	Date
networkException	26119523f0	fix names of betriebsstellen not having ü encoded properly this was not ported from the previous gleam implementation.	2024-07-26 19:05:44 +02:00
stuebinm	8a4723f12f	update for ghc 9.6.5 (nixpkgs 24.05)	2024-06-04 20:04:18 +02:00
stuebinm	0c05c14574	support for platform sections well this blew the query up .. it attempts to do two things: - find platform sections grouped under platform_edges (important if platform sections of adjacent tracks don't line up) - if that fails, find any platforms somewhere under the whole platform object This should (hopefully) cover most cases where platform sections are actually mapped at all.	2024-01-16 01:41:34 +01:00
stuebinm	df9319f8a0	bugfix: allow superfluous "/" in paths esp. a trailing / as in bahnhof.name/MH/ should not lead to ??.	2023-12-26 01:52:00 +01:00
stuebinm	cc5048bdb4	update base / ghc	2023-12-01 12:40:07 +01:00
stuebinm	2c91d09484	update dependencies this should now work with NixOS 23.11's hackage snapshot	2023-11-30 19:17:12 +01:00
stuebinm	71c2ceb1c6	fix fuzzy redirects for platform info lookups	2023-11-29 18:34:08 +01:00
stuebinm	5a0ee20398	allow exact lookups of obscure Ril100 codes	2023-11-29 18:33:54 +01:00
stuebinm	783bf8859a	overpass query: some stations don't have a meta node	2023-11-15 21:53:55 +01:00
stuebinm	b33c00f1c3	default to level=0 if tag not present seems to give slightly better results	2023-11-14 23:50:38 +01:00