Backport DID format changes from ION demo

fission-cli/library/Fission/CLI/Connected.hs

@@ -23,7 +23,7 @@ import           Fission.Error.NotFound.Types
 import qualified Fission.IPFS.Error.Types                  as IPFS
 import qualified Fission.JSON                              as JSON
 import qualified Fission.Key                               as Key
-import           Fission.User.DID.Types
+import           Fission.User.DID.Types                    as DID
 
 import qualified Fission.Web.Auth.Token.JWT.Resolver.Error as JWT.Resolver
 import           Fission.Web.Auth.Token.JWT.Types
@@ -152,13 +152,8 @@ mkConnected inCfg ipfsTimeout = do
 
           let
             ignoredFiles = Environment.ignored config
-
-            cliDID = DID
-              { publicKey = Key.Ed25519PublicKey $ Ed25519.toPublic secretKey
-              , method    = Key
-              }
-
-            cfg = Config { httpManager = getField @"httpManager" inCfg, ..}
+            cliDID       = DID.Key (Key.Ed25519PublicKey $ Ed25519.toPublic secretKey)
+            cfg          = Config { httpManager = getField @"httpManager" inCfg, ..}
 
           Context.run cfg do
             logDebug @Text "Attempting user verification"

fission-cli/library/Fission/CLI/Handler/Setup.hs

@@ -12,7 +12,7 @@ import           Fission.Prelude
 import           Fission.Error
 import           Fission.Key                                 as Key
 
-import           Fission.User.DID.Types
+import           Fission.User.DID.Types                      as DID
 import           Fission.User.Email.Types
 import qualified Fission.User.Username.Error                 as Username
 import           Fission.User.Username.Types
@@ -94,7 +94,7 @@ setup maybeOS maybeUsername maybeEmail maybeKeyFile = do
             Right username -> do
               baseURL <- getRemoteBaseUrl
               signingPK  <- Key.Store.fetchPublic (Proxy @SigningKey)
-              _ <- WNFS.create (DID Key $ Ed25519PublicKey signingPK) "/"
+              _ <- WNFS.create (DID.Key $ Ed25519PublicKey signingPK) "/"
               Env.init username baseURL Nothing
               Display.putOk $ "Done! Welcome to Fission, " <> textDisplay username <> " ✨"
 

fission-cli/library/Fission/CLI/Handler/User/Login.hs

@@ -40,7 +40,7 @@ import qualified Fission.Key.Error                           as Key
 import qualified Fission.Key.Symmetric                       as Symmetric
 
 import           Fission.User.DID.NameService.Class          as DID
-import           Fission.User.DID.Types
+import           Fission.User.DID.Types                      as DID
 import           Fission.User.Username                       as Username
 
 import           Fission.Web.Client
@@ -158,15 +158,15 @@ consume signingSK baseURL optUsername = do
   signingPK <- Key.Store.toPublic (Proxy @SigningKey) signingSK
 
   let
-    myDID = DID Key (Ed25519PublicKey signingPK)
+    myDID = DID.Key (Ed25519PublicKey signingPK)
     topic = PubSub.Topic $ textDisplay targetDID
 
   PubSub.connect baseURL topic \conn -> reattempt 10 do
     logDebug @Text "🤝 Device linking handshake: Step 1"
     aesConn <- secure conn () \(rsaConn :: Secure.Connection m (RSA.PublicKey, RSA.PrivateKey)) -> reattempt 10 do
       let
         Secure.Connection {key = (pk, _sk)} = rsaConn
-        sessionDID = DID Key (RSAPublicKey pk)
+        sessionDID = DID.Key (RSAPublicKey pk)
 
       logDebug @Text "🤝 Device linking handshake: Step 2"
       broadcastApiData conn sessionDID
@@ -273,7 +273,7 @@ produce signingSK baseURL = do
 
     secure conn () \(rsaConn@Secure.Connection {key = (_, sk)} :: Secure.Connection m (RSA.PublicKey, RSA.PrivateKey)) -> reattempt 10 do
       logDebug @Text "🤝 Device linking handshake: Step 2"
-      requestorTempDID@(DID _ tmpPK) <- listenRaw conn
+      requestorTempDID@(DID.Key tmpPK) <- listenRaw conn
 
       case tmpPK of
         Ed25519PublicKey _ ->

fission-cli/library/Fission/CLI/Handler/User/Register.hs

@@ -21,7 +21,7 @@ import           Fission.Web.Auth.Token.JWT.Types
 import           Fission.Web.Auth.Token.Types
 import           Fission.Web.Client                          as Client
 
-import           Fission.User.DID.Types
+import           Fission.User.DID.Types                      as DID
 import           Fission.User.Email.Types
 import           Fission.User.Registration.Types
 import qualified Fission.User.Username.Error                 as Username
