summaryrefslogtreecommitdiff
path: root/app
diff options
context:
space:
mode:
Diffstat (limited to 'app')
-rw-r--r--app/Main.hs255
1 files changed, 255 insertions, 0 deletions
diff --git a/app/Main.hs b/app/Main.hs
new file mode 100644
index 0000000..77b9a77
--- /dev/null
+++ b/app/Main.hs
@@ -0,0 +1,255 @@
+{-# 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.Function ((&))
+import Data.Functor ((<&>))
+import Data.FuzzySet
+import Data.List
+import Data.Map (Map)
+import qualified Data.Map as M
+import Data.Maybe (fromMaybe)
+import Data.Ord
+import Data.Text (Text)
+import qualified Data.Text as T
+import Data.Text.Encoding (encodeUtf8)
+import Data.Time.Clock
+import Data.Tuple (swap)
+import Data.Vector (Vector)
+import qualified Data.Vector as V
+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 = get set query
+ maybeHbf = filter (T.isInfixOf "Hbf" . snd) sorted
+
+data Platform = Platform
+ { osmType :: Text
+ , osmId :: Text
+ , ref :: Maybe Text
+ , localRef :: Maybe Text
+ } deriving Show
+
+instance FromRecord Platform where
+ parseRecord v =
+ Platform <$>
+ v .! 0 <*>
+ v .! 1 <*>
+ v .! 2 <*>
+ v .! 3
+
+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 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]
+ | T.all isUpper query && host `elem` ["leitpunkt"]
+ -> lookupName query leitpunktMap
+ >>= (`lookupCode` ril100map)
+ & maybeAnswer Plaintext & pure
+ | T.all isUpper 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 url)
+ 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;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\
+ \(.a;.b;);\n\
+ \nwr[railway=platform](>>);\n\
+ \out;\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 = Html $ T.concat (renderPlatform <$> V.toList platforms)
+ now <- getCurrentTime
+ 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 Platform{..} = case getRef ref localRef of
+ Just ref -> "<a href=\"https://osm.org/"<>osmType<>"/"<>osmId<>"\">"<>ref<>"</a><br>"
+ Nothing -> ""
+ _ -> pure Notfound
+ queriedRil100 :: Text -> MatchResult Ril100 Text
+ queriedRil100 query = if
+ | T.all isUpper query && host `elem` ["leitpunkt"]
+ -> lookupName query leitpunktMap
+ & maybe None Exact
+ | T.all isUpper 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 "no help yet"
+ 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
+ <&> fmap (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 (emptySet 5 6 False) (V.toList (V.map (!! 2) betriebsstellen))
+ putStrLn (seq ril100set "done")
+
+ let ril100map = mkDoubleMap $ fmap (\line -> (Ril100 (line !! 1), 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{..}))
generated by cgit v1.2.3 (git 2.25.1) at 2025-07-05 13:19:58 +0000