From 02b29877f4988014d7be04e1cd9b6c1caeac9282 Mon Sep 17 00:00:00 2001 From: stuebinm Date: Tue, 14 Nov 2023 02:25:10 +0100 Subject: rewrite it in Haskell --- app/Main.hs | 255 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 255 insertions(+) create mode 100644 app/Main.hs (limited to 'app/Main.hs') 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 -> "osmType<>"/"<>osmId<>"\">"<>ref<>"
" + 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{..})) -- cgit v1.2.3