summaryrefslogtreecommitdiff
path: root/overlays
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
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')
-rw-r--r--overlays/spm/lib/Spm/Api.hs114
-rw-r--r--overlays/spm/package.yaml2
-rw-r--r--overlays/spm/server/Spm/Server.hs54
-rw-r--r--overlays/spm/server/Spm/Server/Database.hs3
-rw-r--r--overlays/spm/spm.nix20
5 files changed, 145 insertions, 48 deletions
diff --git a/overlays/spm/lib/Spm/Api.hs b/overlays/spm/lib/Spm/Api.hs
index c44a7951..af7ae94c 100644
--- a/overlays/spm/lib/Spm/Api.hs
+++ b/overlays/spm/lib/Spm/Api.hs
@@ -3,6 +3,9 @@
3module Spm.Api 3module Spm.Api
4 ( SpmStyle(..), _SpmWords, _SpmConsonants 4 ( SpmStyle(..), _SpmWords, _SpmConsonants
5 , SpmMailbox, SpmDomain 5 , SpmMailbox, SpmDomain
6 , SpmLocal(..), SpmExtension(..)
7 , SpmMapping(..), SpmMappingState(..), SpmMappingListingItem(..), SpmMappingListing(..)
8 , _SpmMappingStateReject
6 , SpmApi, spmApi 9 , SpmApi, spmApi
7 ) where 10 ) where
8 11
@@ -13,11 +16,12 @@ import Servant.API
13import Data.Proxy (Proxy(..)) 16import Data.Proxy (Proxy(..))
14 17
15import Data.Text (Text) 18import Data.Text (Text)
19import qualified Data.Text as Text
16 20
17import GHC.Generics (Generic) 21import GHC.Generics (Generic)
18import Type.Reflection (Typeable) 22import Type.Reflection (Typeable)
19 23
20import Control.Lens.TH 24import Control.Lens
21 25
22import Data.CaseInsensitive (CI) 26import Data.CaseInsensitive (CI)
23import qualified Data.CaseInsensitive as CI 27import qualified Data.CaseInsensitive as CI
@@ -31,8 +35,13 @@ import Data.UUID (UUID)
31import Data.UUID.Instances () 35import Data.UUID.Instances ()
32 36
33import qualified Data.Aeson as JSON 37import qualified Data.Aeson as JSON
38import Data.Aeson.TH (deriveJSON)
39import Data.Aeson.Casing
34 40
35-- import Data.Aeson (ToJSON, FromJSON) 41import Data.Aeson (ToJSON, FromJSON)
42
43import Control.Monad
44import Control.Applicative
36 45
37 46
38data SpmStyle = SpmWords | SpmConsonants 47data SpmStyle = SpmWords | SpmConsonants
@@ -48,7 +57,7 @@ instance FromHttpApiData SpmStyle where
48 | t' == "words" = Right SpmWords 57 | t' == "words" = Right SpmWords
49 | t' == "consonants" = Right SpmConsonants 58 | t' == "consonants" = Right SpmConsonants
50 | otherwise = Left $ "Expected one of ‘words’ or ‘consonants’ but got ‘" <> t <> "’" 59 | otherwise = Left $ "Expected one of ‘words’ or ‘consonants’ but got ‘" <> t <> "’"
51 60
52 61
53newtype SpmMailbox = SpmMailbox { unSpmMailbox :: CI Text } 62newtype SpmMailbox = SpmMailbox { unSpmMailbox :: CI Text }
54 deriving stock (Eq, Ord, Read, Show, Generic, Typeable) 63 deriving stock (Eq, Ord, Read, Show, Generic, Typeable)
@@ -57,7 +66,7 @@ makeWrapped ''SpmMailbox
57 66
58instance MimeRender JSON SpmMailbox where 67instance MimeRender JSON SpmMailbox where
59 mimeRender p mbox = mimeRender p $ JSON.object [ "mailbox" JSON..= unSpmMailbox mbox ] 68 mimeRender p mbox = mimeRender p $ JSON.object [ "mailbox" JSON..= unSpmMailbox mbox ]
60 69
61newtype SpmDomain = SpmDomain { unSpmDomain :: CI Text } 70newtype SpmDomain = SpmDomain { unSpmDomain :: CI Text }
62 deriving stock (Eq, Ord, Read, Show, Generic, Typeable) 71 deriving stock (Eq, Ord, Read, Show, Generic, Typeable)
63 deriving newtype (MimeRender PlainText) 72 deriving newtype (MimeRender PlainText)
@@ -66,31 +75,72 @@ makeWrapped ''SpmDomain
66instance MimeRender JSON SpmDomain where 75instance MimeRender JSON SpmDomain where
67 mimeRender p dom = mimeRender p $ JSON.object [ "domain" JSON..= unSpmDomain dom ] 76 mimeRender p dom = mimeRender p $ JSON.object [ "domain" JSON..= unSpmDomain dom ]
68 77
69-- newtype SpmLocal = SpmLocal 78newtype SpmLocal = SpmLocal
70-- { unSpmLocal :: CI Text 79 { unSpmLocal :: CI Text
71-- } deriving stock (Eq, Ord, Read, Show, Generic, Typeable) 80 } deriving stock (Eq, Ord, Read, Show, Generic, Typeable)
72-- deriving newtype (ToJSON, FromJSON) 81 deriving newtype (ToJSON, FromJSON)
73-- makeWrapped ''SpmLocal 82makeWrapped ''SpmLocal
74-- newtype SpmExtension = SpmExtension 83newtype SpmExtension = SpmExtension
75-- { unSpmExtension :: CI Text 84 { unSpmExtension :: CI Text
76-- } deriving stock (Eq, Ord, Read, Show, Generic, Typeable) 85 } deriving stock (Eq, Ord, Read, Show, Generic, Typeable)
77-- deriving newtype (ToJSON, FromJSON) 86 deriving newtype (ToJSON, FromJSON)
78-- makeWrapped ''SpmExtension 87makeWrapped ''SpmExtension
79 88
80-- newtype SpmMappingListing = SpmMappingListing { unSpmMappingListing :: Set SpmMapping } 89data SpmMappingState = Valid | Reject
81-- deriving stock (Eq, Ord, Read, Show, Generic, Typeable) 90 deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable)
82-- instance ToJSON SpmMappingList where 91instance MimeRender PlainText SpmMappingState where
83-- toJSON SpmMappingListing{..} = object [ "mappings" .= unSpmMappingListing ] 92 mimeRender p = mimeRender @_ @Text p . \case
84 93 Valid -> "valid"
85-- data SpmMapping = SpmMapping 94 Reject -> "reject"
86-- { spmMappingLocal :: Maybe SpmLocal 95instance MimeUnrender PlainText SpmMappingState where
87-- , spmMappingExtension :: Maybe SpmExtension 96 mimeUnrender p bs = mimeUnrender @_ @Text p bs >>= \(CI.mk . Text.strip -> t) -> if
88-- } deriving stock (Eq, Ord, Read, Show, Generic, Typeable) 97 | t == "valid" -> Right Valid
89-- instance ToJSON SpmMapping where 98 | t == "reject" -> Right Reject
90-- toJSON SpmMapping{..} = object 99 | otherwise -> Left "Could not parse SpmMappingState"
91-- [ "local" .= spmMappingLocal 100_SpmMappingStateReject :: Iso' SpmMappingState Bool
92-- , "extension" .= spmMappingExtension 101_SpmMappingStateReject = iso toReject fromReject
93-- ] 102 where toReject Valid = False
103 toReject Reject = True
104 fromReject True = Reject
105 fromReject False = Valid
106
107data SpmMappingListingItem = SpmMappingListingItem
108 { smlMapping :: SpmMapping
109 , smlState :: SpmMappingState
110 } deriving (Eq, Ord, Read, Show, Generic, Typeable)
111
112newtype SpmMappingListing = SpmMappingListing { unSpmMappingListing :: [SpmMappingListingItem] }
113 deriving stock (Eq, Ord, Read, Show, Generic, Typeable)
114
115data SpmMapping = SpmMapping
116 { spmMappingLocal :: Maybe SpmLocal
117 , spmMappingExtension :: Maybe SpmExtension
118 } deriving stock (Eq, Ord, Read, Show, Generic, Typeable)
119instance FromHttpApiData SpmMapping where
120 parseUrlPiece t
121 | [ fmap (SpmLocal . CI.mk) . assertNonEmpty -> spmMappingLocal
122 , fmap (SpmExtension . CI.mk) . assertNonEmpty -> spmMappingExtension
123 ] <- Text.splitOn "+" t
124 , Just () <- void spmMappingLocal <|> void spmMappingExtension
125 = Right SpmMapping{..}
126 | otherwise = Left "Could not parse SpmMapping"
127 where assertNonEmpty :: Text -> Maybe Text
128 assertNonEmpty t' | Text.null t' = Nothing
129 | otherwise = Just t'
130instance ToHttpApiData SpmMapping where
131 toUrlPiece SpmMapping{..} = maybe "" (CI.original . unSpmLocal) spmMappingLocal
132 <> maybe "" (("+" <>) . CI.original . unSpmExtension) spmMappingExtension
133
134deriveJSON (aesonPrefix trainCase) ''SpmMapping
135makePrisms ''SpmMappingState
136deriveJSON JSON.defaultOptions
137 { JSON.constructorTagModifier = trainCase
138 } ''SpmMappingState
139deriveJSON (aesonPrefix trainCase) ''SpmMappingListingItem
140
141instance ToJSON SpmMappingListing where
142 toJSON SpmMappingListing{..} = JSON.object [ "mappings" JSON..= unSpmMappingListing ]
143
94 144
95type SpmApi = "whoami" :> Get '[PlainText, JSON] SpmMailbox 145type SpmApi = "whoami" :> Get '[PlainText, JSON] SpmMailbox
96 :<|> "domain" :> Get '[PlainText, JSON] SpmDomain 146 :<|> "domain" :> Get '[PlainText, JSON] SpmDomain
@@ -98,9 +148,9 @@ type SpmApi = "whoami" :> Get '[PlainText, JSON] SpmMailbox
98 :<|> "instance-id" :> Get '[PlainText, JSON, OctetStream] UUID 148 :<|> "instance-id" :> Get '[PlainText, JSON, OctetStream] UUID
99 :<|> "spm" :> "generate" :> QueryParam "style" SpmStyle :> Get '[PlainText, JSON, OctetStream] SignedJWT 149 :<|> "spm" :> "generate" :> QueryParam "style" SpmStyle :> Get '[PlainText, JSON, OctetStream] SignedJWT
100 :<|> "spm" :> "claim" :> ReqBody '[PlainText, JSON, OctetStream] SignedJWT :> PostNoContent 150 :<|> "spm" :> "claim" :> ReqBody '[PlainText, JSON, OctetStream] SignedJWT :> PostNoContent
101 -- :<|> "mappings" :> Get '[PlainText, JSON] SpmMappingListing 151 :<|> "mappings" :> Get '[JSON] SpmMappingListing
102 -- :<|> "mappings" :> Capture SpmMapping :> GetNoContent 152 :<|> "mappings" :> Capture "mapping" SpmMapping :> Get '[PlainText, JSON] SpmMappingState
103 -- :<|> "mappings" :> Capture SpmMapping :> DeleteNoContent 153 :<|> "mappings" :> Capture "mapping" SpmMapping :> ReqBody '[PlainText, JSON] SpmMappingState :> PatchNoContent
104 154
105spmApi :: Proxy SpmApi 155spmApi :: Proxy SpmApi
106spmApi = Proxy 156spmApi = Proxy
diff --git a/overlays/spm/package.yaml b/overlays/spm/package.yaml
index c1440846..f898b94f 100644
--- a/overlays/spm/package.yaml
+++ b/overlays/spm/package.yaml
@@ -38,6 +38,8 @@ library:
38 - aeson 38 - aeson
39 - jose 39 - jose
40 - uuid 40 - uuid
41 - containers
42 - aeson-casing
41 source-dirs: 43 source-dirs:
42 - lib 44 - lib
43 45
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|]
diff --git a/overlays/spm/spm.nix b/overlays/spm/spm.nix
index 533f190a..2abebe64 100644
--- a/overlays/spm/spm.nix
+++ b/overlays/spm/spm.nix
@@ -1,11 +1,12 @@
1{ mkDerivation, aeson, attoparsec, base, bytestring 1{ mkDerivation, aeson, aeson-casing, attoparsec, base, bytestring
2, case-insensitive, cryptonite, exceptions, file-embed, filepath 2, case-insensitive, containers, cryptonite, exceptions, file-embed
3, hpack, http-api-data, http-types, jose, lens, lens-aeson, lib 3, filepath, hpack, http-api-data, http-types, jose, lens
4, mmorph, monad-logger, MonadRandom, mtl, optparse-applicative 4, lens-aeson, lib, mmorph, monad-logger, MonadRandom, mtl
5, path-pieces, persistent, persistent-postgresql, random 5, optparse-applicative, path-pieces, persistent
6, resource-pool, servant, servant-server, template-haskell, text 6, persistent-postgresql, random, resource-pool, servant
7, th-lift-instances, time, transformers, unliftio-core, uuid 7, servant-server, template-haskell, text, th-lift-instances, time
8, vector, wai, wai-app-static, wai-extra, warp, warp-systemd 8, transformers, unliftio-core, uuid, vector, wai, wai-app-static
9, wai-extra, warp, warp-systemd
9}: 10}:
10mkDerivation { 11mkDerivation {
11 pname = "spm"; 12 pname = "spm";
@@ -14,7 +15,8 @@ mkDerivation {
14 isLibrary = true; 15 isLibrary = true;
15 isExecutable = true; 16 isExecutable = true;
16 libraryHaskellDepends = [ 17 libraryHaskellDepends = [
17 aeson base case-insensitive jose lens servant text uuid 18 aeson aeson-casing base case-insensitive containers jose lens
19 servant text uuid
18 ]; 20 ];
19 libraryToolDepends = [ hpack ]; 21 libraryToolDepends = [ hpack ];
20 executableHaskellDepends = [ 22 executableHaskellDepends = [