summaryrefslogtreecommitdiff
path: root/overlays/spm/lib/Spm/Api.hs
diff options
context:
space:
mode:
Diffstat (limited to 'overlays/spm/lib/Spm/Api.hs')
-rw-r--r--overlays/spm/lib/Spm/Api.hs91
1 files changed, 91 insertions, 0 deletions
diff --git a/overlays/spm/lib/Spm/Api.hs b/overlays/spm/lib/Spm/Api.hs
new file mode 100644
index 00000000..14acfac4
--- /dev/null
+++ b/overlays/spm/lib/Spm/Api.hs
@@ -0,0 +1,91 @@
1{-# LANGUAGE TemplateHaskell, OverloadedStrings #-}
2
3module Spm.Api
4 ( SpmStyle(..), _SpmWords, _SpmConsonants
5 , SpmMailbox
6 , SpmApi, spmApi
7 ) where
8
9import Prelude
10
11import Servant.API
12
13import Data.Proxy (Proxy(..))
14
15import Data.Text (Text)
16
17import GHC.Generics (Generic)
18import Type.Reflection (Typeable)
19
20import Control.Lens.TH
21
22import Data.CaseInsensitive (CI)
23import qualified Data.CaseInsensitive as CI
24import Data.CaseInsensitive.Instances ()
25
26import Crypto.JOSE.JWK (JWKSet)
27import Crypto.JWT (SignedJWT)
28import Crypto.JWT.Instances ()
29
30import Data.UUID (UUID)
31import Data.UUID.Instances ()
32
33-- import Data.Aeson (ToJSON, FromJSON)
34
35
36data SpmStyle = SpmWords | SpmConsonants
37 deriving (Eq, Ord, Read, Show, Bounded, Enum)
38makePrisms ''SpmStyle
39
40instance ToHttpApiData SpmStyle where
41 toUrlPiece = \case
42 SpmWords -> "words"
43 SpmConsonants -> "consonants"
44instance FromHttpApiData SpmStyle where
45 parseUrlPiece t@(CI.mk -> t')
46 | t' == "words" = Right SpmWords
47 | t' == "consonants" = Right SpmConsonants
48 | otherwise = Left $ "Expected one of ‘words’ or ‘consonants’ but got ‘" <> t <> "’"
49
50
51newtype SpmMailbox = SpmMailbox { unSpmMailbox :: CI Text }
52 deriving stock (Eq, Ord, Read, Show, Generic, Typeable)
53 deriving newtype (MimeRender JSON, MimeRender PlainText)
54makeWrapped ''SpmMailbox
55-- newtype SpmLocal = SpmLocal
56-- { unSpmLocal :: CI Text
57-- } deriving stock (Eq, Ord, Read, Show, Generic, Typeable)
58-- deriving newtype (ToJSON, FromJSON)
59-- makeWrapped ''SpmLocal
60-- newtype SpmExtension = SpmExtension
61-- { unSpmExtension :: CI Text
62-- } deriving stock (Eq, Ord, Read, Show, Generic, Typeable)
63-- deriving newtype (ToJSON, FromJSON)
64-- makeWrapped ''SpmExtension
65
66-- newtype SpmMappingListing = SpmMappingListing { unSpmMappingListing :: Set SpmMapping }
67-- deriving stock (Eq, Ord, Read, Show, Generic, Typeable)
68-- instance ToJSON SpmMappingList where
69-- toJSON SpmMappingListing{..} = object [ "mappings" .= unSpmMappingListing ]
70
71-- data SpmMapping = SpmMapping
72-- { spmMappingLocal :: Maybe SpmLocal
73-- , spmMappingExtension :: Maybe SpmExtension
74-- } deriving stock (Eq, Ord, Read, Show, Generic, Typeable)
75-- instance ToJSON SpmMapping where
76-- toJSON SpmMapping{..} = object
77-- [ "local" .= spmMappingLocal
78-- , "extension" .= spmMappingExtension
79-- ]
80
81type SpmApi = "whoami" :> Get '[PlainText, JSON] SpmMailbox
82 :<|> "jwks.json" :> Get '[JSON] JWKSet
83 :<|> "instance-id" :> Get '[PlainText, JSON, OctetStream] UUID
84 :<|> "spm" :> "generate" :> QueryParam "style" SpmStyle :> Get '[PlainText, JSON, OctetStream] SignedJWT
85 :<|> "spm" :> "claim" :> ReqBody '[PlainText, JSON, OctetStream] SignedJWT :> PostNoContent
86 -- :<|> "mappings" :> Get '[PlainText, JSON] SpmMappingListing
87 -- :<|> "mappings" :> Capture SpmMapping :> GetNoContent
88 -- :<|> "mappings" :> Capture SpmMapping :> DeleteNoContent
89
90spmApi :: Proxy SpmApi
91spmApi = Proxy