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.
This commit is contained in:
stuebinm
parent
df9319f8a0
commit
0c05c14574
1 changed files with 60 additions and 14 deletions
64
app/Main.hs
64
app/Main.hs
|
|
@ -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.Simple
|
import Data.FuzzySet.Simple
|
||||||
import Data.List hiding (find)
|
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
|
||||||
|
|
@ -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
|
||||||
|
|
@ -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\
|
||||||
\nwr[~\"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"}
|
||||||
|
|
@ -167,9 +198,8 @@ app AppData{..} request respond = mkAnswer >>= (respond . toResponse)
|
||||||
Right (platforms :: Vector Platform) -> do
|
Right (platforms :: Vector Platform) -> do
|
||||||
let answer = V.toList platforms
|
let answer = V.toList platforms
|
||||||
& sortOn (maybe (0::Int) (fromRight 0 . 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,9 +208,25 @@ 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
|
||||||
|
|
|
||||||
Loading…
Reference in a new issue