{-# LANGUAGE OverloadedStrings #-} module Deployer where import Data.List (isPrefixOf) import Data.Maybe (catMaybes) import Data.Text (pack) import Prelude hiding (error) import Shelly (cp_r, fromText, shelly) import System.Directory (createDirectoryIfMissing, emptyPermissions, getDirectoryContents, getHomeDirectory, getPermissions, removeDirectoryRecursive, removeFile) import System.Posix.Env (getEnv) import System.Exit (ExitCode (..)) import System.FilePath (dropFileName, normalise, ()) import System.Posix.Files (createSymbolicLink, fileExist, getSymbolicLinkStatus, isBlockDevice, isCharacterDevice, isDirectory, isNamedPipe, isRegularFile, isSocket, isSymbolicLink, readSymbolicLink) import System.Process (system) import Formatter (formatPostDeployments, formatPreDeployments) import Types import Utils deploy :: [Deployment] -> Sparker () deploy dps = do state <- initialState dps _ <- runSparkDeployer state $ deployAll dps return () check :: [Deployment] -> Sparker [PreDeployment] check dps = do state <- initialState dps (pdps, _) <- runSparkDeployer state $ predeployments dps return pdps initialState :: [Deployment] -> Sparker DeployerState initialState _ = return DeployerState deployAll :: [Deployment] -> SparkDeployer () deployAll deps = do pdps <- predeployments deps case catErrors pdps of [] -> do deployments pdps postdeployments deps pdps ss -> throwError $ DeployError $ PreDeployError ss catErrors :: [PreDeployment] -> [String] catErrors [] = [] catErrors (s:ss) = case s of Ready _ _ _ -> catErrors ss AlreadyDone -> catErrors ss Error str -> str : catErrors ss predeployments :: [Deployment] -> SparkDeployer [PreDeployment] predeployments dps = do pdps <- mapM preDeployment dps lift $ debug $ formatPreDeployments $ zip dps pdps return pdps preDeployment :: Deployment -> SparkDeployer PreDeployment preDeployment (Put [] dst _) = return $ Error $ unwords ["No source for deployment with destination:", dst] preDeployment dep@(Put (src:ss) dst kind) = do s <- complete src d <- complete dst sd <- diagnose s dd <- diagnose d let ready = return (Ready s d kind) :: SparkDeployer PreDeployment case (sd, dd, kind) of (NonExistent , _ , _ ) -> preDeployment (Put ss d kind) (IsFile _ , NonExistent , _ ) -> ready (IsFile _ , IsFile _ , LinkDeployment) -> incaseElse conf_deploy_replace_files (rmFile d >> preDeployment dep) (error ["Destination", d, "already exists and is file (for a link deployment):", s, "."]) (IsFile _ , IsFile _ , CopyDeployment) -> do equal <- compareFiles s d if equal then done else do incaseElse conf_deploy_replace_files (rmFile d >> preDeployment dep) (error ["Destination", d, "already exists and is a file, different from the source:", s, "."]) (IsFile _ , IsDirectory _ , _ ) -> incaseElse conf_deploy_replace_directories (rmDir d >> preDeployment dep) (error ["Destination", d, "already exists and is a directory."]) (IsFile _ , IsLink _ , LinkDeployment) -> do point <- liftIO $ readSymbolicLink d if point `filePathEqual` s then done else do liftIO $ putStrLn $ point ++ " is not equal to " ++ d incaseElse conf_deploy_replace_links (unlink d >> preDeployment dep) (error ["Destination", d, "already exists and is a symbolic link but not to the source."]) (IsFile _ , IsLink _ , CopyDeployment) -> incaseElse conf_deploy_replace_links (unlink d >> preDeployment dep) (error ["Destination", d, "already exists and is a symbolic link (for a copy deployment):", s, "."]) (IsFile _ , _ , _ ) -> error ["Destination", d, "already exists and is something weird."] (IsDirectory _ , NonExistent , _ ) -> ready (IsDirectory _ , IsFile _ , _ ) -> incaseElse conf_deploy_replace_files (rmFile d >> preDeployment dep) (error ["Destination", d, "already exists and is a file."]) (IsDirectory _ , IsDirectory _ , LinkDeployment) -> incaseElse conf_deploy_replace_directories (rmDir d >> preDeployment dep) (error ["Destination", d, "already exists and is directory (for a link deployment):", s, "."]) (IsDirectory _ , IsDirectory _ , CopyDeployment) -> do equal <- compareDirectories s d if equal then done else do incaseElse conf_deploy_replace_directories (rmDir d >> preDeployment dep) (error ["Destination", d, "already exists and is a directory, different from the source."]) (IsDirectory _ , IsLink _ , LinkDeployment) -> do point <- liftIO $ readSymbolicLink d if point `filePathEqual` s then done else incaseElse conf_deploy_replace_links (unlink d >> preDeployment dep) (error ["Destination", d, "already exists and is a symbolic link but not to the source."]) (IsDirectory _ , IsLink _ , CopyDeployment) -> incaseElse conf_deploy_replace_links (unlink d >> preDeployment dep) (error ["Destination", d, "already exists and is a symbolic link."]) (IsLink _ , _ , _ ) -> error ["Source", s, "is a symbolic link."] _ -> error ["Source", s, "is not a valid file type."] where done :: SparkDeployer PreDeployment done = return $ AlreadyDone error :: [String] -> SparkDeployer PreDeployment error strs = return $ Error $ unwords strs cmpare :: FilePath -> FilePath -> SparkDeployer Bool cmpare f1 f2 = do d1 <- diagnose f1 d2 <- diagnose f2 if d1 /= d2 then return False else case d1 of IsFile _ -> compareFiles f1 f2 IsDirectory _ -> compareDirectories f1 f2 _ -> return True compareFiles :: FilePath -> FilePath -> SparkDeployer Bool compareFiles f1 f2 = do s1 <- liftIO $ readFile f1 s2 <- liftIO $ readFile f2 return $ s1 == s2 compareDirectories :: FilePath -> FilePath -> SparkDeployer Bool compareDirectories d1 d2 = do dc1 <- contents d1 dc2 <- contents d2 b <- mapM (uncurry cmpare) $ zip dc1 dc2 return $ and b where contents d = do cs <- liftIO $ getDirectoryContents d return $ filter (\f -> not $ f == "." || f == "..") cs diagnose :: FilePath -> SparkDeployer Diagnostics diagnose fp = do e <- liftIO $ fileExist fp if e then do s <- liftIO $ getSymbolicLinkStatus fp if isBlockDevice s then return IsBlockDevice else if isCharacterDevice s then return IsCharDevice else if isSocket s then return IsSocket else if isNamedPipe s then return IsPipe else do p <- liftIO $ getPermissions fp if isSymbolicLink s then return $ IsLink p else if isDirectory s then return $ IsDirectory p else if isRegularFile s then return $ IsFile p else throwError $ UnpredictedError "Contact the author if you see this" else do -- Because if a link exists, but it points to something that doesn't exist, it is considered as non-existent by `fileExist` es <- liftIO $ system $ unwords ["test", "-L", fp] case es of ExitSuccess -> return $ IsLink emptyPermissions ExitFailure _ -> return NonExistent deployments :: [PreDeployment] -> SparkDeployer [Maybe String] deployments = mapM deployment deployment :: PreDeployment -> SparkDeployer (Maybe String) deployment AlreadyDone = return Nothing deployment (Error str) = return $ Just str deployment (Ready src dst kind) = do case kind of LinkDeployment -> link src dst CopyDeployment -> copy src dst return Nothing copy :: FilePath -> FilePath -> SparkDeployer () copy src dst = do debug $ unwords ["Copying:", src, "c->", dst] liftIO $ createDirectoryIfMissing True upperDir liftIO $ shelly $ cp_r (fromText $ pack src) (fromText $ pack dst) where upperDir = dropFileName dst link :: FilePath -> FilePath -> SparkDeployer () link src dst = do debug $ unwords ["Linking:", src, "l->", dst] liftIO $ createDirectoryIfMissing True upperDir liftIO $ createSymbolicLink src dst where upperDir = dropFileName dst -- TODO these dont catch errors unlink :: FilePath -> SparkDeployer () unlink fp = do es <- liftIO $ system $ unwords $ ["/usr/bin/unlink", fp] case es of ExitSuccess -> debug $ unwords ["unlinked", fp] ExitFailure _ -> throwError $ DeployError $ PreDeployError ["Something went wrong while unlinking " ++ fp ++ "."] rmFile :: FilePath -> SparkDeployer () rmFile fp = do liftIO $ removeFile fp debug $ unwords ["removed", fp] rmDir :: FilePath -> SparkDeployer () rmDir fp = do liftIO $ removeDirectoryRecursive fp debug $ unwords ["removed", fp] postdeployments :: [Deployment] -> [PreDeployment] -> SparkDeployer () postdeployments deps predeps = do pdps <- mapM postdeployment predeps lift $ debug $ formatPostDeployments $ zip deps pdps case catMaybes pdps of [] -> return () es -> throwError $ DeployError $ PostDeployError es postdeployment :: PreDeployment -> SparkDeployer (Maybe String) postdeployment AlreadyDone = return Nothing postdeployment (Error _) = throwError $ UnpredictedError "Contact the author if you see this. (postdeployment)" postdeployment (Ready src dst kind) = do sd <- diagnose src dd <- diagnose dst case (sd, dd, kind) of (NonExistent , _ , _ ) -> error ["The source", src, "is somehow missing after deployment."] (IsFile _ , NonExistent , _ ) -> error ["The destination", dst, "is somehow non-existent after deployment."] (IsFile _ , IsFile _ , LinkDeployment) -> error ["The destination", dst, "is somehow a file while it was a link deployment."] (IsFile _ , IsFile _ , CopyDeployment) -> compareFile (IsFile _ , IsDirectory _ , _ ) -> error ["The destination", dst, "is somehow a directory after the deployment of the file", src, "."] (IsFile _ , IsLink _ , LinkDeployment) -> compareLink (IsFile _ , IsLink _ , CopyDeployment) -> error ["The destination", dst, "is somehow a link while it was a copy deployment."] (IsFile _ , _ , _ ) -> error ["The destination", dst, "is something weird after deployment."] (IsDirectory _ , NonExistent , _ ) -> error ["The destination", dst, "is somehow non-existent after deployment."] (IsDirectory _ , IsFile _ , _ ) -> error ["The destination", dst, "is somehow a file after the deployment of the directory", src, "."] (IsDirectory _ , IsDirectory _ , LinkDeployment) -> error ["The destination", dst, "is somehow a directory while it was a link deployment."] (IsDirectory _ , IsDirectory _ , CopyDeployment) -> compareDir (IsDirectory _ , IsLink _ , LinkDeployment) -> compareLink (IsDirectory _ , IsLink _ , CopyDeployment) -> error ["The destination", dst, "is somehow a link while it was a copy deployment."] (IsDirectory _ , _ , _ ) -> error ["The destination", dst, "is something weird after deployment."] (IsLink _ , _ , _ ) -> error ["The source", src, "is a symbolic link."] _ -> error ["The source", src, "is something weird."] where fine :: SparkDeployer (Maybe String) fine = return Nothing error :: [String] -> SparkDeployer (Maybe String) error err = return $ Just $ unwords err compareFile :: SparkDeployer (Maybe String) compareFile = do equal <- compareFiles src dst if equal then fine else error ["The source and destination files are somehow still not equal."] compareDir :: SparkDeployer (Maybe String) compareDir = do equal <- compareDirectories src dst if equal then fine else error ["The source and destination directories are somehow still not equal."] compareLink :: SparkDeployer (Maybe String) compareLink = do point <- liftIO $ readSymbolicLink dst if point `filePathEqual` src then fine else do debug $ unwords ["The destination points to", point, "but the src points to", src] error ["The destination is a symbolic link, but it doesn't point to the source."] filePathEqual :: FilePath -> FilePath -> Bool filePathEqual f g = (normalise f) == (normalise g) complete :: FilePath -> SparkDeployer FilePath complete fp = liftIO $ completeI fp completeI :: FilePath -> IO FilePath completeI fp = do let ids = parseId fp strs <- mapM replaceId ids completed <- mapM replaceHome strs return $ concat completed parseId :: FilePath -> [ID] parseId [] = [Plain ""] parseId ('$':'(':rest) = (Var id):(parseId next) where (id, (')':next)) = break (\c -> c == ')') rest parseId (s:ss) = case parseId ss of (Plain str):r -> (Plain (s:str)):r r -> (Plain [s]):r replaceId :: ID -> IO FilePath replaceId (Plain str) = return str replaceId (Var str) = do e <- getEnv str return $ case e of Nothing -> "" Just fp -> fp replaceHome :: FilePath -> IO FilePath replaceHome path = do home <- getHomeDirectory return $ if "~" `isPrefixOf` path then home drop 2 path else path