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
|
{-# LANGUAGE TemplateHaskell, OverloadedStrings #-}
module Spm.Api
( SpmStyle(..), _SpmWords, _SpmConsonants
, SpmMailbox, SpmDomain
, SpmApi, spmApi
) where
import Prelude
import Servant.API
import Data.Proxy (Proxy(..))
import Data.Text (Text)
import GHC.Generics (Generic)
import Type.Reflection (Typeable)
import Control.Lens.TH
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 (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
-- newtype SpmMappingListing = SpmMappingListing { unSpmMappingListing :: Set SpmMapping }
-- deriving stock (Eq, Ord, Read, Show, Generic, Typeable)
-- instance ToJSON SpmMappingList where
-- toJSON SpmMappingListing{..} = object [ "mappings" .= unSpmMappingListing ]
-- data SpmMapping = SpmMapping
-- { spmMappingLocal :: Maybe SpmLocal
-- , spmMappingExtension :: Maybe SpmExtension
-- } deriving stock (Eq, Ord, Read, Show, Generic, Typeable)
-- instance ToJSON SpmMapping where
-- toJSON SpmMapping{..} = object
-- [ "local" .= spmMappingLocal
-- , "extension" .= spmMappingExtension
-- ]
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 '[PlainText, JSON] SpmMappingListing
-- :<|> "mappings" :> Capture SpmMapping :> GetNoContent
-- :<|> "mappings" :> Capture SpmMapping :> DeleteNoContent
spmApi :: Proxy SpmApi
spmApi = Proxy
|
