1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
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 -> "<a href=\"https://osm.org/"<>osmType<>"/"<>osmId<>"\">"<>ref<>"</a><br>"
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{..}))
|
