forks/bahnhof.name
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

sort platforms by level/layer

Browse source
This commit is contained in:
stuebinm 2023-11-14 23:04:37 +01:00
parent 02b29877f4
commit e6cdfadd98
1 changed files with 11 additions and 3 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

14
app/Main.hs
View file

@ -9,6 +9,7 @@ import qualified Data.ByteString as BS
import qualified Data.ByteString.Lazy as LB 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.Function ((&)) import Data.Function ((&))
import Data.Functor ((<&>)) import Data.Functor ((<&>))
import Data.FuzzySet import Data.FuzzySet
@ -20,10 +21,12 @@ import Data.Ord
import Data.Text (Text) import Data.Text (Text)
import qualified Data.Text as T import qualified Data.Text as T
import Data.Text.Encoding (encodeUtf8) import Data.Text.Encoding (encodeUtf8)
import qualified Data.Text.Read as T
import Data.Time.Clock import Data.Time.Clock
import Data.Tuple (swap) import Data.Tuple (swap)
import Data.Vector (Vector) import Data.Vector (Vector)
import qualified Data.Vector as V import qualified Data.Vector as V
import GHC.Base (Alternative ((<|>)))
import qualified Network.HTTP.Client as Client import qualified Network.HTTP.Client as Client
import qualified Network.HTTP.Client.OpenSSL as Client import qualified Network.HTTP.Client.OpenSSL as Client
import Network.HTTP.Types import Network.HTTP.Types
@ -63,6 +66,7 @@ data Platform = Platform
, osmId :: Text , osmId :: Text
, ref :: Maybe Text , ref :: Maybe Text
, localRef :: Maybe Text , localRef :: Maybe Text
, osmLevel :: Maybe Text
} deriving Show } deriving Show
instance FromRecord Platform where instance FromRecord Platform where
@ -71,7 +75,8 @@ instance FromRecord Platform where
v .! 0 <*> v .! 0 <*>
v .! 1 <*> v .! 1 <*>
v .! 2 <*> v .! 2 <*>
v .! 3 v .! 3 <*>
(v .! 4 <|> v .! 5)
data Answer data Answer
= Redirect Text = Redirect Text
@ -145,7 +150,7 @@ 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;false)][timeout:25];\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\ \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\"](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\
@ -160,7 +165,10 @@ app AppData{..} request respond = mkAnswer >>= (respond . toResponse)
case decodeWith tsvOptions NoHeader (Client.responseBody response) of case decodeWith tsvOptions NoHeader (Client.responseBody response) of
Left _ -> pure Notfound Left _ -> pure Notfound
Right (platforms :: Vector Platform) -> do Right (platforms :: Vector Platform) -> do
let answer = Html $ T.concat (renderPlatform <$> V.toList platforms) let answer = V.toList platforms
& sortOn (maybe (-100 :: Int) (fromRight (-100) . fmap fst . T.signed T.decimal) . osmLevel)
<&> renderPlatform
& (Html . T.concat)
now <- getCurrentTime now <- getCurrentTime
atomically $ do atomically $ do
cache <- readTVar platformCache cache <- readTVar platformCache