0c05c14574
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.
316 lines
14 KiB
Haskell
316 lines
14 KiB
Haskell
{-# LANGUAGE LambdaCase #-}
|
|
{-# LANGUAGE MultiWayIf #-}
|
|
{-# LANGUAGE OverloadedStrings #-}
|
|
{-# LANGUAGE RecordWildCards #-}
|
|
|
|
module Main where
|
|
|
|
import Control.Concurrent.STM
|
|
import qualified Data.ByteString as BS
|
|
import qualified Data.ByteString.Lazy as LB
|
|
import Data.Char
|
|
import Data.Csv hiding (lookup)
|
|
import Data.Either
|
|
import Data.Function (on, (&))
|
|
import Data.Functor ((<&>))
|
|
import Data.FuzzySet.Simple
|
|
import Data.List hiding (find)
|
|
import Data.Map (Map)
|
|
import qualified Data.Map as M
|
|
import Data.Maybe (fromMaybe, mapMaybe)
|
|
import Data.Ord
|
|
import Data.Text (Text)
|
|
import qualified Data.Text as T
|
|
import Data.Text.Encoding (encodeUtf8)
|
|
import qualified Data.Text.Read as T
|
|
import Data.Time.Clock
|
|
import Data.Tuple (swap)
|
|
import Data.Vector (Vector)
|
|
import qualified Data.Vector as V
|
|
import GHC.Base (Alternative ((<|>)))
|
|
import qualified Network.HTTP.Client as Client
|
|
import qualified Network.HTTP.Client.OpenSSL as Client
|
|
import Network.HTTP.Types
|
|
import Network.Wai
|
|
import Network.Wai.Handler.Warp (run)
|
|
import Network.Wai.Middleware.RequestLogger
|
|
import Text.FuzzyFind (Alignment (score),
|
|
bestMatch)
|
|
|
|
csvOptions, tsvOptions :: DecodeOptions
|
|
csvOptions = defaultDecodeOptions { decDelimiter = fromIntegral (ord ';') }
|
|
tsvOptions = defaultDecodeOptions { decDelimiter = fromIntegral (ord '\t') }
|
|
|
|
data MatchResult a b
|
|
= Exact a
|
|
| Fuzzy b
|
|
| None
|
|
deriving Show
|
|
|
|
findStationName :: T.Text -> FuzzySet -> MatchResult (Double, Text) (Double, Text)
|
|
findStationName query set = case sorted of
|
|
[exact] -> Exact exact
|
|
_ -> case maybeHbf of
|
|
station:_ -> Fuzzy station
|
|
_ -> case results of
|
|
station:_ -> Fuzzy station
|
|
_ -> None
|
|
where
|
|
sorted = results
|
|
& fmap (\(_, match) -> (fromIntegral . maybe 0 score . bestMatch (T.unpack query) $ T.unpack match, match))
|
|
& sortOn (Down . fst)
|
|
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
|
|
, osmPlatform :: Maybe Text
|
|
, osmSection :: Maybe Text
|
|
, osmPlatformEdge :: Maybe Text
|
|
} deriving Show
|
|
|
|
instance FromRecord Platform where
|
|
parseRecord v =
|
|
Platform <$>
|
|
v .! 0 <*>
|
|
v .! 1 <*>
|
|
v .! 2 <*>
|
|
v .! 3 <*>
|
|
(v .! 4 <|> v .! 5) <*>
|
|
v .! 6 <*>
|
|
v .! 7 <*>
|
|
v .! 8
|
|
|
|
data Answer
|
|
= Redirect Text
|
|
| Plaintext Text
|
|
| Html Text
|
|
| Notfound
|
|
| Unimplemented
|
|
|
|
maybeAnswer :: (a -> Answer) -> Maybe a -> Answer
|
|
maybeAnswer = maybe Notfound
|
|
|
|
|
|
newtype Ril100 = Ril100 { unRil100 :: Text }
|
|
deriving (Eq, Ord, Show)
|
|
|
|
data AppData = AppData
|
|
{ ril100map :: DoubleMap Ril100 Text
|
|
, leitpunktMap :: DoubleMap Ril100 Text
|
|
, ril100set :: FuzzySet
|
|
, ril100BaseUrl :: Text
|
|
, leitpunktBaseUrl :: Text
|
|
, clientManager :: Client.Manager
|
|
, platformCache :: TVar (Map Ril100 (UTCTime, Answer))
|
|
, cacheTime :: NominalDiffTime
|
|
}
|
|
|
|
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
|
|
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)
|
|
-> 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)
|
|
| 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
|
|
None -> pure Notfound
|
|
Fuzzy url -> pure (Redirect (T.intercalate "/" [url, segment]))
|
|
Exact ril100 -> do
|
|
maybeCache <- readTVarIO platformCache <&> M.lookup ril100
|
|
now <- getCurrentTime
|
|
case maybeCache of
|
|
Just (age, answer)
|
|
| now `diffUTCTime` age < cacheTime && segment /= "fetch" -> pure answer
|
|
_ -> do
|
|
let overpassQuery = " \
|
|
\[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\
|
|
\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"}
|
|
putStrLn $ "looking up platforms for " <> show ril100
|
|
response <- Client.httpLbs req clientManager
|
|
case decodeWith tsvOptions NoHeader (Client.responseBody response) of
|
|
Left _ -> pure Notfound
|
|
Right (platforms :: Vector Platform) -> do
|
|
let answer = V.toList platforms
|
|
& sortOn (maybe (0::Int) (fromRight 0 . fmap fst . T.signed T.decimal) . osmLevel)
|
|
<&> renderPlatform platforms
|
|
& (Html . T.concat)
|
|
atomically $ do
|
|
cache <- readTVar platformCache
|
|
writeTVar platformCache (M.insert ril100 (now, answer) cache)
|
|
pure answer
|
|
where
|
|
getRef (Just ref) _ = Just ref
|
|
getRef Nothing (Just ref) = Just ref
|
|
getRef _ _ = Nothing
|
|
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
|
|
| not (T.any isLower query) && host `elem` ["leitpunkt"]
|
|
-> lookupName query leitpunktMap
|
|
& maybe None Exact
|
|
| not (T.any isLower query)
|
|
-> Exact (Ril100 query)
|
|
| host `elem` ["leitpunkt"]
|
|
-> case findStationName query ril100set of
|
|
None -> None
|
|
Exact (_,match) -> lookupName match ril100map
|
|
& maybe None Exact
|
|
Fuzzy (_,match) -> Fuzzy (leitpunktBaseUrl <> "/" <> match)
|
|
| otherwise
|
|
-> case findStationName query ril100set of
|
|
None -> None
|
|
Exact (_,match) -> lookupName match ril100map
|
|
& maybe None Exact
|
|
Fuzzy (_,match) -> Fuzzy (ril100BaseUrl <> "/" <> match)
|
|
helptext = Plaintext $ "\
|
|
\ril100 → Name: " <> ril100BaseUrl <> "/RM\n\
|
|
\Name → ril100: " <> ril100BaseUrl <> "/Mannheim\n\n\
|
|
\Leitpunkt → Name: " <> leitpunktBaseUrl <> "/MA\n\
|
|
\Name → Leitpunkt: " <> leitpunktBaseUrl <> "/Mannheim\n\n\
|
|
\Am selben Bahnsteig gegenüber:\n\
|
|
\ " <> ril100BaseUrl <> "/RM/gleis"
|
|
host = head (BS.split (fromIntegral (ord '.')) rawHost)
|
|
where rawHost = case lookup "x-forwarded-host" $ requestHeaders request of
|
|
Nothing -> fromMaybe "" $ requestHeaderHost request
|
|
Just some -> some
|
|
toResponse :: Answer -> Response
|
|
toResponse ans = case ans of
|
|
Redirect uri -> responseLBS
|
|
status302 [("Location", encodeUtf8 uri)] ""
|
|
Plaintext msg -> responseLBS
|
|
status200 (mkHeaders "text/plain") (LB.fromStrict $ encodeUtf8 msg)
|
|
Html markup -> responseLBS
|
|
status200 (mkHeaders "text/html") (LB.fromStrict $ encodeUtf8 markup)
|
|
Notfound -> responseLBS
|
|
status404 (mkHeaders "text/plain") "??"
|
|
Unimplemented -> responseLBS
|
|
status404 (mkHeaders "text/plain") "Sorry, this is still under construction"
|
|
mkHeaders contentType =
|
|
[ ("Content-Type", contentType<>"; charset=utf8")
|
|
, ("x-data-by", "CC-BY 4.0 DB Netz AG https://data.deutschebahn.com/dataset/data-betriebsstellen.html")
|
|
, ("x-data-by", "OpenStreetMap Contributors https://www.openstreetmap.org/copyright/")
|
|
, ("x-sources-at", "https://stuebinm.eu/git/bahnhof.name")
|
|
]
|
|
|
|
|
|
data DoubleMap code long = DoubleMap { there :: Map code long, back :: Map long code }
|
|
lookupCode :: Ord code => code -> DoubleMap code long -> Maybe long
|
|
lookupCode code maps = M.lookup code (there maps)
|
|
lookupName :: Ord long => long -> DoubleMap code long -> Maybe code
|
|
lookupName name maps = M.lookup name (back maps)
|
|
mkDoubleMap :: (Ord code, Ord long) => Vector (code, long) -> DoubleMap code long
|
|
mkDoubleMap tuplesvec = DoubleMap (M.fromList tuples) (M.fromList (fmap swap tuples))
|
|
where tuples = V.toList tuplesvec
|
|
|
|
main :: IO ()
|
|
main = do
|
|
Right (betriebsstellen :: V.Vector [Text]) <-
|
|
LB.readFile "data/DBNetz-Betriebsstellenverzeichnis-Stand2021-10.csv"
|
|
<&> decodeWith csvOptions HasHeader
|
|
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 (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 leitpunktMap = mkDoubleMap $ fmap (\line -> (Ril100 (line !! 2), line !! 0)) leitpunkte
|
|
|
|
let ril100BaseUrl = "https://ril100.bahnhof.name"
|
|
let leitpunktBaseUrl = "https://leitpunkt.bahnhof.name"
|
|
let cacheTime = 3600 * 24 * 7 -- one week
|
|
platformCache <- newTVarIO mempty
|
|
|
|
Client.withOpenSSL $ do
|
|
clientManager <- Client.newOpenSSLManager
|
|
putStrLn "Starting Server"
|
|
run 8080 (logStdoutDev (app AppData{..}))
|