From ff1ff0a561ee9ce2f04fb55533a8275343e93f3a Mon Sep 17 00:00:00 2001
From: Jens Nolte <git@queezle.net>
Date: Fri, 17 Dec 2021 09:54:22 +0100
Subject: [PATCH] Add util to allocate shared memory
---
quasar-wayland.cabal | 4 +++
src/Quasar/Wayland/Utils/InlineC.hs | 33 ++++++++++++++++++++++
src/Quasar/Wayland/Utils/SharedMemory.hs | 36 ++++++++++++++++++++++++
3 files changed, 73 insertions(+)
create mode 100644 src/Quasar/Wayland/Utils/InlineC.hs
create mode 100644 src/Quasar/Wayland/Utils/SharedMemory.hs
diff --git a/quasar-wayland.cabal b/quasar-wayland.cabal
index 027da67..82a0113 100644
--- a/quasar-wayland.cabal
+++ b/quasar-wayland.cabal
@@ -84,12 +84,16 @@ library
Quasar.Wayland.Protocol.TH
other-modules:
Quasar.Wayland.Protocol.Core
+ Quasar.Wayland.Utils.InlineC
+ Quasar.Wayland.Utils.SharedMemory
build-depends:
base >=4.7 && <5,
binary,
bytestring,
+ containers,
exceptions,
filepath,
+ inline-c,
mtl,
network,
quasar,
diff --git a/src/Quasar/Wayland/Utils/InlineC.hs b/src/Quasar/Wayland/Utils/InlineC.hs
new file mode 100644
index 0000000..73d1d8d
--- /dev/null
+++ b/src/Quasar/Wayland/Utils/InlineC.hs
@@ -0,0 +1,33 @@
+module Quasar.Wayland.Utils.InlineC (
+ ctx
+) where
+
+import Data.Map.Strict as Map
+import Language.C.Inline.Context
+import Language.C.Types
+import Language.Haskell.TH
+import Quasar.Prelude
+import System.Posix.Types (COff(..))
+
+ctx :: Context
+ctx = baseCtx <> extraTypesCtx
+
+emptyCtx :: Context
+emptyCtx = Context {
+ ctxTypesTable = mempty,
+ ctxAntiQuoters = mempty,
+ ctxOutput = mempty,
+ ctxForeignSrcLang = Nothing,
+ ctxEnableCpp = False
+}
+
+extraTypesCtx :: Context
+extraTypesCtx =
+ emptyCtx {
+ ctxTypesTable = Map.fromList types
+ }
+
+types :: [(TypeSpecifier, TypeQ)]
+types = [
+ (TypeName "off_t", [t|COff|])
+ ]
diff --git a/src/Quasar/Wayland/Utils/SharedMemory.hs b/src/Quasar/Wayland/Utils/SharedMemory.hs
new file mode 100644
index 0000000..4de2aab
--- /dev/null
+++ b/src/Quasar/Wayland/Utils/SharedMemory.hs
@@ -0,0 +1,36 @@
+{-# LANGUAGE QuasiQuotes #-}
+{-# LANGUAGE TemplateHaskell #-}
+
+module Quasar.Wayland.Utils.SharedMemory (
+ allocateShmFd,
+) where
+
+import Foreign.C.Error
+import Language.C.Inline qualified as C
+import Language.C.Inline.Unsafe qualified as CU
+import Quasar.Prelude
+import Quasar.Wayland.Utils.InlineC
+import System.Posix.Types (COff(..), Fd(Fd))
+
+C.context ctx
+
+C.verbatim "#define _GNU_SOURCE"
+C.include "<unistd.h>"
+C.include "<sys/mman.h>"
+
+allocateShmFd :: COff -> IO Fd
+allocateShmFd size = Fd <$> throwErrnoIfMinus1 "allocateShmFd"
+ [CU.block|
+ int {
+ int fd = memfd_create("shm", MFD_CLOEXEC | MFD_ALLOW_SEALING);
+ if (fd < 0) {
+ return fd;
+ }
+
+ if (ftruncate(fd, $(off_t size)) < 0) {
+ close(fd);
+ return -1;
+ }
+ return fd;
+ }
+ |]
--
GitLab