Hiroto/update system

.gitignore

@@ -4,6 +4,7 @@
 dist/*
 dist-newstyle/*
 .ghc.environment.*
+stack.yaml.lock
 
 # From daedalus-bridge
 node_modules/*

Makefile

@@ -7,20 +7,20 @@ stylish-haskell: ## Apply stylish-haskell on all *.hs files
 	@find . -type f -name "*.hs" -not -path '.git' -not -path '*.stack-work*' -print0 | xargs -0 stylish-haskell -i
 
 ghci: ## Run repl
-	@stack ghci $(PROJECT_NAME):lib --haddock-deps --ghci-options=-fobject-code
+	@stack ghci $(PROJECT_NAME):lib --haddock-deps --ghci-options=-fobject-code --nix
 
 ghcid:  ## Run ghcid
 	@ghcid --command "stack ghci $(PROJECT_NAME):lib --nix -j12 --ghci-options=-fobject-code"
 
 run-test: ## Build & run test
-	@stack build --fast && \
-	stack test --fast
+	@stack build --fast --nix && \
+	stack test --fast --nix
 
 test-ghci: ## Run repl on test suites
-	@stack ghci $(PROJECT_NAME):lib $(PROJECT_NAME):test:$(PROJECT_NAME)-test --ghci-options=-fobject-code
+	@stack ghci $(PROJECT_NAME):lib $(PROJECT_NAME):test:$(PROJECT_NAME)-test --ghci-options=-fobject-code --nix
 
 test-ghcid: ## Run ghcid on test suites
-	@ghcid --command "stack ghci $(PROJECT_NAME):lib $(PROJECT_NAME):test:$(PROJECT_NAME)-test --ghci-options=-fobject-code"
+	@ghcid --command "stack ghci --nix $(PROJECT_NAME):lib $(PROJECT_NAME):test:$(PROJECT_NAME)-test --ghci-options=-fobject-code"
 
 test-ghcid-nix: ## Run ghcid on test suites with Nix
 	#NUM_PROC = $(nproc --all) # Either try to fetch the real num of cores or default to 4

app/Launcher/Main.hs

@@ -18,6 +18,7 @@ import           Formatting.Buildable (Buildable (..))
 
 import           Control.Exception.Safe (throwM)
 
+-- import           Cardano.Shell.Update.Lib (runUpdater, updaterData)
 import           Cardano.Shell.Configuration.Types (LauncherConfig (..),
                                                     WalletArguments (..),
                                                     WalletPath (..))
@@ -38,6 +39,8 @@ import           Data.X509.Extra (failIfReasons, genRSA256KeyPair,
 main :: IO ()
 main = do
 
+  -- _ <- runUpdater updaterData
+
     let launcherConfig :: LauncherConfig
         launcherConfig = LauncherConfig
             { lcfgFilePath    = "./configuration/cert-configuration.yaml"

cardano-shell.cabal

@@ -31,6 +31,7 @@ library
     -- Update system
     , CardanoShellSpec
     , Cardano.Shell.Update.Types
+    , Cardano.Shell.Update.Lib
     -- Constants
     , Cardano.Shell.Constants.PartialTypes
     , Cardano.Shell.Constants.Types
@@ -42,7 +43,6 @@ library
       Cardano.Shell.NodeIPC.Lib
     , Cardano.Shell.NodeIPC.Message
     , Cardano.Shell.NodeIPC.ServerExample
-
   hs-source-dirs:
       app
     , src
@@ -69,6 +69,8 @@ library
     , text
     , transformers
     , generic-monoid
+  if os(windows)
+    build-depends:     Win32
 
   default-language:    Haskell2010
   default-extensions:  NoImplicitPrelude
@@ -181,6 +183,7 @@ test-suite cardano-shell-test
   other-modules:
       Paths_cardano_shell
       DhallConfigSpec
+      UpdaterSpec
   if !os(windows)
     other-modules:
       NodeIPCSpec

src/Cardano/Shell/Update/Lib.hs

@@ -0,0 +1,145 @@
+{-| Update module
+-}
+
+{-# LANGUAGE CPP                 #-}
+{-# LANGUAGE LambdaCase          #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+
+module Cardano.Shell.Update.Lib
+    ( UpdaterData(..)
+    , UpdateError(..)
+    , RunCmdFunc
+    , updaterData
+    , runUpdater
+    , runUpdater'
+    ) where
+
+import           Cardano.Prelude
+
+import qualified Data.Text as T
+import           Distribution.System (OS (..), buildOS)
+import           Prelude (String)
+import           System.Directory (doesFileExist, removeFile)
+import           System.Environment (getExecutablePath)
+import           System.Process (proc, waitForProcess, withCreateProcess)
+#ifdef mingw32_HOST_OS
+import           System.Win32.Process (getCurrentProcessId)
+#endif
+
+-- | Updater path, args, windows runner path, archive path
+data UpdaterData = UpdaterData
+    { udPath        :: !FilePath
+    , udArgs        :: ![Text]
+    , udWindowsPath :: Maybe FilePath
+    , udArchivePath :: Maybe FilePath
+    }
+
+-- Windows: https://github.com/input-output-hk/daedalus/blob/develop/installers/dhall/win64.dhall#L32-L35
+-- MacOS: https://github.com/input-output-hk/daedalus/blob/develop/installers/dhall/macos64.dhall#L31-L34
+-- Linux: https://github.com/input-output-hk/daedalus/blob/develop/installers/dhall/linux64.dhall#L29-L32
+updaterData :: UpdaterData
+updaterData = case buildOS of
+    Windows -> UpdaterData
+                   "Installer.exe"
+                   []
+                   (Just "Installer.bat")
+                   Nothing
+    OSX     -> UpdaterData
+                    "/usr/bin/open"
+                    ["-FW"]
+                    Nothing
+                    (Just "\\${HOME}/Library/Application Support/Daedalus/installer.pkg")
+    _       -> UpdaterData
+                    "/bin/update-runner"
+                    []
+                    Nothing
+                    (Just "\\${XDG_DATA_HOME}/Daedalus/installer.sh")
+
+data UpdateError
+    = UpdateFailed Int
+    | UpdaterDoesNotExist
+    deriving (Eq, Show)
+
+-- | Run the update system
+--
+-- For UNIX system:
+--
+-- Check that @udPath@ exists, then run the command @udPath udArgs udArchivePath@
+--
+-- For Windows:
+--
+-- Check that @udPath@ exists, but instead of running the command directly, you
+-- first have to generate a @.bat@ file which will act as a script.
+-- After it being generated, you run that script.
+runUpdater :: UpdaterData -> IO (Either UpdateError ExitCode)
+runUpdater = runUpdater' runCmd
+  where
+    runCmd :: FilePath -> [String] -> FilePath -> IO ExitCode
+    runCmd path args archive =
+        withCreateProcess (proc path (args <> [archive]))
+            $ \_in _out _err ph -> waitForProcess ph
+
+type RunCmdFunc = FilePath -> [String] -> FilePath -> IO ExitCode
+
+-- | @runUpdater@ but can inject any runCommand function.
+-- This is used for testing.
+runUpdater' :: RunCmdFunc -> UpdaterData -> IO (Either UpdateError ExitCode)
+runUpdater' runCommand ud = do
+    let path = udPath ud
+    let args = map toS $ udArgs ud
+    let mWindowPath = udWindowsPath ud
+    let archive = maybe mempty (\arch -> toS arch) (udArchivePath ud)
+    updaterExists <- doesFileExist path
+    if updaterExists
+        then do
+            exitCode <- case mWindowPath of
+                Nothing -> runCommand path args archive
+                Just windowsPath -> do
+                    writeWindowsUpdaterRunner windowsPath
+                    runCommand windowsPath args archive
+            case exitCode of
+                ExitSuccess -> do
+                    whenJust (udArchivePath ud) $ \updateArchivePath -> do
+                        removeFile updateArchivePath
+                    return . Right $ ExitSuccess
+                ExitFailure code -> return . Left $ UpdateFailed code
+        else
+            return . Left $ UpdaterDoesNotExist
+  where
+    whenJust :: (Monad m) => Maybe a -> (a -> m ()) -> m ()
+    whenJust (Just a) f = f a
+    whenJust Nothing  _ = return ()
+
+-- | Create @.bat@ file on given @FilePath@
+--
+-- https://github.com/input-output-hk/cardano-sl/blob/develop/tools/src/launcher/Main.hs#L585
+--
+-- The installer cant write to cardano-launcher.exe while it is running
+-- so you must fully stop launcher before you can start the installer.
+-- Because of this, we need a @.bat@ file which will run the update procedure and
+-- re-launch the launcher.
+-- Only Windows has this problem.
+writeWindowsUpdaterRunner :: FilePath -> IO ()
+writeWindowsUpdaterRunner runnerPath = do
+    exePath <- getExecutablePath
+    launcherArgs <- getArgs
+#ifdef mingw32_HOST_OS
+    selfPid <- getCurrentProcessId
+#else
+    let (selfPid :: Integer) = 0 -- This will never be run on non-Windows
+#endif
+    writeFile (toS runnerPath) $ T.unlines
+        [ "TaskKill /PID "<> show selfPid <>" /F"
+        -- Run updater
+        , "%*"
+        -- Delete updater
+        , "del %1"
+        -- Run launcher again
+        , "start \"cardano launcher\" /b " <> (quote $ toS exePath) <> " "
+            <> (T.unwords $ map (quote . toS) launcherArgs)
+        -- Delete the bat file
+        , "(goto) 2>nul & del \"%~f0\""
+        ]
+  where
+    quote :: Text -> Text
+    quote str = "\"" <> str <> "\""

src/Cardano/Shell/Update/Types.hs

@@ -3,8 +3,7 @@ module Cardano.Shell.Update.Types where
 import           Cardano.Prelude
 
 import qualified Data.Map as M
-
-import           Test.QuickCheck
+import           Test.QuickCheck (Gen, choose, frequency, listOf1)
 
 
 -- Types we need to check the behaviour.

stack.yaml

@@ -36,6 +36,5 @@ extra-deps:
   - containers-0.5.11.0
   - libsystemd-journal-1.4.4
 
-
 nix:
   shell-file: stack-shell.nix

test/UpdaterSpec.hs

@@ -0,0 +1,55 @@
+{-# LANGUAGE ScopedTypeVariables #-}
+
+module UpdaterSpec where
+
+import           Cardano.Prelude
+
+import           Prelude (String)
+import           Test.Hspec (Spec, describe, it)
+import           Test.Hspec.QuickCheck (prop)
+import           Test.QuickCheck (Arbitrary (..), elements)
+import           Test.QuickCheck.Monadic (assert, monadicIO, run)
+
+import           Cardano.Shell.Update.Lib (UpdateError (..), UpdaterData (..),
+                                           runUpdater, runUpdater')
+
+updaterSpec :: Spec
+updaterSpec = describe "Update system" $ do
+    it "should be successful" $ monadicIO $ do
+        eExitCode <- run $ runUpdater testUpdaterData
+        assert $ eExitCode == (Right ExitSuccess)
+
+    it "should return error when updater is not found" $ monadicIO $ do
+        eExitCode <- run $ runUpdater testUpdaterDataNoPath
+        assert $ eExitCode == (Left UpdaterDoesNotExist)
+
+    prop "should return expected error" $ \(exitNum :: ExitNum) -> monadicIO $ do
+        eExitCode <- run $ runUpdater' (testRunCmd exitNum) testUpdaterData
+        assert $ eExitCode == (Left . UpdateFailed . getExitNum $ exitNum)
+
+testUpdaterData :: UpdaterData
+testUpdaterData = 
+    UpdaterData
+        "./test/test.sh"
+        []
+        Nothing
+        Nothing
+
+testUpdaterDataNoPath :: UpdaterData
+testUpdaterDataNoPath = 
+    UpdaterData
+        "This path does not exist"
+        []
+        Nothing
+        Nothing
+
+testRunCmd :: ExitNum -> FilePath -> [String] -> FilePath -> IO ExitCode
+testRunCmd (ExitNum num) _ _ _ = return $ ExitFailure num
+
+newtype ExitNum = ExitNum {
+    getExitNum :: Int
+    } deriving Show
+
+-- http://tldp.org/LDP/abs/html/exitcodes.html
+instance Arbitrary ExitNum where
+    arbitrary = ExitNum <$> elements [1, 2, 126, 127, 128, 130, 255]

test/test.sh

@@ -0,0 +1 @@
+exit 0