From 7d6e8a86997b41b351054cef0afc25646091a238 Mon Sep 17 00:00:00 2001
From: Gregor Kleen <gkleen@yggdrasil.li>
Date: Sun, 18 Dec 2022 18:56:13 +0100
Subject: ...

---
 overlays/spm/server/Spm/Server.hs | 40 +++++++++++++++++++++++++++++++++++++++
 1 file changed, 40 insertions(+)

(limited to 'overlays/spm/server')

diff --git a/overlays/spm/server/Spm/Server.hs b/overlays/spm/server/Spm/Server.hs
index 86d7d02b..d8efd826 100644
--- a/overlays/spm/server/Spm/Server.hs
+++ b/overlays/spm/server/Spm/Server.hs
@@ -222,6 +222,7 @@ spmServer dom mbox = whoami
                 :<|> listMappings
                 :<|> getMapping
                 :<|> patchMapping
+                :<|> putMapping
   where
     whoami = do
       Entity _ Mailbox{mailboxIdent} <- maybe (throwError err404) return <=< spmSql . getBy $ UniqueMailbox mbox
@@ -313,6 +314,45 @@ spmServer dom mbox = whoami
       update mmId [ MailboxMappingReject =. view _SpmMappingStateReject mappingState ]
       return NoContent
 
+    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
+
+      let go [] = throwError err403
+          go (SpmMapping{..} : ancestors) = do
+            candidate <- selectList
+              [ MailboxMappingLocal ==. (spmMappingLocal <&> view (_Wrapped . _Unwrapped))
+              , MailboxMappingExtension ==. (spmMappingExtension <&> view (_Wrapped . _Unwrapped))
+              , MailboxMappingDomain ==. dom
+              ]
+              [ LimitTo 1
+              ]
+            case candidate of
+              [Entity _ MailboxMapping{..}] ->
+                unless (mailboxMappingMailbox == mailboxId) $
+                  throwError err403
+              [] -> go ancestors
+              _other -> throwError err500
+       in go $ spmMappingAncestors spmMapping
+
+      insert_ MailboxMapping
+        { mailboxMappingLocal = (spmMappingLocal spmMapping <&> view (_Wrapped . _Unwrapped))
+        , mailboxMappingExtension = (spmMappingExtension spmMapping <&> view (_Wrapped . _Unwrapped))
+        , mailboxMappingDomain = dom
+        , mailboxMappingMailbox = mailboxId
+        , mailboxMappingReject = view _SpmMappingStateReject mappingState
+        }
+      return NoContent
+
 main :: IO ()
 main = runSystemdWarp systemdSettings warpSettings =<< mkSpmApp
   where
-- 
cgit v1.2.3