1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
|
{-# LANGUAGE TemplateHaskell, OverloadedStrings #-}
module Spm.Api
( SpmStyle(..), _SpmWords, _SpmConsonants
, SpmMailbox, SpmDomain
, SpmLocal(..), SpmExtension(..)
, SpmMapping(..), SpmMappingState(..), SpmMappingListingItem(..), SpmMappingListing(..)
, SpmJWTClaims(..), _spmjwtLocal, _SpmJWTLocal
, _SpmMappingText, _SpmMappingStateReject
, spmMappingAncestors
, SpmApi, spmApi
) where
import Prelude
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
import Control.Monad (guard)
import Data.CaseInsensitive (CI)
import qualified Data.CaseInsensitive as CI
import Data.CaseInsensitive.Instances ()
import Crypto.JOSE.JWK (JWKSet)
import Crypto.JWT (SignedJWT, ClaimsSet, HasClaimsSet(..), emptyClaimsSet)
import Crypto.JWT.Instances ()
import Data.UUID (UUID)
import Data.UUID.Instances ()
import qualified Data.Aeson as JSON
import qualified Data.Aeson.Lens as JSON
import Data.Aeson.TH (deriveJSON)
import Data.Aeson.Casing
import Data.Aeson (ToJSON, FromJSON)
data SpmStyle = SpmWords | SpmConsonants
deriving (Eq, Ord, Read, Show, Bounded, Enum)
makePrisms ''SpmStyle
instance ToHttpApiData SpmStyle where
toUrlPiece = \case
SpmWords -> "words"
SpmConsonants -> "consonants"
instance FromHttpApiData SpmStyle where
parseUrlPiece t@(CI.mk -> t')
| 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)
deriving newtype (MimeRender PlainText)
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)
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
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)
_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 = Right . review _SpmMappingText
instance ToHttpApiData SpmMapping where
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
deriveJSON JSON.defaultOptions
{ JSON.constructorTagModifier = trainCase
} ''SpmMappingState
deriveJSON (aesonPrefix trainCase) ''SpmMappingListingItem
instance ToJSON SpmMappingListing where
toJSON SpmMappingListing{..} = JSON.object [ "mappings" JSON..= unSpmMappingListing ]
data SpmJWTClaims = SpmJWTClaims
{ spmjwtStdClaims :: ClaimsSet
, spmjwtLocal :: SpmLocal
} deriving stock (Eq, Show, Generic, Typeable)
makeLensesFor [("spmjwtStdClaims", "_stdClaims"), ("spmjwtLocal", "_spmjwtLocal")] ''SpmJWTClaims
instance HasClaimsSet SpmJWTClaims where
claimsSet = _stdClaims
_SpmJWTLocal :: (Wrapped l, Unwrapped l ~ Unwrapped SpmLocal) => Prism' SpmJWTClaims l
_SpmJWTLocal = prism' toClaims fromClaims
where toClaims (view $ _Wrapped' . _Unwrapped' -> spmjwtLocal) = SpmJWTClaims{..}
where spmjwtStdClaims = emptyClaimsSet
fromClaims SpmJWTClaims{..} = view (_Wrapped' . _Unwrapped') spmjwtLocal <$ guard (spmjwtStdClaims == emptyClaimsSet)
instance JSON.ToJSON SpmJWTClaims where
toJSON SpmJWTClaims{..} = JSON.toJSON spmjwtStdClaims
& JSON._Object . at "li.yggdrasil.local" .~ Just (JSON.toJSON spmjwtLocal)
instance JSON.FromJSON SpmJWTClaims where
parseJSON = JSON.withObject "SpmJWTClaims" $ \o -> SpmJWTClaims
<$> JSON.parseJSON (JSON._Object # o)
<*> o JSON..: "li.yggdrasil.local"
type SpmApi = "whoami" :> Get '[PlainText, JSON] SpmMailbox
:<|> "domain" :> Get '[PlainText, JSON] SpmDomain
:<|> "jwks.json" :> Get '[JSON] JWKSet
:<|> "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 '[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
:<|> "mappings" :> Capture "mapping" SpmMapping :> DeleteNoContent
spmApi :: Proxy SpmApi
spmApi = Proxy
|
