1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
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
|
