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 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.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
|
||||
|
|
@ -67,6 +68,9 @@ 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
|
||||
|
|
@ -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
|
||||
|
|
@ -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\
|
||||
\[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"}
|
||||
|
|
@ -167,9 +198,8 @@ app AppData{..} request respond = mkAnswer >>= (respond . toResponse)
|
|||
Right (platforms :: Vector Platform) -> do
|
||||
let answer = V.toList platforms
|
||||
& sortOn (maybe (0::Int) (fromRight 0 . fmap fst . T.signed T.decimal) . osmLevel)
|
||||
<&> renderPlatform
|
||||
<&> renderPlatform platforms
|
||||
& (Html . T.concat)
|
||||
now <- getCurrentTime
|
||||
atomically $ do
|
||||
cache <- readTVar platformCache
|
||||
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 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
|
||||
|
|
|
|||
Loading…
Reference in a new issue