From b25e8ba4b04be24060b3b83082e606c3e92c85e2 Mon Sep 17 00:00:00 2001
From: Benjamin Koch <snowball@c3pb.de>
Date: Wed, 16 Dec 2020 00:08:32 +0100
Subject: [PATCH] Refactor: move error handling into qubesAdminCall
---
src/QBar/Qubes/AdminAPI.hs | 22 +++++++++++-----------
1 file changed, 11 insertions(+), 11 deletions(-)
diff --git a/src/QBar/Qubes/AdminAPI.hs b/src/QBar/Qubes/AdminAPI.hs
index e8a0dfd..c8a762e 100644
--- a/src/QBar/Qubes/AdminAPI.hs
+++ b/src/QBar/Qubes/AdminAPI.hs
@@ -79,8 +79,8 @@ qubesAdminConnect serviceName args = do
let processConfig = setStdin nullStream $ setStdout createPipe $ shell $ BLC.unpack cmd
startProcess processConfig
-qubesAdminCall :: BL.ByteString -> [BL.ByteString] -> IO QubesAdminReturn
-qubesAdminCall serviceName args = do
+qubesTryAdminCall :: BL.ByteString -> [BL.ByteString] -> IO QubesAdminReturn
+qubesTryAdminCall serviceName args = do
process <- qubesAdminConnect serviceName args
let stdout = getStdout process
hSetBinaryMode stdout True
@@ -90,6 +90,12 @@ qubesAdminCall serviceName args = do
Exception {} -> return reply
Event {} -> fail "service has returned events instead of a reply"
+qubesAdminCall :: BL.ByteString -> [BL.ByteString] -> IO BL.ByteString
+qubesAdminCall serviceName args = qubesTryAdminCall serviceName args >>= get where
+ get Ok {okContent} = return okContent
+ get x@Exception {} = fail $ "service has returned an exception: " <> show x
+ get Event {} = fail "service has returned events instead of a reply"
+
qubesAdminCallP :: BL.ByteString -> [BL.ByteString] -> Producer QubesAdminReturn (P.SafeT IO) ()
qubesAdminCallP serviceName args = do
process <- liftIO $ qubesAdminConnect serviceName args
@@ -215,10 +221,8 @@ instance Read QubesVMState where
_ -> UnknownState
qubesListVMs :: IO (Map.Map BL.ByteString QubesVMInfo)
-qubesListVMs = qubesAdminCall "admin.vm.List" [] >>= fromOk >>= parse
+qubesListVMs = qubesAdminCall "admin.vm.List" [] >>= parse
where
- fromOk (Ok x) = return x
- fromOk x = fail $ "unexpected reply: " <> show x
parse reply = BLC.split '\n' reply
& filter (/="")
& map parseLine
@@ -237,10 +241,8 @@ qubesListVMs = qubesAdminCall "admin.vm.List" [] >>= fromOk >>= parse
tryReadProp name = readMaybe . BLC.unpack =<< getProp name
qubesGetProperty :: BL.ByteString -> IO (Bool, BL.ByteString, BL.ByteString)
-qubesGetProperty name = qubesAdminCall "admin.property.Get" [name] >>= fromOk >>= parse
+qubesGetProperty name = qubesAdminCall "admin.property.Get" [name] >>= parse
where
- fromOk (Ok x) = return x
- fromOk x = fail $ "unexpected reply: " <> show x
parse reply = return (isDefault == "default=True", BL.drop 5 typeStr, value)
where
splitOn ch = fmap BLC.tail . BLC.break (==ch)
@@ -251,10 +253,8 @@ qubesGetDefaultPool = third <$> qubesGetProperty "default_pool"
where third (_, _, x) = x
qubesGetPoolInfo :: BL.ByteString -> IO [(BL.ByteString, BL.ByteString)]
-qubesGetPoolInfo name = qubesAdminCall "admin.pool.Info" [name] >>= fromOk >>= parse
+qubesGetPoolInfo name = qubesAdminCall "admin.pool.Info" [name] >>= parse
where
- fromOk (Ok x) = return x
- fromOk x = fail $ "unexpected reply: " <> show x
parse reply = BLC.split '\n' reply
& filter (/="")
& map parseLine
--
GitLab