diff options
| -rw-r--r-- | app/BahnhofDNS.hs | 59 | ||||
| -rw-r--r-- | app/Main.hs | 64 | ||||
| -rw-r--r-- | app/Util.hs | 103 | ||||
| -rw-r--r-- | bahnhof-name.cabal | 22 |
4 files changed, 190 insertions, 58 deletions
diff --git a/app/BahnhofDNS.hs b/app/BahnhofDNS.hs new file mode 100644 index 0000000..2111aa0 --- /dev/null +++ b/app/BahnhofDNS.hs @@ -0,0 +1,59 @@ + +module Main where + +import Data.ByteString +import Data.Text +import Data.Text.Encoding as TSE +import Network.DNS +import Network.Socket +import Util + +main :: IO () +main = do -- general structure like sample code at https://book.realworldhaskell.org/read/sockets-and-syslog.html (for UDP server) + staticData <- readData + addr : _ <- getAddrInfo (Just defaultHints { addrSocketType = Datagram, addrFamily = AF_INET6, addrFlags = [AI_PASSIVE] }) Nothing (Just "5300") + sckt <- openSocket addr + bind sckt (addrAddress addr) + putStrLn "Starting DNS server (listening on port 5300)" + procMessages staticData sckt + where + procMessages staticData sckt = do + (m,ad) <- receiveFrom sckt -- Network.DNS + + sendTo sckt (response m) ad + procMessages staticData sckt + where + response m = encode $ case (question m) of + (Question qh TXT) : _ -> queryAnswer (uid m) qh + _ -> m -- ping back question without answering it + -- no other way to generate empty responses without providing a question in this library? + + queryAnswer oid qh = case maybeAnswer qh of + Just answer -> responseTXT oid (Question qh TXT) (TSE.encodeUtf8 answer) + Nothing -> responseEmpty oid (Question qh TXT) + + uid msg = identifier (header msg) + maybeAnswer qh = case queryFromQuestionHead qh of + (q, "RIL100") -> lookupCode (Ril100 q) (ril100map staticData) + (q, "LEITPUNKT") -> lookupName q (leitpunktMap staticData) + >>= (`lookupCode` (ril100map staticData)) + (_, _) -> Nothing + +queryFromQuestionHead :: ByteString -> (Text, String) +queryFromQuestionHead q = case splt of + quest : questType : _ -- here we could add enforcement that we only query the intended namespace and not arbitrary subspaces (nsst.ril100.a.b.c.d.e.…) + -> (quest, Data.Text.unpack questType) + _ -> (Data.Text.empty, "") -- side question: is a query without a dot even a legal DNS query? + where + splt = splitOn dot (toUpper $ TSE.decodeUtf8 q) + dot = Data.Text.pack "." + +responseEmpty :: Identifier -> Question -> DNSMessage +responseEmpty idt q = makeResponse idt q [] + +responseTXT :: Identifier -> Question -> ByteString -> DNSMessage +responseTXT idt q txt = makeResponse idt q [ans] + where + dom = qname q + ans = ResourceRecord dom TXT classIN 604800 (RD_TXT txt) + diff --git a/app/Main.hs b/app/Main.hs index 7ad73a1..34442de 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -18,13 +18,11 @@ 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 ((<|>))) @@ -34,33 +32,7 @@ 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 +import Util data Platform = Platform { osmType :: Text @@ -96,9 +68,6 @@ 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 @@ -278,39 +247,20 @@ app AppData{..} request respond = mkAnswer >>= (respond . toResponse) ] -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 . fmap . fmap) (T.replace "�" "ü") - 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 + StaticAppData {..} <- readData - 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), line !! 2)) betriebsstellen - let leitpunktMap = mkDoubleMap $ fmap (\line -> (Ril100 (line !! 2), line !! 0)) leitpunkte + putStrLn "Building index…" + putStrLn (seq ril100set "Index generated.") let ril100BaseUrl = "https://ril100.bahnhof.name" let leitpunktBaseUrl = "https://leitpunkt.bahnhof.name" let cacheTime = 3600 * 24 * 7 -- one week - platformCache <- newTVarIO mempty + platformCache <- newTVarIO mempty clientManager <- Client.newRustlsManager - putStrLn "Starting Server" + + putStrLn "Starting web server (listening on port 8080)" run 8080 (logStdoutDev (app AppData{..})) diff --git a/app/Util.hs b/app/Util.hs new file mode 100644 index 0000000..ce3dcbc --- /dev/null +++ b/app/Util.hs @@ -0,0 +1,103 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} + +module Util where + +import qualified Data.ByteString.Lazy as LB +import Data.Char +import Data.Csv hiding (lookup) +import Data.Function ((&)) +import Data.Functor ((<&>)) +import Data.FuzzySet.Simple +import Data.List hiding (find) +import Data.Map (Map) +import qualified Data.Map as M +import Data.Ord +import Data.Text (Text) +import qualified Data.Text as T +import Data.Tuple (swap) +import Data.Vector (Vector) +import qualified Data.Vector as V +import Text.FuzzyFind (Alignment (score), bestMatch) + + +data MatchResult a b + = Exact a + | Fuzzy b + | None + deriving Show + +data StaticAppData = StaticAppData + { ril100map :: DoubleMap Ril100 Text + , leitpunktMap :: DoubleMap Ril100 Text + , ril100set :: FuzzySet + } + +data DoubleMap code long = DoubleMap + { there :: Map code long + , back :: Map long code + } + +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 + +newtype Ril100 = Ril100 { unRil100 :: Text } + deriving (Eq, Ord, Show) + + +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 + +readBetriebsstellen :: IO (V.Vector [Text]) +readBetriebsstellen = do + Right (x :: V.Vector [Text]) <- + LB.readFile "data/DBNetz-Betriebsstellenverzeichnis-Stand2021-10.csv" + <&> decodeWith csvOptions HasHeader + <&> (fmap . fmap . fmap) (T.replace "�" "ü") + return x + +readLeitpunktMap :: IO (DoubleMap Ril100 Text) +readLeitpunktMap = do + Right (leitpunkte :: V.Vector [Text]) <- + LB.readFile "data/leitpunkte.csv" + <&> decodeWith csvOptions HasHeader + return $ mkDoubleMap $ fmap (\line -> (Ril100 (line !! 2), line !! 0)) leitpunkte + +readData :: IO StaticAppData +readData = do + putStrLn "Parsing input .csv files…" + betriebsstellen <- readBetriebsstellen + leitpunktMap <- readLeitpunktMap + putStrLn "Static data ready." + + let betriebsstellenFiltered = betriebsstellen + & V.filter (\line -> line !! 4 `notElem` ["BUSH", "LGR", "ÜST", "BFT", "ABZW", "BK", "AWAN", "ANST", "LGR"]) + let ril100set = addMany (V.toList (V.map (!! 2) betriebsstellenFiltered)) (emptySet 5 6 False) + let ril100map = mkDoubleMap $ fmap (\line -> (Ril100 (line !! 1), line !! 2)) betriebsstellen + + return StaticAppData{..} + +csvOptions, tsvOptions :: DecodeOptions +csvOptions = defaultDecodeOptions { decDelimiter = fromIntegral (ord ';') } +tsvOptions = defaultDecodeOptions { decDelimiter = fromIntegral (ord '\t') } + diff --git a/bahnhof-name.cabal b/bahnhof-name.cabal index 02a7344..bd20dc0 100644 --- a/bahnhof-name.cabal +++ b/bahnhof-name.cabal @@ -20,8 +20,9 @@ executable bahnhof-name import: warnings main-is: Main.hs + other-modules: Util hs-source-dirs: app - build-depends: base ^>=4.18 + build-depends: base ^>=4.19 , fuzzyset >= 0.3.0 , fuzzyfind , text @@ -39,3 +40,22 @@ executable bahnhof-name , time default-language: GHC2021 ghc-options: -threaded -with-rtsopts=--nonmoving-gc + +executable bahnhof-dns + import: warnings + + main-is: BahnhofDNS.hs + other-modules: Util + hs-source-dirs: app + build-depends: base ^>=4.19 + , fuzzyset >= 0.3.0 + , fuzzyfind + , text + , vector + , cassava + , bytestring + , containers + , dns + , network + default-language: GHC2021 + ghc-options: -threaded -with-rtsopts=--nonmoving-gc |