1 files changed, 147 insertions, 0 deletions
diff --git a/vdv-server/VDV451.hs b/vdv-server/VDV451.hs
new file mode 100644
index 0000000..1d56e1c
--- /dev/null
+++ b/vdv-server/VDV451.hs
@@ -0,0 +1,147 @@
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE DefaultSignatures #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE ExistentialQuantification #-}
+{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE FlexibleInstances #-}
+
+
+module VDV451 where
+
+import qualified Data.ByteString.Lazy as LB
+import qualified Data.ByteString as SB
+import Data.ByteString (ByteString)
+import Data.Text (Text)
+import qualified Data.Text as T
+import Data.Vector (Vector)
+import qualified Data.Vector as V
+import qualified Data.ByteString.Char8 as C8
+import GHC.Base (ord)
+import Fmt ((+|),(|+))
+import Data.Time (Day, toGregorian, UTCTime (..), DiffTime, formatTime, defaultTimeLocale)
+import Data.String (IsString)
+import GHC.Exts (IsString(..))
+import Data.Time.Format.ISO8601 (formatShow)
+import Data.Data (Proxy (..))
+
+class ÖPNVEncode a where
+  encode :: a -> ByteString
+  default encode :: Show a => a -> ByteString
+  encode = C8.pack . show
+
+
+instance ÖPNVEncode Text where
+  -- hopefully not too naive iso8859-1 encoding
+  encode text = if T.null unsafe
+    then C8.pack bytes
+    else error ("invalid unicode in iso8859-1 string: "+|unsafe|+".")
+    where (safe, unsafe) = T.span (\c -> ord c <= 0xFF) text
+          bytes = "\"" <> (concatMap escape (T.unpack safe)) <> "\""
+          escape c = case c of
+            '"' -> "\"\""
+            a -> [a]
+
+instance ÖPNVEncode Day where
+  encode day = "\""+|crop 2 d|+"."+|crop 2 m|+"."+|crop 4 y|+"\""
+    where (y,m,d) = toGregorian day
+          crop n thing = if T.length shown < n
+            then T.replicate (n - T.length shown) "0" <> shown
+            else T.takeEnd n shown
+            where shown = T.pack $ show thing
+
+-- | for things which can be encoded as either string or number,
+-- this module defaults to strings. Add this newtype to the schema
+-- to make things encode as numbers instead.
+newtype AsNumber a = AsNumber a
+
+instance ÖPNVEncode (AsNumber Day) where
+  encode (AsNumber day) =
+    encode (d*1000000 + m*10000 + (fromInteger y `mod` 10000))
+    where (y,m,d) = toGregorian day
+
+instance ÖPNVEncode DiffTime where
+  encode = C8.pack . formatTime defaultTimeLocale "\"%2H:%2M:%2S\""
+
+instance ÖPNVEncode Int
+instance ÖPNVEncode Integer
+
+
+
+data ÖPNVBefehl =
+  MOD | SRC | CHS | VER | IFV
+  | DVE | FFT | TBL | ATR | FRM
+  | REC | END | EOF | COM
+  deriving Show
+
+instance ÖPNVEncode ÖPNVBefehl where
+  encode MOD = "mod"
+  encode SRC = "src"
+  encode CHS = "chs"
+  encode VER = "ver"
+  encode IFV = "ifv"
+  encode DVE = "dve"
+  encode FFT = "fft"
+  encode TBL = "tbl"
+  encode ATR = "atr"
+  encode FRM = "frm"
+  encode REC = "rec"
+  encode END = "end"
+  encode EOF = "eof"
+  encode COM = "com"
+
+data ÖPNVType =
+  ÖChar Int | ÖNum Int
+  deriving Show
+
+instance ÖPNVEncode ÖPNVType where
+  encode (ÖChar n) = "char["+|n|+"]"
+  encode (ÖNum n) = "num["+|n|+".0]"
+
+class ÖPNVDatum a where
+  tableName :: Proxy a -> ByteString
+  tableSchema :: Proxy a -> [(ByteString, ÖPNVType, a -> Feld)]
+
+encodeRow :: forall a. ÖPNVDatum a => a -> [Feld]
+encodeRow a = fmap (\f -> f a) accessors
+  where accessors = fmap (\(_,_,a) -> a) (tableSchema (Proxy @a))
+
+tableInfo :: ÖPNVDatum a => Proxy a -> [(ByteString, ÖPNVType)]
+tableInfo proxy = fmap (\(n, ty, _) -> (n, ty)) (tableSchema proxy)
+
+data Feld = forall a. ÖPNVEncode a => F a | Raw ByteString
+
+instance IsString Feld where
+  fromString = Raw . C8.pack
+
+data ÖPNVOptions = ÖPNVOptions
+  { öpnvSource :: Text
+  , öpnvProgramVersion :: Text
+  , öpnvDataVersion :: Text
+  } deriving Show
+
+
+öpnvSchnittstellenDaten :: forall a. ÖPNVDatum a => ÖPNVOptions -> UTCTime -> Vector a -> LB.ByteString
+öpnvSchnittstellenDaten ÖPNVOptions{..} time rows = LB.intercalate "\n" $ fmap mkRow
+  [ [F MOD, "DD.MM.YYYY", "HH:MM:SS", "free"]
+  , [F SRC, F öpnvSource, F (utctDay time), F (utctDayTime time) ]
+  , [F CHS, F ("ISO8859-1" :: Text)]
+  , [F VER, F öpnvProgramVersion]
+  , [F IFV, F ("1.0" :: Text)]
+  , [F DVE, F öpnvDataVersion]
+  , [F FFT, ""] -- this one is probably not needed?
+  , [F TBL, Raw (tableName (Proxy @a))]
+  , F ATR : fmap Raw colNames
+  , F FRM : fmap F colTypes]
+  <> (fmap (mkRow . ((:) (F REC)) . encodeRow) (V.toList rows))
+  <> fmap mkRow
+  [ [F END, F (length rows)]
+  , [F EOF, "1"]]
+  where
+    mkRow :: [Feld] -> LB.ByteString
+    mkRow = LB.fromStrict
+      . C8.intercalate "; "
+      . fmap (\case { (F a) -> encode a; Raw a -> a })
+    (colNames, colTypes) = unzip (tableInfo (Proxy @a))