summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--.gitignore1
-rw-r--r--CHANGELOG.md5
-rw-r--r--shell.nix9
-rw-r--r--vdv-protocol.cabal55
-rw-r--r--vdv-server/VDV453/Kommunikationsschicht.hs209
-rw-r--r--vdv-test/Main.hs7
6 files changed, 286 insertions, 0 deletions
diff --git a/.gitignore b/.gitignore
new file mode 100644
index 0000000..b5e3679
--- /dev/null
+++ b/.gitignore
@@ -0,0 +1 @@
+dist-newstyle/*
diff --git a/CHANGELOG.md b/CHANGELOG.md
new file mode 100644
index 0000000..b460f5e
--- /dev/null
+++ b/CHANGELOG.md
@@ -0,0 +1,5 @@
+# Revision history for vdv-protocol
+
+## 0.1.0.0 -- YYYY-mm-dd
+
+* First version. Released on an unsuspecting world.
diff --git a/shell.nix b/shell.nix
new file mode 100644
index 0000000..3c0bdb2
--- /dev/null
+++ b/shell.nix
@@ -0,0 +1,9 @@
+{ pkgs ? import <nixpkgs> {} }:
+
+with pkgs;
+
+mkShell {
+ buildInputs = [
+ zlib
+ ];
+}
diff --git a/vdv-protocol.cabal b/vdv-protocol.cabal
new file mode 100644
index 0000000..869745d
--- /dev/null
+++ b/vdv-protocol.cabal
@@ -0,0 +1,55 @@
+cabal-version: 2.4
+name: vdv-protocol
+version: 0.1.0.0
+
+-- A short (one-line) description of the package.
+-- synopsis:
+
+-- A longer description of the package.
+-- description:
+
+-- A URL where users can report bugs.
+-- bug-reports:
+
+-- The license under which the package is released.
+-- license:
+author: stuebinm
+maintainer: stuebinm@disroot.org
+
+-- A copyright notice.
+-- copyright:
+-- category:
+extra-source-files: CHANGELOG.md
+
+library
+ build-depends: base ^>=4.14.3.0
+ , servant
+ , servant-server
+ , servant-client
+ , xml-conduit
+ , xml-hamlet
+ , warp
+ , wai-extra
+ , http-media
+ , http-client
+ , fmt
+ , time
+ , text
+ , containers
+ hs-source-dirs: vdv-server
+ default-language: Haskell2010
+ exposed-modules: VDV453.Kommunikationsschicht
+
+
+executable vdv-protocol
+ 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-test
+ default-language: Haskell2010
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)
diff --git a/vdv-test/Main.hs b/vdv-test/Main.hs
new file mode 100644
index 0000000..6092ddb
--- /dev/null
+++ b/vdv-test/Main.hs
@@ -0,0 +1,7 @@
+module Main where
+
+import VDV453.Kommunikationsschicht
+
+main :: IO ()
+main = do
+ runDumbClient