From 2b92f10ae5dab7c78718db4b701e866ac85d99cb Mon Sep 17 00:00:00 2001
From: Gregor Kleen <gkleen@yggdrasil.li>
Date: Sun, 18 Dec 2022 19:10:03 +0100
Subject: ...

---
 overlays/spm/lib/Spm/Api.hs       |  1 +
 overlays/spm/server/Spm/Server.hs | 35 ++++++++++++++++++++++++-----------
 2 files changed, 25 insertions(+), 11 deletions(-)

(limited to 'overlays')

diff --git a/overlays/spm/lib/Spm/Api.hs b/overlays/spm/lib/Spm/Api.hs
index ce4ee2d9..04dff2c9 100644
--- a/overlays/spm/lib/Spm/Api.hs
+++ b/overlays/spm/lib/Spm/Api.hs
@@ -174,6 +174,7 @@ type SpmApi = "whoami" :> Get '[PlainText, JSON] SpmMailbox
          :<|> "mappings" :> Capture "mapping" SpmMapping :> Get '[PlainText, JSON] SpmMappingState
          :<|> "mappings" :> Capture "mapping" SpmMapping :> ReqBody '[PlainText, JSON] SpmMappingState :> PatchNoContent
          :<|> "mappings" :> Capture "mapping" SpmMapping :> ReqBody '[PlainText, JSON] SpmMappingState :> PutNoContent
+         :<|> "mappings" :> Capture "mapping" SpmMapping :> DeleteNoContent
 
 spmApi :: Proxy SpmApi
 spmApi = Proxy
diff --git a/overlays/spm/server/Spm/Server.hs b/overlays/spm/server/Spm/Server.hs
index d8efd826..6bb9dfe6 100644
--- a/overlays/spm/server/Spm/Server.hs
+++ b/overlays/spm/server/Spm/Server.hs
@@ -223,6 +223,7 @@ spmServer dom mbox = whoami
                 :<|> getMapping
                 :<|> patchMapping
                 :<|> putMapping
+                :<|> deleteMapping
   where
     whoami = do
       Entity _ Mailbox{mailboxIdent} <- maybe (throwError err404) return <=< spmSql . getBy $ UniqueMailbox mbox
@@ -314,19 +315,9 @@ spmServer dom mbox = whoami
       update mmId [ MailboxMappingReject =. view _SpmMappingStateReject mappingState ]
       return NoContent
 
-    putMapping spmMapping mappingState = spmSql $ do
+    assertAuthorizedAncestor spmMapping = do
       Entity mailboxId _ <- maybe (throwError err404) return <=< getBy $ UniqueMailbox mbox
 
-      existing <- selectList
-        [ MailboxMappingLocal ==. (spmMappingLocal spmMapping <&> view (_Wrapped . _Unwrapped))
-        , MailboxMappingExtension ==. (spmMappingExtension spmMapping <&> view (_Wrapped . _Unwrapped))
-        , MailboxMappingDomain ==. dom
-        ]
-        [ LimitTo 1
-        ]
-      unless (null existing) $
-        throwError err409
-
       let go [] = throwError err403
           go (SpmMapping{..} : ancestors) = do
             candidate <- selectList
@@ -344,6 +335,21 @@ spmServer dom mbox = whoami
               _other -> throwError err500
        in go $ spmMappingAncestors spmMapping
 
+    putMapping spmMapping mappingState = spmSql $ do
+      Entity mailboxId _ <- maybe (throwError err404) return <=< getBy $ UniqueMailbox mbox
+
+      existing <- selectList
+        [ MailboxMappingLocal ==. (spmMappingLocal spmMapping <&> view (_Wrapped . _Unwrapped))
+        , MailboxMappingExtension ==. (spmMappingExtension spmMapping <&> view (_Wrapped . _Unwrapped))
+        , MailboxMappingDomain ==. dom
+        ]
+        [ LimitTo 1
+        ]
+      unless (null existing) $
+        throwError err409
+
+      assertAuthorizedAncestor spmMapping
+
       insert_ MailboxMapping
         { mailboxMappingLocal = (spmMappingLocal spmMapping <&> view (_Wrapped . _Unwrapped))
         , mailboxMappingExtension = (spmMappingExtension spmMapping <&> view (_Wrapped . _Unwrapped))
@@ -353,6 +359,13 @@ spmServer dom mbox = whoami
         }
       return NoContent
 
+    deleteMapping spmMapping = spmSql $ do
+      Entity mmId MailboxMapping{} <- getUniqueMapping spmMapping
+      assertAuthorizedAncestor spmMapping
+
+      delete mmId
+      return NoContent
+
 main :: IO ()
 main = runSystemdWarp systemdSettings warpSettings =<< mkSpmApp
   where
-- 
cgit v1.2.3