some more hacking

includes a message queue, more correct implementation of how the routs
work (why do they work like THAT though???), and other fun stuff.

uh also turns out you can't do schema validation with xml-types easily.
ah well. "be liberal in what you accept" and all that …

1 files changed, 129 insertions, 38 deletions

diff --git a/vdv-server/VDV453/Kommunikationsschicht.hs b/vdv-server/VDV453/Kommunikationsschicht.hs
index 7e67db8..8eeaff1 100644
--- a/vdv-server/VDV453/Kommunikationsschicht.hs
+++ b/vdv-server/VDV453/Kommunikationsschicht.hs
@@ -6,7 +6,9 @@
 {-# LANGUAGE RecordWildCards #-}
 {-# LANGUAGE TypeFamilies #-}
 {-# LANGUAGE FlexibleContexts #-}
-
+{-# LANGUAGE AllowAmbiguousTypes #-}
+{-# LANGUAGE DerivingStrategies #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
 
 
 module VDV453.Kommunikationsschicht where
@@ -32,12 +34,18 @@ import Data.Functor ((<&>))
 import Servant (throwError, ServerError (errBody))
 import Data.Typeable (Typeable, typeRep)
 import GHC.Stack (HasCallStack, prettyCallStack, callStack, SrcLoc (..))
-import GHC.Exts (toList)
+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)
+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
 
@@ -57,30 +65,69 @@ instance MimeUnrender XML Element where
 
 type VDV a = ReqBody '[XML] a :> Post '[XML] a
 
-type ServerAPI = "status.xml" :> VDV Element
-  :<|> "aboverwalten.xml" :> VDV Element
-  :<|> "datenabrufen.xml" :> VDV Element
+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))
+
 
-type ClientAPI = "clientstatus.xml" :> VDV Element
-  :<|> "datenbereit.xml" :> VDV Element
 
-serverReqStatus :<|> serverReqAboverwalten :<|> serverReqDatenabrufen = client (Proxy @ServerAPI)
-clientReqStatus :<|> clientReqDatenbereit = client (Proxy @ClientAPI)
+newtype Leitstellenkennung = Leitstellenkennung Text
+  deriving newtype (ToHttpApiData, FromHttpApiData, IsString, Show)
 
-class VDVInfo a where
+
+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 VDVInfo s => VDVServer s where
+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 VDVInfo c => VDVClient c where
+class VDVDienst c => VDVClient c where
   clientAbos :: c -> IO [Abo c]
-  clientDatenBereit :: c -> IO ()
+  -- 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
@@ -91,24 +138,39 @@ instance ToElement Void where
 toNodes :: ToElement a => [a] -> [Node]
 toNodes = fmap (NodeElement . toElement)
 
-data DumbClient a = DumbClient (TVar [a])
+data DumbClient a = DumbClient (TVar [a]) (TQueue DatenBereit)
 
-instance VDVInfo (DumbClient a) where
+instance VDVDienst (DumbClient a) where
   type Abo (DumbClient a) = a
-instance VDVClient (DumbClient a) where
-  clientAbos (DumbClient tvar) = atomically $ readTVar tvar
-  clientDatenBereit _ = do
-    putStrLn "neue Daten bereit!"
-    manager <- newManager defaultManagerSettings
-    req <- runClientM (serverReqDatenabrufen (Element "hello" mempty []))
-      (mkClientEnv manager (BaseUrl Http "localhost" 8081 ""))
-    print req
+  type Slug (DumbClient a) = "dumb"
+  leitstellenkennung _ = "dumbclient"
+  leitstellenname _ = "Einfacher Client A"
 
-
-
-serverServer :: (VDVServer s) => s -> UTCTime -> Server ServerAPI
+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 (Element name attrs children) = do
+  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
@@ -117,7 +179,7 @@ serverServer server startupTime = status :<|> aboverwalten :<|> datenabrufen
             <DatenBereit>false
             <StartDienstZst>#{T.pack $ iso8601Show startupTime}
           |]
-        aboverwalten (Element "AboAnfrage" attrs children) = do
+        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
@@ -136,8 +198,8 @@ serverServer server startupTime = status :<|> aboverwalten :<|> datenabrufen
                    Ergebnis="ok"
                    Fehlernummer="0">
           |]
-        aboverwalten _ = undefined -- TODO: abo löschen etc.
-        datenabrufen (Element "DatenAbrufenAnfrage" attrs children) = do
+        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
@@ -159,12 +221,12 @@ serverServer server startupTime = status :<|> aboverwalten :<|> datenabrufen
               <WeitereDaten>false
               ^{nodes}
             |]
-        datenabrufen _ = throwError err400
+        datenabrufen _ _ = throwError err400
 
 
-clientServer :: (VDVClient c, ToElement (Abo c)) => c -> UTCTime -> Server ClientAPI
+clientServer :: (VDVClient c, ToElement (Abo c)) => c -> UTCTime -> Server (ClientAPI c)
 clientServer client startupTime = status :<|> datenbereit
-  where status (Element name attrs children) = do
+  where status fremdsystem (Element name attrs children) = do
           now <- liftIO $ getCurrentTime
           let mitAbos = M.lookup "MitAbos" attrs == Just "true"
           abos <- liftIO $ clientAbos client
@@ -175,14 +237,15 @@ clientServer client startupTime = status :<|> datenbereit
               <AktiveAbos>
                 ^{toNodes abos}
           |]
-        datenbereit (Element name attrs children) = do
+        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)
 
-          -- TODO: fork here? definitely shouldn't hold the answer back …
-          liftIO $ clientDatenBereit client
+          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}"
@@ -204,6 +267,34 @@ 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|+" ...")
-  run 8080 $ loggerMiddleware $ serve (Proxy @ClientAPI) (clientServer (DumbClient abos) 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)