summaryrefslogtreecommitdiff
path: root/overlays/spm/lib/Spm
diff options
context:
space:
mode:
Diffstat (limited to 'overlays/spm/lib/Spm')
-rw-r--r--overlays/spm/lib/Spm/Api.hs114
1 files changed, 82 insertions, 32 deletions
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 @@
3module Spm.Api 3module Spm.Api
4 ( SpmStyle(..), _SpmWords, _SpmConsonants 4 ( SpmStyle(..), _SpmWords, _SpmConsonants
5 , SpmMailbox, SpmDomain 5 , SpmMailbox, SpmDomain
6 , SpmLocal(..), SpmExtension(..)
7 , SpmMapping(..), SpmMappingState(..), SpmMappingListingItem(..), SpmMappingListing(..)
8 , _SpmMappingStateReject
6 , SpmApi, spmApi 9 , SpmApi, spmApi
7 ) where 10 ) where
8 11
@@ -13,11 +16,12 @@ import Servant.API
13import Data.Proxy (Proxy(..)) 16import Data.Proxy (Proxy(..))
14 17
15import Data.Text (Text) 18import Data.Text (Text)
19import qualified Data.Text as Text
16 20
17import GHC.Generics (Generic) 21import GHC.Generics (Generic)
18import Type.Reflection (Typeable) 22import Type.Reflection (Typeable)
19 23
20import Control.Lens.TH 24import Control.Lens
21 25
22import Data.CaseInsensitive (CI) 26import Data.CaseInsensitive (CI)
23import qualified Data.CaseInsensitive as CI 27import qualified Data.CaseInsensitive as CI
@@ -31,8 +35,13 @@ import Data.UUID (UUID)
31import Data.UUID.Instances () 35import Data.UUID.Instances ()
32 36
33import qualified Data.Aeson as JSON 37import qualified Data.Aeson as JSON
38import Data.Aeson.TH (deriveJSON)
39import Data.Aeson.Casing
34 40
35-- import Data.Aeson (ToJSON, FromJSON) 41import Data.Aeson (ToJSON, FromJSON)
42
43import Control.Monad
44import Control.Applicative
36 45
37 46
38data SpmStyle = SpmWords | SpmConsonants 47data SpmStyle = SpmWords | SpmConsonants
@@ -48,7 +57,7 @@ instance FromHttpApiData SpmStyle where
48 | t' == "words" = Right SpmWords 57 | t' == "words" = Right SpmWords
49 | t' == "consonants" = Right SpmConsonants 58 | t' == "consonants" = Right SpmConsonants
50 | otherwise = Left $ "Expected one of ‘words’ or ‘consonants’ but got ‘" <> t <> "’" 59 | otherwise = Left $ "Expected one of ‘words’ or ‘consonants’ but got ‘" <> t <> "’"
51 60
52 61
53newtype SpmMailbox = SpmMailbox { unSpmMailbox :: CI Text } 62newtype SpmMailbox = SpmMailbox { unSpmMailbox :: CI Text }
54 deriving stock (Eq, Ord, Read, Show, Generic, Typeable) 63 deriving stock (Eq, Ord, Read, Show, Generic, Typeable)
@@ -57,7 +66,7 @@ makeWrapped ''SpmMailbox
57 66
58instance MimeRender JSON SpmMailbox where 67instance MimeRender JSON SpmMailbox where
59 mimeRender p mbox = mimeRender p $ JSON.object [ "mailbox" JSON..= unSpmMailbox mbox ] 68 mimeRender p mbox = mimeRender p $ JSON.object [ "mailbox" JSON..= unSpmMailbox mbox ]
60 69
61newtype SpmDomain = SpmDomain { unSpmDomain :: CI Text } 70newtype SpmDomain = SpmDomain { unSpmDomain :: CI Text }
62 deriving stock (Eq, Ord, Read, Show, Generic, Typeable) 71 deriving stock (Eq, Ord, Read, Show, Generic, Typeable)
63 deriving newtype (MimeRender PlainText) 72 deriving newtype (MimeRender PlainText)
@@ -66,31 +75,72 @@ makeWrapped ''SpmDomain
66instance MimeRender JSON SpmDomain where 75instance MimeRender JSON SpmDomain where
67 mimeRender p dom = mimeRender p $ JSON.object [ "domain" JSON..= unSpmDomain dom ] 76 mimeRender p dom = mimeRender p $ JSON.object [ "domain" JSON..= unSpmDomain dom ]
68 77
69-- newtype SpmLocal = SpmLocal 78newtype SpmLocal = SpmLocal
70-- { unSpmLocal :: CI Text 79 { unSpmLocal :: CI Text
71-- } deriving stock (Eq, Ord, Read, Show, Generic, Typeable) 80 } deriving stock (Eq, Ord, Read, Show, Generic, Typeable)
72-- deriving newtype (ToJSON, FromJSON) 81 deriving newtype (ToJSON, FromJSON)
73-- makeWrapped ''SpmLocal 82makeWrapped ''SpmLocal
74-- newtype SpmExtension = SpmExtension 83newtype SpmExtension = SpmExtension
75-- { unSpmExtension :: CI Text 84 { unSpmExtension :: CI Text
76-- } deriving stock (Eq, Ord, Read, Show, Generic, Typeable) 85 } deriving stock (Eq, Ord, Read, Show, Generic, Typeable)
77-- deriving newtype (ToJSON, FromJSON) 86 deriving newtype (ToJSON, FromJSON)
78-- makeWrapped ''SpmExtension 87makeWrapped ''SpmExtension
79 88
80-- newtype SpmMappingListing = SpmMappingListing { unSpmMappingListing :: Set SpmMapping } 89data SpmMappingState = Valid | Reject
81-- deriving stock (Eq, Ord, Read, Show, Generic, Typeable) 90 deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable)
82-- instance ToJSON SpmMappingList where 91instance MimeRender PlainText SpmMappingState where
83-- toJSON SpmMappingListing{..} = object [ "mappings" .= unSpmMappingListing ] 92 mimeRender p = mimeRender @_ @Text p . \case
84 93 Valid -> "valid"
85-- data SpmMapping = SpmMapping 94 Reject -> "reject"
86-- { spmMappingLocal :: Maybe SpmLocal 95instance MimeUnrender PlainText SpmMappingState where
87-- , spmMappingExtension :: Maybe SpmExtension 96 mimeUnrender p bs = mimeUnrender @_ @Text p bs >>= \(CI.mk . Text.strip -> t) -> if
88-- } deriving stock (Eq, Ord, Read, Show, Generic, Typeable) 97 | t == "valid" -> Right Valid
89-- instance ToJSON SpmMapping where 98 | t == "reject" -> Right Reject
90-- toJSON SpmMapping{..} = object 99 | otherwise -> Left "Could not parse SpmMappingState"
91-- [ "local" .= spmMappingLocal 100_SpmMappingStateReject :: Iso' SpmMappingState Bool
92-- , "extension" .= spmMappingExtension 101_SpmMappingStateReject = iso toReject fromReject
93-- ] 102 where toReject Valid = False
103 toReject Reject = True
104 fromReject True = Reject
105 fromReject False = Valid
106
107data SpmMappingListingItem = SpmMappingListingItem
108 { smlMapping :: SpmMapping
109 , smlState :: SpmMappingState
110 } deriving (Eq, Ord, Read, Show, Generic, Typeable)
111
112newtype SpmMappingListing = SpmMappingListing { unSpmMappingListing :: [SpmMappingListingItem] }
113 deriving stock (Eq, Ord, Read, Show, Generic, Typeable)
114
115data SpmMapping = SpmMapping
116 { spmMappingLocal :: Maybe SpmLocal
117 , spmMappingExtension :: Maybe SpmExtension
118 } deriving stock (Eq, Ord, Read, Show, Generic, Typeable)
119instance FromHttpApiData SpmMapping where
120 parseUrlPiece t
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
131 toUrlPiece SpmMapping{..} = maybe "" (CI.original . unSpmLocal) spmMappingLocal
132 <> maybe "" (("+" <>) . CI.original . unSpmExtension) spmMappingExtension
133
134deriveJSON (aesonPrefix trainCase) ''SpmMapping
135makePrisms ''SpmMappingState
136deriveJSON JSON.defaultOptions
137 { JSON.constructorTagModifier = trainCase
138 } ''SpmMappingState
139deriveJSON (aesonPrefix trainCase) ''SpmMappingListingItem
140
141instance ToJSON SpmMappingListing where
142 toJSON SpmMappingListing{..} = JSON.object [ "mappings" JSON..= unSpmMappingListing ]
143
94 144
95type SpmApi = "whoami" :> Get '[PlainText, JSON] SpmMailbox 145type SpmApi = "whoami" :> Get '[PlainText, JSON] SpmMailbox
96 :<|> "domain" :> Get '[PlainText, JSON] SpmDomain 146 :<|> "domain" :> Get '[PlainText, JSON] SpmDomain
@@ -98,9 +148,9 @@ type SpmApi = "whoami" :> Get '[PlainText, JSON] SpmMailbox
98 :<|> "instance-id" :> Get '[PlainText, JSON, OctetStream] UUID 148 :<|> "instance-id" :> Get '[PlainText, JSON, OctetStream] UUID
99 :<|> "spm" :> "generate" :> QueryParam "style" SpmStyle :> Get '[PlainText, JSON, OctetStream] SignedJWT 149 :<|> "spm" :> "generate" :> QueryParam "style" SpmStyle :> Get '[PlainText, JSON, OctetStream] SignedJWT
100 :<|> "spm" :> "claim" :> ReqBody '[PlainText, JSON, OctetStream] SignedJWT :> PostNoContent 150 :<|> "spm" :> "claim" :> ReqBody '[PlainText, JSON, OctetStream] SignedJWT :> PostNoContent
101 -- :<|> "mappings" :> Get '[PlainText, JSON] SpmMappingListing 151 :<|> "mappings" :> Get '[JSON] SpmMappingListing
102 -- :<|> "mappings" :> Capture SpmMapping :> GetNoContent 152 :<|> "mappings" :> Capture "mapping" SpmMapping :> Get '[PlainText, JSON] SpmMappingState
103 -- :<|> "mappings" :> Capture SpmMapping :> DeleteNoContent 153 :<|> "mappings" :> Capture "mapping" SpmMapping :> ReqBody '[PlainText, JSON] SpmMappingState :> PatchNoContent
104 154
105spmApi :: Proxy SpmApi 155spmApi :: Proxy SpmApi
106spmApi = Proxy 156spmApi = Proxy