summaryrefslogtreecommitdiff
path: root/overlays/spm
diff options
context:
space:
mode:
authorGregor Kleen <gkleen@yggdrasil.li>2022-12-18 19:10:03 +0100
committerGregor Kleen <gkleen@yggdrasil.li>2022-12-18 19:10:03 +0100
commit2b92f10ae5dab7c78718db4b701e866ac85d99cb (patch)
treee4f62ecb93916ee3d76af5d1e71875d9f5dfc72a /overlays/spm
parent7d6e8a86997b41b351054cef0afc25646091a238 (diff)
downloadnixos-2b92f10ae5dab7c78718db4b701e866ac85d99cb.tar
nixos-2b92f10ae5dab7c78718db4b701e866ac85d99cb.tar.gz
nixos-2b92f10ae5dab7c78718db4b701e866ac85d99cb.tar.bz2
nixos-2b92f10ae5dab7c78718db4b701e866ac85d99cb.tar.xz
nixos-2b92f10ae5dab7c78718db4b701e866ac85d99cb.zip
...
Diffstat (limited to 'overlays/spm')
-rw-r--r--overlays/spm/lib/Spm/Api.hs1
-rw-r--r--overlays/spm/server/Spm/Server.hs35
2 files changed, 25 insertions, 11 deletions
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
174 :<|> "mappings" :> Capture "mapping" SpmMapping :> Get '[PlainText, JSON] SpmMappingState 174 :<|> "mappings" :> Capture "mapping" SpmMapping :> Get '[PlainText, JSON] SpmMappingState
175 :<|> "mappings" :> Capture "mapping" SpmMapping :> ReqBody '[PlainText, JSON] SpmMappingState :> PatchNoContent 175 :<|> "mappings" :> Capture "mapping" SpmMapping :> ReqBody '[PlainText, JSON] SpmMappingState :> PatchNoContent
176 :<|> "mappings" :> Capture "mapping" SpmMapping :> ReqBody '[PlainText, JSON] SpmMappingState :> PutNoContent 176 :<|> "mappings" :> Capture "mapping" SpmMapping :> ReqBody '[PlainText, JSON] SpmMappingState :> PutNoContent
177 :<|> "mappings" :> Capture "mapping" SpmMapping :> DeleteNoContent
177 178
178spmApi :: Proxy SpmApi 179spmApi :: Proxy SpmApi
179spmApi = Proxy 180spmApi = 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
223 :<|> getMapping 223 :<|> getMapping
224 :<|> patchMapping 224 :<|> patchMapping
225 :<|> putMapping 225 :<|> putMapping
226 :<|> deleteMapping
226 where 227 where
227 whoami = do 228 whoami = do
228 Entity _ Mailbox{mailboxIdent} <- maybe (throwError err404) return <=< spmSql . getBy $ UniqueMailbox mbox 229 Entity _ Mailbox{mailboxIdent} <- maybe (throwError err404) return <=< spmSql . getBy $ UniqueMailbox mbox
@@ -314,19 +315,9 @@ spmServer dom mbox = whoami
314 update mmId [ MailboxMappingReject =. view _SpmMappingStateReject mappingState ] 315 update mmId [ MailboxMappingReject =. view _SpmMappingStateReject mappingState ]
315 return NoContent 316 return NoContent
316 317
317 putMapping spmMapping mappingState = spmSql $ do 318 assertAuthorizedAncestor spmMapping = do
318 Entity mailboxId _ <- maybe (throwError err404) return <=< getBy $ UniqueMailbox mbox 319 Entity mailboxId _ <- maybe (throwError err404) return <=< getBy $ UniqueMailbox mbox
319 320
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 321 let go [] = throwError err403
331 go (SpmMapping{..} : ancestors) = do 322 go (SpmMapping{..} : ancestors) = do
332 candidate <- selectList 323 candidate <- selectList
@@ -344,6 +335,21 @@ spmServer dom mbox = whoami
344 _other -> throwError err500 335 _other -> throwError err500
345 in go $ spmMappingAncestors spmMapping 336 in go $ spmMappingAncestors spmMapping
346 337
338 putMapping spmMapping mappingState = spmSql $ do
339 Entity mailboxId _ <- maybe (throwError err404) return <=< getBy $ UniqueMailbox mbox
340
341 existing <- selectList
342 [ MailboxMappingLocal ==. (spmMappingLocal spmMapping <&> view (_Wrapped . _Unwrapped))
343 , MailboxMappingExtension ==. (spmMappingExtension spmMapping <&> view (_Wrapped . _Unwrapped))
344 , MailboxMappingDomain ==. dom
345 ]
346 [ LimitTo 1
347 ]
348 unless (null existing) $
349 throwError err409
350
351 assertAuthorizedAncestor spmMapping
352
347 insert_ MailboxMapping 353 insert_ MailboxMapping
348 { mailboxMappingLocal = (spmMappingLocal spmMapping <&> view (_Wrapped . _Unwrapped)) 354 { mailboxMappingLocal = (spmMappingLocal spmMapping <&> view (_Wrapped . _Unwrapped))
349 , mailboxMappingExtension = (spmMappingExtension spmMapping <&> view (_Wrapped . _Unwrapped)) 355 , mailboxMappingExtension = (spmMappingExtension spmMapping <&> view (_Wrapped . _Unwrapped))
@@ -353,6 +359,13 @@ spmServer dom mbox = whoami
353 } 359 }
354 return NoContent 360 return NoContent
355 361
362 deleteMapping spmMapping = spmSql $ do
363 Entity mmId MailboxMapping{} <- getUniqueMapping spmMapping
364 assertAuthorizedAncestor spmMapping
365
366 delete mmId
367 return NoContent
368
356main :: IO () 369main :: IO ()
357main = runSystemdWarp systemdSettings warpSettings =<< mkSpmApp 370main = runSystemdWarp systemdSettings warpSettings =<< mkSpmApp
358 where 371 where