summaryrefslogtreecommitdiff
path: root/overlays/spm/lib/Spm/Api.hs
blob: ce4ee2d9192d6786c0cc7c400ba863b7a7049315 (plain)
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
{-# LANGUAGE TemplateHaskell, OverloadedStrings #-}

module Spm.Api
  ( SpmStyle(..), _SpmWords, _SpmConsonants
  , SpmMailbox, SpmDomain
  , SpmLocal(..), SpmExtension(..)
  , SpmMapping(..), SpmMappingState(..), SpmMappingListingItem(..), SpmMappingListing(..)
  , _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 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)


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 ]


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

spmApi :: Proxy SpmApi
spmApi = Proxy