summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--vdv-protocol.cabal19
-rw-r--r--vdv-server/VDV453/Kommunikationsschicht.hs167
-rw-r--r--vdv-testclient/Main.hs (renamed from vdv-test/Main.hs)0
-rw-r--r--vdv-testserver/Main.hs7
4 files changed, 153 insertions, 40 deletions
diff --git a/vdv-protocol.cabal b/vdv-protocol.cabal
index 869745d..822eb94 100644
--- a/vdv-protocol.cabal
+++ b/vdv-protocol.cabal
@@ -36,12 +36,14 @@ library
, time
, text
, containers
+ , stm
+ , async
hs-source-dirs: vdv-server
default-language: Haskell2010
exposed-modules: VDV453.Kommunikationsschicht
-executable vdv-protocol
+executable vdv-testclient
main-is: Main.hs
-- Modules included in this executable, other than Main.
@@ -51,5 +53,18 @@ executable vdv-protocol
-- other-extensions:
build-depends: base ^>=4.14.3.0
, vdv-protocol
- hs-source-dirs: vdv-test
+ hs-source-dirs: vdv-testclient
+ default-language: Haskell2010
+
+executable vdv-testserver
+ main-is: Main.hs
+
+ -- Modules included in this executable, other than Main.
+ -- other-modules:
+
+ -- LANGUAGE extensions used by modules in this package.
+ -- other-extensions:
+ build-depends: base ^>=4.14.3.0
+ , vdv-protocol
+ hs-source-dirs: vdv-testserver
default-language: Haskell2010
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)
diff --git a/vdv-test/Main.hs b/vdv-testclient/Main.hs
index 6092ddb..6092ddb 100644
--- a/vdv-test/Main.hs
+++ b/vdv-testclient/Main.hs
diff --git a/vdv-testserver/Main.hs b/vdv-testserver/Main.hs
new file mode 100644
index 0000000..ba2ee21
--- /dev/null
+++ b/vdv-testserver/Main.hs
@@ -0,0 +1,7 @@
+module Main where
+
+import VDV453.Kommunikationsschicht
+
+main :: IO ()
+main = do
+ runDumbServer