Compare commits
No commits in common. "26119523f0356b7e4caa1943ff00b6e764790719" and "8ae435ab77e2cc67e5e0412e58e4448e013b8de8" have entirely different histories.
26119523f0
...
8ae435ab77
2 changed files with 31 additions and 78 deletions
95
app/Main.hs
95
app/Main.hs
|
|
@ -1,4 +1,3 @@
|
|||
{-# LANGUAGE LambdaCase #-}
|
||||
{-# LANGUAGE MultiWayIf #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE RecordWildCards #-}
|
||||
|
|
@ -11,13 +10,13 @@ import qualified Data.ByteString.Lazy as LB
|
|||
import Data.Char
|
||||
import Data.Csv hiding (lookup)
|
||||
import Data.Either
|
||||
import Data.Function (on, (&))
|
||||
import Data.Function ((&))
|
||||
import Data.Functor ((<&>))
|
||||
import Data.FuzzySet.Simple
|
||||
import Data.List hiding (find)
|
||||
import Data.FuzzySet
|
||||
import Data.List
|
||||
import Data.Map (Map)
|
||||
import qualified Data.Map as M
|
||||
import Data.Maybe (fromMaybe, mapMaybe)
|
||||
import Data.Maybe (fromMaybe)
|
||||
import Data.Ord
|
||||
import Data.Text (Text)
|
||||
import qualified Data.Text as T
|
||||
|
|
@ -59,7 +58,7 @@ 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 = find query set
|
||||
results = get set query
|
||||
maybeHbf = filter (T.isInfixOf "Hbf" . snd) sorted
|
||||
|
||||
data Platform = Platform
|
||||
|
|
@ -68,9 +67,6 @@ data Platform = Platform
|
|||
, ref :: Maybe Text
|
||||
, localRef :: Maybe Text
|
||||
, osmLevel :: Maybe Text
|
||||
, osmPlatform :: Maybe Text
|
||||
, osmSection :: Maybe Text
|
||||
, osmPlatformEdge :: Maybe Text
|
||||
} deriving Show
|
||||
|
||||
instance FromRecord Platform where
|
||||
|
|
@ -80,10 +76,7 @@ instance FromRecord Platform where
|
|||
v .! 1 <*>
|
||||
v .! 2 <*>
|
||||
v .! 3 <*>
|
||||
(v .! 4 <|> v .! 5) <*>
|
||||
v .! 6 <*>
|
||||
v .! 7 <*>
|
||||
v .! 8
|
||||
(v .! 4 <|> v .! 5)
|
||||
|
||||
data Answer
|
||||
= Redirect Text
|
||||
|
|
@ -114,7 +107,7 @@ app :: AppData -> Application
|
|||
app AppData{..} request respond = mkAnswer >>= (respond . toResponse)
|
||||
where
|
||||
mkAnswer :: IO Answer
|
||||
mkAnswer = case filter (/= mempty) (pathInfo request) of
|
||||
mkAnswer = case pathInfo request of
|
||||
[] -> pure helptext
|
||||
["favicon.ico"] -> pure Notfound
|
||||
["cache"] -> do
|
||||
|
|
@ -125,11 +118,11 @@ app AppData{..} request respond = mkAnswer >>= (respond . toResponse)
|
|||
& T.unlines
|
||||
& (pure . Plaintext)
|
||||
[query]
|
||||
| not (T.any isLower query) && host `elem` ["leitpunkt"]
|
||||
| T.all isUpper query && host `elem` ["leitpunkt"]
|
||||
-> lookupName query leitpunktMap
|
||||
>>= (`lookupCode` ril100map)
|
||||
& maybeAnswer Plaintext & pure
|
||||
| not (T.any isLower query)
|
||||
| T.all isUpper query
|
||||
-> lookupCode (Ril100 query) ril100map
|
||||
& maybeAnswer Plaintext & pure
|
||||
| host `elem` ["leitpunkt"]
|
||||
|
|
@ -148,7 +141,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 (T.intercalate "/" [url, segment]))
|
||||
Fuzzy url -> pure (Redirect url)
|
||||
Exact ril100 -> do
|
||||
maybeCache <- readTVarIO platformCache <&> M.lookup ril100
|
||||
now <- getCurrentTime
|
||||
|
|
@ -157,37 +150,13 @@ 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, 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\
|
||||
\[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\
|
||||
\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"
|
||||
\out;\n"
|
||||
let req = "https://overpass-api.de/api/interpreter"
|
||||
{ Client.requestBody = Client.RequestBodyBS overpassQuery
|
||||
, Client.method = "POST"}
|
||||
|
|
@ -197,9 +166,10 @@ app AppData{..} request respond = mkAnswer >>= (respond . toResponse)
|
|||
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
|
||||
& sortOn (maybe (-100 :: Int) (fromRight (-100) . fmap fst . T.signed T.decimal) . osmLevel)
|
||||
<&> renderPlatform
|
||||
& (Html . T.concat)
|
||||
now <- getCurrentTime
|
||||
atomically $ do
|
||||
cache <- readTVar platformCache
|
||||
writeTVar platformCache (M.insert ril100 (now, answer) cache)
|
||||
|
|
@ -208,32 +178,16 @@ app AppData{..} request respond = mkAnswer >>= (respond . toResponse)
|
|||
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>"
|
||||
renderPlatform Platform{..} = case getRef ref localRef of
|
||||
Just ref -> "<a href=\"https://osm.org/"<>osmType<>"/"<>osmId<>"\">"<>ref<>"</a><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"]
|
||||
| T.all isUpper query && host `elem` ["leitpunkt"]
|
||||
-> lookupName query leitpunktMap
|
||||
& maybe None Exact
|
||||
| not (T.any isLower query)
|
||||
| T.all isUpper query
|
||||
-> Exact (Ril100 query)
|
||||
| host `elem` ["leitpunkt"]
|
||||
-> case findStationName query ril100set of
|
||||
|
|
@ -292,17 +246,16 @@ 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"])
|
||||
<&> fmap (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)
|
||||
let ril100set = addMany (emptySet 5 6 False) (V.toList (V.map (!! 2) betriebsstellen))
|
||||
putStrLn (seq ril100set "done")
|
||||
|
||||
let ril100map = mkDoubleMap $ fmap (\line -> (Ril100 (line !! 1), T.replace "<EFBFBD>" "ü" (line !! 2))) betriebsstellen
|
||||
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"
|
||||
|
|
|
|||
|
|
@ -21,8 +21,8 @@ executable bahnhof-name
|
|||
|
||||
main-is: Main.hs
|
||||
hs-source-dirs: app
|
||||
build-depends: base ^>=4.18
|
||||
, fuzzyset >= 0.3.0
|
||||
build-depends: base ^>=4.16.4.0
|
||||
, fuzzyset
|
||||
, fuzzyfind
|
||||
, text
|
||||
, vector
|
||||
|
|
|
|||
Loading…
Reference in a new issue