diff options
Diffstat (limited to '')
| -rw-r--r-- | vdv-protocol.cabal | 19 | ||||
| -rw-r--r-- | vdv-server/VDV453/Kommunikationsschicht.hs | 167 | ||||
| -rw-r--r-- | vdv-testclient/Main.hs (renamed from vdv-test/Main.hs) | 0 | ||||
| -rw-r--r-- | vdv-testserver/Main.hs | 7 |
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 |