summaryrefslogtreecommitdiff
path: root/vdv-server/VDV453
diff options
context:
space:
mode:
authorstuebinm2022-11-09 01:08:05 +0100
committerstuebinm2022-11-09 01:08:55 +0100
commita31e8759c0fffb8c4f2e87624eb9e520f04f273c (patch)
treef0a23cf8c0a68c37719125913c13b62f4e40c4f8 /vdv-server/VDV453
parentf2179094320eada798ece41911e1489beb12ab82 (diff)
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 …
Diffstat (limited to 'vdv-server/VDV453')
-rw-r--r--vdv-server/VDV453/Kommunikationsschicht.hs167
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)