{-# LANGUAGE LambdaCase        #-}
{-# 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                        (on, (&))
import           Data.Functor                         ((<&>))
import           Data.FuzzySet.Simple
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 ((<|>)))
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 = find query set
    maybeHbf = filter (T.isInfixOf "Hbf" . snd) sorted

data Platform = Platform
  { osmType         :: Text
  , osmId           :: Text
  , ref             :: Maybe Text
  , localRef        :: Maybe Text
  , osmLevel        :: Maybe Text
  , osmPlatform     :: Maybe Text
  , osmSection      :: Maybe Text
  , osmPlatformEdge :: Maybe Text
  } deriving Show

instance FromRecord Platform where
  parseRecord v =
    Platform <$>
      v .! 0 <*>
      v .! 1 <*>
      v .! 2 <*>
      v .! 3 <*>
      (v .! 4 <|> v .! 5) <*>
      v .! 6 <*>
      v .! 7 <*>
      v .! 8

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 filter (/= mempty) (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]
        | not (T.any isLower query) && host `elem` ["leitpunkt"]
          -> lookupName query leitpunktMap
            >>= (`lookupCode` ril100map)
            & 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)
        | 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 (T.intercalate "/" [url, segment]))
        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, platform, section, track;false)][timeout:25];\n\
                 \nwr[~\"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\
                 \foreach {\n\
                 \  ._ -> .a;\n\
                 \  out tags;\n\
                 \  >> -> .p;\n\
                 \  nwr.p[\"railway\"=\"platform_edge\"][\"ref\"] -> .edges;\n\
                 \  if (edges.count(nwr) == 0) {\n\
                 \    >>;\n\
                 \    node._[\"railway:platform:section\"] -> ._;\n\
                 \    convert node platform = a.u(id()),\n\
                 \                 section = t[\"railway:platform:section\"],\n\
                 \                 ::id = id();\n\
                 \    out tags;\n\
                 \  } else {  \n\
                 \    foreach.edges {\n\
                 \      ._ -> .b;\n\
                 \      >>;\n\
                 \      node._[\"railway:platform:section\"] -> ._;\n\
                 \      convert node platform = a.u(id()),\n\
                 \                   section = t[\"railway:platform:section\"],\n\
                 \                   track = b.u(t[\"ref\"]),\n\
                 \                   ::id = id();\n\
                 \      out tags;\n\
                 \    }\n\
                 \  }\n\
                 \}\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 platforms
                       & (Html . T.concat)
                  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 others p = case getRef (ref p) (localRef p) of
                      Just ref -> mkAnchor p ref<>"</a>"<>renderedSections<>"<br>"
                      Nothing -> ""
                      where sectionGroups = others
                              & V.filter ((== Just (osmId p)) . osmPlatform)
                              & V.toList
                              & groupBy ((==) `on` osmPlatformEdge)
                            renderSectionGroup sections = if null sections then "" else sections
                              & sortOn osmSection
                              & mapMaybe (\p -> case osmSection p of Just s -> Just (mkAnchor p s) ; _ -> Nothing)
                              & intersperse ","
                              & ((osmPlatformEdge (head sections) & \case {Nothing -> ""; Just a -> a<>": "}) :)
                              & T.concat
                            renderedSections = if null sectionGroups then "" else sectionGroups
                              <&> renderSectionGroup
                              & (": " :)
                              & 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
        | not (T.any isLower query) && host `elem` ["leitpunkt"]
          -> lookupName query leitpunktMap
              & maybe None Exact
        | not (T.any isLower 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
  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

  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), T.replace "�" "ü" (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{..}))