spm: list/get/patch mailbox mappings

6 files changed, 160 insertions, 48 deletions

diff --git a/hosts/surtr/postgresql/default.nix b/hosts/surtr/postgresql/default.nix
index 9cf494ae..907c652d 100644
--- a/hosts/surtr/postgresql/default.nix
+++ b/hosts/surtr/postgresql/default.nix
@@ -220,6 +220,21 @@ in {
           ALTER DEFAULT PRIVILEGES IN SCHEMA public GRANT SELECT ON TABLES TO "postfix-ccert-sender-policy";
           GRANT SELECT ON ALL TABLES IN SCHEMA public TO "postfix-ccert-sender-policy";
           COMMIT;
+
+          BEGIN;
+          SELECT _v.register_patch('008-mailbox-mapping-claim', ARRAY['000-base', '002-citext', '003-extensions'], null);
+          ALTER TABLE mailbox_mapping DROP CONSTRAINT mailbox_mapping_extension_check;
+          ALTER TABLE mailbox_mapping ADD CONSTRAINT mailbox_mapping_extension_check CHECK (CASE WHEN extension IS NOT NULL THEN extension NOT LIKE '%+%' AND extension <> ''' AND local IS DISTINCT FROM ''' ELSE true END);
+
+          ALTER TABLE mailbox_mapping DROP CONSTRAINT local_domain_unique;
+          ALTER TABLE mailbox_mapping ADD CONSTRAINT local_domain_unique UNIQUE (local, domain) WHERE extension IS null;
+
+          ALTER TABLE mailbox_mapping ADD CONSTRAINT local_extension_domain_unique UNIQUE (local, extension, domain);
+
+          ALTER TABLE mailbox_mapping ADD COLUMN reject bool NOT NULL DEFAULT false;
+
+          CREATE OR REPLACE VIEW virtual_mailbox_access (lookup, action) AS SELECT (CASE WHEN local IS NULL THEN ''' ELSE local END) || (CASE WHEN extension IS NULL THEN ''' ELSE '+' || extension END) || '@' || domain AS lookup, CASE WHEN mailbox IS NULL OR reject THEN 'REJECT' ELSE 'DUNNO' END AS action FROM mailbox_mapping;
+          COMMIT;
         ''}
 
         psql etebase postgres -eXf ${pkgs.writeText "etebase.sql" ''
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 = [