summaryrefslogtreecommitdiffstats
path: root/read-jsons.hs
diff options
context:
space:
mode:
authortv <tv@krebsco.de>2021-06-04 00:37:48 +0200
committertv <tv@krebsco.de>2021-06-04 00:37:48 +0200
commitf51618000e1d96543e5e0ad72219855e9dea42d8 (patch)
treedc63bb05e748c008f2d816f4079e659dffe0cafb /read-jsons.hs
parent032cb86ff8108eb4915a692015da344a41f78506 (diff)
wipwip2
Diffstat (limited to 'read-jsons.hs')
-rw-r--r--read-jsons.hs140
1 files changed, 140 insertions, 0 deletions
diff --git a/read-jsons.hs b/read-jsons.hs
new file mode 100644
index 0000000..0f9e973
--- /dev/null
+++ b/read-jsons.hs
@@ -0,0 +1,140 @@
+{-# LANGUAGE OverloadedStrings, DeriveGeneric, NoMonomorphismRestriction, RankNTypes, BangPatterns #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE ViewPatterns #-}
+{-# LANGUAGE LambdaCase #-}
+module Main where
+
+import Control.Exception (catch)
+import Control.Monad (forever)
+import Data.Bool (bool)
+import qualified Data.Text as Text
+import qualified Data.Text.Read as Text
+import qualified Data.Text.IO as Text
+import qualified Data.Char as Char
+import qualified Data.Aeson as Aeson
+import qualified Data.Aeson.Types as Aeson (Parser)
+--import qualified Data.ByteString.Streaming.Aeson as Aeson (streamParse)
+import qualified Data.ByteString as ByteString
+import qualified Data.ByteString.Lazy as ByteString.Lazy
+--import Data.JsonStream.Parser (value, arrayOf, (.:), Parser)
+--import Data.Aeson (FromJSON, parseJSON, withObject)
+import qualified Data.Aeson.TH as TH (deriveJSON, defaultOptions, defaultTaggedObject, Options(fieldLabelModifier,constructorTagModifier,sumEncoding),tagFieldName)
+import Data.Text (Text)
+import Data.Function ((&))
+--import Streaming
+--import qualified Streaming.Prelude as S
+import System.IO.Streams (Generator, InputStream, OutputStream)
+import qualified System.IO.Streams as Streams
+import Control.Applicative
+import qualified Data.Aeson as Aeson
+import Data.ByteString
+import Data.HashMap.Strict (HashMap)
+import qualified Data.HashMap.Strict as HashMap
+import System.IO (stdin, stderr)
+import qualified System.IO as String (hPutStrLn)
+import System.IO (hFlush)
+import GHC.IO.Handle.FD (fdToHandle)
+import System.IO.Streams hiding (stdin, stderr)
+import System.IO.Streams.Attoparsec (parseFromStream)
+import System.IO.Streams.Attoparsec (ParseException)
+import Options.Applicative
+
+data Options = Options
+ { optionsSignalInputURI :: Maybe Text
+ , optionsControlOutputURI :: Maybe Text
+ , optionsDebugOutputURI :: Maybe Text
+ }
+ deriving (Show)
+
+--main :: IO ()
+--main = do
+-- options <- execParser optionsParser
+-- putStrLn
+-- (concat ["Hello, ", optVal options, ", the flag is ", show (optFlag options)])
+-- where
+optionsParser :: ParserInfo Options
+optionsParser =
+ info
+ (helper <*> versionOption <*> programOptions)
+ (fullDesc <> progDesc "optparse example" <>
+ header
+ "optparse-example - a small example program for optparse-applicative")
+ where
+ versionOption :: Parser (a -> a)
+ versionOption = infoOption "0.0" (long "version" <> help "Show version")
+ programOptions :: Parser Options
+ programOptions =
+ Options
+ <$> optional (strOption $ long "signal" <> metavar "URI") -- value "default <> help ".."
+ <*> optional (strOption $ long "control" <> metavar "URI")
+ <*> optional (strOption $ long "debug" <> metavar "URI")
+
+
+
+data Msg = Msg
+ { msg_text :: Maybe Text
+ } | Time { time_value :: Double }
+ deriving (Show)
+
+$(TH.deriveJSON TH.defaultOptions
+ { TH.constructorTagModifier = Prelude.map Char.toLower
+ , TH.fieldLabelModifier = Prelude.tail . Prelude.dropWhile (/='_')
+ , TH.sumEncoding = TH.defaultTaggedObject { TH.tagFieldName = "type" }
+ } ''Msg)
+
+
+--parseJSONFromStream :: FromJSON a => InputStream ByteString -> IO a
+--parseJSONFromStream = parseJSON <$> parseFromStream json'
+
+
+handleFromURI = \case
+ Just s | ["fd", Text.decimal -> Right (h, "")] <- Text.split (==':') s -> do
+ -- TODO exceptions?
+ Right . Just <$> fdToHandle h
+
+ Just s ->
+ return $ Left $ "unsupported URI: " <> s
+
+ Nothing ->
+ return $ Right Nothing
+
+
+-- while jq -cn '[{type:"msg",value:"\(now)"},{"type":"time","value":now}][]'; do sleep 1; echo 121231.2; done | (exec 3<&0 4>&1 5>&2; exec xterm -e ./read-jsons --signal=fd:3 --control=fd:4 --debug=fd:5)
+main :: IO ()
+main = do
+ options <- execParser optionsParser
+ print options
+
+ jsonOut <- fdToHandle 4
+ debugOutHandle <- fdToHandle 5
+
+ -- TODO specify protocol
+ -- TODO http+unix:/path/to/socket (TODO client vs server)
+ -- TODO fd:
+ maybeSignalInputHandle <- handleFromURI $ optionsSignalInputURI options
+
+ case maybeSignalInputHandle of
+ Right (Just signalInputHandle) -> do
+ String.hPutStrLn debugOutHandle $ "signal input handle: " <> show signalInputHandle
+
+ --let notEOF s = if ByteString.null s then Nothing else Just s
+ -- TODO Data.ByteString.Extra.hGetMaybe
+ let maybeSome = bool Nothing . Just <*> not . ByteString.null
+ let hGetMaybe h c = maybeSome <$> ByteString.hGet h c
+
+ let parse stream = Aeson.fromJSON <$> parseFromStream Aeson.json' stream :: IO (Aeson.Result Msg)
+
+
+ makeInputStream (hGetMaybe signalInputHandle 1) >>= forever . ((>>=String.hPutStrLn debugOutHandle . show) . parse)
+ -- TODO `catch` \e -> Prelude.putStrLn ("Caught " <> show (e :: ParseException))
+
+ Right Nothing ->
+ hPutStrLn debugOutHandle $ "signal input disabled"
+
+ Left error -> do
+ Text.hPutStrLn debugOutHandle $ "failed to open signal input: " <> error