module Life.Github
(
checkRemoteSync
, cloneRepo
, createNewBranch
, doesBranchExist
, insideRepo
, withSynced
, copyLife
, addToRepo
, createRepository
, pullUpdateFromRepo
, removeFromRepo
, updateDotfilesRepo
, updateFromRepo
, getUserLogin
) where
import Colourista (errorMessage, infoMessage, warningMessage)
import Control.Exception (catch, throwIO)
import Path (Abs, Dir, File, Path, Rel, toFilePath, (</>))
import Path.IO (copyDirRecur, copyFile, getHomeDir, withCurrentDir)
import Shellmet (($|))
import System.IO.Error (IOError, isDoesNotExistError)
import Life.Configuration (LifeConfiguration (..), lifeConfigMinus, parseRepoLife)
import Life.Core (Branch (..), CommitMsg (..), CopyDirection (..), Owner (..), Repo (..), master)
import Life.Message (chooseYesNo)
import Life.Path (lifePath, relativeToHome, repoName)
import qualified Data.Text as Text
askToPushka :: CommitMsg -> IO ()
askToPushka :: CommitMsg -> IO ()
askToPushka commitMsg :: CommitMsg
commitMsg = do
"git" ["add", "."]
Text -> IO ()
infoMessage "The following changes are going to be pushed:"
"git" ["diff", "--name-status", "HEAD"]
Bool
continue <- Text -> IO Bool
chooseYesNo "Would you like to proceed?"
if Bool
continue
then Branch -> CommitMsg -> IO ()
pushka Branch
master CommitMsg
commitMsg
else Text -> IO ()
errorMessage "Abort pushing" IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> IO ()
forall (m :: * -> *) a. MonadIO m => m a
exitFailure
pushka :: Branch -> CommitMsg -> IO ()
pushka :: Branch -> CommitMsg -> IO ()
pushka (Branch branch :: Text
branch) (CommitMsg commitMsg :: Text
commitMsg) = do
"git" ["add", "."]
"git" ["commit", "-m", Text
commitMsg]
"git" ["push", "-u", "origin", Text
branch]
createRepository :: Maybe Owner -> Repo -> IO ()
createRepository :: Maybe Owner -> Repo -> IO ()
createRepository mo :: Maybe Owner
mo (Repo repo :: Text
repo) = do
Text
owner <- Maybe Owner -> IO Text
getOwnerLogin Maybe Owner
mo
let description :: Text
description = ":computer: Configuration files"
"git" ["init"]
"hub" ["create", "-d", Text
description, Text
owner Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> "/" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
repo]
Branch -> CommitMsg -> IO ()
pushka Branch
master (CommitMsg -> IO ()) -> CommitMsg -> IO ()
forall a b. (a -> b) -> a -> b
$ Text -> CommitMsg
CommitMsg "Create the project"
getUserLogin :: IO Text
getUserLogin :: IO Text
getUserLogin = do
Text
login <- "git" FilePath -> [Text] -> IO Text
$| ["config", "user.login"]
if Text
login Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== ""
then Text -> IO ()
errorMessage "user.login is not specified" IO () -> IO Text -> IO Text
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> IO Text
forall (m :: * -> *) a. MonadIO m => m a
exitFailure
else Text -> IO Text
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text -> IO Text) -> Text -> IO Text
forall a b. (a -> b) -> a -> b
$ Text -> Text
forall a. ToText a => a -> Text
toText Text
login
getOwnerLogin :: Maybe Owner -> IO Text
getOwnerLogin :: Maybe Owner -> IO Text
getOwnerLogin = IO Text -> (Owner -> IO Text) -> Maybe Owner -> IO Text
forall b a. b -> (a -> b) -> Maybe a -> b
maybe IO Text
getUserLogin (Text -> IO Text
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text -> IO Text) -> (Owner -> Text) -> Owner -> IO Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Owner -> Text
unOwner)
insideRepo :: IO a -> IO a
insideRepo :: IO a -> IO a
insideRepo action :: IO a
action = do
Path Abs Dir
repoPath <- Path Rel Dir -> IO (Path Abs Dir)
forall (m :: * -> *) t. MonadIO m => Path Rel t -> m (Path Abs t)
relativeToHome Path Rel Dir
repoName
Path Abs Dir -> IO a -> IO a
forall (m :: * -> *) b a.
(MonadIO m, MonadMask m) =>
Path b Dir -> m a -> m a
withCurrentDir Path Abs Dir
repoPath IO a
action
pushRepo :: CommitMsg -> IO ()
pushRepo :: CommitMsg -> IO ()
pushRepo = IO () -> IO ()
forall a. IO a -> IO a
insideRepo (IO () -> IO ()) -> (CommitMsg -> IO ()) -> CommitMsg -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CommitMsg -> IO ()
askToPushka
cloneRepo :: Maybe Owner -> IO ()
cloneRepo :: Maybe Owner -> IO ()
cloneRepo mo :: Maybe Owner
mo = do
Text
owner <- Maybe Owner -> IO Text
getOwnerLogin Maybe Owner
mo
Path Abs Dir
homeDir <- IO (Path Abs Dir)
forall (m :: * -> *). MonadIO m => m (Path Abs Dir)
getHomeDir
Path Abs Dir -> IO () -> IO ()
forall (m :: * -> *) b a.
(MonadIO m, MonadMask m) =>
Path b Dir -> m a -> m a
withCurrentDir Path Abs Dir
homeDir (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
Text -> IO ()
infoMessage "Using SSH to clone repo..."
"git" ["clone", "git@github.com:" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
owner Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> "/dotfiles.git"]
createNewBranch :: Branch -> IO ()
createNewBranch :: Branch -> IO ()
createNewBranch (Branch branch :: Text
branch) =
"git" ["checkout", "-b", Text
branch]
checkRemoteSync :: Branch -> IO Bool
checkRemoteSync :: Branch -> IO Bool
checkRemoteSync (Branch branch :: Text
branch) = do
"git" ["fetch", "origin", Text
branch]
Text
localHash <- "git" FilePath -> [Text] -> IO Text
$| ["rev-parse", Text
branch]
Text
remoteHash <- "git" FilePath -> [Text] -> IO Text
$| ["rev-parse", "origin/" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
branch]
Bool -> IO Bool
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Bool -> IO Bool) -> Bool -> IO Bool
forall a b. (a -> b) -> a -> b
$ Text
localHash Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
remoteHash
doesBranchExist :: Branch -> IO Bool
doesBranchExist :: Branch -> IO Bool
doesBranchExist (Branch branch :: Text
branch) = do
Text
r <- "git" FilePath -> [Text] -> IO Text
$| ["ls-remote", "--heads", "origin", Text
branch]
Bool -> IO Bool
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Bool -> IO Bool) -> Bool -> IO Bool
forall a b. (a -> b) -> a -> b
$ Bool -> Bool
not (Text -> Bool
Text.null Text
r)
withSynced :: Branch -> IO a -> IO a
withSynced :: Branch -> IO a -> IO a
withSynced branch :: Branch
branch@(Branch branchname :: Text
branchname) action :: IO a
action = IO a -> IO a
forall a. IO a -> IO a
insideRepo (IO a -> IO a) -> IO a -> IO a
forall a b. (a -> b) -> a -> b
$ do
Text -> IO ()
infoMessage "Checking if repo is synchronized..."
Bool
isSynced <- Branch -> IO Bool
checkRemoteSync Branch
branch
if Bool
isSynced then do
Text -> IO ()
infoMessage "Repo is up-to-date"
IO a
action
else do
Text -> IO ()
warningMessage "Local version of repository is out of date"
Bool
shouldSync <- Text -> IO Bool
chooseYesNo "Do you want to sync repo with remote?"
if Bool
shouldSync then do
"git" ["rebase", "origin/" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
branchname]
IO a
action
else do
Text -> IO ()
errorMessage "Aborting current command because repository is not synchronized with remote"
IO a
forall (m :: * -> *) a. MonadIO m => m a
exitFailure
pullUpdateFromRepo :: LifeConfiguration -> IO ()
pullUpdateFromRepo :: LifeConfiguration -> IO ()
pullUpdateFromRepo life :: LifeConfiguration
life = do
IO () -> IO ()
forall a. IO a -> IO a
insideRepo (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ "git" ["pull", "-r"]
LifeConfiguration -> IO ()
updateFromRepo LifeConfiguration
life
updateFromRepo :: LifeConfiguration -> IO ()
updateFromRepo :: LifeConfiguration -> IO ()
updateFromRepo excludeLife :: LifeConfiguration
excludeLife = IO () -> IO ()
forall a. IO a -> IO a
insideRepo (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
Text -> IO ()
infoMessage "Copying files from repo to local machine..."
LifeConfiguration
repoLife <- IO LifeConfiguration
parseRepoLife
let lifeToLive :: LifeConfiguration
lifeToLive = LifeConfiguration -> LifeConfiguration -> LifeConfiguration
lifeConfigMinus LifeConfiguration
repoLife LifeConfiguration
excludeLife
CopyDirection -> LifeConfiguration -> IO ()
copyLife CopyDirection
FromRepoToHome LifeConfiguration
lifeToLive
updateDotfilesRepo :: CommitMsg -> LifeConfiguration -> IO ()
updateDotfilesRepo :: CommitMsg -> LifeConfiguration -> IO ()
updateDotfilesRepo commitMsg :: CommitMsg
commitMsg life :: LifeConfiguration
life = do
CopyDirection -> LifeConfiguration -> IO ()
copyLife CopyDirection
FromHomeToRepo LifeConfiguration
life
CommitMsg -> IO ()
pushRepo CommitMsg
commitMsg
copyLife :: CopyDirection -> LifeConfiguration -> IO ()
copyLife :: CopyDirection -> LifeConfiguration -> IO ()
copyLife direction :: CopyDirection
direction LifeConfiguration{..} = do
CopyDirection -> [Path Rel File] -> IO ()
copyFiles CopyDirection
direction (Set (Path Rel File) -> [Path Rel File]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList Set (Path Rel File)
lifeConfigurationFiles)
CopyDirection -> [Path Rel Dir] -> IO ()
copyDirs CopyDirection
direction (Set (Path Rel Dir) -> [Path Rel Dir]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList Set (Path Rel Dir)
lifeConfigurationDirectories)
copyFiles :: CopyDirection -> [Path Rel File] -> IO ()
copyFiles :: CopyDirection -> [Path Rel File] -> IO ()
copyFiles = (Path Abs File -> Path Abs File -> IO ())
-> CopyDirection -> [Path Rel File] -> IO ()
forall t.
(Path Abs t -> Path Abs t -> IO ())
-> CopyDirection -> [Path Rel t] -> IO ()
copyPathList Path Abs File -> Path Abs File -> IO ()
forall (m :: * -> *) b0 b1.
MonadIO m =>
Path b0 File -> Path b1 File -> m ()
copyFile
copyDirs :: CopyDirection -> [Path Rel Dir] -> IO ()
copyDirs :: CopyDirection -> [Path Rel Dir] -> IO ()
copyDirs = (Path Abs Dir -> Path Abs Dir -> IO ())
-> CopyDirection -> [Path Rel Dir] -> IO ()
forall t.
(Path Abs t -> Path Abs t -> IO ())
-> CopyDirection -> [Path Rel t] -> IO ()
copyPathList Path Abs Dir -> Path Abs Dir -> IO ()
forall (m :: * -> *) b0 b1.
(MonadIO m, MonadCatch m) =>
Path b0 Dir -> Path b1 Dir -> m ()
copyDirRecur
copyPathList
:: (Path Abs t -> Path Abs t -> IO ())
-> CopyDirection
-> [Path Rel t]
-> IO ()
copyPathList :: (Path Abs t -> Path Abs t -> IO ())
-> CopyDirection -> [Path Rel t] -> IO ()
copyPathList copyAction :: Path Abs t -> Path Abs t -> IO ()
copyAction direction :: CopyDirection
direction pathList :: [Path Rel t]
pathList = do
Path Abs Dir
homeDir <- IO (Path Abs Dir)
forall (m :: * -> *). MonadIO m => m (Path Abs Dir)
getHomeDir
let repoDir :: Path Abs Dir
repoDir = Path Abs Dir
homeDir Path Abs Dir -> Path Rel Dir -> Path Abs Dir
forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel Dir
repoName
[Path Rel t] -> (Path Rel t -> IO ()) -> IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ [Path Rel t]
pathList ((Path Rel t -> IO ()) -> IO ()) -> (Path Rel t -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \entryPath :: Path Rel t
entryPath -> do
let homePath :: Path Abs t
homePath = Path Abs Dir
homeDir Path Abs Dir -> Path Rel t -> Path Abs t
forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel t
entryPath
let repoPath :: Path Abs t
repoPath = Path Abs Dir
repoDir Path Abs Dir -> Path Rel t -> Path Abs t
forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel t
entryPath
case CopyDirection
direction of
FromHomeToRepo -> Path Abs t -> Path Abs t -> IO ()
copyAction Path Abs t
homePath Path Abs t
repoPath
FromRepoToHome -> Path Abs t -> Path Abs t -> IO ()
copyAction Path Abs t
repoPath Path Abs t
homePath
updateLifeFile :: IO ()
updateLifeFile :: IO ()
updateLifeFile = do
Path Abs File
lifeFile <- Path Rel File -> IO (Path Abs File)
forall (m :: * -> *) t. MonadIO m => Path Rel t -> m (Path Abs t)
relativeToHome Path Rel File
lifePath
Path Abs File
repoLifeFile <- Path Rel File -> IO (Path Abs File)
forall (m :: * -> *) t. MonadIO m => Path Rel t -> m (Path Abs t)
relativeToHome (Path Rel Dir
repoName Path Rel Dir -> Path Rel File -> Path Rel File
forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel File
lifePath)
Path Abs File -> Path Abs File -> IO ()
forall (m :: * -> *) b0 b1.
MonadIO m =>
Path b0 File -> Path b1 File -> m ()
copyFile Path Abs File
lifeFile Path Abs File
repoLifeFile
addToRepo :: (Path Abs t -> Path Abs t -> IO ()) -> Path Rel t -> IO ()
addToRepo :: (Path Abs t -> Path Abs t -> IO ()) -> Path Rel t -> IO ()
addToRepo copyFun :: Path Abs t -> Path Abs t -> IO ()
copyFun path :: Path Rel t
path = do
Path Abs t
sourcePath <- Path Rel t -> IO (Path Abs t)
forall (m :: * -> *) t. MonadIO m => Path Rel t -> m (Path Abs t)
relativeToHome Path Rel t
path
Path Abs t
destinationPath <- Path Rel t -> IO (Path Abs t)
forall (m :: * -> *) t. MonadIO m => Path Rel t -> m (Path Abs t)
relativeToHome (Path Rel Dir
repoName Path Rel Dir -> Path Rel t -> Path Rel t
forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel t
path)
Path Abs t -> Path Abs t -> IO ()
copyFun Path Abs t
sourcePath Path Abs t
destinationPath
IO ()
updateLifeFile
let commitMsg :: CommitMsg
commitMsg = Text -> CommitMsg
CommitMsg (Text -> CommitMsg) -> Text -> CommitMsg
forall a b. (a -> b) -> a -> b
$ "Add: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> FilePath -> Text
forall a. ToText a => a -> Text
toText (Path Rel t -> FilePath
forall b t. Path b t -> FilePath
toFilePath Path Rel t
path)
CommitMsg -> IO ()
pushRepo CommitMsg
commitMsg
removeFromRepo :: (Path Abs t -> IO ()) -> Path Rel t -> IO ()
removeFromRepo :: (Path Abs t -> IO ()) -> Path Rel t -> IO ()
removeFromRepo removeFun :: Path Abs t -> IO ()
removeFun path :: Path Rel t
path = do
Path Abs t
absPath <- Path Rel t -> IO (Path Abs t)
forall (m :: * -> *) t. MonadIO m => Path Rel t -> m (Path Abs t)
relativeToHome (Path Rel Dir
repoName Path Rel Dir -> Path Rel t -> Path Rel t
forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel t
path)
IO () -> (IOError -> IO ()) -> IO ()
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
catch (Path Abs t -> IO ()
removeFun Path Abs t
absPath) IOError -> IO ()
handleNotExist
IO ()
updateLifeFile
let commitMsg :: CommitMsg
commitMsg = Text -> CommitMsg
CommitMsg (Text -> CommitMsg) -> Text -> CommitMsg
forall a b. (a -> b) -> a -> b
$ "Remove: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
pathTextName
CommitMsg -> IO ()
pushRepo CommitMsg
commitMsg
where
pathTextName :: Text
pathTextName :: Text
pathTextName = FilePath -> Text
forall a. ToText a => a -> Text
toText (FilePath -> Text) -> FilePath -> Text
forall a b. (a -> b) -> a -> b
$ Path Rel t -> FilePath
forall b t. Path b t -> FilePath
toFilePath Path Rel t
path
handleNotExist :: IOError -> IO ()
handleNotExist :: IOError -> IO ()
handleNotExist e :: IOError
e = if IOError -> Bool
isDoesNotExistError IOError
e
then Text -> IO ()
errorMessage ("File/directory " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
pathTextName Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> " is not found") IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> IO ()
forall (m :: * -> *) a. MonadIO m => m a
exitFailure
else IOError -> IO ()
forall e a. Exception e => e -> IO a
throwIO IOError
e