2 files changed, 79 insertions, 16 deletions

diff --git a/overlays/spm/lib/Spm/Api.hs b/overlays/spm/lib/Spm/Api.hs
index af7ae94c..ce4ee2d9 100644
--- a/overlays/spm/lib/Spm/Api.hs
+++ b/overlays/spm/lib/Spm/Api.hs
@@ -5,7 +5,8 @@ module Spm.Api
   , SpmMailbox, SpmDomain
   , SpmLocal(..), SpmExtension(..)
   , SpmMapping(..), SpmMappingState(..), SpmMappingListingItem(..), SpmMappingListing(..)
-  , _SpmMappingStateReject
+  , _SpmMappingText, _SpmMappingStateReject
+  , spmMappingAncestors
   , SpmApi, spmApi
   ) where
 
@@ -40,9 +41,6 @@ import Data.Aeson.Casing
 
 import Data.Aeson (ToJSON, FromJSON)
 
-import Control.Monad
-import Control.Applicative
-
 
 data SpmStyle = SpmWords | SpmConsonants
   deriving (Eq, Ord, Read, Show, Bounded, Enum)
@@ -116,20 +114,44 @@ data SpmMapping = SpmMapping
   { spmMappingLocal :: Maybe SpmLocal
   , spmMappingExtension :: Maybe SpmExtension
   } deriving stock (Eq, Ord, Read, Show, Generic, Typeable)
+
+_SpmMappingText :: Iso' SpmMapping Text
+_SpmMappingText = iso toText fromText
+  where
+    toText :: SpmMapping -> Text
+    toText SpmMapping{..} = maybe "" (CI.original . unSpmLocal) spmMappingLocal
+                         <> maybe "" (("+" <>) . CI.original . unSpmExtension) spmMappingExtension
+
+    fromText :: Text -> SpmMapping
+    fromText t = case ts ^? _Snoc of
+        Nothing -> SpmMapping{ spmMappingLocal = Nothing, spmMappingExtension = Nothing }
+        Just (tInit, tLast) -> SpmMapping
+          { spmMappingLocal = fmap (SpmLocal . CI.mk) . assertNonEmpty $ Text.intercalate extSep tInit
+          , spmMappingExtension = fmap (SpmExtension . CI.mk) $ assertNonEmpty tLast
+          }
+      where
+        extSep = "+"
+
+        ts = Text.splitOn extSep t
+
+        assertNonEmpty :: Text -> Maybe Text
+        assertNonEmpty t' | Text.null t' = Nothing
+                          | otherwise = Just t'
+
 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'
+  parseUrlPiece = Right . review _SpmMappingText
 instance ToHttpApiData SpmMapping where
-  toUrlPiece SpmMapping{..} = maybe "" (CI.original . unSpmLocal) spmMappingLocal
-                           <> maybe "" (("+" <>) . CI.original . unSpmExtension) spmMappingExtension
+  toUrlPiece = view _SpmMappingText
+
+spmMappingAncestors :: SpmMapping -> [SpmMapping]
+spmMappingAncestors spmMapping = case nextMapping of
+    Nothing -> []
+    Just next -> next : spmMappingAncestors next
+  where
+    nextMapping = case spmMapping of
+      SpmMapping{ spmMappingLocal, spmMappingExtension = Just _ } -> Just SpmMapping{spmMappingLocal, spmMappingExtension = Nothing}
+      SpmMapping{ spmMappingLocal = Just _ } -> Just SpmMapping{spmMappingLocal = Nothing, spmMappingExtension = Nothing}
+      SpmMapping{} -> Nothing
 
 deriveJSON (aesonPrefix trainCase) ''SpmMapping
 makePrisms ''SpmMappingState
@@ -151,6 +173,7 @@ type SpmApi = "whoami" :> Get '[PlainText, JSON] SpmMailbox
          :<|> "mappings" :> Get '[JSON] SpmMappingListing
          :<|> "mappings" :> Capture "mapping" SpmMapping :> Get '[PlainText, JSON] SpmMappingState
          :<|> "mappings" :> Capture "mapping" SpmMapping :> ReqBody '[PlainText, JSON] SpmMappingState :> PatchNoContent
+         :<|> "mappings" :> Capture "mapping" SpmMapping :> ReqBody '[PlainText, JSON] SpmMappingState :> PutNoContent
 
 spmApi :: Proxy SpmApi
 spmApi = Proxy
diff --git a/overlays/spm/server/Spm/Server.hs b/overlays/spm/server/Spm/Server.hs
index 86d7d02b..d8efd826 100644
--- a/overlays/spm/server/Spm/Server.hs
+++ b/overlays/spm/server/Spm/Server.hs
@@ -222,6 +222,7 @@ spmServer dom mbox = whoami
                 :<|> listMappings
                 :<|> getMapping
                 :<|> patchMapping
+                :<|> putMapping
   where
     whoami = do
       Entity _ Mailbox{mailboxIdent} <- maybe (throwError err404) return <=< spmSql . getBy $ UniqueMailbox mbox
@@ -313,6 +314,45 @@ spmServer dom mbox = whoami
       update mmId [ MailboxMappingReject =. view _SpmMappingStateReject mappingState ]
       return NoContent
 
+    putMapping spmMapping mappingState = spmSql $ do
+      Entity mailboxId _ <- maybe (throwError err404) return <=< getBy $ UniqueMailbox mbox
+
+      existing <- selectList
+        [ MailboxMappingLocal ==. (spmMappingLocal spmMapping <&> view (_Wrapped . _Unwrapped))
+        , MailboxMappingExtension ==. (spmMappingExtension spmMapping <&> view (_Wrapped . _Unwrapped))
+        , MailboxMappingDomain ==. dom
+        ]
+        [ LimitTo 1
+        ]
+      unless (null existing) $
+        throwError err409
+
+      let go [] = throwError err403
+          go (SpmMapping{..} : ancestors) = do
+            candidate <- selectList
+              [ MailboxMappingLocal ==. (spmMappingLocal <&> view (_Wrapped . _Unwrapped))
+              , MailboxMappingExtension ==. (spmMappingExtension <&> view (_Wrapped . _Unwrapped))
+              , MailboxMappingDomain ==. dom
+              ]
+              [ LimitTo 1
+              ]
+            case candidate of
+              [Entity _ MailboxMapping{..}] ->
+                unless (mailboxMappingMailbox == mailboxId) $
+                  throwError err403
+              [] -> go ancestors
+              _other -> throwError err500
+       in go $ spmMappingAncestors spmMapping
+
+      insert_ MailboxMapping
+        { mailboxMappingLocal = (spmMappingLocal spmMapping <&> view (_Wrapped . _Unwrapped))
+        , mailboxMappingExtension = (spmMappingExtension spmMapping <&> view (_Wrapped . _Unwrapped))
+        , mailboxMappingDomain = dom
+        , mailboxMappingMailbox = mailboxId
+        , mailboxMappingReject = view _SpmMappingStateReject mappingState
+        }
+      return NoContent
+
 main :: IO ()
 main = runSystemdWarp systemdSettings warpSettings =<< mkSpmApp
   where