path: root/vdv-server/VDV453/Kommunikationsschicht.hs

{-# LANGUAGE DataKinds, OverloadedStrings, TypeOperators, TypeApplications #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TemplateHaskell, QuasiQuotes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}


module VDV453.Kommunikationsschicht where

import Servant.API
import Servant.Server (Server, serve, Handler, err400)
import Data.Proxy (Proxy(..))
import Network.Wai.Handler.Warp (run)
import Network.HTTP.Media.MediaType ((//))
import Text.XML
import Debug.Trace (trace)
import Fmt
import Text.Hamlet.XML (xml)
import Control.Monad.IO.Class (MonadIO(liftIO))
import Data.Time (getCurrentTime, UTCTime)
import Data.Time.Format.ISO8601 (iso8601Show, iso8601ParseM)
import qualified Data.Text as T
import qualified Data.Map as M
import           Network.Wai.Middleware.RequestLogger (OutputFormat (..),
                                                       RequestLoggerSettings (..),
                                                       mkRequestLogger)
import Data.Functor ((<&>))
import Servant (throwError, ServerError (errBody))
import Data.Typeable (Typeable, typeRep)
import GHC.Stack (HasCallStack, prettyCallStack, callStack, SrcLoc (..))
import GHC.Exts (toList, IsString)
import Data.Text (Text)
import GHC.Conc (TVar, newTVar, atomically, readTVar)
import Data.Void (Void, absurd)
import Servant.Client (client, runClientM, BaseUrl (BaseUrl), Scheme (Http), mkClientEnv, HasClient (Client), ClientM)
import Network.HTTP.Client (newManager, defaultManagerSettings)
import GHC.Conc.Sync (writeTVar)
import Data.Kind (Type)
import GHC.TypeLits (Symbol, symbolVal, KnownSymbol)
import Control.Concurrent.STM (TQueue, writeTQueue, newTQueueIO, readTQueue)
import Control.Monad (forever)
import Control.Concurrent.Async (async, wait)

data XML


instance Accept XML where
  contentType _ = "text" // "xml"

instance MimeRender XML Element where
  mimeRender _ root = renderLBS def (Document (Prologue [] Nothing []) root [])

instance MimeUnrender XML Element where
  mimeUnrender _ lbs = case parseLBS def lbs of
    Right (Document p root e) ->
      trace ("trace: received document: "+|show p|+", _, "+|show e|+".") (Right root)
    Left err -> Left (show err)


type VDV a = ReqBody '[XML] a :> Post '[XML] a

type ServerAPI s =
  Capture "Fremdsystem" Leitstellenkennung :> Slug s :> "status.xml" :> VDV Element
  :<|> Capture "Fremdsystem" Leitstellenkennung :> Slug s :> "aboverwalten.xml" :> VDV Element
  :<|> Capture "Fremdsystem" Leitstellenkennung :> Slug s :> "datenabrufen.xml" :> VDV Element

type ClientAPI s =
  Capture "Fremdsystem" Leitstellenkennung :> Slug s :> "clientstatus.xml" :> VDV Element
  :<|> Capture "Fremdsystem" Leitstellenkennung :> Slug s :> "datenbereit.xml" :> VDV Element



-- this part is mildly annoying; the constraint here prevents using the nicer syntax
-- to declare all of these at once
serverReqStatus :: forall d. KnownSymbol (Slug d) => Leitstellenkennung -> Element -> ClientM Element
serverReqStatus = c
  where (c :<|> _ :<|> _) = client (Proxy @(ServerAPI d))
serverReqAboverwalten :: forall d. KnownSymbol (Slug d) => Leitstellenkennung -> Element -> ClientM Element
serverReqAboverwalten = c
  where (_ :<|> c :<|> _) = client (Proxy @(ServerAPI d))
serverReqDatenabrufen :: forall d. KnownSymbol (Slug d) => Leitstellenkennung -> Element -> ClientM Element
serverReqDatenabrufen = c
  where (_ :<|> _ :<|> c) = client (Proxy @(ServerAPI d))

clientReqStatus :: forall d. KnownSymbol (Slug d) => Leitstellenkennung -> Element -> ClientM Element
clientReqStatus = c
  where (c :<|> _) = client (Proxy @(ClientAPI d))
clientReqDatenBereit :: forall d. KnownSymbol (Slug d) => Leitstellenkennung -> Element -> ClientM Element
clientReqDatenBereit = c
  where (_ :<|> c) = client (Proxy @(ClientAPI d))



newtype Leitstellenkennung = Leitstellenkennung Text
  deriving newtype (ToHttpApiData, FromHttpApiData, IsString, Show)


class VDVDienst a where
  type Abo a
  type (Slug a) :: Symbol
  leitstellenkennung :: a -> Leitstellenkennung
  leitstellenname :: a -> Text

slug :: forall d. (VDVDienst d, KnownSymbol (Slug d)) => Text
slug = T.pack $ symbolVal (Proxy @(Slug d))

class (KnownSymbol (Slug s), VDVDienst s) => VDVServer s where
  serverAbos :: s -> IO [Abo s]

  serverAboAnfrage :: s -> Text -> UTCTime -> [Node] -> IO (Maybe (Int, Text))
  serverDatenAbrufen :: s -> Text -> UTCTime -> Bool -> IO (Either (Int, Text) [Node])
  -- TODO

class VDVDienst c => VDVClient c where
  clientAbos :: c -> IO [Abo c]
  -- clientDatenBereit :: c -> IO ()
  clientMessageQueue :: c -> TQueue DatenBereit

data DatenBereit = DatenBereit
  { bereitZst :: UTCTime
  , bereitSender :: Text
  , bereitFremdsystem :: Leitstellenkennung
  , bereitPayload :: [Node]
  } deriving Show

class ToElement a where
  toElement :: a -> Element

instance ToElement Void where
  toElement = absurd

toNodes :: ToElement a => [a] -> [Node]
toNodes = fmap (NodeElement . toElement)

data DumbClient a = DumbClient (TVar [a]) (TQueue DatenBereit)

instance VDVDienst (DumbClient a) where
  type Abo (DumbClient a) = a
  type Slug (DumbClient a) = "dumb"
  leitstellenkennung _ = "dumbclient"
  leitstellenname _ = "Einfacher Client A"

instance VDVClient (DumbClient a) where
  clientAbos c@(DumbClient tvar _) = atomically $ readTVar tvar
  clientMessageQueue (DumbClient _ queue) = queue

data DumbServer a = DumbServer (TVar [a])

instance VDVDienst (DumbServer a) where
  type Abo (DumbServer a) = a
  type Slug (DumbServer a) = "dumb"
  leitstellenkennung _ = "dumbserver"
  leitstellenname _ = "Einfacher Server B"
instance VDVServer (DumbServer ()) where
  serverAbos (DumbServer tvar) = atomically $ readTVar tvar
  serverAboAnfrage (DumbServer tvar) client timestamp newabos =
    atomically $ do
      abos <- readTVar tvar
      writeTVar tvar (abos <> fmap (const ()) abos)
      pure Nothing -- no error occured (or is possible)
  serverDatenAbrufen (DumbServer tvar) client zst alle =
    pure (Right $ [ NodeElement $ Element "dummy" mempty [] ] )


serverServer :: (VDVServer s) => s -> UTCTime -> Server (ServerAPI s)
serverServer server startupTime = status :<|> aboverwalten :<|> datenabrufen
  where status fremdsystem (Element name attrs children) = do
          now <- liftIO $ getCurrentTime
          -- TODO: no idea what to do with the request information, it doesn't seem relevant at all?
          -- TODO: not sure how to decide if DatenBereit is true or false
          pure $ Element "StatusAntwort" mempty [xml|
            <Status Zst="#{T.pack $ iso8601Show now}">
            <DatenBereit>false
            <StartDienstZst>#{T.pack $ iso8601Show startupTime}
          |]
        aboverwalten fremdsystem (Element "AboAnfrage" attrs children) = do
          sender <- unwrap (M.lookup "Sender" attrs)
          zst <- unwrap (M.lookup "Zst" attrs) >>= (unwrap . iso8601ParseM . T.unpack)
          let abos = children
          status <- liftIO $ serverAboAnfrage server sender zst abos
          now <- liftIO $ getCurrentTime
          pure $ Element "AboAntwort" mempty [xml|
            $maybe (code, msg) <- status
              <Bestaetigung
                 Zst="#{T.pack $ iso8601Show now}"
                 Ergebnis="nok"
                 Fehlernummer="#{T.pack $ show code}"
                 Fehlertext="#{msg}">
            $nothing
              <Bestaetigung
                Zst="#{T.pack $ iso8601Show now}"
                   Ergebnis="ok"
                   Fehlernummer="0">
          |]
        aboverwalten _ _ = undefined -- TODO: abo löschen etc.
        datenabrufen fremdsystem (Element "DatenAbrufenAnfrage" attrs children) = do
          sender <- unwrap (M.lookup "Sender" attrs)
          zst <- unwrap (M.lookup "Zst" attrs) >>= (unwrap . iso8601ParseM . T.unpack)
          datensatzAlle <- pure True
          now <- liftIO $ getCurrentTime
          status <- liftIO $ serverDatenAbrufen server sender zst datensatzAlle
          case status of
            Left (code, msg) -> pure $ Element "DatenAbrufenAntwort" mempty [xml|
              <Bestaetigung
                 Zst="#{T.pack $ iso8601Show now}"
                 Ergebnis="nok"
                 Fehlernummer="#{T.pack $ show code}"
                 Fehlertext="#{msg}">
            |]
            Right nodes -> pure $ Element "DatenAbrufenAntwort" mempty [xml|
              <Bestaetigung
                Zst="#{T.pack $ iso8601Show now}"
                   Ergebnis="ok"
                   Fehlernummer="0">
              <WeitereDaten>false
              ^{nodes}
            |]
        datenabrufen _ _ = throwError err400


clientServer :: (VDVClient c, ToElement (Abo c)) => c -> UTCTime -> Server (ClientAPI c)
clientServer client startupTime = status :<|> datenbereit
  where status fremdsystem (Element name attrs children) = do
          now <- liftIO $ getCurrentTime
          let mitAbos = M.lookup "MitAbos" attrs == Just "true"
          abos <- liftIO $ clientAbos client
          pure $ Element "ClientStatusAntwort" mempty [xml|
            <Status Zst="#{T.pack $ iso8601Show now}" Ergebnis="ok">
            <StartDienstZst>#{T.pack $ iso8601Show startupTime}
            $if mitAbos
              <AktiveAbos>
                ^{toNodes abos}
          |]
        datenbereit fremdsystem (Element name attrs children) = do
          now <- liftIO $ getCurrentTime
          sender <- unwrap $ M.lookup "Sender" attrs
          zst :: UTCTime <- unwrap (M.lookup "Zst" attrs)
            >>= (unwrap . iso8601ParseM  . T.unpack)

          liftIO $ atomically $ writeTQueue (clientMessageQueue client)
            $ DatenBereit zst sender fremdsystem children
          liftIO $ print "added message to queue"
          pure $ Element "DatenBereitAntwort" mempty [xml|
            <Bestaetigung
              Zst="#{T.pack $ iso8601Show now}"
              Ergebnis="ok"
              Fehlernummer="0">
          |]



-- | just deny the request if this is Nothing, and print a debug trace instead
unwrap :: forall a. (HasCallStack, Typeable a) => Maybe a -> Handler a
unwrap (Just a) = pure a
unwrap Nothing =
  trace ("trace: failed to unwrap a Maybe "+|show (typeRep (Proxy @a))|+" ("+|srcLocModule|+", line "+|srcLocStartLine|+")")
  throwError err400
  where (_, SrcLoc{..}) = head $ toList callStack

runDumbClient :: IO ()
runDumbClient = do
  loggerMiddleware <- mkRequestLogger def { outputFormat = Detailed True }
  abos <- atomically $ newTVar (mempty :: [Void])
  msgqueue <- newTQueueIO
  startupTime <- getCurrentTime
  let client = DumbClient abos msgqueue
  putStrLn ("startup of dumb client at "+|iso8601Show startupTime|+" ...")

  r <- async $ run 8080
    $ loggerMiddleware
    $ serve (Proxy @(ClientAPI (DumbClient Void))) (clientServer client startupTime)

  forever $ do
    DatenBereit {..} <- atomically $ readTQueue msgqueue
    putStrLn "neue Daten bereit!"
    manager <- newManager defaultManagerSettings
    now <- getCurrentTime

    let msg = Element "DatenAbrufenAnfrage"
         (M.fromList [("Sender",leitstellenname client), ("Zst",T.pack $ iso8601Show now)])
         [xml|<DatensatzAlle>false|]
    req <- runClientM (serverReqDatenabrufen @(DumbClient Void) (leitstellenkennung client) msg)
      (mkClientEnv manager (BaseUrl Http "localhost" 8081 ""))
    print req

  wait r -- should be unreachable; here for completeness

runDumbServer :: IO ()
runDumbServer = do
  loggerMiddleware <- mkRequestLogger def { outputFormat = Detailed True }
  abos <- atomically $ newTVar (mempty :: [()])
  startupTime <- getCurrentTime
  putStrLn ("startup of dumb server at "+|iso8601Show startupTime|+" ...")
  run 8081 $ loggerMiddleware $ serve (Proxy @(ServerAPI (DumbServer ()))) (serverServer (DumbServer abos) startupTime)