From 6f49d8632e6ceccb0399764e7da86cc4cba9ab04 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Fri, 16 Dec 2022 20:29:28 +0100 Subject: spm: list/get/patch mailbox mappings --- overlays/spm/lib/Spm/Api.hs | 114 +++++++++++++++++++++-------- overlays/spm/package.yaml | 2 + overlays/spm/server/Spm/Server.hs | 54 ++++++++++++-- overlays/spm/server/Spm/Server/Database.hs | 3 + overlays/spm/spm.nix | 20 ++--- 5 files changed, 145 insertions(+), 48 deletions(-) (limited to 'overlays/spm') 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 @@ module Spm.Api ( SpmStyle(..), _SpmWords, _SpmConsonants , SpmMailbox, SpmDomain + , SpmLocal(..), SpmExtension(..) + , SpmMapping(..), SpmMappingState(..), SpmMappingListingItem(..), SpmMappingListing(..) + , _SpmMappingStateReject , SpmApi, spmApi ) where @@ -13,11 +16,12 @@ import Servant.API import Data.Proxy (Proxy(..)) import Data.Text (Text) +import qualified Data.Text as Text import GHC.Generics (Generic) import Type.Reflection (Typeable) -import Control.Lens.TH +import Control.Lens import Data.CaseInsensitive (CI) import qualified Data.CaseInsensitive as CI @@ -31,8 +35,13 @@ import Data.UUID (UUID) import Data.UUID.Instances () import qualified Data.Aeson as JSON +import Data.Aeson.TH (deriveJSON) +import Data.Aeson.Casing --- import Data.Aeson (ToJSON, FromJSON) +import Data.Aeson (ToJSON, FromJSON) + +import Control.Monad +import Control.Applicative data SpmStyle = SpmWords | SpmConsonants @@ -48,7 +57,7 @@ instance FromHttpApiData SpmStyle where | t' == "words" = Right SpmWords | t' == "consonants" = Right SpmConsonants | otherwise = Left $ "Expected one of ‘words’ or ‘consonants’ but got ‘" <> t <> "’" - + newtype SpmMailbox = SpmMailbox { unSpmMailbox :: CI Text } deriving stock (Eq, Ord, Read, Show, Generic, Typeable) @@ -57,7 +66,7 @@ makeWrapped ''SpmMailbox instance MimeRender JSON SpmMailbox where mimeRender p mbox = mimeRender p $ JSON.object [ "mailbox" JSON..= unSpmMailbox mbox ] - + newtype SpmDomain = SpmDomain { unSpmDomain :: CI Text } deriving stock (Eq, Ord, Read, Show, Generic, Typeable) deriving newtype (MimeRender PlainText) @@ -66,31 +75,72 @@ makeWrapped ''SpmDomain instance MimeRender JSON SpmDomain where mimeRender p dom = mimeRender p $ JSON.object [ "domain" JSON..= unSpmDomain dom ] --- newtype SpmLocal = SpmLocal --- { unSpmLocal :: CI Text --- } deriving stock (Eq, Ord, Read, Show, Generic, Typeable) --- deriving newtype (ToJSON, FromJSON) --- makeWrapped ''SpmLocal --- newtype SpmExtension = SpmExtension --- { unSpmExtension :: CI Text --- } deriving stock (Eq, Ord, Read, Show, Generic, Typeable) --- deriving newtype (ToJSON, FromJSON) --- makeWrapped ''SpmExtension - --- newtype SpmMappingListing = SpmMappingListing { unSpmMappingListing :: Set SpmMapping } --- deriving stock (Eq, Ord, Read, Show, Generic, Typeable) --- instance ToJSON SpmMappingList where --- toJSON SpmMappingListing{..} = object [ "mappings" .= unSpmMappingListing ] - --- data SpmMapping = SpmMapping --- { spmMappingLocal :: Maybe SpmLocal --- , spmMappingExtension :: Maybe SpmExtension --- } deriving stock (Eq, Ord, Read, Show, Generic, Typeable) --- instance ToJSON SpmMapping where --- toJSON SpmMapping{..} = object --- [ "local" .= spmMappingLocal --- , "extension" .= spmMappingExtension --- ] +newtype SpmLocal = SpmLocal + { unSpmLocal :: CI Text + } deriving stock (Eq, Ord, Read, Show, Generic, Typeable) + deriving newtype (ToJSON, FromJSON) +makeWrapped ''SpmLocal +newtype SpmExtension = SpmExtension + { unSpmExtension :: CI Text + } deriving stock (Eq, Ord, Read, Show, Generic, Typeable) + deriving newtype (ToJSON, FromJSON) +makeWrapped ''SpmExtension + +data SpmMappingState = Valid | Reject + deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable) +instance MimeRender PlainText SpmMappingState where + mimeRender p = mimeRender @_ @Text p . \case + Valid -> "valid" + Reject -> "reject" +instance MimeUnrender PlainText SpmMappingState where + mimeUnrender p bs = mimeUnrender @_ @Text p bs >>= \(CI.mk . Text.strip -> t) -> if + | t == "valid" -> Right Valid + | t == "reject" -> Right Reject + | otherwise -> Left "Could not parse SpmMappingState" +_SpmMappingStateReject :: Iso' SpmMappingState Bool +_SpmMappingStateReject = iso toReject fromReject + where toReject Valid = False + toReject Reject = True + fromReject True = Reject + fromReject False = Valid + +data SpmMappingListingItem = SpmMappingListingItem + { smlMapping :: SpmMapping + , smlState :: SpmMappingState + } deriving (Eq, Ord, Read, Show, Generic, Typeable) + +newtype SpmMappingListing = SpmMappingListing { unSpmMappingListing :: [SpmMappingListingItem] } + deriving stock (Eq, Ord, Read, Show, Generic, Typeable) + +data SpmMapping = SpmMapping + { spmMappingLocal :: Maybe SpmLocal + , spmMappingExtension :: Maybe SpmExtension + } deriving stock (Eq, Ord, Read, Show, Generic, Typeable) +instance FromHttpApiData SpmMapping where + parseUrlPiece t + | [ fmap (SpmLocal . CI.mk) . assertNonEmpty -> spmMappingLocal + , fmap (SpmExtension . CI.mk) . assertNonEmpty -> spmMappingExtension + ] <- Text.splitOn "+" t + , Just () <- void spmMappingLocal <|> void spmMappingExtension + = Right SpmMapping{..} + | otherwise = Left "Could not parse SpmMapping" + where assertNonEmpty :: Text -> Maybe Text + assertNonEmpty t' | Text.null t' = Nothing + | otherwise = Just t' +instance ToHttpApiData SpmMapping where + toUrlPiece SpmMapping{..} = maybe "" (CI.original . unSpmLocal) spmMappingLocal + <> maybe "" (("+" <>) . CI.original . unSpmExtension) spmMappingExtension + +deriveJSON (aesonPrefix trainCase) ''SpmMapping +makePrisms ''SpmMappingState +deriveJSON JSON.defaultOptions + { JSON.constructorTagModifier = trainCase + } ''SpmMappingState +deriveJSON (aesonPrefix trainCase) ''SpmMappingListingItem + +instance ToJSON SpmMappingListing where + toJSON SpmMappingListing{..} = JSON.object [ "mappings" JSON..= unSpmMappingListing ] + type SpmApi = "whoami" :> Get '[PlainText, JSON] SpmMailbox :<|> "domain" :> Get '[PlainText, JSON] SpmDomain @@ -98,9 +148,9 @@ type SpmApi = "whoami" :> Get '[PlainText, JSON] SpmMailbox :<|> "instance-id" :> Get '[PlainText, JSON, OctetStream] UUID :<|> "spm" :> "generate" :> QueryParam "style" SpmStyle :> Get '[PlainText, JSON, OctetStream] SignedJWT :<|> "spm" :> "claim" :> ReqBody '[PlainText, JSON, OctetStream] SignedJWT :> PostNoContent - -- :<|> "mappings" :> Get '[PlainText, JSON] SpmMappingListing - -- :<|> "mappings" :> Capture SpmMapping :> GetNoContent - -- :<|> "mappings" :> Capture SpmMapping :> DeleteNoContent + :<|> "mappings" :> Get '[JSON] SpmMappingListing + :<|> "mappings" :> Capture "mapping" SpmMapping :> Get '[PlainText, JSON] SpmMappingState + :<|> "mappings" :> Capture "mapping" SpmMapping :> ReqBody '[PlainText, JSON] SpmMappingState :> PatchNoContent spmApi :: Proxy SpmApi spmApi = 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: - aeson - jose - uuid + - containers + - aeson-casing source-dirs: - lib 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 |] 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 @@ -{ mkDerivation, aeson, attoparsec, base, bytestring -, case-insensitive, cryptonite, exceptions, file-embed, filepath -, hpack, http-api-data, http-types, jose, lens, lens-aeson, lib -, mmorph, monad-logger, MonadRandom, mtl, optparse-applicative -, path-pieces, persistent, persistent-postgresql, random -, resource-pool, servant, servant-server, template-haskell, text -, th-lift-instances, time, transformers, unliftio-core, uuid -, vector, wai, wai-app-static, wai-extra, warp, warp-systemd +{ mkDerivation, aeson, aeson-casing, attoparsec, base, bytestring +, case-insensitive, containers, cryptonite, exceptions, file-embed +, filepath, hpack, http-api-data, http-types, jose, lens +, lens-aeson, lib, mmorph, monad-logger, MonadRandom, mtl +, optparse-applicative, path-pieces, persistent +, persistent-postgresql, random, resource-pool, servant +, servant-server, template-haskell, text, th-lift-instances, time +, transformers, unliftio-core, uuid, vector, wai, wai-app-static +, wai-extra, warp, warp-systemd }: mkDerivation { pname = "spm"; @@ -14,7 +15,8 @@ mkDerivation { isLibrary = true; isExecutable = true; libraryHaskellDepends = [ - aeson base case-insensitive jose lens servant text uuid + aeson aeson-casing base case-insensitive containers jose lens + servant text uuid ]; libraryToolDepends = [ hpack ]; executableHaskellDepends = [ -- cgit v1.2.3