summaryrefslogtreecommitdiff
path: root/vdv-server
diff options
context:
space:
mode:
Diffstat (limited to 'vdv-server')
-rw-r--r--vdv-server/VDV453/Kommunikationsschicht.hs209
1 files changed, 209 insertions, 0 deletions
diff --git a/vdv-server/VDV453/Kommunikationsschicht.hs b/vdv-server/VDV453/Kommunikationsschicht.hs
new file mode 100644
index 0000000..7e67db8
--- /dev/null
+++ b/vdv-server/VDV453/Kommunikationsschicht.hs
@@ -0,0 +1,209 @@
+{-# LANGUAGE DataKinds, OverloadedStrings, TypeOperators, TypeApplications #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE TemplateHaskell, QuasiQuotes #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE FlexibleContexts #-}
+
+
+
+module VDV453.Kommunikationsschicht where
+
+import Servant.API
+import Servant.Server (Server, serve, Handler, err400)
+import Data.Proxy (Proxy(..))
+import Network.Wai.Handler.Warp (run)
+import Network.HTTP.Media.MediaType ((//))
+import Text.XML
+import Debug.Trace (trace)
+import Fmt
+import Text.Hamlet.XML (xml)
+import Control.Monad.IO.Class (MonadIO(liftIO))
+import Data.Time (getCurrentTime, UTCTime)
+import Data.Time.Format.ISO8601 (iso8601Show, iso8601ParseM)
+import qualified Data.Text as T
+import qualified Data.Map as M
+import Network.Wai.Middleware.RequestLogger (OutputFormat (..),
+ RequestLoggerSettings (..),
+ mkRequestLogger)
+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 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 Network.HTTP.Client (newManager, defaultManagerSettings)
+
+data XML
+
+
+instance Accept XML where
+ contentType _ = "text" // "xml"
+
+instance MimeRender XML Element where
+ mimeRender _ root = renderLBS def (Document (Prologue [] Nothing []) root [])
+
+instance MimeUnrender XML Element where
+ mimeUnrender _ lbs = case parseLBS def lbs of
+ Right (Document p root e) ->
+ trace ("trace: received document: "+|show p|+", _, "+|show e|+".") (Right root)
+ Left err -> Left (show err)
+
+
+type VDV a = ReqBody '[XML] a :> Post '[XML] a
+
+type ServerAPI = "status.xml" :> VDV Element
+ :<|> "aboverwalten.xml" :> VDV Element
+ :<|> "datenabrufen.xml" :> VDV Element
+
+type ClientAPI = "clientstatus.xml" :> VDV Element
+ :<|> "datenbereit.xml" :> VDV Element
+
+serverReqStatus :<|> serverReqAboverwalten :<|> serverReqDatenabrufen = client (Proxy @ServerAPI)
+clientReqStatus :<|> clientReqDatenbereit = client (Proxy @ClientAPI)
+
+class VDVInfo a where
+ type Abo a
+
+class VDVInfo 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
+ clientAbos :: c -> IO [Abo c]
+ clientDatenBereit :: c -> IO ()
+
+
+class ToElement a where
+ toElement :: a -> Element
+
+instance ToElement Void where
+ toElement = absurd
+
+toNodes :: ToElement a => [a] -> [Node]
+toNodes = fmap (NodeElement . toElement)
+
+data DumbClient a = DumbClient (TVar [a])
+
+instance VDVInfo (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
+
+
+
+serverServer :: (VDVServer s) => s -> UTCTime -> Server ServerAPI
+serverServer server startupTime = status :<|> aboverwalten :<|> datenabrufen
+ where status (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
+ pure $ Element "StatusAntwort" mempty [xml|
+ <Status Zst="#{T.pack $ iso8601Show now}">
+ <DatenBereit>false
+ <StartDienstZst>#{T.pack $ iso8601Show startupTime}
+ |]
+ aboverwalten (Element "AboAnfrage" attrs children) = do
+ sender <- unwrap (M.lookup "Sender" attrs)
+ zst <- unwrap (M.lookup "Zst" attrs) >>= (unwrap . iso8601ParseM . T.unpack)
+ let abos = children
+ status <- liftIO $ serverAboAnfrage server sender zst abos
+ now <- liftIO $ getCurrentTime
+ pure $ Element "AboAntwort" mempty [xml|
+ $maybe (code, msg) <- status
+ <Bestaetigung
+ Zst="#{T.pack $ iso8601Show now}"
+ Ergebnis="nok"
+ Fehlernummer="#{T.pack $ show code}"
+ Fehlertext="#{msg}">
+ $nothing
+ <Bestaetigung
+ Zst="#{T.pack $ iso8601Show now}"
+ Ergebnis="ok"
+ Fehlernummer="0">
+ |]
+ aboverwalten _ = undefined -- TODO: abo löschen etc.
+ datenabrufen (Element "DatenAbrufenAnfrage" attrs children) = do
+ sender <- unwrap (M.lookup "Sender" attrs)
+ zst <- unwrap (M.lookup "Zst" attrs) >>= (unwrap . iso8601ParseM . T.unpack)
+ datensatzAlle <- pure True
+ now <- liftIO $ getCurrentTime
+ status <- liftIO $ serverDatenAbrufen server sender zst datensatzAlle
+ case status of
+ Left (code, msg) -> pure $ Element "DatenAbrufenAntwort" mempty [xml|
+ <Bestaetigung
+ Zst="#{T.pack $ iso8601Show now}"
+ Ergebnis="nok"
+ Fehlernummer="#{T.pack $ show code}"
+ Fehlertext="#{msg}">
+ |]
+ Right nodes -> pure $ Element "DatenAbrufenAntwort" mempty [xml|
+ <Bestaetigung
+ Zst="#{T.pack $ iso8601Show now}"
+ Ergebnis="ok"
+ Fehlernummer="0">
+ <WeitereDaten>false
+ ^{nodes}
+ |]
+ datenabrufen _ = throwError err400
+
+
+clientServer :: (VDVClient c, ToElement (Abo c)) => c -> UTCTime -> Server ClientAPI
+clientServer client startupTime = status :<|> datenbereit
+ where status (Element name attrs children) = do
+ now <- liftIO $ getCurrentTime
+ let mitAbos = M.lookup "MitAbos" attrs == Just "true"
+ abos <- liftIO $ clientAbos client
+ pure $ Element "ClientStatusAntwort" mempty [xml|
+ <Status Zst="#{T.pack $ iso8601Show now}" Ergebnis="ok">
+ <StartDienstZst>#{T.pack $ iso8601Show startupTime}
+ $if mitAbos
+ <AktiveAbos>
+ ^{toNodes abos}
+ |]
+ datenbereit (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
+ pure $ Element "DatenBereitAntwort" mempty [xml|
+ <Bestaetigung
+ Zst="#{T.pack $ iso8601Show now}"
+ Ergebnis="ok"
+ Fehlernummer="0">
+ |]
+
+
+
+-- | just deny the request if this is Nothing, and print a debug trace instead
+unwrap :: forall a. (HasCallStack, Typeable a) => Maybe a -> Handler a
+unwrap (Just a) = pure a
+unwrap Nothing =
+ trace ("trace: failed to unwrap a Maybe "+|show (typeRep (Proxy @a))|+" ("+|srcLocModule|+", line "+|srcLocStartLine|+")")
+ throwError err400
+ where (_, SrcLoc{..}) = head $ toList callStack
+
+runDumbClient :: IO ()
+runDumbClient = do
+ loggerMiddleware <- mkRequestLogger def { outputFormat = Detailed True }
+ abos <- atomically $ newTVar (mempty :: [Void])
+ startupTime <- getCurrentTime
+ putStrLn ("startup of dumb client at "+|iso8601Show startupTime|+" ...")
+ run 8080 $ loggerMiddleware $ serve (Proxy @ClientAPI) (clientServer (DumbClient abos) startupTime)