From 7d6e8a86997b41b351054cef0afc25646091a238 Mon Sep 17 00:00:00 2001
From: Gregor Kleen <gkleen@yggdrasil.li>
Date: Sun, 18 Dec 2022 18:56:13 +0100
Subject: ...

---
 overlays/spm/lib/Spm/Api.hs | 55 ++++++++++++++++++++++++++++++++-------------
 1 file changed, 39 insertions(+), 16 deletions(-)

(limited to 'overlays/spm/lib/Spm')

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
-- 
cgit v1.2.3