From 6f49d8632e6ceccb0399764e7da86cc4cba9ab04 Mon Sep 17 00:00:00 2001
From: Gregor Kleen <gkleen@yggdrasil.li>
Date: Fri, 16 Dec 2022 20:29:28 +0100
Subject: spm: list/get/patch mailbox mappings

---
 overlays/spm/server/Spm/Server.hs          | 54 ++++++++++++++++++++++++++----
 overlays/spm/server/Spm/Server/Database.hs |  3 ++
 2 files changed, 50 insertions(+), 7 deletions(-)

(limited to 'overlays/spm/server')

diff --git a/overlays/spm/server/Spm/Server.hs b/overlays/spm/server/Spm/Server.hs
index 0dd3e810..9ba3e446 100644
--- a/overlays/spm/server/Spm/Server.hs
+++ b/overlays/spm/server/Spm/Server.hs
@@ -87,7 +87,7 @@ import Control.Monad.Trans.Except
 import Data.Monoid (First(..))
 
 import Numeric.Natural
-  
+
 import Spm.Server.Ctx
 import Spm.Server.UI
 
@@ -118,8 +118,8 @@ type SpmServerApi =    Header' '[Required, Strict] "SPM-Domain" MailDomain
 
 spmServerApi :: Proxy SpmServerApi
 spmServerApi = Proxy
-  
-  
+
+
 requestMailMailbox :: Request -> Either Text MailMailbox
 requestMailMailbox req = do
     clientVerify <- getHeader hSslClientVerify
@@ -131,7 +131,7 @@ requestMailMailbox req = do
     spmMailbox <- left Text.pack $ parseOnly (asciiCI "CN=" *> (CI.mk <$> takeText) <* endOfInput) clientSDN
 
     return $ _Wrapped # spmMailbox
-  where 
+  where
     getHeader :: forall a. FromHttpApiData a => HeaderName -> Either Text a
     getHeader hdrName = parseHeader <=< maybeToEither ("Missing “" <> Text.decodeUtf8 (CI.original hdrName) <> "”") . lookup hdrName $ requestHeaders req
 
@@ -164,7 +164,7 @@ data ServerCtxError
   | ServerCtxJwkSetEmpty
   deriving stock (Eq, Ord, Read, Show, Generic, Typeable)
   deriving anyclass (Exception)
-  
+
 mkSpmApp :: (MonadUnliftIO m, MonadThrow m) => m Application
 mkSpmApp = do
   requestLogger <- mkSpmRequestLogger
@@ -218,6 +218,9 @@ spmServer dom mbox = whoami
                 :<|> instanceId
                 :<|> generate
                 :<|> claim
+                :<|> listMappings
+                :<|> getMapping
+                :<|> patchMapping
   where
     whoami = do
       Entity _ Mailbox{mailboxIdent} <- maybe (throwError err404) return <=< spmSql . getBy $ UniqueMailbox mbox
@@ -226,7 +229,7 @@ spmServer dom mbox = whoami
     domain = return $ dom ^. _Wrapped . re _Wrapped
 
     jwkSet = views sctxJwkSet $ over _Wrapped (^.. folded . asPublicKey . _Just)
-  
+
     instanceId = view sctxInstanceId
 
     generate (fromMaybe SpmWords -> style) = do
@@ -269,7 +272,44 @@ spmServer dom mbox = whoami
 
       spmSql $ do
         Entity mailboxMappingMailbox _ <- maybe (throwError err404) return <=< getBy $ UniqueMailbox mbox
-        maybe (throwError err400{ errBody = "Address already claimed" }) (const $ return NoContent) =<< insertUnique MailboxMapping{mailboxMappingExtension = Nothing, mailboxMappingDomain = dom, ..}
+        maybe (throwError err400{ errBody = "Address already claimed" }) (const $ return NoContent) =<< insertUnique MailboxMapping{mailboxMappingExtension = Nothing, mailboxMappingDomain = dom, mailboxMappingReject = False, ..}
+
+    listMappings = spmSql $ do
+      Entity mailboxId _ <- maybe (throwError err404) return <=< getBy $ UniqueMailbox mbox
+      mappings <- selectList [ MailboxMappingMailbox ==. mailboxId, MailboxMappingDomain ==. dom ] []
+      return $ mappings
+        & fmap (\(Entity _ MailboxMapping{..}) -> SpmMappingListingItem
+                 { smlMapping = SpmMapping
+                   { spmMappingLocal = view (_Wrapped . _Unwrapped) <$> mailboxMappingLocal
+                   , spmMappingExtension = view (_Wrapped . _Unwrapped) <$> mailboxMappingExtension
+                   }
+                 , smlState = _SpmMappingStateReject # mailboxMappingReject
+                 }
+               )
+        & SpmMappingListing
+
+    getUniqueMapping SpmMapping{..} = do
+      Entity mailboxId _ <- maybe (throwError err404) return <=< getBy $ UniqueMailbox mbox
+      candidateMappings <- selectList
+        [ MailboxMappingMailbox ==. mailboxId
+        , MailboxMappingLocal ==. (spmMappingLocal <&> view (_Wrapped . _Unwrapped))
+        , MailboxMappingExtension ==. (spmMappingExtension <&> view (_Wrapped . _Unwrapped))
+        , MailboxMappingDomain ==. dom
+        ]
+        [ LimitTo 1
+        ]
+      case candidateMappings of
+        [mMapping] -> return mMapping
+        _other -> throwError err404
+
+    getMapping spmMapping = spmSql $ do
+      Entity _ MailboxMapping{..} <- getUniqueMapping spmMapping
+      return $ _SpmMappingStateReject # mailboxMappingReject
+
+    patchMapping spmMapping mappingState = spmSql $ do
+      Entity mmId MailboxMapping{} <- getUniqueMapping spmMapping
+      update mmId [ MailboxMappingReject =. view _SpmMappingStateReject mappingState ]
+      return NoContent
 
 main :: IO ()
 main = runSystemdWarp systemdSettings warpSettings =<< mkSpmApp
diff --git a/overlays/spm/server/Spm/Server/Database.hs b/overlays/spm/server/Spm/Server/Database.hs
index cc133e06..3156e920 100644
--- a/overlays/spm/server/Spm/Server/Database.hs
+++ b/overlays/spm/server/Spm/Server/Database.hs
@@ -69,5 +69,8 @@ share [mkPersist sqlSettings] [persistLowerCase|
     extension MailExtension Maybe
     domain MailDomain
     mailbox MailboxId
+    reject Bool
+    UniqueDomain domain sql=domain_unique !force
     UniqueLocalDomain local domain sql=local_domain_unique !force
+    UniqueLocalExtensionDomain local extension domain sql=local_extension_domain_unique !force
 |]
-- 
cgit v1.2.3