diff options
| -rw-r--r-- | .gitignore | 1 | ||||
| -rw-r--r-- | CHANGELOG.md | 5 | ||||
| -rw-r--r-- | shell.nix | 9 | ||||
| -rw-r--r-- | vdv-protocol.cabal | 55 | ||||
| -rw-r--r-- | vdv-server/VDV453/Kommunikationsschicht.hs | 209 | ||||
| -rw-r--r-- | vdv-test/Main.hs | 7 |
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 |