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 Data.Char
import Data.Csv hiding (lookup)
import Data.Either
import Data.Function ((&))
import Data.Functor ((<&>))
import Data.FuzzySet
@ -20,10 +21,12 @@ 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
@ -63,6 +66,7 @@ data Platform = Platform
, osmId :: Text
, ref :: Maybe Text
, localRef :: Maybe Text
, osmLevel :: Maybe Text
} deriving Show
instance FromRecord Platform where
@ -71,7 +75,8 @@ instance FromRecord Platform where
v .! 0 <*>
v .! 1 <*>
v .! 2 <*>
v .! 3
v .! 3 <*>
(v .! 4 <|> v .! 5)
data Answer
= Redirect Text
@ -145,7 +150,7 @@ 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;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\
\rel[public_transport~\"stop_area|stop_area_group\"](bn) -> .a;\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
Left _ -> pure Notfound
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
atomically $ do
cache <- readTVar platformCache