From a31e8759c0fffb8c4f2e87624eb9e520f04f273c Mon Sep 17 00:00:00 2001 From: stuebinm Date: Wed, 9 Nov 2022 01:08:05 +0100 Subject: 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 … --- vdv-server/VDV453/Kommunikationsschicht.hs | 167 ++++++++++++++++++++++------- 1 file changed, 129 insertions(+), 38 deletions(-) (limited to 'vdv-server') 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 false #{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 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 ^{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| 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) -- cgit v1.2.3