...

5 files changed, 158 insertions, 0 deletions

diff --git a/overlays/spm/lib/Crypto/JWT/Instances.hs b/overlays/spm/lib/Crypto/JWT/Instances.hs
new file mode 100644
index 00000000..fa3c83b0
--- /dev/null
+++ b/overlays/spm/lib/Crypto/JWT/Instances.hs
@@ -0,0 +1,22 @@
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+
+module Crypto.JWT.Instances () where
+
+import Prelude
+import Control.Arrow
+
+import Crypto.JWT
+import Servant.API.ContentTypes
+
+
+instance MimeRender PlainText SignedJWT where
+  mimeRender _ = encodeCompact
+
+instance MimeRender OctetStream SignedJWT where
+  mimeRender _ = encodeCompact
+
+instance MimeUnrender PlainText SignedJWT where
+  mimeUnrender _ = left (show @Error) . decodeCompact
+
+instance MimeUnrender OctetStream SignedJWT where
+  mimeUnrender _ = left (show @Error) . decodeCompact
diff --git a/overlays/spm/lib/Data/CaseInsensitive/Instances.hs b/overlays/spm/lib/Data/CaseInsensitive/Instances.hs
new file mode 100644
index 00000000..1476b9d9
--- /dev/null
+++ b/overlays/spm/lib/Data/CaseInsensitive/Instances.hs
@@ -0,0 +1,22 @@
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+
+module Data.CaseInsensitive.Instances () where
+
+import Prelude
+
+import Data.CaseInsensitive (CI)
+import qualified Data.CaseInsensitive as CI
+
+import Servant.API.ContentTypes
+
+import Data.Aeson
+
+
+instance MimeRender PlainText a => MimeRender PlainText (CI a) where
+  mimeRender p = mimeRender p . CI.original
+
+instance ToJSON a => ToJSON (CI a) where
+  toJSON = toJSON . CI.original
+
+instance (FromJSON a, CI.FoldCase a) => FromJSON (CI a) where
+  parseJSON = fmap CI.mk . parseJSON
diff --git a/overlays/spm/lib/Data/UUID/Instances.hs b/overlays/spm/lib/Data/UUID/Instances.hs
new file mode 100644
index 00000000..335937d8
--- /dev/null
+++ b/overlays/spm/lib/Data/UUID/Instances.hs
@@ -0,0 +1,18 @@
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+
+module Data.UUID.Instances () where
+
+import Prelude
+import Data.UUID (UUID)
+import qualified Data.UUID as UUID
+import Servant.API.ContentTypes
+
+
+instance MimeRender PlainText UUID where
+  mimeRender p = mimeRender p . UUID.toText
+
+instance MimeRender JSON UUID where
+  mimeRender p = mimeRender p . UUID.toText
+
+instance MimeRender OctetStream UUID where
+  mimeRender p = mimeRender p . UUID.toByteString
diff --git a/overlays/spm/lib/Spm.hs b/overlays/spm/lib/Spm.hs
new file mode 100644
index 00000000..c7f7dfe5
--- /dev/null
+++ b/overlays/spm/lib/Spm.hs
@@ -0,0 +1,5 @@
+module Spm
+  ( module Spm.Api
+  ) where
+
+import Spm.Api
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 @@
+{-# LANGUAGE TemplateHaskell, OverloadedStrings #-}
+
+module Spm.Api
+  ( SpmStyle(..), _SpmWords, _SpmConsonants
+  , SpmMailbox
+  , 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 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 JSON, MimeRender PlainText)
+makeWrapped ''SpmMailbox
+-- 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
+         :<|> "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