316 lines
14 KiB
Haskell
316 lines
14 KiB
Haskell
{-# LANGUAGE LambdaCase #-}
|
||
{-# LANGUAGE MultiWayIf #-}
|
||
{-# LANGUAGE OverloadedStrings #-}
|
||
{-# LANGUAGE RecordWildCards #-}
|
||
|
||
module Main where
|
||
|
||
import Control.Concurrent.STM
|
||
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 (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, mapMaybe)
|
||
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
|
||
import Network.Wai
|
||
import Network.Wai.Handler.Warp (run)
|
||
import Network.Wai.Middleware.RequestLogger
|
||
import Text.FuzzyFind (Alignment (score),
|
||
bestMatch)
|
||
|
||
csvOptions, tsvOptions :: DecodeOptions
|
||
csvOptions = defaultDecodeOptions { decDelimiter = fromIntegral (ord ';') }
|
||
tsvOptions = defaultDecodeOptions { decDelimiter = fromIntegral (ord '\t') }
|
||
|
||
data MatchResult a b
|
||
= Exact a
|
||
| Fuzzy b
|
||
| None
|
||
deriving Show
|
||
|
||
findStationName :: T.Text -> FuzzySet -> MatchResult (Double, Text) (Double, Text)
|
||
findStationName query set = case sorted of
|
||
[exact] -> Exact exact
|
||
_ -> case maybeHbf of
|
||
station:_ -> Fuzzy station
|
||
_ -> case results of
|
||
station:_ -> Fuzzy station
|
||
_ -> None
|
||
where
|
||
sorted = results
|
||
& fmap (\(_, match) -> (fromIntegral . maybe 0 score . bestMatch (T.unpack query) $ T.unpack match, match))
|
||
& sortOn (Down . fst)
|
||
results = find query set
|
||
maybeHbf = filter (T.isInfixOf "Hbf" . snd) sorted
|
||
|
||
data Platform = Platform
|
||
{ osmType :: Text
|
||
, osmId :: Text
|
||
, ref :: Maybe Text
|
||
, localRef :: Maybe Text
|
||
, osmLevel :: Maybe Text
|
||
, osmPlatform :: Maybe Text
|
||
, osmSection :: Maybe Text
|
||
, osmPlatformEdge :: Maybe Text
|
||
} deriving Show
|
||
|
||
instance FromRecord Platform where
|
||
parseRecord v =
|
||
Platform <$>
|
||
v .! 0 <*>
|
||
v .! 1 <*>
|
||
v .! 2 <*>
|
||
v .! 3 <*>
|
||
(v .! 4 <|> v .! 5) <*>
|
||
v .! 6 <*>
|
||
v .! 7 <*>
|
||
v .! 8
|
||
|
||
data Answer
|
||
= Redirect Text
|
||
| Plaintext Text
|
||
| Html Text
|
||
| Notfound
|
||
| Unimplemented
|
||
|
||
maybeAnswer :: (a -> Answer) -> Maybe a -> Answer
|
||
maybeAnswer = maybe Notfound
|
||
|
||
|
||
newtype Ril100 = Ril100 { unRil100 :: Text }
|
||
deriving (Eq, Ord, Show)
|
||
|
||
data AppData = AppData
|
||
{ ril100map :: DoubleMap Ril100 Text
|
||
, leitpunktMap :: DoubleMap Ril100 Text
|
||
, ril100set :: FuzzySet
|
||
, ril100BaseUrl :: Text
|
||
, leitpunktBaseUrl :: Text
|
||
, clientManager :: Client.Manager
|
||
, platformCache :: TVar (Map Ril100 (UTCTime, Answer))
|
||
, cacheTime :: NominalDiffTime
|
||
}
|
||
|
||
app :: AppData -> Application
|
||
app AppData{..} request respond = mkAnswer >>= (respond . toResponse)
|
||
where
|
||
mkAnswer :: IO Answer
|
||
mkAnswer = case filter (/= mempty) (pathInfo request) of
|
||
[] -> pure helptext
|
||
["favicon.ico"] -> pure Notfound
|
||
["cache"] -> do
|
||
cache <- readTVarIO platformCache
|
||
now <- getCurrentTime
|
||
M.toList cache
|
||
& fmap (\(ril100, (age, _)) -> (T.pack . show) (unRil100 ril100, now `diffUTCTime` age))
|
||
& T.unlines
|
||
& (pure . Plaintext)
|
||
[query]
|
||
| not (T.any isLower query) && host `elem` ["leitpunkt"]
|
||
-> lookupName query leitpunktMap
|
||
>>= (`lookupCode` ril100map)
|
||
& maybeAnswer Plaintext & pure
|
||
| not (T.any isLower query)
|
||
-> lookupCode (Ril100 query) ril100map
|
||
& maybeAnswer Plaintext & pure
|
||
| host `elem` ["leitpunkt"]
|
||
-> pure $ case findStationName query ril100set of
|
||
None -> Notfound
|
||
Exact (_,match) -> lookupName match ril100map
|
||
>>= (`lookupCode` leitpunktMap)
|
||
& maybeAnswer Plaintext
|
||
Fuzzy (_,match) -> Redirect (leitpunktBaseUrl <> "/" <> match)
|
||
| otherwise
|
||
-> pure $ case findStationName query ril100set of
|
||
None -> Notfound
|
||
Exact (_,match) -> lookupName match ril100map
|
||
& maybeAnswer (Plaintext . unRil100)
|
||
Fuzzy (_,match) -> Redirect (ril100BaseUrl <> "/" <> match)
|
||
[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]))
|
||
Exact ril100 -> do
|
||
maybeCache <- readTVarIO platformCache <&> M.lookup ril100
|
||
now <- getCurrentTime
|
||
case maybeCache of
|
||
Just (age, answer)
|
||
| 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\
|
||
\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"
|
||
let req = "https://overpass-api.de/api/interpreter"
|
||
{ Client.requestBody = Client.RequestBodyBS overpassQuery
|
||
, Client.method = "POST"}
|
||
putStrLn $ "looking up platforms for " <> show ril100
|
||
response <- Client.httpLbs req clientManager
|
||
case decodeWith tsvOptions NoHeader (Client.responseBody response) of
|
||
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
|
||
& (Html . T.concat)
|
||
atomically $ do
|
||
cache <- readTVar platformCache
|
||
writeTVar platformCache (M.insert ril100 (now, answer) cache)
|
||
pure answer
|
||
where
|
||
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>"
|
||
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"]
|
||
-> lookupName query leitpunktMap
|
||
& maybe None Exact
|
||
| not (T.any isLower query)
|
||
-> Exact (Ril100 query)
|
||
| host `elem` ["leitpunkt"]
|
||
-> case findStationName query ril100set of
|
||
None -> None
|
||
Exact (_,match) -> lookupName match ril100map
|
||
& maybe None Exact
|
||
Fuzzy (_,match) -> Fuzzy (leitpunktBaseUrl <> "/" <> match)
|
||
| otherwise
|
||
-> case findStationName query ril100set of
|
||
None -> None
|
||
Exact (_,match) -> lookupName match ril100map
|
||
& maybe None Exact
|
||
Fuzzy (_,match) -> Fuzzy (ril100BaseUrl <> "/" <> match)
|
||
helptext = Plaintext $ "\
|
||
\ril100 → Name: " <> ril100BaseUrl <> "/RM\n\
|
||
\Name → ril100: " <> ril100BaseUrl <> "/Mannheim\n\n\
|
||
\Leitpunkt → Name: " <> leitpunktBaseUrl <> "/MA\n\
|
||
\Name → Leitpunkt: " <> leitpunktBaseUrl <> "/Mannheim\n\n\
|
||
\Am selben Bahnsteig gegenüber:\n\
|
||
\ " <> ril100BaseUrl <> "/RM/gleis"
|
||
host = head (BS.split (fromIntegral (ord '.')) rawHost)
|
||
where rawHost = case lookup "x-forwarded-host" $ requestHeaders request of
|
||
Nothing -> fromMaybe "" $ requestHeaderHost request
|
||
Just some -> some
|
||
toResponse :: Answer -> Response
|
||
toResponse ans = case ans of
|
||
Redirect uri -> responseLBS
|
||
status302 [("Location", encodeUtf8 uri)] ""
|
||
Plaintext msg -> responseLBS
|
||
status200 (mkHeaders "text/plain") (LB.fromStrict $ encodeUtf8 msg)
|
||
Html markup -> responseLBS
|
||
status200 (mkHeaders "text/html") (LB.fromStrict $ encodeUtf8 markup)
|
||
Notfound -> responseLBS
|
||
status404 (mkHeaders "text/plain") "??"
|
||
Unimplemented -> responseLBS
|
||
status404 (mkHeaders "text/plain") "Sorry, this is still under construction"
|
||
mkHeaders contentType =
|
||
[ ("Content-Type", contentType<>"; charset=utf8")
|
||
, ("x-data-by", "CC-BY 4.0 DB Netz AG https://data.deutschebahn.com/dataset/data-betriebsstellen.html")
|
||
, ("x-data-by", "OpenStreetMap Contributors https://www.openstreetmap.org/copyright/")
|
||
, ("x-sources-at", "https://stuebinm.eu/git/bahnhof.name")
|
||
]
|
||
|
||
|
||
data DoubleMap code long = DoubleMap { there :: Map code long, back :: Map long code }
|
||
lookupCode :: Ord code => code -> DoubleMap code long -> Maybe long
|
||
lookupCode code maps = M.lookup code (there maps)
|
||
lookupName :: Ord long => long -> DoubleMap code long -> Maybe code
|
||
lookupName name maps = M.lookup name (back maps)
|
||
mkDoubleMap :: (Ord code, Ord long) => Vector (code, long) -> DoubleMap code long
|
||
mkDoubleMap tuplesvec = DoubleMap (M.fromList tuples) (M.fromList (fmap swap tuples))
|
||
where tuples = V.toList tuplesvec
|
||
|
||
main :: IO ()
|
||
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"])
|
||
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)
|
||
putStrLn (seq ril100set "done")
|
||
|
||
let ril100map = mkDoubleMap $ fmap (\line -> (Ril100 (line !! 1), T.replace "<EFBFBD>" "ü" (line !! 2))) betriebsstellen
|
||
let leitpunktMap = mkDoubleMap $ fmap (\line -> (Ril100 (line !! 2), line !! 0)) leitpunkte
|
||
|
||
let ril100BaseUrl = "https://ril100.bahnhof.name"
|
||
let leitpunktBaseUrl = "https://leitpunkt.bahnhof.name"
|
||
let cacheTime = 3600 * 24 * 7 -- one week
|
||
platformCache <- newTVarIO mempty
|
||
|
||
Client.withOpenSSL $ do
|
||
clientManager <- Client.newOpenSSLManager
|
||
putStrLn "Starting Server"
|
||
run 8080 (logStdoutDev (app AppData{..}))
|