From f51618000e1d96543e5e0ad72219855e9dea42d8 Mon Sep 17 00:00:00 2001
From: tv <tv@krebsco.de>
Date: Fri, 4 Jun 2021 00:37:48 +0200
Subject: wip

---
 read-jsons.hs | 140 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
 1 file changed, 140 insertions(+)
 create mode 100644 read-jsons.hs

(limited to 'read-jsons.hs')

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
-- 
cgit v1.2.3