Compare commits

..

10 commits

Author SHA1 Message Date
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
2 changed files with 78 additions and 31 deletions

View file

@ -1,3 +1,4 @@
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiWayIf #-} {-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE RecordWildCards #-}
@ -10,13 +11,13 @@ import qualified Data.ByteString.Lazy as LB
import Data.Char import Data.Char
import Data.Csv hiding (lookup) import Data.Csv hiding (lookup)
import Data.Either import Data.Either
import Data.Function ((&)) import Data.Function (on, (&))
import Data.Functor ((<&>)) import Data.Functor ((<&>))
import Data.FuzzySet import Data.FuzzySet.Simple
import Data.List import Data.List hiding (find)
import Data.Map (Map) import Data.Map (Map)
import qualified Data.Map as M import qualified Data.Map as M
import Data.Maybe (fromMaybe) import Data.Maybe (fromMaybe, mapMaybe)
import Data.Ord import Data.Ord
import Data.Text (Text) import Data.Text (Text)
import qualified Data.Text as T import qualified Data.Text as T
@ -58,7 +59,7 @@ findStationName query set = case sorted of
sorted = results sorted = results
& fmap (\(_, match) -> (fromIntegral . maybe 0 score . bestMatch (T.unpack query) $ T.unpack match, match)) & fmap (\(_, match) -> (fromIntegral . maybe 0 score . bestMatch (T.unpack query) $ T.unpack match, match))
& sortOn (Down . fst) & sortOn (Down . fst)
results = get set query results = find query set
maybeHbf = filter (T.isInfixOf "Hbf" . snd) sorted maybeHbf = filter (T.isInfixOf "Hbf" . snd) sorted
data Platform = Platform data Platform = Platform
@ -67,6 +68,9 @@ data Platform = Platform
, ref :: Maybe Text , ref :: Maybe Text
, localRef :: Maybe Text , localRef :: Maybe Text
, osmLevel :: Maybe Text , osmLevel :: Maybe Text
, osmPlatform :: Maybe Text
, osmSection :: Maybe Text
, osmPlatformEdge :: Maybe Text
} deriving Show } deriving Show
instance FromRecord Platform where instance FromRecord Platform where
@ -76,7 +80,10 @@ instance FromRecord Platform where
v .! 1 <*> v .! 1 <*>
v .! 2 <*> v .! 2 <*>
v .! 3 <*> v .! 3 <*>
(v .! 4 <|> v .! 5) (v .! 4 <|> v .! 5) <*>
v .! 6 <*>
v .! 7 <*>
v .! 8
data Answer data Answer
= Redirect Text = Redirect Text
@ -107,7 +114,7 @@ app :: AppData -> Application
app AppData{..} request respond = mkAnswer >>= (respond . toResponse) app AppData{..} request respond = mkAnswer >>= (respond . toResponse)
where where
mkAnswer :: IO Answer mkAnswer :: IO Answer
mkAnswer = case pathInfo request of mkAnswer = case filter (/= mempty) (pathInfo request) of
[] -> pure helptext [] -> pure helptext
["favicon.ico"] -> pure Notfound ["favicon.ico"] -> pure Notfound
["cache"] -> do ["cache"] -> do
@ -118,11 +125,11 @@ app AppData{..} request respond = mkAnswer >>= (respond . toResponse)
& T.unlines & T.unlines
& (pure . Plaintext) & (pure . Plaintext)
[query] [query]
| T.all isUpper query && host `elem` ["leitpunkt"] | not (T.any isLower query) && host `elem` ["leitpunkt"]
-> lookupName query leitpunktMap -> lookupName query leitpunktMap
>>= (`lookupCode` ril100map) >>= (`lookupCode` ril100map)
& maybeAnswer Plaintext & pure & maybeAnswer Plaintext & pure
| T.all isUpper query | not (T.any isLower query)
-> lookupCode (Ril100 query) ril100map -> lookupCode (Ril100 query) ril100map
& maybeAnswer Plaintext & pure & maybeAnswer Plaintext & pure
| host `elem` ["leitpunkt"] | 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"] [query, segment] | segment `elem` ["gleis", "track", "tracks", "gleise", "platform", "platforms", "fetch"]
-> case queriedRil100 query of -> case queriedRil100 query of
None -> pure Notfound None -> pure Notfound
Fuzzy url -> pure (Redirect url) Fuzzy url -> pure (Redirect (T.intercalate "/" [url, segment]))
Exact ril100 -> do Exact ril100 -> do
maybeCache <- readTVarIO platformCache <&> M.lookup ril100 maybeCache <- readTVarIO platformCache <&> M.lookup ril100
now <- getCurrentTime now <- getCurrentTime
@ -150,13 +157,37 @@ app AppData{..} request respond = mkAnswer >>= (respond . toResponse)
| now `diffUTCTime` age < cacheTime && segment /= "fetch" -> pure answer | now `diffUTCTime` age < cacheTime && segment /= "fetch" -> pure answer
_ -> do _ -> do
let overpassQuery = " \ let overpassQuery = " \
\[out:csv(::type, ::id, ref, local_ref, level, layer;false)][timeout:25];\n\ \[out:csv(::type, ::id, ref, local_ref, level, layer, platform, section, track;false)][timeout:25];\n\
\node[~\"railway:ref|railway:ref:parent\"~\"^"<>encodeUtf8 (unRil100 ril100)<>"$\"][operator~\"^(DB |Deutsch)\"];\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\"](bn);) -> .a;\n\
\rel[public_transport~\"stop_area|stop_area_group\"](br.a) -> .b;\n\ \rel[public_transport~\"stop_area|stop_area_group\"](br.a) -> .b;\n\
\(.a;.b;);\n\ \(.a;.b;);\n\
\nwr[railway=platform](>>);\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" let req = "https://overpass-api.de/api/interpreter"
{ Client.requestBody = Client.RequestBodyBS overpassQuery { Client.requestBody = Client.RequestBodyBS overpassQuery
, Client.method = "POST"} , Client.method = "POST"}
@ -166,10 +197,9 @@ app AppData{..} request respond = mkAnswer >>= (respond . toResponse)
Left _ -> pure Notfound Left _ -> pure Notfound
Right (platforms :: Vector Platform) -> do Right (platforms :: Vector Platform) -> do
let answer = V.toList platforms let answer = V.toList platforms
& sortOn (maybe (-100 :: Int) (fromRight (-100) . fmap fst . T.signed T.decimal) . osmLevel) & sortOn (maybe (0::Int) (fromRight 0 . fmap fst . T.signed T.decimal) . osmLevel)
<&> renderPlatform <&> renderPlatform platforms
& (Html . T.concat) & (Html . T.concat)
now <- getCurrentTime
atomically $ do atomically $ do
cache <- readTVar platformCache cache <- readTVar platformCache
writeTVar platformCache (M.insert ril100 (now, answer) cache) 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 (Just ref) _ = Just ref
getRef Nothing (Just ref) = Just ref getRef Nothing (Just ref) = Just ref
getRef _ _ = Nothing getRef _ _ = Nothing
renderPlatform Platform{..} = case getRef ref localRef of renderPlatform others p = case getRef (ref p) (localRef p) of
Just ref -> "<a href=\"https://osm.org/"<>osmType<>"/"<>osmId<>"\">"<>ref<>"</a><br>" Just ref -> mkAnchor p ref<>"</a>"<>renderedSections<>"<br>"
Nothing -> "" 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 _ -> pure Notfound
queriedRil100 :: Text -> MatchResult Ril100 Text queriedRil100 :: Text -> MatchResult Ril100 Text
queriedRil100 query = if queriedRil100 query = if
| T.all isUpper query && host `elem` ["leitpunkt"] | not (T.any isLower query) && host `elem` ["leitpunkt"]
-> lookupName query leitpunktMap -> lookupName query leitpunktMap
& maybe None Exact & maybe None Exact
| T.all isUpper query | not (T.any isLower query)
-> Exact (Ril100 query) -> Exact (Ril100 query)
| host `elem` ["leitpunkt"] | host `elem` ["leitpunkt"]
-> case findStationName query ril100set of -> case findStationName query ril100set of
@ -246,16 +292,17 @@ main = do
Right (betriebsstellen :: V.Vector [Text]) <- Right (betriebsstellen :: V.Vector [Text]) <-
LB.readFile "data/DBNetz-Betriebsstellenverzeichnis-Stand2021-10.csv" LB.readFile "data/DBNetz-Betriebsstellenverzeichnis-Stand2021-10.csv"
<&> decodeWith csvOptions HasHeader <&> 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]) <- Right (leitpunkte :: V.Vector [Text]) <-
LB.readFile "data/leitpunkte.csv" LB.readFile "data/leitpunkte.csv"
<&> decodeWith csvOptions HasHeader <&> decodeWith csvOptions HasHeader
putStrLn "building Index ..." 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") 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 leitpunktMap = mkDoubleMap $ fmap (\line -> (Ril100 (line !! 2), line !! 0)) leitpunkte
let ril100BaseUrl = "https://ril100.bahnhof.name" let ril100BaseUrl = "https://ril100.bahnhof.name"

View file

@ -21,8 +21,8 @@ executable bahnhof-name
main-is: Main.hs main-is: Main.hs
hs-source-dirs: app hs-source-dirs: app
build-depends: base ^>=4.16.4.0 build-depends: base ^>=4.18
, fuzzyset , fuzzyset >= 0.3.0
, fuzzyfind , fuzzyfind
, text , text
, vector , vector