From 6f49d8632e6ceccb0399764e7da86cc4cba9ab04 Mon Sep 17 00:00:00 2001
From: Gregor Kleen <gkleen@yggdrasil.li>
Date: Fri, 16 Dec 2022 20:29:28 +0100
Subject: spm: list/get/patch mailbox mappings

---
 overlays/spm/lib/Spm/Api.hs | 114 +++++++++++++++++++++++++++++++-------------
 1 file changed, 82 insertions(+), 32 deletions(-)

(limited to 'overlays/spm/lib')

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