summaryrefslogtreecommitdiff
path: root/overlays/spm/server/Spm/Server.hs
diff options
context:
space:
mode:
Diffstat (limited to 'overlays/spm/server/Spm/Server.hs')
-rw-r--r--overlays/spm/server/Spm/Server.hs40
1 files changed, 40 insertions, 0 deletions
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
222 :<|> listMappings 222 :<|> listMappings
223 :<|> getMapping 223 :<|> getMapping
224 :<|> patchMapping 224 :<|> patchMapping
225 :<|> putMapping
225 where 226 where
226 whoami = do 227 whoami = do
227 Entity _ Mailbox{mailboxIdent} <- maybe (throwError err404) return <=< spmSql . getBy $ UniqueMailbox mbox 228 Entity _ Mailbox{mailboxIdent} <- maybe (throwError err404) return <=< spmSql . getBy $ UniqueMailbox mbox
@@ -313,6 +314,45 @@ spmServer dom mbox = whoami
313 update mmId [ MailboxMappingReject =. view _SpmMappingStateReject mappingState ] 314 update mmId [ MailboxMappingReject =. view _SpmMappingStateReject mappingState ]
314 return NoContent 315 return NoContent
315 316
317 putMapping spmMapping mappingState = spmSql $ do
318 Entity mailboxId _ <- maybe (throwError err404) return <=< getBy $ UniqueMailbox mbox
319
320 existing <- selectList
321 [ MailboxMappingLocal ==. (spmMappingLocal spmMapping <&> view (_Wrapped . _Unwrapped))
322 , MailboxMappingExtension ==. (spmMappingExtension spmMapping <&> view (_Wrapped . _Unwrapped))
323 , MailboxMappingDomain ==. dom
324 ]
325 [ LimitTo 1
326 ]
327 unless (null existing) $
328 throwError err409
329
330 let go [] = throwError err403
331 go (SpmMapping{..} : ancestors) = do
332 candidate <- selectList
333 [ MailboxMappingLocal ==. (spmMappingLocal <&> view (_Wrapped . _Unwrapped))
334 , MailboxMappingExtension ==. (spmMappingExtension <&> view (_Wrapped . _Unwrapped))
335 , MailboxMappingDomain ==. dom
336 ]
337 [ LimitTo 1
338 ]
339 case candidate of
340 [Entity _ MailboxMapping{..}] ->
341 unless (mailboxMappingMailbox == mailboxId) $
342 throwError err403
343 [] -> go ancestors
344 _other -> throwError err500
345 in go $ spmMappingAncestors spmMapping
346
347 insert_ MailboxMapping
348 { mailboxMappingLocal = (spmMappingLocal spmMapping <&> view (_Wrapped . _Unwrapped))
349 , mailboxMappingExtension = (spmMappingExtension spmMapping <&> view (_Wrapped . _Unwrapped))
350 , mailboxMappingDomain = dom
351 , mailboxMappingMailbox = mailboxId
352 , mailboxMappingReject = view _SpmMappingStateReject mappingState
353 }
354 return NoContent
355
316main :: IO () 356main :: IO ()
317main = runSystemdWarp systemdSettings warpSettings =<< mkSpmApp 357main = runSystemdWarp systemdSettings warpSettings =<< mkSpmApp
318 where 358 where