simple hacky thing that doesn't do validation

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)