@@ -123,7 +123,7 @@ createAccount maybeUsername maybeEmail = do
 
   exchangePK <- KeyStore.fetchPublic (Proxy @ExchangeKey)
   signingPK  <- KeyStore.fetchPublic (Proxy @SigningKey)
-  _          <- WNFS.create (DID Key $ Ed25519PublicKey signingPK) "/"
+  _          <- WNFS.create (DID.Key $ Ed25519PublicKey signingPK) "/"
 
   let
     form = Registration

fission-core/library/Fission/User/DID/Oldstyle/Types.hs

@@ -1,22 +1,21 @@
 -- | Module for DEPRECATED Ed25519 DID encoding format
 module Fission.User.DID.Oldstyle.Types (Oldstyle (..)) where
 
-import qualified RIO.ByteString                as BS
+import qualified RIO.ByteString         as BS
 
 import           Fission.Prelude
 
-import qualified Fission.Internal.UTF8         as UTF8
+import qualified Fission.Internal.UTF8  as UTF8
 
-import           Fission.Key                   as Key
-import           Fission.User.DID.Method.Types
-import           Fission.User.DID.Types
+import           Fission.Key            as Key
+import           Fission.User.DID.Types as DID
 
 -- | DEPRECATED Encoding of oldstyle Ed25519 DIDs. Manual use only
 newtype Oldstyle = Oldstyle { did :: DID }
   deriving stock (Show, Eq)
 
 instance Display Oldstyle where
