diff --git a/fission-cli/library/Fission/CLI/Handler/App/Publish.hs b/fission-cli/library/Fission/CLI/Handler/App/Publish.hs index 17a13d90c..c59ca286e 100644 --- a/fission-cli/library/Fission/CLI/Handler/App/Publish.hs +++ b/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,7 +133,7 @@ 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 @@ -136,15 +141,11 @@ publish 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 @@ -152,7 +153,7 @@ handleTreeChanges :: -> 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 diff --git a/fission-cli/package.yaml b/fission-cli/package.yaml index 5ac9df8d5..01349bcc9 100644 --- a/fission-cli/package.yaml +++ b/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 diff --git a/fission-cli/test/Fission/Test/CLI.hs b/fission-cli/test/Fission/Test/CLI.hs new file mode 100644 index 000000000..50e4b71a2 --- /dev/null +++ b/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 diff --git a/fission-cli/test/Fission/Test/CLI/Prelude.hs b/fission-cli/test/Fission/Test/CLI/Prelude.hs new file mode 100644 index 000000000..95e68dc4d --- /dev/null +++ b/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] diff --git a/fission-cli/test/Main.hs b/fission-cli/test/Main.hs new file mode 100644 index 000000000..c61ae20c1 --- /dev/null +++ b/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 diff --git a/fission-web-client/library/Fission/Web/Client/Error.hs b/fission-web-client/library/Fission/Web/Client/Error.hs index d0bbaefe0..46c79bb1c 100644 --- a/fission-web-client/library/Fission/Web/Client/Error.hs +++ b/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