269 lines
11 KiB
Haskell
269 lines
11 KiB
Haskell
{-# 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.Either
|
|
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 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 ((<|>)))
|
|
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
|
|
, osmLevel :: Maybe Text
|
|
} deriving Show
|
|
|
|
instance FromRecord Platform where
|
|
parseRecord v =
|
|
Platform <$>
|
|
v .! 0 <*>
|
|
v .! 1 <*>
|
|
v .! 2 <*>
|
|
v .! 3 <*>
|
|
(v .! 4 <|> v .! 5)
|
|
|
|
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, level, layer;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 = V.toList platforms
|
|
& sortOn (maybe (0::Int) (fromRight 0 . fmap fst . T.signed T.decimal) . osmLevel)
|
|
<&> renderPlatform
|
|
& (Html . T.concat)
|
|
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 $ "\
|
|
\ril100 → Name: " <> ril100BaseUrl <> "/RM\n\
|
|
\Name → ril100: " <> ril100BaseUrl <> "/Mannheim\n\n\
|
|
\Leitpunkt → Name: " <> leitpunktBaseUrl <> "/MA\n\
|
|
\Name → Leitpunkt: " <> leitpunktBaseUrl <> "/Mannheim\n\n\
|
|
\Am selben Bahnsteig gegenüber:\n\
|
|
\ " <> ril100BaseUrl <> "/RM/gleis"
|
|
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{..}))
|