packages feed

monomer-flatpak-example 0.0.12.0 → 0.0.13.0

raw patch · 8 files changed

+484/−5 lines, 8 filesdep +asyncdep ~desktop-portal

Dependencies added: async

Dependency ranges changed: desktop-portal

Files

+ app/Bindings/PipeWire.chs view
@@ -0,0 +1,139 @@+{-# LANGUAGE ForeignFunctionInterface #-}+module Bindings.PipeWire where++#include <pipewire/pipewire.h>+#include <pipewire_hacks.h>++import Bindings.Util+import Data.Text (Text)+import Foreign (FunPtr, Ptr, Storable (..))+import Foreign.C (CInt, CString, CUInt)+import Foreign.Marshal.Utils (with)++data DictItem = DictItem {key :: CString, value :: CString}++{#pointer *spa_dict_item as DictItemPtr -> DictItem#}++instance Storable DictItem where+  sizeOf _ = {#sizeof spa_dict_item#}+  alignment _ = {#alignof spa_dict_item#}+  peek p = do+    DictItem <$> {#get spa_dict_item->key#} p+             <*> {#get spa_dict_item->value#} p+  poke p a = do+    {#set spa_dict_item->key#} p a.key+    {#set spa_dict_item->value#} p a.value++data Dict = Dict {flags :: CUInt, nItems :: CUInt, items :: Ptr DictItem}++{#pointer *spa_dict as DictPtr -> Dict#}++instance Storable Dict where+  sizeOf _ = {#sizeof spa_dict#}+  alignment _ = {#alignof spa_dict#}+  peek p = do+    Dict <$> {#get spa_dict->flags#} p+         <*> {#get spa_dict->n_items#} p+         <*> {#get spa_dict->items#} p+  poke p a = do+    {#set spa_dict->flags#} p a.flags+    {#set spa_dict->n_items#} p a.nItems+    {#set spa_dict->items#} p a.items++{#pointer *spa_hook as SpaHook#}++spaHookSize :: Int+spaHookSize = {#sizeof spa_hook#}++data RegistryEvents = RegistryEvents+  { version :: CUInt+  , globalCallback :: FunPtr (Ptr () -> CUInt -> CUInt -> CString -> CUInt -> DictPtr -> IO ())+  , globalRemoveCallback :: FunPtr (Ptr () -> CUInt -> IO ())+  }++instance Storable RegistryEvents where+  sizeOf _ = {#sizeof pw_registry_events#}+  alignment _ = {#alignof pw_registry_events#}+  peek p = do+    version <- {#get pw_registry_events->version#} p+    globalCallback <- {#get pw_registry_events->global#} p+    globalRemoveCallback <- {#get pw_registry_events->global_remove#} p+    pure RegistryEvents {version, globalCallback, globalRemoveCallback}+  poke p a = do+    {#set pw_registry_events->version#} p a.version+    {#set pw_registry_events->global#} p a.globalCallback+    {#set pw_registry_events->global_remove#} p a.globalRemoveCallback++{#pointer *pw_registry_events as RegistryEventsPtr -> RegistryEvents#}++versionRegistry :: CUInt+versionRegistry = {#const PW_VERSION_REGISTRY#}++versionRegistryEvents :: CUInt+versionRegistryEvents = {#const PW_VERSION_REGISTRY_EVENTS#}++foreign import ccall "wrapper"+  registryEventsGlobalCallback ::+    (Ptr () -> CUInt -> CUInt -> CString -> CUInt -> DictPtr -> IO ()) ->+    IO (FunPtr (Ptr () -> CUInt -> CUInt -> CString -> CUInt -> DictPtr -> IO ()))++foreign import ccall "wrapper"+  registryEventsGlobalRemoveCallback ::+    (Ptr () -> CUInt -> IO ()) ->+    IO (FunPtr (Ptr () -> CUInt -> IO ()))++{#pointer *pw_main_loop as MainLoop newtype#}++{#pointer *pw_loop as Loop newtype#}++{#pointer *pw_properties as Properties newtype#}++{#pointer *pw_proxy as Proxy newtype#}++{#pointer *pw_stream as Stream newtype#}++{#pointer *pw_core as Core newtype#}++{#pointer *pw_context as Context newtype#}++{#pointer *pw_registry as Registry newtype#}++{#fun unsafe pw_init as init {id `Ptr CInt', id `Ptr (Ptr CString)'} -> `()' #}++{#fun unsafe pw_deinit as deinit {} -> `()'#}++{#fun unsafe pw_main_loop_new as mainLoopNew {`DictPtr'} -> `MainLoop'#}++{#fun unsafe pw_main_loop_get_loop as mainLoopGetLoop {`MainLoop'} -> `Loop'#}++{#fun pw_main_loop_run as mainLoopRun {`MainLoop'} -> `CInt'#}++{#fun unsafe pw_main_loop_destroy as mainLoopDestroy {`MainLoop'} -> `()'#}++{#fun unsafe pw_main_loop_quit as mainLoopQuit {`MainLoop'} -> `CInt'#}++{#fun unsafe pw_stream_destroy as streamDestroy {`Stream'} -> `()'#}++{#fun unsafe pw_core_get_registry_ as coreGetRegistry {`Core', `CUInt', `CUInt'} -> `Registry'#}++{#fun unsafe pw_core_disconnect as coreDisconnect {`Core'} -> `CInt'#}++{#fun unsafe pw_registry_add_listener_ as registryAddListener {`Registry', `SpaHook', with* `RegistryEvents'} -> `()'#}++{#fun unsafe pw_context_new as contextNew {`Loop', `Properties', `CUInt'} -> `Context'#}++{#fun unsafe pw_context_connect_fd as contextConnectFd {`Context', `CInt', `Properties', `CInt'} -> `Core'#}++{#fun unsafe pw_context_destroy as contextDestroy {`Context'} -> `()'#}++{#fun unsafe variadic pw_properties_new[const char *, const char *] as propertiesNew1 {withText* `Text', withText* `Text', withNull- `CString'} -> `Properties'#}++{#fun unsafe variadic pw_properties_new[const char *, const char *, const char *, const char *] as propertiesNew2 {withText* `Text', withText* `Text', withText* `Text', withText* `Text', withNull- `CString'} -> `Properties'#}++{#fun unsafe variadic pw_properties_new[const char *, const char *, const char *, const char *, const char *, const char *] as propertiesNew3 {withText* `Text', withText* `Text', withText* `Text', withText* `Text', withText* `Text', withText* `Text', withNull- `CString'} -> `Properties'#}++{#fun unsafe variadic pw_properties_new[const char *, const char *, const char *, const char *, const char *, const char *, const char *, const char *] as propertiesNew4 {withText* `Text', withText* `Text', withText* `Text', withText* `Text', withText* `Text', withText* `Text', withText* `Text', withText* `Text', withNull- `CString'} -> `Properties'#}++{#fun unsafe pw_properties_set as propertiesSet {`Properties', withText* `Text', withText* `Text'} -> `CInt'#}++{#fun unsafe pw_proxy_destroy as proxyDestroy {`Proxy'} -> `()'#}
+ app/Bindings/Util.hs view
@@ -0,0 +1,22 @@+module Bindings.Util+  ( withText,+    withNull,+    cStringToText,+  )+where++import Data.ByteString (packCString, useAsCString)+import Data.Text (Text)+import Data.Text.Encoding qualified as T+import Foreign (Ptr, nullPtr)+import Foreign.C (CString)++withText :: Text -> (CString -> IO b) -> IO b+withText t = useAsCString (T.encodeUtf8 t)++withNull :: (Ptr a -> b) -> b+withNull f = f nullPtr++cStringToText :: CString -> IO Text+cStringToText cstr =+  T.decodeUtf8 <$> packCString cstr
+ app/Camera.hs view
@@ -0,0 +1,122 @@+module Camera (camera) where++import Control.Exception (SomeException, catch)+import Data.Function ((&))+import Data.Map.Strict (Map)+import Data.Map.Strict qualified as Map+import Data.Text (Text, intercalate, pack)+import Desktop.Portal (Client)+import Desktop.Portal qualified as Portal+import Monomer+import PipeWire (PipeWireCallbacks (..), PipeWireClient, RegistryObject (..))+import PipeWire qualified+import System.Posix.Types (Fd)++data CameraModel = CameraModel+  { portalClient :: Client,+    state :: CameraState+  }+  deriving (Eq, Show)++data CameraState+  = StateCheckingPresent+  | StateNotFound+  | StateAccessing+  | StateAccessDenied+  | StateOpeningPipeWire+  | StateOpenedPipeWire Fd+  | StateConnectedToPipewire PipeWireClient (Map Word RegistryObject)+  deriving (Eq, Show)++data CameraEvent+  = Init+  | Dispose+  | SetState CameraState+  | ShowAlert {title :: Text, body :: Text}+  | CamerasChanged (Map Word RegistryObject)++camera :: (CompParentModel s, CompositeEvent e) => Client -> (Text -> Text -> e) -> WidgetNode s e+camera portalClient parentAlert =+  compositeD_ "MonomerFlatpakExample.Camera" (WidgetValue initialModel) buildUI (handleEvent parentAlert) cfg+  where+    cfg = [onInit Init, onDispose Dispose]+    initialModel = CameraModel {portalClient, state = StateCheckingPresent}++buildUI :: UIBuilder CameraModel CameraEvent+buildUI _wenv model =+  label_ (lbl model.state) [multiline] `styleBasic` [padding 40]+  where+    lbl = \case+      StateCheckingPresent ->+        "Checking for camera..."+      StateAccessing ->+        "Requesting access to camera..."+      StateNotFound ->+        "Camera not found."+      StateAccessDenied ->+        "Camera access denied."+      StateOpeningPipeWire ->+        "Opening pipewire..."+      StateOpenedPipeWire fd ->+        "Opened pipewire: " <> pack (show fd)+      StateConnectedToPipewire _client cameras ->+        "Found cameras:\n\n" <> formatCameras cameras++formatCameras :: Map Word RegistryObject -> Text+formatCameras cameras =+  (formatCamera <$> Map.elems cameras)+    & intercalate "\n\n"+  where+    formatCamera c =+      Map.assocs c.props.items+        & fmap (\(key, value) -> key <> ": " <> value)+        & intercalate "\n"++handleEvent :: (Text -> Text -> ep) -> EventHandler CameraModel CameraEvent sp ep+handleEvent parentAlert _env _node model = \case+  Init ->+    [ Producer $ \emit -> do+        catchErrors "Checking for camera failed" emit $ do+          Portal.isCameraPresent model.portalClient >>= \case+            False -> emit (SetState StateNotFound)+            True -> do+              emit (SetState StateAccessing)+              Portal.accessCamera model.portalClient >>= Portal.await >>= \case+                Nothing -> emit (SetState StateAccessDenied)+                Just () -> do+                  emit (SetState StateOpeningPipeWire)+                  fd <- Portal.openPipeWireRemote model.portalClient+                  emit (SetState (StateOpenedPipeWire fd))+                  let cbs =+                        PipeWireCallbacks+                          { cameraAdded = \cameras _ -> emit (CamerasChanged cameras),+                            cameraRemoved = \cameras _ -> emit (CamerasChanged cameras)+                          }+                  pwClient <- PipeWire.run fd cbs+                  emit (SetState (StateConnectedToPipewire pwClient mempty))+                  -- need to keep thread alive so monomer keeps accepting our events!+                  PipeWire.waitForQuit pwClient+    ]+  Dispose ->+    [ Producer $ \_emit -> do+        case model.state of+          StateConnectedToPipewire pwClient _ ->+            PipeWire.quit pwClient+          _ ->+            pure ()+    ]+  SetState state ->+    [Model model {state}]+  ShowAlert {title, body} ->+    [Report (parentAlert title body)]+  CamerasChanged cameras ->+    case model.state of+      StateConnectedToPipewire client _cameras ->+        [Model model {state = StateConnectedToPipewire client cameras}]+      _ -> []++catchErrors :: Text -> (CameraEvent -> IO ()) -> IO () -> IO ()+catchErrors title emit cmd = catch cmd handler+  where+    handler (e :: SomeException) =+      emit (ShowAlert title (pack (show e)))
app/Main.hs view
@@ -1,5 +1,6 @@ module Main (main) where +import Camera (camera) import Control.Exception (SomeException, catch) import Control.Monad (void) import DBus (Variant, toVariant)@@ -30,6 +31,7 @@     environmentVariables :: Seq EnvironmentInfo,     showOpenURI :: Bool,     showDocuments :: Bool,+    showCamera :: Bool,     alertContents :: AlertContents   }   deriving (Eq, Show)@@ -61,6 +63,7 @@   | RetrieveSecret   | SetShowOpenURI Bool   | SetShowDocuments Bool+  | SetShowCamera Bool   | RequestFailed Text   | CancelRequest   | CloseAlert@@ -81,6 +84,7 @@           environmentVariables = mempty,           showOpenURI = False,           showDocuments = False,+          showCamera = False,           alertContents = AlertNotShown         }     config regularFontPath boldFontPath iconPath =@@ -113,7 +117,8 @@                   button "Add Notification" AddNotification,                   button "Read Settings" ReadSettings,                   button "Open URI" (SetShowOpenURI True),-                  button "Retrieve Secret" RetrieveSecret+                  button "Retrieve Secret" RetrieveSecret,+                  button "Camera" (SetShowCamera True)                 ]                 `styleBasic` [padding 5],               hagrid@@ -129,6 +134,7 @@             ],           maybeOpenURI,           maybeDocuments,+          maybeCamera,           -- nodeKey to workaround https://github.com/fjvallarino/monomer/issues/265           maybeAlert `nodeKey` pack (show model.alertContents)         ]@@ -149,6 +155,14 @@             (documents model.portalClient ShowAlertMessage `styleBasic` [padding 20])       | otherwise = spacer `nodeVisible` False +    maybeCamera+      | model.showCamera =+          alert_+            (SetShowCamera False)+            [titleCaption "Camera Portal"]+            (camera model.portalClient ShowAlertMessage `styleBasic` [padding 20])+      | otherwise = spacer `nodeVisible` False+     maybeAlert = case model.alertContents of       AlertNotShown ->         spacer `nodeVisible` False@@ -242,6 +256,8 @@     [Model model {showOpenURI}]   SetShowDocuments showDocuments ->     [Model model {showDocuments}]+  SetShowCamera showCamera ->+    [Model model {showCamera}]   AddNotification ->     [ Producer $ \emit -> do         catchRequestErrors emit $@@ -266,8 +282,9 @@     [Model model {alertContents = AlertSettings results}]   RetrieveSecret ->     [ Producer $ \emit -> do-        secret <- Portal.retrieveSecret model.portalClient-        emit (ShowAlertMessage "Retrieved Secret Successfully" (hex secret))+        catchRequestErrors emit $ do+          secret <- Portal.retrieveSecret model.portalClient+          emit (ShowAlertMessage "Retrieved Secret Successfully" (hex secret))     ]   ShowAlertMessage {title, body} ->     [Model model {alertContents = AlertMessage {title, body}}]
+ app/PipeWire.hs view
@@ -0,0 +1,148 @@+-- | A high-level (no raw pointer types) interface to PipeWire.+module PipeWire+  ( SpaDictMap (..),+    RegistryObject (..),+    PipeWireCallbacks (..),+    PipeWireClient,+    run,+    quit,+    waitForQuit,+  )+where++import Bindings.PipeWire (DictPtr, MainLoop, Properties (..), RegistryEvents (..))+import Bindings.PipeWire qualified as B+import Bindings.Util qualified as B+import Control.Concurrent (MVar, modifyMVar_, newEmptyMVar, newMVar, putMVar, readMVar, tryTakeMVar)+import Control.Concurrent.Async (Async, asyncBound, asyncThreadId, wait)+import Control.Exception (bracket)+import Control.Monad (forM, void, when)+import Data.Map.Strict (Map)+import Data.Map.Strict qualified as Map+import Data.Text (Text)+import Foreign (allocaBytes, freeHaskellFunPtr, nullPtr, peek, peekArray)+import System.Posix.Types (Fd (..))+import Unsafe.Coerce (unsafeCoerce)++data SpaDictMap = SpaDictMap+  { flags :: Word,+    items :: Map Text Text+  }+  deriving (Eq, Show)++data RegistryObject = RegistryObject+  { id :: Word,+    permissions :: Word,+    typ :: Text,+    version :: Word,+    props :: SpaDictMap+  }+  deriving (Eq, Show)++data PipeWireCallbacks = PipeWireCallbacks+  { cameraAdded :: Map Word RegistryObject -> RegistryObject -> IO (),+    cameraRemoved :: Map Word RegistryObject -> Word -> IO ()+  }++data PipeWireClient = PipeWireClient+  { async :: Async (),+    mainLoop :: MVar MainLoop+  }++instance Eq PipeWireClient where+  p1 == p2 = p1.async == p2.async++instance Show PipeWireClient where+  show p = "PipeWireClient<" <> show (asyncThreadId p.async) <> ">"++run :: Fd -> PipeWireCallbacks -> IO PipeWireClient+run (Fd fd) cbs = do+  loopVar <- newEmptyMVar+  camerasVar <- newMVar Map.empty++  async <- asyncBound $ do+    bracket (B.registryEventsGlobalCallback (addCb camerasVar)) freeHaskellFunPtr $ \globalCallback -> do+      bracket (B.registryEventsGlobalRemoveCallback (removeCb camerasVar)) freeHaskellFunPtr $ \globalRemoveCallback -> do+        let events =+              RegistryEvents+                { version = B.versionRegistryEvents,+                  globalCallback,+                  globalRemoveCallback+                }++        B.init nullPtr nullPtr+        mainLoop <- B.mainLoopNew nullPtr+        putMVar loopVar mainLoop+        loop <- B.mainLoopGetLoop mainLoop+        context <- B.contextNew loop (Properties nullPtr) 0+        core <- B.contextConnectFd context fd (Properties nullPtr) 0++        allocaBytes B.spaHookSize $ \listenerHandle -> do+          registry <- B.coreGetRegistry core B.versionRegistry 0+          B.registryAddListener registry listenerHandle events+          void (B.mainLoopRun mainLoop)+          B.proxyDestroy (unsafeCoerce registry)++        void (B.coreDisconnect core)+        B.contextDestroy context+        B.mainLoopDestroy mainLoop+        B.deinit+  void (readMVar loopVar) -- don't return until we can call quit safely...+  pure PipeWireClient {mainLoop = loopVar, async}+  where+    addCb camerasVar _data camId permissions typPtr version propsPtr = do+      typ <- B.cStringToText typPtr+      props <- decodeDict propsPtr+      let registryObj =+            RegistryObject+              { id = fromIntegral camId,+                permissions = fromIntegral permissions,+                typ,+                version = fromIntegral version,+                props+              }+      when (isCamera registryObj) $ do+        modifyMVar_ camerasVar $ \cameras -> do+          let newCameras = Map.insert registryObj.id registryObj cameras+          cbs.cameraAdded newCameras registryObj+          pure newCameras++    removeCb camerasVar _data camId = do+      let wordId = fromIntegral camId+      modifyMVar_ camerasVar $ \cameras -> do+        case Map.lookup wordId cameras of+          Just registryObj | isCamera registryObj -> do+            let newCameras = Map.delete wordId cameras+            cbs.cameraRemoved newCameras wordId+            pure newCameras+          _ -> do+            pure cameras++quit :: PipeWireClient -> IO ()+quit client = do+  tryTakeMVar client.mainLoop >>= \case+    Nothing -> pure () -- we already quit+    Just ml -> void (B.mainLoopQuit ml)++waitForQuit :: PipeWireClient -> IO ()+waitForQuit client = do+  wait client.async++isCamera :: RegistryObject -> Bool+isCamera obj =+  Map.lookup "media.class" obj.props.items == Just "Video/Source"+    && Map.lookup "media.role" obj.props.items == Just "Camera"++decodeDict :: DictPtr -> IO SpaDictMap+decodeDict dictPtr = do+  dict <- peek dictPtr+  items <- peekArray (fromIntegral dict.nItems) dict.items+  itemPairs <- forM items $ \item -> do+    (,)+      <$> B.cStringToText item.key+      <*> B.cStringToText item.value+  pure+    SpaDictMap+      { flags = fromIntegral dict.flags,+        items = Map.fromList itemPairs+      }
assets/io.github.Dretch.MonomerFlatpakExample.metainfo.xml view
@@ -23,6 +23,11 @@   </screenshots>    <releases>+    <release version="0.0.13.0" date="2023-10-07">+      <description>+      Add a basic demo of the Camera API. Update to v23.08 of the Flatpak platform.+      </description>+    </release>     <release version="0.0.12.0" date="2023-09-10">       <description>       Add a demo of the Secret API.
+ cbits/pipewire_hacks.c view
@@ -0,0 +1,17 @@+#include <pipewire_hacks.h>++struct pw_registry* pw_core_get_registry_(+    struct pw_core* core,+    uint32_t version,+    size_t user_data_size) {++  return pw_core_get_registry(core, version, user_data_size);+}++void pw_registry_add_listener_(+  struct pw_registry* registry,+  struct spa_hook* listener,+  struct pw_registry_events* events) {+  +  pw_registry_add_listener(registry, listener, events, NULL);+}
monomer-flatpak-example.cabal view
@@ -1,6 +1,6 @@ cabal-version: 1.12 name:          monomer-flatpak-example-version:       0.0.12.0+version:       0.0.13.0 license:       MIT license-file:  LICENSE maintainer:    garethdanielsmith@gmail.com@@ -26,10 +26,17 @@  executable monomer-flatpak-example     main-is:            Main.hs+    build-tools:        c2hs >=0+    pkgconfig-depends:  libspa-0.2, libpipewire-0.3+    c-sources:          cbits/pipewire_hacks.c     hs-source-dirs:     app     other-modules:+        Bindings.PipeWire+        Bindings.Util+        Camera         Documents         OpenURI+        PipeWire         Paths_monomer_flatpak_example      default-language:   Haskell2010@@ -39,18 +46,20 @@         NoFieldSelectors OverloadedRecordDot OverloadedStrings         RecordWildCards ScopedTypeVariables +    include-dirs:       cbits     ghc-options:         -threaded -rtsopts -with-rtsopts=-N -Wall -Wcompat         -Wincomplete-record-updates -Wincomplete-uni-patterns         -Wredundant-constraints      build-depends:+        async <2.3,         base >=4.7 && <5,         bytestring <0.12,         containers <0.7,         data-default-class <0.2,         dbus <1.4,-        desktop-portal >=0.3.1.0 && <0.4,+        desktop-portal >=0.3.2.0 && <0.4,         directory <1.4,         modern-uri <0.4,         monomer <1.6,