bahnhof-dns: new application

* New executable `bahnhof-dns`, which serves TXT records over DNS
  at `*.ril100.` and `*.leitpunkt.`
* Extract definitions used by both executables into new Util module

(slightly amended by stuebinm)

1 files changed, 103 insertions, 0 deletions

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') }
+