summaryrefslogtreecommitdiff
path: root/overlays/spm
diff options
context:
space:
mode:
Diffstat (limited to 'overlays/spm')
-rw-r--r--overlays/spm/lib/Spm/Api.hs55
-rw-r--r--overlays/spm/server/Spm/Server.hs40
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
5 , SpmMailbox, SpmDomain 5 , SpmMailbox, SpmDomain
6 , SpmLocal(..), SpmExtension(..) 6 , SpmLocal(..), SpmExtension(..)
7 , SpmMapping(..), SpmMappingState(..), SpmMappingListingItem(..), SpmMappingListing(..) 7 , SpmMapping(..), SpmMappingState(..), SpmMappingListingItem(..), SpmMappingListing(..)
8 , _SpmMappingStateReject 8 , _SpmMappingText, _SpmMappingStateReject
9 , spmMappingAncestors
9 , SpmApi, spmApi 10 , SpmApi, spmApi
10 ) where 11 ) where
11 12
@@ -40,9 +41,6 @@ import Data.Aeson.Casing
40 41
41import Data.Aeson (ToJSON, FromJSON) 42import Data.Aeson (ToJSON, FromJSON)
42 43
43import Control.Monad
44import Control.Applicative
45
46 44
47data SpmStyle = SpmWords | SpmConsonants 45data SpmStyle = SpmWords | SpmConsonants
48 deriving (Eq, Ord, Read, Show, Bounded, Enum) 46 deriving (Eq, Ord, Read, Show, Bounded, Enum)
@@ -116,20 +114,44 @@ data SpmMapping = SpmMapping
116 { spmMappingLocal :: Maybe SpmLocal 114 { spmMappingLocal :: Maybe SpmLocal
117 , spmMappingExtension :: Maybe SpmExtension 115 , spmMappingExtension :: Maybe SpmExtension
118 } deriving stock (Eq, Ord, Read, Show, Generic, Typeable) 116 } deriving stock (Eq, Ord, Read, Show, Generic, Typeable)
117
118_SpmMappingText :: Iso' SpmMapping Text
119_SpmMappingText = iso toText fromText
120 where
121 toText :: SpmMapping -> Text
122 toText SpmMapping{..} = maybe "" (CI.original . unSpmLocal) spmMappingLocal
123 <> maybe "" (("+" <>) . CI.original . unSpmExtension) spmMappingExtension
124
125 fromText :: Text -> SpmMapping
126 fromText t = case ts ^? _Snoc of
127 Nothing -> SpmMapping{ spmMappingLocal = Nothing, spmMappingExtension = Nothing }
128 Just (tInit, tLast) -> SpmMapping
129 { spmMappingLocal = fmap (SpmLocal . CI.mk) . assertNonEmpty $ Text.intercalate extSep tInit
130 , spmMappingExtension = fmap (SpmExtension . CI.mk) $ assertNonEmpty tLast
131 }
132 where
133 extSep = "+"
134
135 ts = Text.splitOn extSep t
136
137 assertNonEmpty :: Text -> Maybe Text
138 assertNonEmpty t' | Text.null t' = Nothing
139 | otherwise = Just t'
140
119instance FromHttpApiData SpmMapping where 141instance FromHttpApiData SpmMapping where
120 parseUrlPiece t 142 parseUrlPiece = Right . review _SpmMappingText
121 | [ fmap (SpmLocal . CI.mk) . assertNonEmpty -> spmMappingLocal
122 , fmap (SpmExtension . CI.mk) . assertNonEmpty -> spmMappingExtension
123 ] <- Text.splitOn "+" t
124 , Just () <- void spmMappingLocal <|> void spmMappingExtension
125 = Right SpmMapping{..}
126 | otherwise = Left "Could not parse SpmMapping"
127 where assertNonEmpty :: Text -> Maybe Text
128 assertNonEmpty t' | Text.null t' = Nothing
129 | otherwise = Just t'
130instance ToHttpApiData SpmMapping where 143instance ToHttpApiData SpmMapping where
131 toUrlPiece SpmMapping{..} = maybe "" (CI.original . unSpmLocal) spmMappingLocal 144 toUrlPiece = view _SpmMappingText
132 <> maybe "" (("+" <>) . CI.original . unSpmExtension) spmMappingExtension 145
146spmMappingAncestors :: SpmMapping -> [SpmMapping]
147spmMappingAncestors spmMapping = case nextMapping of
148 Nothing -> []
149 Just next -> next : spmMappingAncestors next
150 where
151 nextMapping = case spmMapping of
152 SpmMapping{ spmMappingLocal, spmMappingExtension = Just _ } -> Just SpmMapping{spmMappingLocal, spmMappingExtension = Nothing}
153 SpmMapping{ spmMappingLocal = Just _ } -> Just SpmMapping{spmMappingLocal = Nothing, spmMappingExtension = Nothing}
154 SpmMapping{} -> Nothing
133 155
134deriveJSON (aesonPrefix trainCase) ''SpmMapping 156deriveJSON (aesonPrefix trainCase) ''SpmMapping
135makePrisms ''SpmMappingState 157makePrisms ''SpmMappingState
@@ -151,6 +173,7 @@ type SpmApi = "whoami" :> Get '[PlainText, JSON] SpmMailbox
151 :<|> "mappings" :> Get '[JSON] SpmMappingListing 173 :<|> "mappings" :> Get '[JSON] SpmMappingListing
152 :<|> "mappings" :> Capture "mapping" SpmMapping :> Get '[PlainText, JSON] SpmMappingState 174 :<|> "mappings" :> Capture "mapping" SpmMapping :> Get '[PlainText, JSON] SpmMappingState
153 :<|> "mappings" :> Capture "mapping" SpmMapping :> ReqBody '[PlainText, JSON] SpmMappingState :> PatchNoContent 175 :<|> "mappings" :> Capture "mapping" SpmMapping :> ReqBody '[PlainText, JSON] SpmMappingState :> PatchNoContent
176 :<|> "mappings" :> Capture "mapping" SpmMapping :> ReqBody '[PlainText, JSON] SpmMappingState :> PutNoContent
154 177
155spmApi :: Proxy SpmApi 178spmApi :: Proxy SpmApi
156spmApi = Proxy 179spmApi = 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
222 :<|> listMappings 222 :<|> listMappings
223 :<|> getMapping 223 :<|> getMapping
224 :<|> patchMapping 224 :<|> patchMapping
225 :<|> putMapping
225 where 226 where
226 whoami = do 227 whoami = do
227 Entity _ Mailbox{mailboxIdent} <- maybe (throwError err404) return <=< spmSql . getBy $ UniqueMailbox mbox 228 Entity _ Mailbox{mailboxIdent} <- maybe (throwError err404) return <=< spmSql . getBy $ UniqueMailbox mbox
@@ -313,6 +314,45 @@ spmServer dom mbox = whoami
313 update mmId [ MailboxMappingReject =. view _SpmMappingStateReject mappingState ] 314 update mmId [ MailboxMappingReject =. view _SpmMappingStateReject mappingState ]
314 return NoContent 315 return NoContent
315 316
317 putMapping spmMapping mappingState = spmSql $ do
318 Entity mailboxId _ <- maybe (throwError err404) return <=< getBy $ UniqueMailbox mbox
319
320 existing <- selectList
321 [ MailboxMappingLocal ==. (spmMappingLocal spmMapping <&> view (_Wrapped . _Unwrapped))
322 , MailboxMappingExtension ==. (spmMappingExtension spmMapping <&> view (_Wrapped . _Unwrapped))
323 , MailboxMappingDomain ==. dom
324 ]
325 [ LimitTo 1
326 ]
327 unless (null existing) $
328 throwError err409
329
330 let go [] = throwError err403
331 go (SpmMapping{..} : ancestors) = do
332 candidate <- selectList
333 [ MailboxMappingLocal ==. (spmMappingLocal <&> view (_Wrapped . _Unwrapped))
334 , MailboxMappingExtension ==. (spmMappingExtension <&> view (_Wrapped . _Unwrapped))
335 , MailboxMappingDomain ==. dom
336 ]
337 [ LimitTo 1
338 ]
339 case candidate of
340 [Entity _ MailboxMapping{..}] ->
341 unless (mailboxMappingMailbox == mailboxId) $
342 throwError err403
343 [] -> go ancestors
344 _other -> throwError err500
345 in go $ spmMappingAncestors spmMapping
346
347 insert_ MailboxMapping
348 { mailboxMappingLocal = (spmMappingLocal spmMapping <&> view (_Wrapped . _Unwrapped))
349 , mailboxMappingExtension = (spmMappingExtension spmMapping <&> view (_Wrapped . _Unwrapped))
350 , mailboxMappingDomain = dom
351 , mailboxMappingMailbox = mailboxId
352 , mailboxMappingReject = view _SpmMappingStateReject mappingState
353 }
354 return NoContent
355
316main :: IO () 356main :: IO ()
317main = runSystemdWarp systemdSettings warpSettings =<< mkSpmApp 357main = runSystemdWarp systemdSettings warpSettings =<< mkSpmApp
318 where 358 where