summaryrefslogtreecommitdiff
path: root/vdv-server
diff options
context:
space:
mode:
Diffstat (limited to 'vdv-server')
-rw-r--r--vdv-server/VDV451.hs147
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))