quasar-web-client: Fix duplicate port in URI

Co-authored-by: Jan Beinke <[email protected]>

examples/Midi.hs

@@ -0,0 +1,36 @@
+module Main (main) where
+
+import Quasar.Midi
+import Control.Concurrent (forkIO, threadDelay)
+import Data.String (fromString)
+import Data.Text (Text)
+import Data.Text qualified as T
+import Data.Text.Lazy qualified as TL
+import Network.Wai.Handler.Warp
+import Quasar
+import Quasar.Observable.Core
+import Quasar.Observable.Lift
+import Quasar.Observable.List as ObservableList
+import Quasar.Observable.Map as ObservableMap
+import Quasar.Observable.ObservableVar
+import Quasar.Prelude
+import Quasar.Web
+import Quasar.Web.Server (toWaiApplication)
+import System.IO (hPutStrLn, stderr)
+
+main :: IO ()
+main = runQuasarAndExit do
+  --midi <- startMidi
+
+  let rootDiv = domElement "div" mempty (ObservableList.fromList [
+          "hello world!"
+        ])
+
+  liftIO $ runSettings settings $ toWaiApplication rootDiv
+  where
+    port :: Port
+    port = 9013
+    settings =
+      setBeforeMainLoop (hPutStrLn stderr ("Listening on port " <> show port)) $
+      setPort port
+      defaultSettings

quasar-midi/README.md

@@ -0,0 +1 @@
+# quasar-midi

quasar-midi/quasar-midi.cabal

@@ -0,0 +1,67 @@
+cabal-version: 3.0
+
+name:           quasar-midi
+version:        0.1.0.0
+license:        BSD-2-Clause
+build-type:     Simple
+extra-source-files:
+    README.md
+
+source-repository head
+  type: git
+  location: https://github.com/queezle42/quasar
+
+common shared-properties
+  default-extensions:
+    AllowAmbiguousTypes
+    ApplicativeDo
+    BangPatterns
+    BlockArguments
+    DataKinds
+    DefaultSignatures
+    DerivingStrategies
+    DuplicateRecordFields
+    FunctionalDependencies
+    GADTs
+    LambdaCase
+    MagicHash
+    NoImplicitPrelude
+    NoStarIsType
+    OverloadedRecordDot
+    OverloadedStrings
+    QuasiQuotes
+    TemplateHaskellQuotes
+    TypeFamilies
+    ViewPatterns
+  default-language: GHC2021
+  ghc-options:
+    -Weverything
+    -Wno-all-missed-specialisations
+    -Wno-missing-deriving-strategies
+    -Wno-missing-import-lists
+    -Wno-missing-kind-signatures
+    -Wno-missing-safe-haskell-mode
+    -Wno-unsafe
+    -Werror=incomplete-patterns
+    -Werror=missing-fields
+    -Werror=missing-home-modules
+    -Werror=missing-methods
+
+library
+  import: shared-properties
+  build-depends:
+    aeson,
+    base <5,
+    bytestring,
+    containers,
+    nyan-interpolation,
+    process,
+    quasar,
+    text,
+    utf8-string,
+  exposed-modules:
+    Quasar.Midi
+  other-modules:
+    Quasar.Midi.Aseq2jsonPath
+  hs-source-dirs:
+    src

quasar-midi/src/Quasar/Midi.hs

