diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,12 @@ +Change log +========== + +life-sync uses [PVP Versioning][1]. +The change log is available [on GitHub][2]. + +[1]: https://pvp.haskell.org +[2]: https://github.com/kowainik/life-sync/releases + +# 1.0 + +* Initially created. diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,21 @@ +MIT License + +Copyright (c) 2017 Dmitry Kovanikov + +Permission is hereby granted, free of charge, to any person obtaining a copy +of this software and associated documentation files (the "Software"), to deal +in the Software without restriction, including without limitation the rights +to use, copy, modify, merge, publish, distribute, sublicense, and/or sell +copies of the Software, and to permit persons to whom the Software is +furnished to do so, subject to the following conditions: + +The above copyright notice and this permission notice shall be included in all +copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, +OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE +SOFTWARE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,153 @@ +# life-sync + +[![Hackage](https://img.shields.io/hackage/v/life-sync.svg)](https://hackage.haskell.org/package/life-sync) +[![Build status](https://secure.travis-ci.org/kowainik/life-sync.svg)](https://travis-ci.org/kowainik/life-sync) +[![MIT license](https://img.shields.io/badge/license-MIT-blue.svg)](https://github.com/kowainik/life-sync/blob/master/LICENSE) +[![Stackage LTS](http://stackage.org/package/life-sync/badge/lts)](http://stackage.org/lts/package/life-sync) +[![Stackage Nightly](http://stackage.org/package/life-sync/badge/nightly)](http://stackage.org/nightly/package/life-sync) + +`life-sync` is a CLI tool that makes it easier to synchronize `dotfiles` +repository with personal configs across multiple machines. + +## Motivation + +You might have some configuration files with different settings for your system. +For example: + +1. Preferred settings for your editors (Spacemacs, Vim, etc.). +2. Useful bash aliases and other miscellaneous shell settings. +3. Git configuration. + +And much more! But sometimes you start working from a new fresh machine without +having your settings within touch, like in these situations: + +1. You bought a new PC or laptop. +2. You might reinstall your system on your working machine. +3. You were given a new laptop at work. + +Every time this happens, you need to walk through the tedious process of copying +your data again. It's a well-known practice to +[store configs in `dotfiles` GitHub repository](https://dotfiles.github.io/). +And `life-sync` makes it much easier to maintain this repository! With a single +command, your can copy every file and directory from `dotfiles` repository to +your machine. Or update your remote `dotfiles` repository after multiple local +changes to different files. + +## Installation + +Installation process can be done with one simple command: + +```shell +$ cabal install life-sync +``` + +or + +```shell +$ stack install life-sync-1.0 +``` + +You can turn on the bash auto-completion by running the following command: + +``` +$ source <(life --bash-completion-script `which life`) +``` + +## Usage + +> **NOTE:** make sure you configured SSH for your Github. `life-sync` assumes +> that you have SSH configured. + +After installing `life-sync` you need to call command `life` with specified options: + +``` +$ life --help +Usage: life COMMAND + life-sync synchronize your personal configs + +Available options: + -h,--help Show this help text + +Available commands: + init Initialize GitHub repository named 'dotfiles' if you + don't have one. + add Add file or directory to the life configuration. + remove Remove file or directory from the life configuration. + push Updates GitHub repository from local state and push + the latest version. + pull Updates local state of '.life' and 'dotfiles' from + GitHub repository. + +`life init` usage: life init OWNER + OWNER Your github user name + +`life add` usage: life add ((-f|--file FILE_PATH) | (-d|--dir DIRECTORY_PATH)) + -f,--file FILE_PATH File to add + -d,--dir FILE_PATH Directory to add + +`life remove` usage: life remove ((-f|--file FILE_PATH) | (-d|--dir DIRECTORY_PATH)) + -f,--file FILE_PATH File to remove + -d,--dir FILE_PATH Directory to remote + +`life push` usage: life push + +`life pull` usage: life pull OWNER [-f|--no-file FILE_PATH] [-d|--no-dir FILE_PATH] + OWNER Your github user name + -f,--no-file FILE_PATH Excluding these specific files from copying + -d,--no-dir FILE_PATH Excluding these specific directories from copying + +``` + +> **NOTE:** If some command takes a path to a file or a directory as an +> argument, the path should be specifed relative to the home directory. + +`life-sync` keeps the structure of your `dotfiles` repository in its own file +called `.life` which is stored in `dotfiles` repository as well. + +You can see an example of `dotfiles` repository maintained by `life-sync` here: + +* [ChShersh/dotfiles](https://github.com/ChShersh/dotfiles) + +## Examples + +### Create `dotfiles` repository for the first time + +``` +$ life init MyGithubName +``` + +### Track new file or directory + +To track a file: + +``` +$ life add -f path/to/file/relative/from/home +``` + +To track a directory: + +``` +$ life add -d path/to/dir/relative/from/home +``` + +To stop tracking some file, use `life remove` command instead. + +### Push all changes to remote repository + +``` +$ life push +``` + +### Pull all changes from remote repository + +To pull every file and directory: + +``` +$ life pull ChShersh +``` + +To pull everything except some files or some directories: + +``` +$ life pull ChShersh --no-file some/file --no-dir some/dir +``` diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/app/Main.hs b/app/Main.hs new file mode 100644 --- /dev/null +++ b/app/Main.hs @@ -0,0 +1,24 @@ +module Main where + +import Path (parseRelDir, parseRelFile) + +import Life.Main.Add (lifeAdd) +import Life.Main.Init (lifeInit) +import Life.Main.Pull (lifePull) +import Life.Main.Push (lifePush) +import Life.Main.Remove (lifeRemove) + +import Options (LifeCommand (..), PathOptions (..), PullOptions (..), parseCommand) + +import qualified Data.Set as Set + +main :: IO () +main = parseCommand >>= \case + Init owner -> lifeInit owner + Add PathOptions{..} -> lifeAdd pathOptionsPath + Remove PathOptions{..} -> lifeRemove pathOptionsPath + Push -> lifePush + Pull PullOptions{..} -> do + withoutFiles <- Set.fromList <$> mapM parseRelFile pullOptionsNoFiles + withoutDirs <- Set.fromList <$> mapM parseRelDir pullOptionsNoDirs + lifePull pullOptionsOwner withoutFiles withoutDirs diff --git a/app/Options.hs b/app/Options.hs new file mode 100644 --- /dev/null +++ b/app/Options.hs @@ -0,0 +1,119 @@ +{-# LANGUAGE ApplicativeDo #-} + +-- | Command line options for Importify + +module Options + ( LifeCommand (..) + , PathOptions (..) + , PullOptions (..) + + , parseCommand + ) where + +import Options.Applicative (Parser, ParserInfo, command, execParser, fullDesc, help, helper, info, + long, metavar, progDesc, short, strArgument, strOption, subparser) + +import Life.Configuration (LifePath (..)) +import Life.Github (Owner (..)) + +-- | Commands to execute +data LifeCommand + = Init Owner + | Add PathOptions + | Remove PathOptions + | Push + | Pull PullOptions + deriving (Show) + +--------------------------------------------------------------------------- +-- Boilerplate +---------------------------------------------------------------------------- + +commandParser :: Parser LifeCommand +commandParser = subparser $ + command "init" + (info (helper <*> fmap Init ownerParser) + (fullDesc <> progDesc "Initialize GitHub repository named 'dotfiles' if you don't have one.")) + <> command "add" + (info (helper <*> fmap Add pathOptionsParser) + (fullDesc <> progDesc "Add file or directory to the life configuration.")) + <> command "remove" + (info (helper <*> fmap Remove pathOptionsParser) + (fullDesc <> progDesc "Remove file or directory from the life configuration.")) + <> command "push" + (info (helper <*> pure Push) + (fullDesc <> progDesc "Updates GitHub repository from local state and push the latest version.")) + <> command "pull" + (info (helper <*> fmap Pull pullOptionsParser) + (fullDesc <> progDesc "Updates local state of '.life' and 'dotfiles' from GitHub repository.")) + + +optionsInfo :: ParserInfo LifeCommand +optionsInfo = info + (helper <*> commandParser) + (fullDesc <> progDesc "life-sync synchronize your personal configs") + +parseCommand :: IO LifeCommand +parseCommand = execParser optionsInfo + +ownerParser :: Parser Owner +ownerParser = fmap Owner + $ strArgument + $ metavar "OWNER" + <> help "Your github user name" + +---------------------------------------------------------------------------- +-- life pull +---------------------------------------------------------------------------- + +data PullOptions = PullOptions + { pullOptionsOwner :: Owner + , pullOptionsNoFiles :: [FilePath] + , pullOptionsNoDirs :: [FilePath] + } deriving (Show) + +pullOptionsParser :: Parser PullOptions +pullOptionsParser = do + pullOptionsOwner <- ownerParser + + -- TODO: reuse LifePath parser here?... + pullOptionsNoFiles <- many $ strOption + $ metavar "FILE_PATH" + <> long "no-file" + <> short 'f' + <> help "Excluding these specific files from copying" + + pullOptionsNoDirs <- many $ strOption + $ metavar "FILE_PATH" + <> long "no-dir" + <> short 'd' + <> help "Excluding these specific directories from copying" + + pure PullOptions{..} + +---------------------------------------------------------------------------- +-- life add and remove +---------------------------------------------------------------------------- + +data PathOptions = PathOptions + { pathOptionsPath :: LifePath + } deriving (Show) + +pathOptionsParser :: Parser PathOptions +pathOptionsParser = do + pathOptionsPath <- fileParser <|> dirParser + pure PathOptions{..} + where + fileParser :: Parser LifePath + fileParser = File <$> strOption + ( metavar "FILE_PATH" + <> long "file" + <> short 'f' + ) + + dirParser :: Parser LifePath + dirParser = Dir <$> strOption + ( metavar "DIRECTORY_PATH" + <> long "dir" + <> short 'd' + ) diff --git a/life-sync.cabal b/life-sync.cabal new file mode 100644 --- /dev/null +++ b/life-sync.cabal @@ -0,0 +1,101 @@ +name: life-sync +version: 1.0 +description: Synchronize personal configs across multiple machines +homepage: https://github.com/kowainik/life-sync +bug-reports: https://github.com/kowainik/life-sync/issues +license: MIT +license-file: LICENSE +author: Kowainik +maintainer: xrom.xkov@gmail.com +copyright: 2018 Kowainik +category: Configuration +stability: experimental +build-type: Simple +cabal-version: 2.0 +tested-with: GHC == 8.2.2 + , GHC == 8.4.3 +extra-doc-files: README.md + , CHANGELOG.md + +source-repository head + type: git + location: https://github.com/kowainik/life-sync.git + +library + hs-source-dirs: src + + exposed-modules: Prelude + Life.Configuration + Life.Github + Life.Message + Life.Shell + Life.Main.Add + Life.Main.Init + Life.Main.Pull + Life.Main.Push + Life.Main.Remove + Life.Validation + + build-depends: base-noprelude >= 4.9 && < 5 + , ansi-terminal + , bytestring + , containers + , fmt + , microlens-platform + , path + , path-io + , process + , text >= 1.2 + , tomland >= 0.2.1 + , universum >= 1.2.0 + + ghc-options: -Wall + default-language: Haskell2010 + + default-extensions: GeneralizedNewtypeDeriving + LambdaCase + OverloadedStrings + RecordWildCards + ScopedTypeVariables + TypeApplications + +executable life + hs-source-dirs: app + main-is: Main.hs + other-modules: Options + ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N + + build-depends: base-noprelude + , containers + , life-sync + , optparse-applicative + , path + + default-language: Haskell2010 + + default-extensions: LambdaCase + OverloadedStrings + RecordWildCards + +test-suite life-sync-test + type: exitcode-stdio-1.0 + hs-source-dirs: test + main-is: Spec.hs + other-modules: Test.Roundtrip + + build-tool-depends: tasty-discover:tasty-discover + build-depends: base-noprelude, life-sync + , containers + , filepath + , hedgehog + , path + , tasty + , tasty-hedgehog + + ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N + default-language: Haskell2010 + + default-extensions: LambdaCase + OverloadedStrings + RecordWildCards + TypeApplications diff --git a/src/Life/Configuration.hs b/src/Life/Configuration.hs new file mode 100644 --- /dev/null +++ b/src/Life/Configuration.hs @@ -0,0 +1,178 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} + +-- | Contains configuration data type. + +module Life.Configuration + ( LifePath (..) + + , LifeConfiguration (..) + , singleDirConfig + , singleFileConfig + + , lifeConfigMinus + +-- -- * Parsing exceptions +-- , ParseLifeException (..) + + -- * Lenses for 'LifeConfiguration' + , files + , directories + + -- * Parse 'LifeConfiguration' under @~/.life@ + , parseHomeLife + , parseRepoLife + , parseLifeConfiguration + + -- * Render 'LifeConfiguration' under @~/.life@ + , renderLifeConfiguration + , writeGlobalLife + ) where + +import Fmt (indentF, unlinesF, (+|), (|+)) +import Lens.Micro.Platform (makeFields) +import Path (Dir, File, Path, Rel, fromAbsFile, parseRelDir, parseRelFile, toFilePath, ()) +import Toml (BiToml, Valuer (..), (.=)) + +import Life.Shell (lifePath, relativeToHome, repoName) + +import qualified Data.Set as Set +import qualified Text.Show as Show +import qualified Toml + + +-- | Data type to represent either file or directory. +data LifePath = File FilePath | Dir FilePath + deriving (Show) + +---------------------------------------------------------------------------- +-- Life Configuration data type with lenses +---------------------------------------------------------------------------- + +data LifeConfiguration = LifeConfiguration + { lifeConfigurationFiles :: Set (Path Rel File) + , lifeConfigurationDirectories :: Set (Path Rel Dir) + } deriving (Show, Eq) + +makeFields ''LifeConfiguration + +---------------------------------------------------------------------------- +-- Algebraic instances and utilities +---------------------------------------------------------------------------- + +instance Semigroup LifeConfiguration where + life1 <> life2 = LifeConfiguration + { lifeConfigurationFiles = life1^.files <> life2^.files + , lifeConfigurationDirectories = life1^.directories <> life2^.directories + } + +instance Monoid LifeConfiguration where + mempty = LifeConfiguration mempty mempty + mappend = (<>) + +singleFileConfig :: Path Rel File -> LifeConfiguration +singleFileConfig file = mempty & files .~ one file + +singleDirConfig :: Path Rel Dir -> LifeConfiguration +singleDirConfig dir = mempty & directories .~ one dir + +---------------------------------------------------------------------------- +-- LifeConfiguration difference +---------------------------------------------------------------------------- + +lifeConfigMinus :: LifeConfiguration -- ^ repo .life config + -> LifeConfiguration -- ^ global config + -> LifeConfiguration -- ^ configs that are not in global +lifeConfigMinus dotfiles global = LifeConfiguration + (Set.difference (dotfiles ^. files) (global ^. files)) + (Set.difference (dotfiles ^. directories) (global ^. directories)) + +---------------------------------------------------------------------------- +-- Toml parser for life configuration +---------------------------------------------------------------------------- + +data CorpseConfiguration = CorpseConfiguration + { corpseFiles :: [FilePath] + , corpseDirectories :: [FilePath] + } + +corpseConfiguationT :: BiToml CorpseConfiguration +corpseConfiguationT = CorpseConfiguration + <$> Toml.arrayOf stringV "files" .= corpseFiles + <*> Toml.arrayOf stringV "directories" .= corpseDirectories + where + stringV :: Valuer 'Toml.TString String + stringV = Valuer (Toml.matchText >=> pure . toString) (Toml.String . toText) + +resurrect :: MonadThrow m => CorpseConfiguration -> m LifeConfiguration +resurrect CorpseConfiguration{..} = do + filePaths <- mapM parseRelFile corpseFiles + dirPaths <- mapM parseRelDir corpseDirectories + + pure $ LifeConfiguration + { lifeConfigurationFiles = Set.fromList filePaths + , lifeConfigurationDirectories = Set.fromList dirPaths + } + +-- TODO: should tomland one day support this?... +-- | Converts 'LifeConfiguration' into TOML file. +renderLifeConfiguration :: Bool -- ^ True to see empty entries in output + -> LifeConfiguration + -> Text +renderLifeConfiguration printIfEmpty LifeConfiguration{..} = mconcat $ + maybeToList (render "directories" lifeConfigurationDirectories) + ++ [ "\n" ] + ++ maybeToList (render "files" lifeConfigurationFiles) + where + render :: Text -> Set (Path b t) -> Maybe Text + render key paths = do + let prefix = key <> " = " + let array = renderStringArray (length prefix) (map show $ toList paths) + + if not printIfEmpty && null paths + then Nothing + else Just $ prefix <> array + + renderStringArray :: Int -> [String] -> Text + renderStringArray _ [] = "[]" + renderStringArray n (x:xs) = "[ " +| x |+ "\n" + +| indentF n (unlinesF (map (", " ++) xs ++ ["]"])) + |+ "" + +writeGlobalLife :: LifeConfiguration -> IO () +writeGlobalLife config = do + lifeFilePath <- relativeToHome lifePath + writeFile (fromAbsFile lifeFilePath) (renderLifeConfiguration True config) + +---------------------------------------------------------------------------- +-- Life configuration parsing +---------------------------------------------------------------------------- + +parseLifeConfiguration :: MonadThrow m => Text -> m LifeConfiguration +parseLifeConfiguration tomlText = case Toml.decode corpseConfiguationT tomlText of + Left err -> throwM $ LoadTomlException (toFilePath lifePath) $ Toml.prettyException err + Right cfg -> resurrect cfg + +parseLife :: Path Rel File -> IO LifeConfiguration +parseLife path = relativeToHome path + >>= readFile . fromAbsFile + >>= parseLifeConfiguration + +-- | Reads 'LifeConfiguration' from @~\/.life@ file. +parseHomeLife :: IO LifeConfiguration +parseHomeLife = parseLife lifePath + +-- | Reads 'LifeConfiguration' from @~\/dotfiles\/.life@ file. +parseRepoLife :: IO LifeConfiguration +parseRepoLife = parseLife (repoName lifePath) + +data LoadTomlException = LoadTomlException FilePath Text + +instance Show.Show LoadTomlException where + show (LoadTomlException filePath msg) = "Couldnt parse file " ++ filePath ++ ": " ++ show msg + +instance Exception LoadTomlException diff --git a/src/Life/Github.hs b/src/Life/Github.hs new file mode 100644 --- /dev/null +++ b/src/Life/Github.hs @@ -0,0 +1,204 @@ +-- | Utilities to work with GitHub repositories using "hub". + +module Life.Github + ( Owner (..) + , Repo (..) + + -- * Repository utils + , checkRemoteSync + , cloneRepo + , insideRepo + , withSynced + + -- * Repository manipulation commands + , CopyDirection (..) + , copyLife + , addToRepo + , createRepository + , pullUpdateFromRepo + , removeFromRepo + , updateDotfilesRepo + , updateFromRepo + ) where + +import Control.Exception (throwIO) +import Path (Abs, Dir, File, Path, Rel, toFilePath, ()) +import Path.IO (copyDirRecur, copyFile, getHomeDir, withCurrentDir) +import System.IO.Error (IOError, isDoesNotExistError) + +import Life.Configuration (LifeConfiguration (..), lifeConfigMinus, parseRepoLife) +import Life.Message (chooseYesNo, errorMessage, infoMessage, warningMessage) +import Life.Shell (lifePath, relativeToHome, repoName, ($|)) + +newtype Owner = Owner { getOwner :: Text } deriving (Show) +newtype Repo = Repo { getRepo :: Text } deriving (Show) + +---------------------------------------------------------------------------- +-- VSC commands +---------------------------------------------------------------------------- + +askToPushka :: Text -> IO () +askToPushka commitMsg = do + "git" ["add", "."] + infoMessage "The following changes are going to be pushed:" + "git" ["diff", "--name-status", "HEAD"] + continue <- chooseYesNo "Would you like to proceed?" + if continue + then pushka commitMsg + else errorMessage "Abort pushing" >> exitFailure + +-- | Make a commit and push it. +pushka :: Text -> IO () +pushka commitMsg = do + "git" ["add", "."] + "git" ["commit", "-m", commitMsg] + "git" ["push", "-u", "origin", "master"] + +-- | Creates repository on GitHub inside given folder. +createRepository :: Owner -> Repo -> IO () +createRepository (Owner owner) (Repo repo) = do + let description = ":computer: Configuration files" + "git" ["init"] + "hub" ["create", "-d", description, owner <> "/" <> repo] + pushka "Create the project" + +---------------------------------------------------------------------------- +-- dotfiles workflow +---------------------------------------------------------------------------- + +-- | Executes action with 'repoName' set as pwd. +insideRepo :: (MonadIO m, MonadMask m) => m a -> m a +insideRepo action = do + repoPath <- relativeToHome repoName + withCurrentDir repoPath action + +-- | Commits all changes inside 'repoName' and pushes to remote. +pushRepo :: Text -> IO () +pushRepo = insideRepo . askToPushka + +-- | Clones @dotfiles@ repository assuming it doesn't exist. +cloneRepo :: Owner -> IO () +cloneRepo (Owner owner) = do + homeDir <- getHomeDir + withCurrentDir homeDir $ do + infoMessage "Using SSH to clone repo..." + "git" ["clone", "git@github.com:" <> owner <> "/dotfiles.git"] + +-- | Returns true if local @dotfiles@ repository is synchronized with remote repo. +checkRemoteSync :: IO Bool +checkRemoteSync = do + "git" ["fetch", "origin", "master"] + localHash <- "git" $| ["rev-parse", "master"] + remoteHash <- "git" $| ["rev-parse", "origin/master"] + pure $ localHash == remoteHash + +withSynced :: IO a -> IO a +withSynced action = insideRepo $ do + infoMessage "Checking if repo is synchnorized..." + isSynced <- checkRemoteSync + if isSynced then do + infoMessage "Repo is up-to-date" + action + else do + warningMessage "Local version of repository is out of date" + shouldSync <- chooseYesNo "Do you want to sync repo with remote?" + if shouldSync then do + "git" ["rebase", "origin/master"] + action + else do + errorMessage "Aborting current command because repository is not synchronized with remote" + exitFailure + +---------------------------------------------------------------------------- +-- File manipulation +---------------------------------------------------------------------------- + +data CopyDirection = FromHomeToRepo | FromRepoToHome + +pullUpdateFromRepo :: LifeConfiguration -> IO () +pullUpdateFromRepo life = do + insideRepo $ "git" ["pull", "-r"] + updateFromRepo life + +updateFromRepo :: LifeConfiguration -> IO () +updateFromRepo excludeLife = insideRepo $ do + infoMessage "Copying files from repo to local machine..." + + repoLife <- parseRepoLife + let lifeToLive = lifeConfigMinus repoLife excludeLife + + copyLife FromRepoToHome lifeToLive + +updateDotfilesRepo :: Text -> LifeConfiguration -> IO () +updateDotfilesRepo commitMsg life = do + copyLife FromHomeToRepo life + pushRepo commitMsg + +copyLife :: CopyDirection -> LifeConfiguration -> IO () +copyLife direction LifeConfiguration{..} = do + copyFiles direction (toList lifeConfigurationFiles) + copyDirs direction (toList lifeConfigurationDirectories) + +-- | Copy files to repository and push changes to remote repository. +copyFiles :: CopyDirection -> [Path Rel File] -> IO () +copyFiles = copyPathList copyFile + +-- | Copy dirs to repository. +copyDirs :: CopyDirection -> [Path Rel Dir] -> IO () +copyDirs = copyPathList copyDirRecur + +copyPathList :: (Path Abs t -> Path Abs t -> IO ()) + -- ^ Copying action + -> CopyDirection + -- ^ Describes in which direction files should be copied + -> [Path Rel t] + -- ^ List of paths to copy + -> IO () +copyPathList copyAction direction pathList = do + homeDir <- getHomeDir + let repoDir = homeDir repoName + + for_ pathList $ \entryPath -> do + let homePath = homeDir entryPath + let repoPath = repoDir entryPath + case direction of + FromHomeToRepo -> copyAction homePath repoPath + FromRepoToHome -> copyAction repoPath homePath + +-- | Adds file or directory to the repository and commits +addToRepo :: (Path Abs t -> Path Abs t -> IO ()) -> Path Rel t -> IO () +addToRepo copyFun path = do + -- copy file + sourcePath <- relativeToHome path + destinationPath <- relativeToHome (repoName path) + copyFun sourcePath destinationPath + + -- update .life file + lifeFile <- relativeToHome lifePath + repoLifeFile <- relativeToHome (repoName lifePath) + copyFile lifeFile repoLifeFile + + let commitMsg = "Add: " <> toText (toFilePath path) + pushRepo commitMsg + +-- | Removes file or directory from the repository and commits +removeFromRepo :: (Path Abs t -> IO ()) -> Path Rel t -> IO () +removeFromRepo removeFun path = do + absPath <- relativeToHome (repoName path) + catch (removeFun absPath) handleNotExist + + -- update .life file + lifeFile <- relativeToHome lifePath + repoLifeFile <- relativeToHome (repoName lifePath) + copyFile lifeFile repoLifeFile + + let commitMsg = "Remove: " <> pathTextName + pushRepo commitMsg + where + pathTextName :: Text + pathTextName = toText $ toFilePath path + + handleNotExist :: IOError -> IO () + handleNotExist e = if isDoesNotExistError e + then errorMessage ("File/directory " <> pathTextName <> " is not found") >> exitFailure + else throwIO e diff --git a/src/Life/Main/Add.hs b/src/Life/Main/Add.hs new file mode 100644 --- /dev/null +++ b/src/Life/Main/Add.hs @@ -0,0 +1,95 @@ +{-# LANGUAGE Rank2Types #-} + +-- | Functions to add file/directory to your life. + +module Life.Main.Add + ( lifeAdd + ) where + +import Path (Abs, Dir, File, Path, Rel, parent, toFilePath, ()) +import Path.IO (copyDirRecur, copyFile, doesDirExist, doesFileExist, ensureDir, getHomeDir, + makeRelative, resolveDir, resolveFile) + +import Life.Configuration (LifeConfiguration, LifePath (..), directories, files, parseHomeLife, + writeGlobalLife) +import Life.Github (addToRepo, withSynced) +import Life.Main.Init (lifeInitQuestion) +import Life.Message (abortCmd, errorMessage, infoMessage, warningMessage) +import Life.Shell (LifeExistence (..), relativeToHome, repoName, whatIsLife) + +import qualified Data.ByteString.Lazy as LBS +import qualified Data.Set as Set + +-- | Add path to existing life-configuration file. +lifeAdd :: LifePath -> IO () +lifeAdd lPath = whatIsLife >>= \case + -- actual life add process + Both _ _ -> withSynced addingProcess + + -- if one of them is missing -- abort + OnlyRepo _ -> abortCmd "add" ".life file doesn't exist" + OnlyLife _ -> abortCmd "add" "dotfiles/ directory doesn't exist" + + -- if both .life and dotfiles doesn't exist go to init process + NoLife -> lifeInitQuestion "add" addingProcess + where + addingProcess :: IO () + addingProcess = do + homeDirPath <- getHomeDir + case lPath of + (File path) -> do + filePath <- resolveFile homeDirPath path + whenM (doesFileExist filePath) $ do + relativeFile <- makeRelative homeDirPath filePath + resolveConfiguration files checkEqualFiles copyFileWithDir relativeFile + + (Dir path) -> do + dirPath <- resolveDir homeDirPath path + whenM (doesDirExist dirPath) $ do + relativeDir <- makeRelative homeDirPath dirPath + resolveConfiguration directories checkEqualDirs copyDirRecur relativeDir + + -- We didn't find the file + errorMessage "The file/directory doesn't exist" >> exitFailure + +resolveConfiguration :: Lens' LifeConfiguration (Set (Path Rel t)) + -> (Path Rel t -> IO Bool) + -> (Path Abs t -> Path Abs t -> IO ()) + -> Path Rel t + -> IO () +resolveConfiguration confLens checkContent copyFun path = do + configuration <- parseHomeLife + let newConfiguration = configuration & confLens %~ Set.insert path + + isSameAsInRepo <- checkContent path + if isSameAsInRepo then do + let pathText = toText $ toFilePath path + infoMessage $ "Path " <> pathText <> " is already latest version in repository" + else do + writeGlobalLife newConfiguration + addToRepo copyFun path + + exitSuccess + +checkEqualFiles :: Path Rel File -> IO Bool +checkEqualFiles path = do + homeFilePath <- relativeToHome path + repoFilePath <- relativeToHome (repoName path) + + isRepoFile <- doesFileExist repoFilePath + if isRepoFile then do + originContent <- LBS.readFile $ toFilePath homeFilePath + repoContent <- LBS.readFile $ toFilePath repoFilePath + + pure $ originContent == repoContent + else + pure False + +checkEqualDirs :: Path Rel Dir -> IO Bool +checkEqualDirs _ = do + warningMessage "TODO: check directories to be equal" + pure True + +-- | Just like 'copyFile' but also creates directory for second file. +copyFileWithDir :: Path Abs File -> Path Abs File -> IO () +copyFileWithDir from to = ensureDir (parent to) >> copyFile from to diff --git a/src/Life/Main/Init.hs b/src/Life/Main/Init.hs new file mode 100644 --- /dev/null +++ b/src/Life/Main/Init.hs @@ -0,0 +1,114 @@ +{-# LANGUAGE TemplateHaskell #-} + +-- | Contains function to create repository. + +module Life.Main.Init + ( lifeInit + , lifeInitQuestion + ) where + +import Path (mkRelFile) +import Path.IO (doesDirExist, doesFileExist) + +import Life.Configuration (LifeConfiguration (..), parseHomeLife, renderLifeConfiguration, + singleFileConfig, writeGlobalLife) +import Life.Github (CopyDirection (..), Owner (..), Repo (Repo), copyLife, createRepository, + insideRepo) +import Life.Message (abortCmd, chooseYesNo, infoMessage, promptNonEmpty, skipMessage, + successMessage, warningMessage) +import Life.Shell (LifeExistence (..), createDirInHome, lifePath, relativeToHome, repoName, + whatIsLife) + +import qualified Data.Set as Set + +predefinedLifeConfig :: LifeConfiguration +predefinedLifeConfig = mempty + { lifeConfigurationFiles = Set.fromList + [ $(mkRelFile ".bash_profile") + , $(mkRelFile ".profile") + , $(mkRelFile ".vimrc") + , $(mkRelFile ".emacs") + , $(mkRelFile ".spacemacs") + , $(mkRelFile ".gitconfig") + , $(mkRelFile ".ghc/ghci.conf") + , $(mkRelFile ".stylish-haskell.yaml") + ] + } + +lifeInit :: Owner -> IO () +lifeInit owner = whatIsLife >>= \case + NoLife -> createLifeFile >>= createDotfilesDir + OnlyLife _ -> askCreateLife >>= createDotfilesDir + OnlyRepo _ -> abortCmd "init" "'~/dotfiles' directory already exist" -- TODO: initialize .life from repo? :thinking_suicide: + Both _ _ -> abortCmd "init" "'~/.life' file and '~/.dotfiles' directory are already initialized" + where + askCreateLife :: IO LifeConfiguration + askCreateLife = do + warningMessage ".life file is already exist." + useIt <- chooseYesNo "Would you like to use it?" + if useIt then parseHomeLife else createLifeFile + + createLifeFile :: IO LifeConfiguration + createLifeFile = do + infoMessage "Checking existence of some commonly used predefined files..." + (exist, noExist) <- scanConfig predefinedLifeConfig + + unless (noExist == mempty) $ do + infoMessage "The following files and directories weren't found; they won't be added to '~/.life' file:" + skipMessage $ renderLifeConfiguration False noExist + + unless (exist == mempty) $ do + infoMessage "Found the following files and directories:" + successMessage $ renderLifeConfiguration False exist + + useDiscovered <- chooseYesNo "Would you like to add all discovered existing files and directories to .life configuration?" + let lifeConfig = singleFileConfig lifePath <> (if useDiscovered then exist else mempty) + + infoMessage "Initializing global .life configuration file..." + writeGlobalLife lifeConfig + pure lifeConfig + + createDotfilesDir :: LifeConfiguration -> IO () + createDotfilesDir lifeConfig = do + () <$ createDirInHome repoName + insideRepo $ do + copyLife FromHomeToRepo lifeConfig + createRepository owner (Repo "dotfiles") + +{- | Split given configuration into two: + +1. All files and directories which exist on machine. +2. Other non-existing files and dirs. +-} +scanConfig :: LifeConfiguration -> IO (LifeConfiguration, LifeConfiguration) +scanConfig LifeConfiguration{..} = do + (existingFiles, nonExistingFiles) <- partitionM (relativeToHome >=> doesFileExist) lifeConfigurationFiles + (existingDirs, nonExistingDirs) <- partitionM (relativeToHome >=> doesDirExist) lifeConfigurationDirectories + pure ( LifeConfiguration (Set.fromList existingFiles) (Set.fromList existingDirs) + , LifeConfiguration (Set.fromList nonExistingFiles) (Set.fromList nonExistingDirs) + ) + +partitionM :: forall f m a . (Monad m, Foldable f) => (a -> m Bool) -> f a -> m ([a], [a]) +partitionM check = foldM partitionAction ([], []) + where + partitionAction :: ([a], [a]) -> a -> m ([a], [a]) + partitionAction (ifTrue, ifFalse) a = check a >>= \case + True -> pure (a : ifTrue, ifFalse) + False -> pure (ifTrue, a : ifFalse) + + +-- | If @.life@ and @dotfiles@ are not present you could want +-- to ask one if it needed to be initialised. +lifeInitQuestion :: Text -- ^ Command name + -> IO () -- ^ Process to do + -> IO () +lifeInitQuestion cmd process = do + warningMessage ".life file and dotfiles/ do not exist" + toInit <- chooseYesNo "Would you like to proceed initialization process?" + if toInit then do + infoMessage "Initialization process starts.." + skipMessage "Insert your GitHub username:" + owner <- promptNonEmpty + lifeInit $ Owner owner + process + else abortCmd cmd "'~/.life' file is not initialized" diff --git a/src/Life/Main/Pull.hs b/src/Life/Main/Pull.hs new file mode 100644 --- /dev/null +++ b/src/Life/Main/Pull.hs @@ -0,0 +1,39 @@ +-- | Command to update local state from remote state. + +module Life.Main.Pull + ( lifePull + ) where + +import Path (Dir, File, Path, Rel) + +import Life.Configuration (LifeConfiguration (..)) +import Life.Github (Owner, cloneRepo, pullUpdateFromRepo, updateFromRepo) +import Life.Main.Init (lifeInitQuestion) +import Life.Message (abortCmd, choose, warningMessage) +import Life.Shell (LifeExistence (..), whatIsLife) + +lifePull :: Owner -> Set (Path Rel File) -> Set (Path Rel Dir) -> IO () +lifePull owner withoutFiles withoutDirs = whatIsLife >>= \case + OnlyRepo _ -> warningMessage ".life file not found" >> pullUpdate + OnlyLife _ -> warningMessage "dotfiles not found" >> clone >> update + NoLife -> initOrPull + Both _ _ -> pullUpdate + where + initOrPull :: IO () + initOrPull = do + warningMessage ".life file and dotfiles repo not found" + action <- choose "Do you want to (F)etch existing repo, (I)nit from scratch or (A)bort operation?" + ["f", "i", "a"] + case action of + "f" -> clone >> update + "i" -> lifeInitQuestion "pull" pass + "a" -> abortCmd "pull" "Cannot find .life and dotfiles" + _ -> error "Impossible choice" + + life :: LifeConfiguration + life = LifeConfiguration withoutFiles withoutDirs + + clone, update, pullUpdate :: IO () + clone = cloneRepo owner + update = updateFromRepo life + pullUpdate = pullUpdateFromRepo life diff --git a/src/Life/Main/Push.hs b/src/Life/Main/Push.hs new file mode 100644 --- /dev/null +++ b/src/Life/Main/Push.hs @@ -0,0 +1,73 @@ +{-# LANGUAGE TupleSections #-} + +-- | Functions to update remote repository + +module Life.Main.Push + ( lifePush + ) where + +import Path (Abs, Path, Rel, toFilePath, ()) +import Path.IO (doesDirExist, doesFileExist, removeDirRecur, removeFile) + +import Life.Configuration (LifeConfiguration (..), directories, files, lifeConfigMinus, + parseHomeLife, parseRepoLife) +import Life.Github (updateDotfilesRepo, withSynced) +import Life.Main.Init (lifeInitQuestion) +import Life.Message (abortCmd) +import Life.Shell (LifeExistence (..), relativeToHome, repoName, whatIsLife) +import Life.Validation (Validation (..)) + +import qualified Data.Set as Set +import qualified Data.Text as Text + +lifePush :: IO () +lifePush = whatIsLife >>= \case + OnlyRepo _ -> abortCmd "push" ".life file doesn't exist" + OnlyLife _ -> abortCmd "push" "dotfiles file doesn't exist" + NoLife -> lifeInitQuestion "push" pushProcess + Both _ _ -> withSynced pushProcess + where + pushProcess :: IO () + pushProcess = do + -- check that all from .life exist + globalConf <- parseHomeLife + checkLife globalConf >>= \case + Failure msgs -> abortCmd "push" $ "Following files/directories are missing:\n" + <> Text.intercalate "\n" msgs + Success _ -> do + -- first, find the difference between repo .life and global .life + repoConf <- parseRepoLife + let removeConfig = lifeConfigMinus repoConf globalConf + -- delete all redundant files from local dotfiles + removeAll removeConfig + + -- copy from local files to repo including .life + -- commmit & push + updateDotfilesRepo "Push updates" globalConf + + + -- | checks if all the files/dirs from global .life exist. + checkLife :: LifeConfiguration -> IO (Validation [Text] LifeConfiguration) + checkLife lf = do + eFiles <- traverse (withExist doesFileExist) $ Set.toList (lf ^. files) + eDirs <- traverse (withExist doesDirExist) $ Set.toList (lf ^. directories) + pure $ LifeConfiguration + <$> checkPaths eFiles + <*> checkPaths eDirs + where + withExist :: (Path Abs f -> IO Bool) -> Path Rel f -> IO (Path Rel f, Bool) + withExist doesExist path = (path,) <$> (relativeToHome path >>= doesExist) + + checkPaths :: [(Path Rel f, Bool)] -> Validation [Text] (Set (Path Rel f)) + checkPaths = fmap Set.fromList . traverse checkPath + + checkPath :: (Path Rel t, Bool) -> Validation [Text] (Path Rel t) + checkPath (f, is) = if is then Success f else Failure [toText (toFilePath f)] + + -- | removes all redundant files from repo folder. + removeAll :: LifeConfiguration -> IO () + removeAll conf = do + for_ (conf ^. files) $ \f -> + relativeToHome (repoName f) >>= removeFile + for_ (conf ^. directories) $ \d -> + relativeToHome (repoName d) >>= removeDirRecur diff --git a/src/Life/Main/Remove.hs b/src/Life/Main/Remove.hs new file mode 100644 --- /dev/null +++ b/src/Life/Main/Remove.hs @@ -0,0 +1,50 @@ +{-# LANGUAGE Rank2Types #-} + +-- | Functions to remove from your life. + +module Life.Main.Remove + ( lifeRemove + ) where + +import Path (Abs, Path, Rel) +import Path.IO (getHomeDir, makeRelative, removeDirRecur, removeFile, resolveDir, resolveFile) + +import Life.Configuration (LifeConfiguration, LifePath (..), directories, files, parseHomeLife, + writeGlobalLife) +import Life.Github (removeFromRepo, withSynced) +import Life.Message (abortCmd, warningMessage) +import Life.Shell (LifeExistence (..), whatIsLife) + +import qualified Data.Set as Set + +-- | Remove path from existing life-configuration file. +lifeRemove :: LifePath -> IO () +lifeRemove lPath = whatIsLife >>= \case + -- if one of them is missing -- abort + NoLife -> abortCmd "remove" ".life and docfiles/ do not exist" + OnlyLife _ -> abortCmd "remove" "dotfiles/ directory doesn't exist" + OnlyRepo _ -> abortCmd "remove" ".life file doesn't exist" + -- actual life remove process + Both _ _ -> withSynced $ do + homeDirPath <- getHomeDir + case lPath of + (File path) -> do + filePath <- resolveFile homeDirPath path >>= makeRelative homeDirPath + resolveConfiguration files removeFile filePath + (Dir path) -> do + dirPath <- resolveDir homeDirPath path >>= makeRelative homeDirPath + resolveConfiguration directories removeDirRecur dirPath + +resolveConfiguration :: Lens' LifeConfiguration (Set (Path Rel t)) + -> (Path Abs t -> IO ()) -- ^ function to remove object + -> Path Rel t + -> IO () +resolveConfiguration confLens removeFun path = do + configuration <- parseHomeLife + + let newConfiguration = configuration & confLens %~ Set.delete path + if configuration == newConfiguration + then warningMessage "File or directory is not in tracked" >> exitFailure + else do + writeGlobalLife newConfiguration + removeFromRepo removeFun path diff --git a/src/Life/Message.hs b/src/Life/Message.hs new file mode 100644 --- /dev/null +++ b/src/Life/Message.hs @@ -0,0 +1,139 @@ +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE ViewPatterns #-} + +module Life.Message + ( beautyPrint + , boldText + , prompt + , promptNonEmpty + , errorMessage + , warningMessage + , successMessage + , infoMessage + , skipMessage + , abortCmd + + -- * Questions + , choose + , chooseYesNo + ) where + +import System.Console.ANSI (Color (..), ColorIntensity (Vivid), ConsoleIntensity (BoldIntensity), + ConsoleLayer (Foreground), SGR (..), setSGR) +import System.IO (hFlush) + +import qualified Data.Text as T +import qualified Universum.Unsafe as Unsafe + +---------------------------------------------------------------------------- +-- Ansi-terminal +---------------------------------------------------------------------------- + +-- Explicit flush ensures prompt messages are in the correct order on all systems. +putStrFlush :: Text -> IO () +putStrFlush msg = do + putText msg + hFlush stdout + +setColor :: Color -> IO () +setColor color = setSGR [SetColor Foreground Vivid color] + +-- | Starts bold printing. +bold :: IO () +bold = setSGR [SetConsoleIntensity BoldIntensity] + +-- | Resets all previous settings. +reset :: IO () +reset = do + setSGR [Reset] + hFlush stdout + +-- | Takes list of formatting options, prints text using this format options. +beautyPrint :: [IO ()] -> Text -> IO () +beautyPrint formats msg = do + sequence_ formats + putText msg + reset + +prompt :: IO Text +prompt = do + setColor Blue + putStrFlush " ⟳ " + reset + getLine + +promptNonEmpty :: IO Text +promptNonEmpty = do + res <- T.strip <$> prompt + if null res + then warningMessage "The answer shouldn't be empty" >> promptNonEmpty + else pure res + + +boldText :: Text -> IO () +boldText message = bold >> putStrFlush message >> reset + +boldDefault :: Text -> IO () +boldDefault message = boldText (" [" <> message <> "]") + +colorMessage :: Color -> Text -> IO () +colorMessage color message = do + setColor color + putTextLn $ " " <> message + reset + +errorMessage, warningMessage, successMessage, infoMessage, skipMessage :: Text -> IO () +errorMessage = colorMessage Red +warningMessage = colorMessage Yellow +successMessage = colorMessage Green +infoMessage = colorMessage Blue +skipMessage = colorMessage Cyan + +-- | Print message and abort current process. +abortCmd :: Text -> Text -> IO () +abortCmd cmd msg = do + warningMessage msg + errorMessage $ "Aborting 'life " <> cmd <> "' command." + exitFailure + +---------------------------------------------------------------------------- +-- Questions +---------------------------------------------------------------------------- + +printQuestion :: Text -> [Text] -> IO () +printQuestion question (def:rest) = do + let restSlash = T.intercalate "/" rest + putStrFlush question + boldDefault def + putTextLn $ "/" <> restSlash +printQuestion question [] = putTextLn question + +choose :: Text -> [Text] -> IO Text +choose question choices = do + printQuestion question choices + answer <- prompt + if | T.null answer -> pure (Unsafe.head choices) + | T.toLower answer `elem` choices -> pure answer + | otherwise -> do + errorMessage "This wasn't a valid choice." + choose question choices + +data Answer = Y | N + +yesOrNo :: Text -> Maybe Answer +yesOrNo (T.toLower -> answer ) + | T.null answer = Just Y + | answer `elem` ["yes", "y", "ys"] = Just Y + | answer `elem` ["no", "n"] = Just N + | otherwise = Nothing + +chooseYesNo :: Text -> IO Bool +chooseYesNo q = do + printQuestion q ["y", "n"] + answer <- yesOrNo <$> prompt + case answer of + Nothing -> do + errorMessage "This wasn't a valid choice." + chooseYesNo q + Just Y -> pure True + Just N -> pure False diff --git a/src/Life/Shell.hs b/src/Life/Shell.hs new file mode 100644 --- /dev/null +++ b/src/Life/Shell.hs @@ -0,0 +1,87 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} + +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} + +-- | This module contains utility functions to work with shell. + +-- TODO: rename this module to Life.Path ? + +module Life.Shell + ( -- * Constants + lifePath + , repoName + + -- * Functions + , LifeExistence (..) + , createDirInHome + , relativeToHome + , whatIsLife + , ($|) + ) where + +import Path (Abs, Dir, File, Path, Rel, mkRelDir, mkRelFile, ()) +import Path.IO (createDirIfMissing, doesDirExist, doesFileExist, getHomeDir) +import System.Process (callCommand, readProcess, showCommandForUser) + +---------------------------------------------------------------------------- +-- Global constants +---------------------------------------------------------------------------- + +-- | Name for life configuration file. +lifePath :: Path Rel File +lifePath = $(mkRelFile ".life") + +-- TODO: consistent naming with @lifePath@ ? +-- | Default repository name for life configuration files. +repoName :: Path Rel Dir +repoName = $(mkRelDir "dotfiles/") + +---------------------------------------------------------------------------- +-- Shell interface +---------------------------------------------------------------------------- + +-- This is needed to be able to call commands by writing strings. +instance (a ~ Text, b ~ ()) => IsString ([a] -> IO b) where + fromString cmd args = do + let cmdStr = showCommandForUser cmd (map toString args) + putStrLn $ "⚙ " ++ cmdStr + callCommand cmdStr + +-- | Run shell command with given options and return stdout of executed command. +infix 5 $| +($|) :: FilePath -> [Text] -> IO String +cmd $| args = readProcess cmd (map toString args) "" + +-- | Creates directory with name "folder" under "~/folder". +createDirInHome :: Path Rel Dir -> IO (Path Abs Dir) +createDirInHome dirName = do + newDir <- relativeToHome dirName + newDir <$ createDirIfMissing False newDir + +-- | Creates path relative to home directory +relativeToHome :: MonadIO m => Path Rel t -> m (Path Abs t) +relativeToHome path = do + homeDir <- getHomeDir + pure $ homeDir path + +data LifeExistence + = NoLife + | OnlyLife (Path Abs File) + | OnlyRepo (Path Abs Dir) + | Both (Path Abs File) (Path Abs Dir) + +whatIsLife :: IO LifeExistence +whatIsLife = do + lifeFile <- relativeToHome lifePath + repoDir <- relativeToHome repoName + + isFile <- doesFileExist lifeFile + isDir <- doesDirExist repoDir + + pure $ case (isFile, isDir) of + (False, False) -> NoLife + (True, False) -> OnlyLife lifeFile + (False, True) -> OnlyRepo repoDir + (True, True) -> Both lifeFile repoDir diff --git a/src/Life/Validation.hs b/src/Life/Validation.hs new file mode 100644 --- /dev/null +++ b/src/Life/Validation.hs @@ -0,0 +1,27 @@ +module Life.Validation + ( Validation (..) + ) where + +-- | 'Validation' is 'Either' with a Left that is a 'Monoid' +data Validation e a + = Failure e + | Success a + deriving (Eq, Ord, Show) + +instance Functor (Validation e) where + fmap _ (Failure e) = Failure e + fmap f (Success a) = Success (f a) + +instance Semigroup e => Semigroup (Validation e a) where + Failure e1 <> Failure e2 = Failure (e1 <> e2) + Failure _ <> Success a2 = Success a2 + Success a1 <> Failure _ = Success a1 + Success a1 <> Success _ = Success a1 + +instance Semigroup e => Applicative (Validation e) where + pure = Success + + Failure e1 <*> Failure e2 = Failure (e1 <> e2) + Failure e1 <*> Success _ = Failure e1 + Success _ <*> Failure e2 = Failure e2 + Success f <*> Success a = Success (f a) diff --git a/src/Prelude.hs b/src/Prelude.hs new file mode 100644 --- /dev/null +++ b/src/Prelude.hs @@ -0,0 +1,7 @@ +-- | Uses @universum@ as default prelude. + +module Prelude + ( module Universum + ) where + +import Universum diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,1 @@ +{-# OPTIONS_GHC -F -pgmF tasty-discover #-} diff --git a/test/Test/Roundtrip.hs b/test/Test/Roundtrip.hs new file mode 100644 --- /dev/null +++ b/test/Test/Roundtrip.hs @@ -0,0 +1,36 @@ +module Test.Roundtrip where + +import Hedgehog (Gen, Property, forAll, property, tripping) +import Path.Internal (Path (Path)) +import System.FilePath (pathSeparator, ()) + +import Life.Configuration (LifeConfiguration (..), parseLifeConfiguration, renderLifeConfiguration) + +import qualified Data.Set as Set +import qualified Hedgehog.Gen as Gen +import qualified Hedgehog.Range as Range + +hprop_ConfigurationRoundtrip :: Property +hprop_ConfigurationRoundtrip = property $ do + cfg <- forAll genLifeConfiguration + tripping cfg (renderLifeConfiguration True) (parseLifeConfiguration @Maybe) + +genLifeConfiguration :: Gen LifeConfiguration +genLifeConfiguration = do + lifeConfigurationFiles <- genPathSet genFilePath + lifeConfigurationDirectories <- genPathSet genDirPath + pure LifeConfiguration{..} + +-- it's safe to use 'Path' constructor here even if such things are not recommended by API +-- our generators should be safe; and if not - this will be caught by test later +genPathSet :: Gen FilePath -> Gen (Set (Path b t)) +genPathSet gen = Set.fromList . fmap Path <$> Gen.list (Range.constant 0 30) gen + +genDirPath :: Gen FilePath +genDirPath = (++ [pathSeparator]) <$> genFilePath + +genFilePath :: Gen FilePath +genFilePath = foldr1 () <$> Gen.nonEmpty (Range.constant 1 10) genFilePathPiece + +genFilePathPiece :: Gen String +genFilePathPiece = Gen.string (Range.constant 1 10) Gen.alphaNum