diff options
Diffstat (limited to 'app/Main.hs')
| -rw-r--r-- | app/Main.hs | 64 |
1 files changed, 7 insertions, 57 deletions
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{..})) |