@@ -0,0 +1,162 @@
+module Quasar.Midi (
+  startMidi,
+) where
+
+import Data.Aeson
+import Data.ByteString qualified as BS
+import Data.ByteString.Lazy qualified as BSL
+import Data.ByteString.UTF8 qualified as Utf8
+import Data.Map.Strict qualified as Map
+import Data.Text
+import Quasar.Midi.Aseq2jsonPath (aseq2jsonPath)
+import Quasar.Observable.Core
+import Quasar.Observable.Lift (liftObservable)
+import Quasar.Observable.Map (ObservableMap, ObservableMapVar)
+import Quasar.Observable.Map qualified as ObservableMap
+import Quasar.Observable.ObservableVar
+import Quasar.Observable.Subject (readSubjectIO)
+import Quasar.Prelude
+import System.IO
+import System.Process
+import Quasar.MonadQuasar
+import Quasar.MonadQuasar.Misc (runQuasarAndExit)
+import Quasar.Async (async_)
+
+data MidiSource = MidiSource {
+  clientName :: Text,
+  name :: Text,
+  channels :: ObservableMap Load '[SomeException] Word8 MidiChannel
+}
+
+data MidiSourceVar = MidiSourceVar {
+  clientName :: Text,
+  name :: Text,
+  channels :: ObservableMapVar Word8 MidiChannelVar
+}
+
+readonlyMidiSource :: MidiSourceVar -> MidiSource
+readonlyMidiSource var = MidiSource {
+  clientName = var.clientName,
+  name = var.name,
+  channels = readonlyMidiChannel <$> ObservableMap.liftObservableMap (ObservableMap.toObservableMap var.channels)
+}
+
+data MidiChannel = MidiChannel {
+  params :: ObservableMap Load '[SomeException] Word8 Word8,
+  notes :: ObservableMap Load '[SomeException] Word8 MidiNote
+}
+
+data MidiChannelVar = MidiChannelVar {
+  params :: ObservableMapVar Word8 Word8,
+  notes :: ObservableMapVar Word8 MidiNoteVar
+}
+
+readonlyMidiChannel :: MidiChannelVar -> MidiChannel
+readonlyMidiChannel var = MidiChannel {
+  params = ObservableMap.liftObservableMap (ObservableMap.toObservableMap var.params),
+  notes = readonlyMidiNote <$> ObservableMap.liftObservableMap (ObservableMap.toObservableMap var.notes)
+}
+
+data MidiNote = MidiNote {
+  velocity :: Word8,
+  aftertouch :: Observable Load '[SomeException] Word8
+}
+
+data MidiNoteVar = MidiNoteVar {
+  velocity :: Word8,
+  aftertouch :: ObservableVar NoLoad '[] Word8
+}
+
+readonlyMidiNote :: MidiNoteVar -> MidiNote
+readonlyMidiNote var = MidiNote {
+  velocity = var.velocity,
+  aftertouch = liftObservable (toObservable var.aftertouch)
+}
+
+data MidiEvent
+  = MidiSourceStart Text Text Text -- source clientName name
+  | MidiSourceExit Text -- source
+  | MidiControlChange Text Word8 Word8 Word8 -- source channel param value
+  | MidiSystemExclusive Text [Word8] -- source raw
+  | MidiNoteOn Text Word8 Word8 Word8 -- source channel note velocity
+  | MidiNoteOff Text Word8 Word8 Word8 -- source channel note velocity
+  | MidiAftertouch Text Word8 Word8 Word8 -- source channel note velocity
+  | MidiStart Text -- source
+  | MidiContinue Text -- source
+  | MidiStop Text -- source
+  | MidiTimingClock Text -- source
+  deriving (Show, Eq)
+
+instance FromJSON MidiEvent where
+  parseJSON = withObject "MidiEvent" \x -> do
+    eventType :: Text <- x .: "eventType"
+    case eventType of
+      "source-start" -> MidiSourceStart <$> x .: "source" <*> x .: "clientName" <*> x .: "name"
+      "source-exit" -> MidiSourceExit <$> x .: "source"
+      "control-change" -> MidiControlChange <$> x .: "source" <*> x .: "channel" <*> x .: "param" <*> x .: "value"
+      "note-on" -> MidiNoteOn <$> x .: "source" <*> x .: "channel" <*> x .: "note" <*> x .: "velocity"
+      "note-off" -> MidiNoteOff <$> x .: "source" <*> x .: "channel" <*> x .: "note" <*> x .: "velocity"
+      "polyphonic-key-pressure" -> MidiAftertouch <$> x .: "source" <*> x .: "channel" <*> x .: "note" <*> x .: "velocity"
+      "system-exclusive" -> MidiSystemExclusive <$> x .: "source" <*> x .: "raw"
+      "start" -> MidiStart <$> x .: "source"
+      "continue" -> MidiContinue <$> x .: "source"
+      "stop" -> MidiStop <$> x .: "source"
+      "timing-clock" -> MidiTimingClock <$> x .: "source"
+      _ -> fail $ "unknown eventType: " <> show eventType
+
+startMidi :: QuasarIO (ObservableMap Load '[SomeException] Text MidiSource)
+startMidi = do
+  aseq2jsonRead <- liftIO do
+    (aseq2jsonRead, aseq2jsonWrite) <- createPipe
+    hSetBuffering aseq2jsonRead LineBuffering
+    let processConfig = (proc aseq2jsonPath []) {
+      close_fds = True,
+      std_in = NoStream,
+      std_out = UseHandle aseq2jsonWrite
+    }
+    (Nothing, Nothing, Nothing, process) <- createProcess processConfig
+    pure aseq2jsonRead
+  var <- ObservableMap.newVarIO mempty
+  async_ $ liftIO $ forever do
+    line <- BS.hGetLine aseq2jsonRead
+    case eitherDecode (BSL.fromStrict line) of
+      Right event -> handleMessage var event
+      Left msg -> hPutStrLn stderr $ "Failed to parse: " <> Utf8.toString line <> "\n" <> msg
+  pure (readonlyMidiSource <$> ObservableMap.liftObservableMap (ObservableMap.toObservableMap var))
+
+handleMessage :: ObservableMapVar Text MidiSourceVar -> MidiEvent -> IO ()
+handleMessage var (MidiSourceStart source clientName name) = atomicallyC do
+  channels <- ObservableMap.newVar mempty
+  ObservableMap.insertVar var source (MidiSourceVar clientName name channels)
+handleMessage var (MidiSourceExit source) = atomicallyC do
+  ObservableMap.deleteVar var source
+handleMessage var (MidiControlChange source channel param value) = atomicallyC do
+  getChannel var source channel >>= mapM_ \midiChannel -> do
+    ObservableMap.insertVar midiChannel.params param value
+handleMessage var (MidiTimingClock _source) = pure ()
+handleMessage var event = print event
+
+getChannel :: ObservableMapVar Text MidiSourceVar -> Text -> Word8 -> STMc NoRetry '[] (Maybe MidiChannelVar)
+getChannel var source channel = do
+  getSource var source >>= mapM \midiSource -> do
+    midiChannels <- ObservableMap.readVar midiSource.channels
+    case Map.lookup channel midiChannels of
+      Just midiChannel -> pure midiChannel
+      Nothing -> do
+        midiChannel <- newMidiChannel
+        ObservableMap.insertVar midiSource.channels channel midiChannel
+        pure midiChannel
+
+newMidiChannel :: STMc NoRetry '[] MidiChannelVar
+newMidiChannel = do
+  params <- ObservableMap.newVar mempty
+  notes <- ObservableMap.newVar mempty
+  pure MidiChannelVar {
+    params,
+    notes
+  }
+
+getSource :: ObservableMapVar Text MidiSourceVar -> Text -> STMc NoRetry '[] (Maybe MidiSourceVar)
+getSource var source = do
+  midiSources <- ObservableMap.readVar var
+  pure (Map.lookup source midiSources)

quasar-midi/src/Quasar/Midi/Aseq2jsonPath.hs

@@ -0,0 +1,19 @@
+{-# LANGUAGE CPP #-}
+
+module Quasar.Midi.Aseq2jsonPath (
+  aseq2jsonPath,
+) where
+
+import Data.String (String)
+
+#ifdef QUASAR_MIDI_ASEQ2JSON
+import Text.Interpolation.Nyan (int)
+#endif
+
+aseq2jsonPath :: String
+
+#ifdef QUASAR_MIDI_ASEQ2JSON
+aseq2jsonPath = [int||QUASAR_MIDI_ASEQ2JSON|];
+#else
+aseq2jsonPath = "aseq2json";
+#endif

quasar-prometheus/quasar-prometheus.cabal

@@ -0,0 +1,75 @@
+cabal-version: 3.0
+
+name:           quasar-prometheus
+version:        0.1.0.0
+license:        BSD-2-Clause
+build-type:     Simple
+
+source-repository head
+  type: git
+  location: https://github.com/queezle42/quasar
+
+common shared-properties
+  default-extensions:
+    AllowAmbiguousTypes
+    ApplicativeDo
+    BangPatterns
+    BlockArguments
+    DataKinds
+    DefaultSignatures
+    DerivingStrategies
+    DuplicateRecordFields
+    FunctionalDependencies
+    GADTs
+    LambdaCase
+    MagicHash
+    NoImplicitPrelude
+    NoStarIsType
+    OverloadedRecordDot
+    OverloadedStrings
+    QuasiQuotes
+    TemplateHaskellQuotes
+    TypeFamilies
+    ViewPatterns
+  default-language: GHC2021
+  ghc-options:
+    -Weverything
+    -Wno-all-missed-specialisations
+    -Wno-missing-deriving-strategies
+    -Wno-missing-import-lists
+    -Wno-missing-kind-signatures
+    -Wno-missing-safe-haskell-mode
+    -Wno-unsafe
+    -Werror=incomplete-patterns
+    -Werror=missing-fields
+    -Werror=missing-home-modules
+    -Werror=missing-methods
+
+library
+  import: shared-properties
+  build-depends:
+    base <5,
+    containers,
+    quasar,
+    text,
+  exposed-modules:
+    Quasar.Prometheus
+  other-modules:
+  hs-source-dirs:
+    src
+
+test-suite quasar-prometheus-test
+  import: shared-properties
+  type: exitcode-stdio-1.0
+  ghc-options:
+    -threaded
+    -rtsopts
+    "-with-rtsopts=-N"
+  build-depends:
+    base <5,
+    hspec,
+    quasar-prometheus,
+  main-is: Spec.hs
+  other-modules:
+  hs-source-dirs:
+    test