summaryrefslogtreecommitdiff
path: root/overlays/spm/lib
diff options
context:
space:
mode:
Diffstat (limited to 'overlays/spm/lib')
-rw-r--r--overlays/spm/lib/Spm/Api.hs55
1 files changed, 39 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