summaryrefslogtreecommitdiff
path: root/app
diff options
context:
space:
mode:
Diffstat (limited to '')
-rw-r--r--app/Main.hs103
-rw-r--r--app/Util.hs16
2 files changed, 66 insertions, 53 deletions
diff --git a/app/Main.hs b/app/Main.hs
index 0f2e3e7..b6ba540 100644
--- a/app/Main.hs
+++ b/app/Main.hs
@@ -50,12 +50,13 @@ instance FromRecord Platform where
Platform <$>
v .! 0 <*>
v .! 1 <*>
- v .! 2 <*>
- v .! 3 <*>
- (v .! 4 <|> v .! 5) <*>
- v .! 6 <*>
- v .! 7 <*>
- v .! 8
+ v .!? 2 <*>
+ v .!? 3 <*>
+ (v .!? 4 <|> v .!? 5) <*>
+ v .!? 6 <*>
+ v .!? 7 <*>
+ v .!? 8
+ where v .!? b = fromMaybe (pure Nothing) $ fmap parseField (v V.!? b)
data Answer
= Redirect Text
@@ -85,47 +86,21 @@ app :: AppData -> Application
app AppData{..} request respond = mkAnswer >>= (respond . toResponse)
where
mkAnswer :: IO Answer
- mkAnswer = case filter (/= mempty) (pathInfo request) of
- [] -> pure helptext
- ["favicon.ico"] -> pure Notfound
- ["cache"] -> do
+ mkAnswer = case unsnoc (filter (/= mempty) (pathInfo request)) of
+ Nothing -> pure helptext
+ Just ([], "favicon.ico") -> pure Notfound
+ Just ([], "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]
- | not (T.any isLower query) && host `elem` ["leitpunkt"]
- -> lookupName query leitpunktMap
- >>= (`lookupCode` ril100map)
- & maybeAnswer Plaintext & pure
- | not (T.any isLower query) && host `elem` ["rnv"]
- -> lookupCode (RnvId query) rnvMap
- & maybeAnswer Plaintext & pure
- | not (T.any isLower 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)
- | host `elem` ["rnv"]
- -> lookupName query rnvMap
- & maybeAnswer (Plaintext . unRnv) & pure
- | 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
+ Just (query, segment) | segment `elem` ["gleis", "track", "tracks", "gleise", "platform", "platforms", "fetch"]
+ -> case queriedRil100 (T.intercalate "/" query) of
None -> pure Notfound
Fuzzy url -> pure (Redirect (T.intercalate "/" [url, segment]))
+ Ambiguous possibilities -> pure (listOfCompletions possibilities)
Exact ril100 -> do
maybeCache <- readTVarIO platformCache <&> M.lookup ril100
now <- getCurrentTime
@@ -208,26 +183,51 @@ app AppData{..} request respond = mkAnswer >>= (respond . toResponse)
& T.intercalate " "
mkAnchor p inner =
"<a href=\"https://osm.org/"<>osmType p<>"/"<>osmId p<>"\">"<>inner<>"</a>"
- _ -> pure Notfound
- queriedRil100 :: Text -> MatchResult Ril100 Text
- queriedRil100 query = if
+ Just _
| not (T.any isLower query) && host `elem` ["leitpunkt"]
-> lookupName query leitpunktMap
- & maybe None Exact
+ >>= (`lookupCode` ril100map)
+ & maybeAnswer Plaintext & pure
+ | not (T.any isLower query) && host `elem` ["rnv"]
+ -> lookupCode (RnvId query) rnvMap
+ & maybeAnswer Plaintext & pure
| not (T.any isLower query)
- -> Exact (Ril100 query)
+ -> lookupCode (Ril100 query) ril100map
+ & maybeAnswer Plaintext & pure
| host `elem` ["leitpunkt"]
- -> case findStationName query ril100set of
- None -> None
+ -> pure $ case findStationName query ril100set of
+ None -> Notfound
+ Ambiguous possibilities -> listOfLinks leitpunktBaseUrl possibilities
+ Exact (_,match) -> lookupName match ril100map
+ >>= (`lookupCode` leitpunktMap)
+ & maybeAnswer Plaintext
+ Fuzzy (_,match) -> Redirect (leitpunktBaseUrl <> "/" <> match)
+ | host `elem` ["rnv"]
+ -> lookupName query rnvMap
+ & maybeAnswer (Plaintext . unRnv) & pure
+ | otherwise
+ -> pure $ case findStationName query ril100set of
+ None -> Notfound
+ Ambiguous possibilities -> listOfLinks ril100BaseUrl possibilities
Exact (_,match) -> lookupName match ril100map
+ & maybeAnswer (Plaintext . unRil100)
+ Fuzzy (_,match) -> Redirect (ril100BaseUrl <> "/" <> match)
+ where query = T.intercalate "/" (pathInfo request)
+ queriedRil100 :: Text -> MatchResult Ril100 Text (Text, Text)
+ queriedRil100 query = if
+ | not (T.any isLower query) && host `elem` ["leitpunkt"]
+ -> lookupName query leitpunktMap
& maybe None Exact
- Fuzzy (_,match) -> Fuzzy (leitpunktBaseUrl <> "/" <> match)
+ | not (T.any isLower query)
+ -> Exact (Ril100 query)
| otherwise
-> case findStationName query ril100set of
None -> None
+ Ambiguous possibilities -> Ambiguous (fmap (\(_, t) -> (baseUrl <> "/" <> t, t)) possibilities)
Exact (_,match) -> lookupName match ril100map
& maybe None Exact
- Fuzzy (_,match) -> Fuzzy (ril100BaseUrl <> "/" <> match)
+ Fuzzy (_,match) -> Fuzzy (baseUrl <> "/" <> match)
+ where baseUrl = if host `elem` ["leitpunkt"] then leitpunktBaseUrl else ril100BaseUrl
helptext = Html $ "\
\<pre>\
\ril100 → Name: " <> ril100BaseUrl <> "/RM\n\
@@ -270,6 +270,13 @@ app AppData{..} request respond = mkAnswer >>= (respond . toResponse)
, ("x-data-by", "OpenStreetMap Contributors https://www.openstreetmap.org/copyright/")
, ("x-sources-at", "https://stuebinm.eu/git/bahnhof.name")
]
+ listOfCompletions possibilities = possibilities
+ & fmap (\(href, text) -> "<a href=\"" <> href <> "\">" <> text <> "</a>")
+ & T.intercalate "<br>"
+ & Html
+ listOfLinks baseUrl possibilities = possibilities
+ & fmap (\(_, t) -> (baseUrl <> "/" <> t, t))
+ & listOfCompletions
diff --git a/app/Util.hs b/app/Util.hs
index 094f229..ee8a5e6 100644
--- a/app/Util.hs
+++ b/app/Util.hs
@@ -23,9 +23,10 @@ import qualified Data.Vector as V
import Text.FuzzyFind (Alignment (score), bestMatch)
-data MatchResult a b
+data MatchResult a b c
= Exact a
| Fuzzy b
+ | Ambiguous [c]
| None
deriving Show
@@ -41,18 +42,22 @@ data DoubleMap code long = DoubleMap
, back :: Map long code
}
-findStationName :: T.Text -> FuzzySet -> MatchResult (Double, Text) (Double, Text)
+findStationName :: T.Text -> FuzzySet -> MatchResult (Double, Text) (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
+ [] -> None
+ [station] -> Fuzzy station
+ s1:s2:_
+ | fst s1 - fst s2 < 10 -> Ambiguous $ (takeWhile ((> fst s1 - 10) . fst) results)
+ | otherwise -> Fuzzy s1
where
sorted = results
& fmap (\(_, match) -> (fromIntegral . maybe 0 score . bestMatch (T.unpack query) $ T.unpack match, match))
& sortOn (Down . fst)
+ -- check if difference between first two is <10 or such
results = find query set
maybeHbf = filter (T.isInfixOf "Hbf" . snd) sorted
@@ -102,7 +107,8 @@ readData = do
putStrLn "Static data ready."
let betriebsstellenFiltered = betriebsstellen
- & V.filter (\line -> line !! 4 `notElem` ["BUSH", "LGR", "ÜST", "BFT", "ABZW", "BK", "AWAN", "ANST", "LGR"])
+ & V.filter (\line -> line !! 4 `notElem` ["BUSH", "LGR", "ÜST", "ABZW", "BK", "AWAN", "ANST", "LGR"]
+ && line !! 5 `notElem` [ "TrSt" ])
let ril100set = addMany (V.toList (V.map (!! 2) betriebsstellenFiltered)) (emptySet 5 6 False)
let ril100map = mkDoubleMap $ fmap (\line -> (Ril100 (line !! 1), line !! 2)) betriebsstellen
generated by cgit v1.3.1 (git 2.54.0) at 2026-09-29 22:59:25 +0000