Generate new UCAN on CLI retry (#553)

fission-cli/library/Fission/CLI/Handler/App/Publish.hs

@@ -8,6 +8,7 @@ import           System.FSNotify                           as FS
 
 import           RIO.Directory
 import           Web.Browser
+import           Servant.Client
 
 import           Network.HTTP.Types.Status
 import qualified Network.IPFS.Process.Error                as IPFS.Process
@@ -27,7 +28,6 @@ import           Fission.URL
 import           Fission.Authorization.ServerDID
 import           Fission.Error.NotFound.Types
 
-import           Fission.Web.Auth.Token.JWT                as JWT
 import           Fission.Web.Auth.Token.Types
 
 import           Fission.Web.Client                        as Client
@@ -48,7 +48,7 @@ import           Fission.CLI.Environment                   (MonadEnvironment)
 import           Fission.CLI.WebNative.Mutation.Auth.Store as UCAN
 
 -- | Sync the current working directory to the server over IPFS
-publish ::
+publish :: forall m .
   ( MonadIO          m
   , MonadCleanup     m
   , MonadLogger      m
@@ -104,12 +104,17 @@ publish
 
         Right cid@(CID hash) -> do
           logDebug $ "📱 Directory CID is " <> hash
-          _     <- IPFS.Daemon.runDaemon
-          proof <- getRootUserProof
-          req   <- updateApp appURL cid (Just updateData) <$> Client.attachAuth proof
+          _ <- IPFS.Daemon.runDaemon
+
+          let
+            runUpdate :: CID -> m (ClientM ())
+            runUpdate cid' = do
+              proof <- getRootUserProof
+              ucan  <- Client.attachAuth proof
+              return $ updateApp appURL cid' (Just updateData) ucan
 
           logUser @Text "✈️  Pushing to remote"
-          retryOnStatus [status502] 100 req >>= \case
+          retryOnStatus [status502] 100 (runUpdate cid) >>= \case
             Left err -> do
               CLI.Error.put err "Server unable to sync data"
               raise err
@@ -128,31 +133,27 @@ publish
                     timeCache <- newTVar now
                     return (hashCache, timeCache)
 
-                  void $ handleTreeChanges runner proof appURL updateData timeCache hashCache watchMgr absBuildPath
+                  void $ handleTreeChanges runner runUpdate appURL updateData timeCache hashCache watchMgr absBuildPath
                   liftIO . forever $ threadDelay 1_000_000 -- Sleep main thread
 
               success appURL
 
 handleTreeChanges ::
   ( MonadIO        m
   , MonadLogger    m
-  , MonadTime      m
   , MonadLocalIPFS m
   , MonadWebClient m
-  , MonadWebAuth   m Token
-  , MonadWebAuth   m Ed25519.SecretKey
-  , ServerDID      m
   )
   => (m () -> IO ())
-  -> JWT.Proof
+  -> (CID -> m (ClientM ()))
   -> URL
   -> Bool
   -> TVar UTCTime
   -> TVar Text
   -> WatchManager
   -> FilePath -- ^ Build dir
   -> IO StopListening
-handleTreeChanges runner userProof appURL copyFilesFlag timeCache hashCache watchMgr absDir =
+handleTreeChanges runner runUpdate appURL copyFilesFlag timeCache hashCache watchMgr absDir =
   FS.watchTree watchMgr absDir (\_ -> True) \_ ->
     runner do
       now <- getCurrentTime
@@ -190,9 +191,8 @@ handleTreeChanges runner userProof appURL copyFilesFlag timeCache hashCache watc
               Just oldHash -> do
                 logDebug $ "CID: " <> display oldHash <> " -> " <> display newHash
                 UTF8.putNewline
-                req <- updateApp appURL cid (Just copyFilesFlag) <$> attachAuth userProof
 
-                retryOnStatus [status502] 100 req >>= \case
+                retryOnStatus [status502] 100 (runUpdate cid) >>= \case
                   Left err -> CLI.Error.put err "Server unable to sync data"
                   Right _  -> success appURL
 

fission-cli/package.yaml

@@ -1,5 +1,5 @@
 name: fission-cli
-version: '2.16.0.0'
+version: '2.16.1.0'
 category: CLI
 author:
   - Brooklyn Zelenka
@@ -182,6 +182,24 @@ executables:
     # cc-options: -static
     # ld-options: -static -pthread
 
+tests:
+  fission-cli-test:
+    main: Main.hs
+    source-dirs:
+      - library
+      - test
+    dependencies:
+      - hspec
+      - hspec-core
+      - hspec-expectations
+      - fission-web-server
+      - QuickCheck
+      - quickcheck-instances
+      - tasty
+      - tasty-hunit
+      - tasty-hspec
+      - tasty-smallcheck
+
 benchmarks:
   fission-cli-benchmark:
     main: Main.hs

fission-cli/test/Fission/Test/CLI.hs

@@ -0,0 +1,9 @@
+module Fission.Test.CLI where
+
+import           Fission.Test.CLI.Prelude
+
+spec :: Spec
+spec =
+  describe "Fission.CLI" do
+    it "runs at all" do
+      1 `shouldNotBe` 2

fission-cli/test/Fission/Test/CLI/Prelude.hs

@@ -0,0 +1,32 @@
+module Fission.Test.CLI.Prelude
+  ( module Fission.Prelude
+  --
+  , module Test.Tasty
+  , module Test.Tasty.Hspec
+  , module Test.QuickCheck
+  --
+  , itsProp'
+  , shouldHaveRun
+  ) where
+
+import           Test.Tasty                (TestTree, defaultMain, testGroup)
+import           Test.Tasty.Hspec
+
+import           Test.QuickCheck           hiding (Result (..))
+import           Test.QuickCheck.Instances ()
+
+import           Fission.Prelude           hiding (Result (..), log)
+
+-- | Prop test with the default number of tries (100)
+itsProp' :: (HasCallStack, Testable a) => String -> a -> SpecWith ()
+itsProp' description prop = it ("🔀 " <> description) $ property prop
+
+shouldHaveRun ::
+  ( Eq   (OpenUnion logs)
+  , Show (OpenUnion logs)
+  , IsMember eff logs
+  )
+  => [OpenUnion logs]
+  -> eff
+  -> Expectation
+shouldHaveRun effLog eff = effLog `shouldContain` [openUnionLift eff]

fission-cli/test/Main.hs

@@ -0,0 +1,9 @@
+module Main (main) where
+
+import qualified Fission.Test.CLI         as CLI
+import           Fission.Test.CLI.Prelude
+
+main :: IO ()
+main = do
+  spec <- testSpecs $ parallel CLI.spec
+  defaultMain $ testGroup "Tests" spec

fission-web-client/library/Fission/Web/Client/Error.hs

@@ -3,30 +3,28 @@ module Fission.Web.Client.Error
   , checkStatus
   ) where
 
-import           Fission.Error
-import           Fission.Prelude           hiding (fromMaybe)
-
-import           Fission.Web.Client
 import           Network.HTTP.Types.Status
 import           Servant.Client
 
+import           Fission.Prelude           hiding (fromMaybe)
+
+import           Fission.Error
+import           Fission.Web.Client
 
 retryOnStatus ::
-  ( MonadWebClient m
-  , MonadLogger m
+  ( MonadLogger    m
+  , MonadWebClient m
   )
   => [Status]
   -> Natural
-  -> ClientM a
+  -> m (ClientM a)
   -> m (Either ClientError a)
-retryOnStatus retryOn times req =
-  retryOnErr (checkStatus retryOn) times (sendRequest req)
+retryOnStatus retryOn times mkReq =
+  retryOnErr (checkStatus retryOn) times do
+    req <- mkReq
+    sendRequest req
 
-checkStatus ::
-  MonadLogger m
-  => [Status]
-  -> Either ClientError a
-  -> m Bool
+checkStatus :: MonadLogger m => [Status] -> Either ClientError a -> m Bool
 checkStatus retryOn = \case
   Right _ ->
     return True