summaryrefslogtreecommitdiff
path: root/overlays/spm/server/Spm
diff options
context:
space:
mode:
authorGregor Kleen <gkleen@yggdrasil.li>2022-12-16 20:29:28 +0100
committerGregor Kleen <gkleen@yggdrasil.li>2022-12-16 20:29:28 +0100
commit6f49d8632e6ceccb0399764e7da86cc4cba9ab04 (patch)
tree39a1e15181139cc9b9cdbacdc6362c743be4753d /overlays/spm/server/Spm
parentbbb5a2502ad108186c9257c5fa420a4965059043 (diff)
downloadnixos-6f49d8632e6ceccb0399764e7da86cc4cba9ab04.tar
nixos-6f49d8632e6ceccb0399764e7da86cc4cba9ab04.tar.gz
nixos-6f49d8632e6ceccb0399764e7da86cc4cba9ab04.tar.bz2
nixos-6f49d8632e6ceccb0399764e7da86cc4cba9ab04.tar.xz
nixos-6f49d8632e6ceccb0399764e7da86cc4cba9ab04.zip
spm: list/get/patch mailbox mappings
Diffstat (limited to 'overlays/spm/server/Spm')
-rw-r--r--overlays/spm/server/Spm/Server.hs54
-rw-r--r--overlays/spm/server/Spm/Server/Database.hs3
2 files changed, 50 insertions, 7 deletions
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
87import Data.Monoid (First(..)) 87import Data.Monoid (First(..))
88 88
89import Numeric.Natural 89import Numeric.Natural
90 90
91import Spm.Server.Ctx 91import Spm.Server.Ctx
92import Spm.Server.UI 92import Spm.Server.UI
93 93
@@ -118,8 +118,8 @@ type SpmServerApi = Header' '[Required, Strict] "SPM-Domain" MailDomain
118 118
119spmServerApi :: Proxy SpmServerApi 119spmServerApi :: Proxy SpmServerApi
120spmServerApi = Proxy 120spmServerApi = Proxy
121 121
122 122
123requestMailMailbox :: Request -> Either Text MailMailbox 123requestMailMailbox :: Request -> Either Text MailMailbox
124requestMailMailbox req = do 124requestMailMailbox req = do
125 clientVerify <- getHeader hSslClientVerify 125 clientVerify <- getHeader hSslClientVerify
@@ -131,7 +131,7 @@ requestMailMailbox req = do
131 spmMailbox <- left Text.pack $ parseOnly (asciiCI "CN=" *> (CI.mk <$> takeText) <* endOfInput) clientSDN 131 spmMailbox <- left Text.pack $ parseOnly (asciiCI "CN=" *> (CI.mk <$> takeText) <* endOfInput) clientSDN
132 132
133 return $ _Wrapped # spmMailbox 133 return $ _Wrapped # spmMailbox
134 where 134 where
135 getHeader :: forall a. FromHttpApiData a => HeaderName -> Either Text a 135 getHeader :: forall a. FromHttpApiData a => HeaderName -> Either Text a
136 getHeader hdrName = parseHeader <=< maybeToEither ("Missing “" <> Text.decodeUtf8 (CI.original hdrName) <> "”") . lookup hdrName $ requestHeaders req 136 getHeader hdrName = parseHeader <=< maybeToEither ("Missing “" <> Text.decodeUtf8 (CI.original hdrName) <> "”") . lookup hdrName $ requestHeaders req
137 137
@@ -164,7 +164,7 @@ data ServerCtxError
164 | ServerCtxJwkSetEmpty 164 | ServerCtxJwkSetEmpty
165 deriving stock (Eq, Ord, Read, Show, Generic, Typeable) 165 deriving stock (Eq, Ord, Read, Show, Generic, Typeable)
166 deriving anyclass (Exception) 166 deriving anyclass (Exception)
167 167
168mkSpmApp :: (MonadUnliftIO m, MonadThrow m) => m Application 168mkSpmApp :: (MonadUnliftIO m, MonadThrow m) => m Application
169mkSpmApp = do 169mkSpmApp = do
170 requestLogger <- mkSpmRequestLogger 170 requestLogger <- mkSpmRequestLogger
@@ -218,6 +218,9 @@ spmServer dom mbox = whoami
218 :<|> instanceId 218 :<|> instanceId
219 :<|> generate 219 :<|> generate
220 :<|> claim 220 :<|> claim
221 :<|> listMappings
222 :<|> getMapping
223 :<|> patchMapping
221 where 224 where
222 whoami = do 225 whoami = do
223 Entity _ Mailbox{mailboxIdent} <- maybe (throwError err404) return <=< spmSql . getBy $ UniqueMailbox mbox 226 Entity _ Mailbox{mailboxIdent} <- maybe (throwError err404) return <=< spmSql . getBy $ UniqueMailbox mbox
@@ -226,7 +229,7 @@ spmServer dom mbox = whoami
226 domain = return $ dom ^. _Wrapped . re _Wrapped 229 domain = return $ dom ^. _Wrapped . re _Wrapped
227 230
228 jwkSet = views sctxJwkSet $ over _Wrapped (^.. folded . asPublicKey . _Just) 231 jwkSet = views sctxJwkSet $ over _Wrapped (^.. folded . asPublicKey . _Just)
229 232
230 instanceId = view sctxInstanceId 233 instanceId = view sctxInstanceId
231 234
232 generate (fromMaybe SpmWords -> style) = do 235 generate (fromMaybe SpmWords -> style) = do
@@ -269,7 +272,44 @@ spmServer dom mbox = whoami
269 272
270 spmSql $ do 273 spmSql $ do
271 Entity mailboxMappingMailbox _ <- maybe (throwError err404) return <=< getBy $ UniqueMailbox mbox 274 Entity mailboxMappingMailbox _ <- maybe (throwError err404) return <=< getBy $ UniqueMailbox mbox
272 maybe (throwError err400{ errBody = "Address already claimed" }) (const $ return NoContent) =<< insertUnique MailboxMapping{mailboxMappingExtension = Nothing, mailboxMappingDomain = dom, ..} 275 maybe (throwError err400{ errBody = "Address already claimed" }) (const $ return NoContent) =<< insertUnique MailboxMapping{mailboxMappingExtension = Nothing, mailboxMappingDomain = dom, mailboxMappingReject = False, ..}
276
277 listMappings = spmSql $ do
278 Entity mailboxId _ <- maybe (throwError err404) return <=< getBy $ UniqueMailbox mbox
279 mappings <- selectList [ MailboxMappingMailbox ==. mailboxId, MailboxMappingDomain ==. dom ] []
280 return $ mappings
281 & fmap (\(Entity _ MailboxMapping{..}) -> SpmMappingListingItem
282 { smlMapping = SpmMapping
283 { spmMappingLocal = view (_Wrapped . _Unwrapped) <$> mailboxMappingLocal
284 , spmMappingExtension = view (_Wrapped . _Unwrapped) <$> mailboxMappingExtension
285 }
286 , smlState = _SpmMappingStateReject # mailboxMappingReject
287 }
288 )
289 & SpmMappingListing
290
291 getUniqueMapping SpmMapping{..} = do
292 Entity mailboxId _ <- maybe (throwError err404) return <=< getBy $ UniqueMailbox mbox
293 candidateMappings <- selectList
294 [ MailboxMappingMailbox ==. mailboxId
295 , MailboxMappingLocal ==. (spmMappingLocal <&> view (_Wrapped . _Unwrapped))
296 , MailboxMappingExtension ==. (spmMappingExtension <&> view (_Wrapped . _Unwrapped))
297 , MailboxMappingDomain ==. dom
298 ]
299 [ LimitTo 1
300 ]
301 case candidateMappings of
302 [mMapping] -> return mMapping
303 _other -> throwError err404
304
305 getMapping spmMapping = spmSql $ do
306 Entity _ MailboxMapping{..} <- getUniqueMapping spmMapping
307 return $ _SpmMappingStateReject # mailboxMappingReject
308
309 patchMapping spmMapping mappingState = spmSql $ do
310 Entity mmId MailboxMapping{} <- getUniqueMapping spmMapping
311 update mmId [ MailboxMappingReject =. view _SpmMappingStateReject mappingState ]
312 return NoContent
273 313
274main :: IO () 314main :: IO ()
275main = runSystemdWarp systemdSettings warpSettings =<< mkSpmApp 315main = 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|
69 extension MailExtension Maybe 69 extension MailExtension Maybe
70 domain MailDomain 70 domain MailDomain
71 mailbox MailboxId 71 mailbox MailboxId
72 reject Bool
73 UniqueDomain domain sql=domain_unique !force
72 UniqueLocalDomain local domain sql=local_domain_unique !force 74 UniqueLocalDomain local domain sql=local_domain_unique !force
75 UniqueLocalExtensionDomain local extension domain sql=local_extension_domain_unique !force
73|] 76|]