Enable CLI to browser linking (#502)

fission-cli/library/Fission/CLI/Environment/Types.hs

@@ -27,6 +27,7 @@ data Env = Env
   -- Releases
   , updateChecked  :: UTCTime
   }
+  deriving (Eq, Show)
 
 instance ToJSON Env where
   toJSON Env {..} = object

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

@@ -107,14 +107,8 @@ login optUsername = do
     baseURL = rootURL {baseUrlPath = "/user/link"}
 
   attempt ensureNotLoggedIn >>= \case
-    Right () ->
-      consume signingSK baseURL optUsername
-
-    Left  err -> do
-      -- TODO replace below with `produce signingSK baseURL` when auth lobby can handle EdDSA
-      Env {username} <- Env.get
-      logUser $ "Already logged in as " <> textDisplay username
-      raise err
+    Right () -> consume signingSK baseURL optUsername
+    Left  _  -> produce signingSK baseURL
 
 type ConsumerConstraints m =
   ( MonadIO          m
@@ -175,7 +169,7 @@ consume signingSK baseURL optUsername = do
         sessionDID = DID Key (RSAPublicKey pk)
 
       logDebug @Text "🤝 Device linking handshake: Step 2"
-      broadcastRaw conn sessionDID
+      broadcastApiData conn sessionDID
 
       reattempt 10 do
         logDebug @Text "🤝 Device linking handshake: Step 3"
@@ -189,7 +183,7 @@ consume signingSK baseURL optUsername = do
 
         -- TODO waiting on FE to not send an append UCAN -- case (jwt |> claims |> potency) == AuthNOnly of
         ensure $ UCAN.containsFact jwt \facts ->
-          if any (== SessionKey sessionKey) facts
+          if SessionKey sessionKey `elem` facts
             then Right ()
             else Left JWT.Proof.MissingExpectedFact
 
@@ -304,24 +298,32 @@ produce signingSK baseURL = do
               logDebug @Text "🤝 Device linking handshake: Step 5"
               PIN.Payload requestorDID pin <- secureListenJSON aesConn
 
-              pinOK <- reaskYN $ "Does this code match your second device? " <> textDisplay pin
+              pinOK <- reaskYN $ "🔢  Does this code match your second device? " <> textDisplay pin
               unless pinOK do
                 raise $ Mismatch @PIN
 
               reattempt 100 do
                 logDebug @Text "🤝 Device linking handshake: Step 6"
 
-                (_, readKey) <- WebNative.FileSystem.Auth.Store.getMostPrivileged rootDID "/"
+                readKey <- do
+                  attempt (WebNative.FileSystem.Auth.Store.getMostPrivileged rootDID "/") >>= \case
+                    Left _ ->
+                      case rootProof of
+                        RootCredential -> WebNative.FileSystem.Auth.Store.create rootDID "/"
+                        _              -> raise $ NotFound @(Symmetric.Key AES256)
+
+                    Right (_, key) ->
+                      return key
 
                 let
                   jwt    = delegateSuperUser requestorDID signingSK rootProof now
                   bearer = Bearer.fromJWT jwt
 
-                accessOK <- reaskYN $ "Grant access to: " <> JWT.prettyPrintGrants jwt
+                accessOK <- reaskYN $ "🧞 Grant access? " <> JWT.prettyPrintGrants jwt
                 unless accessOK $ raise (Status Denied)
 
                 aesConn `secureBroadcastJSON` User.Link.Payload {bearer, readKey}
 
-    UTF8.putTextLn "Login to other device successful 👍"
+    UTF8.putTextLn "🤝 Login to other device successful 🎉"
 
   return username

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

@@ -1,9 +1,9 @@
 -- | Setup command
 module Fission.CLI.Handler.User.Register (register) where
 
-import qualified Data.Yaml                                 as YAML
+import qualified Data.Yaml                                   as YAML
 
-import qualified Crypto.PubKey.Ed25519                     as Ed25519
+import qualified Crypto.PubKey.Ed25519                       as Ed25519
 import           Crypto.Random
 
 import           Network.DNS
@@ -14,28 +14,30 @@ import           Fission.Prelude
 
 import           Fission.Authorization.ServerDID
 import           Fission.Error.Types
-import           Fission.Key.Error                         as Key
+import           Fission.Key                                 as Key
 import           Fission.User.Username.Types
 
 import           Fission.Web.Auth.Token.JWT.Types
 import           Fission.Web.Auth.Token.Types
-import           Fission.Web.Client                        as Client
-import qualified Fission.Web.Client.User                   as User
+import           Fission.Web.Client                          as Client
+import qualified Fission.Web.Client.User                     as User
 
 import           Fission.User.DID.Types
 import           Fission.User.Email.Types
 import           Fission.User.Registration.Types
-import qualified Fission.User.Username.Error               as Username
+import qualified Fission.User.Username.Error                 as Username
 
 import           Fission.CLI.Remote
 
-import           Fission.CLI.Display.Error                 as CLI.Error
-import           Fission.CLI.Display.Success               as CLI.Success
+import           Fission.CLI.Display.Error                   as CLI.Error
+import           Fission.CLI.Display.Success                 as CLI.Success
 
-import           Fission.CLI.Environment                   as Env
-import           Fission.CLI.Key.Store                     as KeyStore
-import qualified Fission.CLI.Prompt                        as Prompt
-import           Fission.CLI.WebNative.Mutation.Auth.Store as UCAN
+import           Fission.CLI.Environment                     as Env
+import           Fission.CLI.Key.Store                       as KeyStore
+import qualified Fission.CLI.Prompt                          as Prompt
+
+import qualified Fission.CLI.WebNative.FileSystem.Auth.Store as WNFS
+import           Fission.CLI.WebNative.Mutation.Auth.Store   as UCAN
 
 register ::
   ( MonadIO          m
@@ -47,6 +49,7 @@ register ::
   , MonadTime        m
   , MonadRandom      m
   , ServerDID        m
+  , WNFS.MonadStore  m
   , MonadWebAuth     m Token
   , MonadWebAuth     m (SecretKey SigningKey)
 
@@ -90,6 +93,7 @@ createAccount ::
   , MonadTime        m
   , ServerDID        m
   , MonadRandom      m
+  , WNFS.MonadStore  m
   , MonadWebAuth     m Token
   , MonadWebAuth     m Ed25519.SecretKey
 
@@ -118,8 +122,9 @@ createAccount maybeUsername maybeEmail = do
     Nothing   -> Email <$> Prompt.reaskNotEmpty' "Email:"
     Just mail -> return mail
 
-  exchangeSK <- KeyStore.fetch $ Proxy @ExchangeKey
-  exchangePK <- KeyStore.toPublic (Proxy @ExchangeKey) exchangeSK
+  exchangePK <- KeyStore.fetchPublic (Proxy @ExchangeKey)
+  signingPK  <- KeyStore.fetchPublic (Proxy @SigningKey)
+  _          <- WNFS.create (DID Key $ Ed25519PublicKey signingPK) "/"
 
   let
     form = Registration

fission-cli/library/Fission/CLI/Key/Store.hs

@@ -2,6 +2,7 @@ module Fission.CLI.Key.Store
   ( create
   , forceCreate
   , fetch
+  , fetchPublic
   , delete
   , persist
   , exists
@@ -78,6 +79,18 @@ fetch keyRole = do
   scrubbed <- getAsBytes keyRole
   ensureM $ parse keyRole scrubbed
 
+fetchPublic ::
+  ( MonadIO       m
+  , MonadKeyStore m key
+  , MonadRaise    m
+  , m `Raises` Key.Error
+  )
+  => Proxy key
+  -> m (PublicKey key)
+fetchPublic keyRole = do
+  sk <- fetch keyRole
+  toPublic keyRole sk
+
 getAsBytes ::
   ( MonadIO       m
   , MonadKeyStore m key

fission-cli/library/Fission/CLI/PIN/Payload/Types.hs

@@ -1,5 +1,7 @@
 module Fission.CLI.PIN.Payload.Types (Payload (..)) where
 
+import           Servant.API
+
 import           Fission.Prelude
 
 import           Fission.User.DID.Types
@@ -24,3 +26,9 @@ instance FromJSON Payload where
     did <- obj .: "did"
     pin <- obj .: "pin"
     return Payload {..}
+
+instance MimeRender OctetStream Payload where
+  mimeRender _ payload = encode payload
+
+instance MimeUnrender OctetStream Payload where
+  mimeUnrender _ lbs = eitherDecode lbs

fission-cli/library/Fission/CLI/PIN/Types.hs

@@ -3,6 +3,8 @@ module Fission.CLI.PIN.Types (PIN (..)) where
 import qualified RIO.Text                as Text
 import qualified RIO.Vector              as Vector
 
+import           Servant.API
+
 import           Fission.Prelude
 
 import           Fission.Emoji.Class
@@ -59,3 +61,9 @@ instance FromJSON PIN where
 
 instance Display (Mismatch PIN) where
   display _ = "PIN codes do not match"
+
+instance MimeRender OctetStream PIN where
+  mimeRender _ pin =  encode pin
+
+instance MimeUnrender OctetStream PIN where
+  mimeUnrender _ lbs = eitherDecode lbs

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

@@ -2,7 +2,7 @@ module Fission.CLI.PubSub
   ( listenJSON
   , listenRaw
   , broadcastJSON
-  , broadcastRaw
+  , broadcastApiData
   , module Fission.CLI.PubSub.Class
   , module Fission.CLI.PubSub.Topic.Types
   ) where
@@ -47,6 +47,6 @@ listenRaw conn = do
 broadcastJSON :: (MonadPubSub m, ToJSON msg) => Connection m -> msg -> m ()
 broadcastJSON conn msg = sendLBS conn $ encode msg
 
-broadcastRaw :: (MonadPubSub m, ToHttpApiData msg) => Connection m -> msg -> m ()
-broadcastRaw conn msg =
+broadcastApiData :: (MonadPubSub m, ToHttpApiData msg) => Connection m -> msg -> m ()
+broadcastApiData conn msg =
   sendLBS conn . Binary.toLazyByteString $ toEncodedUrlPiece msg

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

@@ -13,7 +13,8 @@ import qualified Crypto.PubKey.RSA                                 as RSA
 import qualified Crypto.PubKey.RSA.OAEP                            as RSA.OAEP
 import           Crypto.Random
 
-import           Data.ByteArray                                    as ByteArray hiding (any)
+import           Data.ByteArray                                    as ByteArray hiding
+                                                                                (any)
 import qualified Data.Yaml                                         as YAML
 
 import           Control.Monad.Base
@@ -39,6 +40,8 @@ import qualified Network.IPFS.Process.Error                        as Process
 import           Network.IPFS.Types                                as IPFS
 
 import qualified Network.WebSockets.Client                         as WS
+import           Servant.API                                       hiding
+                                                                   (IsMember)
 import           Servant.Client
 import qualified Wuss                                              as WSS
 
@@ -281,7 +284,7 @@ instance
     storePath `JSON.writeFile` WebNative.FileSystem.Auth.Store newGlobalStore
 
   getAllMatching did subGraphRoot = do
-    logDebug $ "Looking up AES key for " <> display did <> " @ " <> displayShow subGraphRoot
+    logDebug $ "👀 🔑 Looking up AES keys matching " <> display did <> " @ " <> displayShow subGraphRoot
 
     storePath  <- wnfsKeyStorePath
     storeOrErr <- attempt $ JSON.readFile storePath
@@ -519,7 +522,7 @@ instance
            | cmd == Just "pin" || cmd == Just "add" -> (Nothing,  opts' <> [arg', timeout, cidVersion, ignore])
            | otherwise                              -> (Nothing,  opts' <> [arg', timeout])
 
-      processStr = intercalate " " ("IPFS_PATH=" <> ipfsRepo : ipfs : opts)
+      processStr = unwords ("IPFS_PATH=" <> ipfsRepo : ipfs : opts)
       rawProcess = fromString processStr
       process    =
         case pipeArg of
@@ -729,10 +732,10 @@ instance forall errs cfg .
 
     let
       Symmetric.Key aesClear = sessionKey
-      ucan = Bearer.BareToken bearerToken
+      token = Bearer.BareToken bearerToken
 
     iv           <- ensureM   Symmetric.genIV
-    msg          <- ensure  $ Symmetric.encrypt sessionKey iv ucan
+    msg          <- ensure  $ Symmetric.encrypt sessionKey iv token
     encryptedAES <- ensureM $ RSA.OAEP.encrypt oaepParams rsaPK aesClear
 
     return PubSub.Handshake { iv
@@ -767,8 +770,8 @@ oaepParams = RSA.OAEP.defaultOAEPParams SHA256
 
 instance forall errs cfg msg .
   ( HasLogFunc cfg
-  , ToJSON   msg
-  , FromJSON msg
+  , MimeRender   OctetStream msg
+  , MimeUnrender OctetStream msg
   , IV.GenError `IsMember` errs
   , CryptoError `IsMember` errs
   , Display (OpenUnion errs)
@@ -784,8 +787,8 @@ instance forall errs cfg msg .
       Left cryptoError ->
         return . Left $ CannotDecrypt cryptoError
 
-      Right bs ->
-        case eitherDecodeStrict bs of
+      Right lbs ->
+        case mimeUnrender (Proxy @OctetStream) $ Lazy.fromStrict lbs of
           Left err -> return . Left $ UnableToDeserialize err
           Right a  -> return $ Right a
 

fission-cli/library/Fission/CLI/User/Link/Payload/Types.hs

@@ -2,6 +2,8 @@ module Fission.CLI.User.Link.Payload.Types (Payload (..)) where
 
 import           Crypto.Cipher.AES                   (AES256)
 
+import           Servant.API
+
 import           Fission.Prelude
 
 import qualified Fission.Key.Symmetric.Types         as Symmetric
@@ -14,9 +16,9 @@ data Payload = Payload
   deriving Eq
 
 instance ToJSON Payload where
-  toJSON Payload {readKey, bearer = Bearer.Token {rawContent}} =
+  toJSON Payload {readKey, bearer} =
     object [ "readKey" .= readKey
-           , "ucan"    .= rawContent
+           , "ucan"    .= BareToken bearer
            ]
 
 instance FromJSON Payload where
@@ -26,3 +28,9 @@ instance FromJSON Payload where
     bearer  <- parseJSON $ String ("bearer " <> rawUCAN)
 
     return Payload {..}
+
+instance MimeRender OctetStream Payload where
+  mimeRender _ payload = encode payload
+
+instance MimeUnrender OctetStream Payload where
+  mimeUnrender _ lbs = eitherDecode lbs

fission-cli/library/Fission/CLI/WebNative/FileSystem/Auth/Store.hs

@@ -1,23 +1,41 @@
 module Fission.CLI.WebNative.FileSystem.Auth.Store
-  ( getLeastPrivileged
+  ( create
+  , getLeastPrivileged
   , getMostPrivileged
   -- * Reexports
   , module Fission.CLI.WebNative.FileSystem.Auth.Store.Class
   , module Fission.CLI.WebNative.FileSystem.Auth.Store.Types
   ) where
 
 import           Crypto.Cipher.AES                                 (AES256)
+import           Crypto.Random.Types
 import qualified RIO.Map                                           as Map
 
 import           Fission.Prelude
 
 import           Fission.Error.NotFound.Types
-import qualified Fission.Key.Symmetric.Types                       as Symmetric
+import qualified Fission.Key.Symmetric                             as Symmetric
 import           Fission.User.DID.Types
 
-import           Fission.CLI.WebNative.FileSystem.Auth.Store.Class
+import qualified Fission.CLI.WebNative.FileSystem.Auth.Store.Class as WNFS.Auth
 import           Fission.CLI.WebNative.FileSystem.Auth.Store.Types
 
+-- Reexport
+
+import           Fission.CLI.WebNative.FileSystem.Auth.Store.Class
+
+create ::
+  ( MonadRandom m
+  , MonadStore  m
+  )
+  => DID
+  -> FilePath
+  -> m (Symmetric.Key AES256)
+create did path = do
+  key <- Symmetric.genAES256
+  WNFS.Auth.set did path key
+  return key
+
 getLeastPrivileged ::
   ( MonadStore m
   , MonadRaise m

fission-cli/library/Fission/CLI/WebNative/FileSystem/Auth/Store/Types.hs

@@ -7,7 +7,5 @@ import           Fission.Prelude
 import qualified Fission.Key.Symmetric.Types as Symmetric
 import           Fission.User.DID.Types
 
-newtype Store = Store { getStore :: DID :=> (FilePath :=> Symmetric.Key AES256) }
+newtype Store = Store { getStore :: Map DID (Map FilePath (Symmetric.Key AES256)) }
   deriving newtype (Eq, ToJSON, FromJSON)
-
-type k :=> v = Map k v