-  textDisplay Oldstyle {did = DID Key (Ed25519PublicKey ed)} =
+  textDisplay Oldstyle {did = DID.Key (Ed25519PublicKey ed)} =
     mconcat
       [ "did:key:z"
       , forgetEncoding . UTF8.toBase58Text $ BS.pack (0xed : 0x01 : BS.unpack (encodeUtf8 $ textDisplay ed))

fission-core/library/Fission/User/DID/Types.hs

@@ -1,8 +1,4 @@
-module Fission.User.DID.Types
-  ( DID (..)
-  -- * Reexport
-  , module Fission.User.DID.Method.Types
-  ) where
+module Fission.User.DID.Types (DID (..)) where
 
 import qualified RIO.ByteString.Lazy               as Lazy
 
@@ -30,7 +26,6 @@ import qualified Fission.Internal.UTF8             as UTF8
 
 import           Fission.Error.AlreadyExists.Types
 import           Fission.Key                       as Key
-import           Fission.User.DID.Method.Types
 
 {- | A DID key, broken into its constituant parts
 
@@ -76,21 +71,17 @@ RSA
 Right (DID {method = Key, publicKey = MIIBIjANBgkqhkiG9w0BAQEFAAOCAQ8AMIIBCgKCAQEAnzyis1ZjfNB0bBgKFMSvvkTtwlvBsaJq7S5wA+kzeVOVpVWwkWdVha4s38XM/pa/yr47av7+z3VTmvDRyAHcaT92whREFpLv9cj5lTeJSibyr/Mrm/YtjCZVWgaOYIhwrXwKLqPr/11inWsAkfIytvHWTxZYEcXLgAXFuUuaS3uF9gEiNQwzGTU1v0FqkqTBr4B8nW3HCN47XUu0t8Y0e+lf4s4OxQawWD79J9/5d3Ry0vbV3Am1FtGJiJvOwRsIfVChDpYStTcHTCMqtvWbV6L11BWkpzGXSW4Hv43qa+GSYOD2QU68Mb59oSk2OB+BtOLpJofmbGEGgvmwyCI9MwIDAQAB})
 
 -}
-data DID = DID
-  { method    :: Method
-  , publicKey :: Key.Public
-  } deriving (Show, Eq)
+newtype DID
+  = Key Key.Public
+  -- More varieties here later
+  deriving (Show, Eq)
 
 -- For FromJSON
 instance Ord DID where
   a `compare` b = textDisplay a `compare` textDisplay b
 
 instance Arbitrary DID where
-  arbitrary = do
-    publicKey <- arbitrary
-    method    <- arbitrary
-
-    return DID {..}
+  arbitrary = Key <$> arbitrary
 
 instance Hashable DID where
   hashWithSalt salt did = hashWithSalt salt $ textDisplay did
@@ -108,11 +99,8 @@ instance FromHttpApiData DID where
       Right val -> Right val
 
 instance Display DID where -- NOTE `pk` here is base2, not base58
-  textDisplay (DID method pk) = header <> forgetEncoding (UTF8.toBase58Text $ BS.pack multicodecW8)
+  textDisplay (Key pk) = "did:key:z" <> forgetEncoding (UTF8.toBase58Text $ BS.pack multicodecW8)
     where
-      header :: Text
-      header = "did:" <> textDisplay method <> ":" <> "z"
-
       multicodecW8 :: [Word8]
       multicodecW8 =
         case pk of
@@ -170,4 +158,4 @@ parseText txt =
         nope ->
           fail . show . BS64.encode $ BS.pack nope <> " is not an acceptable did:key"
 
-      return $ DID Key pk
+      return $ Key pk

fission-core/library/Fission/Web/Auth/Token/JWT.hs

@@ -63,7 +63,7 @@ getRootDID ::
   -> m DID
 getRootDID fallbackPK = \case
   RootCredential ->
-    return $ DID Key fallbackPK
+    return $ DID.Key fallbackPK
 
   Nested _ jwt ->  do
     JWT {claims = JWT.Claims {sender}} <- ensureM $ getRoot jwt
@@ -121,13 +121,8 @@ mkUCAN ::
   -> JWT
 mkUCAN receiver senderSK nbf exp facts resource potency proof = JWT {..}
   where
-    sig = signEd25519 header claims senderSK
-
-    sender = DID
-      { publicKey = Key.Ed25519PublicKey $ Ed25519.toPublic senderSK
-      , method    = DID.Key
-      }
-
+    sig    = signEd25519 header claims senderSK
+    sender = DID.Key (Key.Ed25519PublicKey $ Ed25519.toPublic senderSK)
     claims = JWT.Claims {..}
 
     header = JWT.Header

fission-core/library/Fission/Web/Auth/Token/JWT/Types.hs

@@ -30,7 +30,7 @@ import           Network.IPFS.CID.Types
 import qualified RIO.ByteString.Lazy                              as Lazy
 import qualified RIO.Text                                         as Text
 
-import qualified Servant.API as Servant
+import qualified Servant.API                                      as Servant
 
 import           Fission.Prelude
 
@@ -44,7 +44,7 @@ import qualified Fission.Internal.RSA2048.Pair.Types              as RSA2048
 import qualified Fission.Internal.UTF8                            as UTF8
 
 import           Fission.Authorization.Potency.Types
-import           Fission.User.DID.Types
+import           Fission.User.DID.Types                           as DID
 
 import           Fission.Web.Auth.Token.JWT.Fact.Types
 import           Fission.Web.Auth.Token.JWT.Header.Types          (Header (..))
@@ -84,7 +84,7 @@ instance Arbitrary JWT where
     claims' <- arbitrary
 
     let
-      claims = claims' {sender = DID Key pk}
+      claims = claims' {sender = DID.Key pk}
 
       sig' = case sk of
         Left rsaSK -> Unsafe.unsafePerformIO $ signRS256 header claims rsaSK
@@ -180,11 +180,7 @@ instance Arbitrary Claims where
     nbf      <- arbitrary
     pk       <- arbitrary
 
-    let
-      receiver = DID
-        { publicKey = pk
-        , method    = Key
-        }
+    let receiver = DID.Key pk
 
     return Claims {..}
 

fission-core/library/Fission/Web/Auth/Token/JWT/Validation.hs

@@ -16,7 +16,7 @@ import           Fission.Prelude
 
 import           Fission.Key                                      as Key
 import           Fission.SemVer.Types
-import           Fission.User.DID                                 as User
+import           Fission.User.DID                                 as DID
 
 import           Fission.Web.Auth.Token.JWT.Resolver              as Proof
 
@@ -134,7 +134,7 @@ checkRSA2048Signature (JWT.RawContent raw) jwt@JWT {..} (RS256.Signature innerSi
 
   where
     content = encodeUtf8 raw
-    Claims {sender = User.DID {publicKey}} = claims
+    Claims {sender = DID.Key publicKey} = claims
 
 checkEd25519Signature :: JWT.RawContent -> JWT -> Either JWT.Error JWT
 checkEd25519Signature (JWT.RawContent raw) jwt@JWT {..} =
@@ -148,4 +148,4 @@ checkEd25519Signature (JWT.RawContent raw) jwt@JWT {..} =
       Left $ JWT.SignatureError InvalidPublicKey
 
   where
-    Claims {sender = User.DID {publicKey}} = claims
+    Claims {sender = DID.Key publicKey} = claims

fission-core/test/Fission/Test/User/DID.hs

@@ -9,7 +9,7 @@ import qualified RIO.ByteString.Lazy             as Lazy
 import           Servant.API
 
 import           Fission.Key                     as Key
-import           Fission.User.DID
+import           Fission.User.DID                as DID
 import           Fission.User.DID.Oldstyle.Types
 
 import           Fission.Test.Prelude
@@ -23,41 +23,41 @@ spec =
           expected :: Lazy.ByteString
           expected = "did:key:zx2iySNP57tN67ZPKvH77wPtthXgXUD1Zfc3sXDN8iDQm6MUiHN8a2xUQseVsbEqLwxaQHij1dzrfgavXesQFDNjPAa4sHs65KuXroZfDhVCSLpqMTtgJp8ZZcW7wF"
         in
-          encode (DID Key rsaKey) `shouldBe` "\"" <> expected <> "\""
+          encode (DID.Key rsaKey) `shouldBe` "\"" <> expected <> "\""
 
     context "Ed25519" do
       it "serializes to a well-known value"
         let
           expected :: Text
           expected = "did:key:z6MkgYGF3thn8k1Fv4p4dWXKtsXCnLH7q9yw4QgNPULDmDKB"
         in
-          encode (DID Key edKey) `shouldBe` JSON.encode expected
+          encode (DID.Key edKey) `shouldBe` JSON.encode expected
 
       itsProp' "deserialize . serialize ~ id" \(ed25519pk :: Ed25519.PublicKey) ->
-        decode (encode . DID Key $ Ed25519PublicKey ed25519pk) `shouldBe`
-          Just (DID Key $ Ed25519PublicKey ed25519pk)
+        decode (encode . DID.Key $ Ed25519PublicKey ed25519pk) `shouldBe`
+          Just (DID.Key $ Ed25519PublicKey ed25519pk)
 
       itsProp' "lengths is always 56" \(ed25519pk :: Ed25519.PublicKey) ->
-        Lazy.length (encode . DID Key $ Ed25519PublicKey ed25519pk) `shouldBe` 56 + 2 -- extra 2 for quotes because JSON
+        Lazy.length (encode . DID.Key $ Ed25519PublicKey ed25519pk) `shouldBe` 56 + 2 -- extra 2 for quotes because JSON
 
       itsProp' "always starts with 'did:key:z6Mk'" \(ed25519pk :: Ed25519.PublicKey) ->
-        Lazy.take 13 (encode . DID Key $ Ed25519PublicKey ed25519pk) `shouldBe` "\"did:key:z6Mk"
+        Lazy.take 13 (encode . DID.Key $ Ed25519PublicKey ed25519pk) `shouldBe` "\"did:key:z6Mk"
 
       context "Legacy (AKA `Oldstyle`)" do
         it "deserializes to a well-known value" $
           eitherDecodeStrict ("\"" <> encodeUtf8 oldstyle <> "\"")
-            `shouldBe` Right (DID Key edKey)
+            `shouldBe` Right (DID.Key edKey)
 
         it "can be manually set to display in the Oldstyle format" $
-          textDisplay Oldstyle { did = DID Key edKey } `shouldBe` oldstyle
+          textDisplay Oldstyle { did = DID.Key edKey } `shouldBe` oldstyle
 
       context "W3C did:key Ed25519 test vectors" do
         didKeyTestVectors |> foldMapM \(idx, bs) ->
           it ("Deserializes vector #" <> show idx <> " to a valid DID") $
             eitherDecode (encode bs) `shouldSatisfy` isEd25519DidKey
 
     itsProp' "serialized is isomorphic to ADT" \(did :: DID) ->
-      JSON.decode (JSON.encode did) `shouldBe` Just did
+      JSON.eitherDecode (JSON.encode did) `shouldBe` Right did
 
     itsProp' "is a base58 encoded Key DID" \(did :: DID) ->
       Lazy.isPrefixOf "\"did:key:z" (JSON.encode did)
@@ -70,7 +70,7 @@ Right edKey = parseUrlPiece "Hv+AVRD2WUjUFOsSNbsmrp9fokuwrUnjBcr92f0kxw4="
 
 isEd25519DidKey :: Either String DID -> Bool
 isEd25519DidKey = \case
-  Right (DID Key (Ed25519PublicKey _)) -> True
+  Right (DID.Key (Ed25519PublicKey _)) -> True
   _                                    -> False
 
 didKeyTestVectors :: [(Natural, Text)]

fission-web-server/library/Fission/Web/Server/Auth/Token/UCAN.hs

@@ -5,7 +5,7 @@ import           Fission.Prelude
 import           Fission.Error.NotFound.Types
 
 import           Fission.Authorization.ServerDID
-import           Fission.User.DID.Types
+import           Fission.User.DID.Types                             as DID
 
 import           Fission.Web.Auth.Token.JWT                         as JWT
 import           Fission.Web.Auth.Token.JWT.Resolver                as Proof
@@ -55,7 +55,7 @@ toAuthorization jwt@JWT {claims = JWT.Claims {..}} = do
     Left err ->
       throwM err
 
-    Right JWT {claims = JWT.Claims {sender = DID {publicKey = pk}}} ->
+    Right JWT {claims = JWT.Claims {sender = DID.Key pk}} ->
       runDB (User.getByPublicKey pk) >>= \case
         Nothing ->
           Web.Error.throw $ NotFound @User