From 7d6e8a86997b41b351054cef0afc25646091a238 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Sun, 18 Dec 2022 18:56:13 +0100 Subject: ... --- overlays/spm/lib/Spm/Api.hs | 55 +++++++++++++++++++++++++++------------ overlays/spm/server/Spm/Server.hs | 40 ++++++++++++++++++++++++++++ 2 files changed, 79 insertions(+), 16 deletions(-) (limited to 'overlays/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 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 -- cgit v1.2.3