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
|
{-# LANGUAGE TemplateHaskell, OverloadedStrings #-}
module Spm.Api
( SpmStyle(..), _SpmWords, _SpmConsonants
, SpmMailbox, SpmDomain
, SpmLocal(..), SpmExtension(..)
, SpmMapping(..), SpmMappingState(..), SpmMappingListingItem(..), SpmMappingListing(..)
, _SpmMappingStateReject
, 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 Data.CaseInsensitive (CI)
import qualified Data.CaseInsensitive as CI
import Data.CaseInsensitive.Instances ()
import Crypto.JOSE.JWK (JWKSet)
import Crypto.JWT (SignedJWT)
import Crypto.JWT.Instances ()
import Data.UUID (UUID)
import Data.UUID.Instances ()
import qualified Data.Aeson as JSON
import Data.Aeson.TH (deriveJSON)
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)
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)
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'
instance ToHttpApiData SpmMapping where
toUrlPiece SpmMapping{..} = maybe "" (CI.original . unSpmLocal) spmMappingLocal
<> maybe "" (("+" <>) . CI.original . unSpmExtension) spmMappingExtension
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 ]
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
spmApi :: Proxy SpmApi
spmApi = Proxy
|
