diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,14 +1,47 @@ -Change log -========== +# Changelog -life-sync uses [PVP Versioning][1]. +`life-sync` uses [PVP Versioning][1]. The change log is available [on GitHub][2]. -# 1.0.1 +## 1.1.0.0 — Mar 25, 2020 +* [#36](https://github.com/kowainik/life-sync/issues/36): + Get GitHub username from `.gitconfig` if applicable. + (by [@SanchayanMaity](https://github.com/SanchayanMaity)) +* [#48](https://github.com/kowainik/life-sync/issues/48): + Fix minor bug with broken `life add -d`. + (by [@nixorn](https://github.com/nixorn)) +* [#65](https://github.com/kowainik/life-sync/issues/65): + + Move to GHC-8.8.3. + + Bump up `relude` to `0.6.0.0`. + + Bump up `tomland` to `1.2.1.0`. + + Bump up `optparse-applicative` to `0.15`. + (by [@chshersh](https://github.com/chshersh)) +* [#68](https://github.com/kowainik/life-sync/issues/68): + Move to `validation-selective`. + (by [@chshersh](https://github.com/chshersh)) +* [#75](https://github.com/kowainik/life-sync/issues/75): + Move to `colourista`. + (by [@chshersh](https://github.com/chshersh)) +* [#70](https://github.com/kowainik/life-sync/issues/70): + Move to `shellmet`. + (by [@vrom911](https://github.com/vrom911)) +* [#77](https://github.com/kowainik/life-sync/issues/77): + Remove `fmt` dependency. + (by [@chshersh](https://github.com/chshersh)) +* [#79](https://github.com/kowainik/life-sync/issues/79): + Remove `microlens-platform` dependency. + (by [@vrom911](https://github.com/vrom911)) +* [#59](https://github.com/kowainik/life-sync/issues/59): + Bump to relude-0.4.0. + Bump to GHC-8.4.4. + (by [@nixorn](https://github.com/nixorn)) + +## 1.0.1 + * Switch to `relude`. -# 1.0 +## 1.0 * Initially created. diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,21 +1,373 @@ -MIT License +Mozilla Public License Version 2.0 +================================== -Copyright (c) 2017 Dmitry Kovanikov +1. Definitions +-------------- -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: +1.1. "Contributor" + means each individual or legal entity that creates, contributes to + the creation of, or owns Covered Software. -The above copyright notice and this permission notice shall be included in all -copies or substantial portions of the Software. +1.2. "Contributor Version" + means the combination of the Contributions of others (if any) used + by a Contributor and that particular Contributor's Contribution. -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. +1.3. "Contribution" + means Covered Software of a particular Contributor. + +1.4. "Covered Software" + means Source Code Form to which the initial Contributor has attached + the notice in Exhibit A, the Executable Form of such Source Code + Form, and Modifications of such Source Code Form, in each case + including portions thereof. + +1.5. "Incompatible With Secondary Licenses" + means + + (a) that the initial Contributor has attached the notice described + in Exhibit B to the Covered Software; or + + (b) that the Covered Software was made available under the terms of + version 1.1 or earlier of the License, but not also under the + terms of a Secondary License. + +1.6. "Executable Form" + means any form of the work other than Source Code Form. + +1.7. "Larger Work" + means a work that combines Covered Software with other material, in + a separate file or files, that is not Covered Software. + +1.8. "License" + means this document. + +1.9. "Licensable" + means having the right to grant, to the maximum extent possible, + whether at the time of the initial grant or subsequently, any and + all of the rights conveyed by this License. + +1.10. "Modifications" + means any of the following: + + (a) any file in Source Code Form that results from an addition to, + deletion from, or modification of the contents of Covered + Software; or + + (b) any new file in Source Code Form that contains any Covered + Software. + +1.11. "Patent Claims" of a Contributor + means any patent claim(s), including without limitation, method, + process, and apparatus claims, in any patent Licensable by such + Contributor that would be infringed, but for the grant of the + License, by the making, using, selling, offering for sale, having + made, import, or transfer of either its Contributions or its + Contributor Version. + +1.12. "Secondary License" + means either the GNU General Public License, Version 2.0, the GNU + Lesser General Public License, Version 2.1, the GNU Affero General + Public License, Version 3.0, or any later versions of those + licenses. + +1.13. "Source Code Form" + means the form of the work preferred for making modifications. + +1.14. "You" (or "Your") + means an individual or a legal entity exercising rights under this + License. For legal entities, "You" includes any entity that + controls, is controlled by, or is under common control with You. For + purposes of this definition, "control" means (a) the power, direct + or indirect, to cause the direction or management of such entity, + whether by contract or otherwise, or (b) ownership of more than + fifty percent (50%) of the outstanding shares or beneficial + ownership of such entity. + +2. License Grants and Conditions +-------------------------------- + +2.1. Grants + +Each Contributor hereby grants You a world-wide, royalty-free, +non-exclusive license: + +(a) under intellectual property rights (other than patent or trademark) + Licensable by such Contributor to use, reproduce, make available, + modify, display, perform, distribute, and otherwise exploit its + Contributions, either on an unmodified basis, with Modifications, or + as part of a Larger Work; and + +(b) under Patent Claims of such Contributor to make, use, sell, offer + for sale, have made, import, and otherwise transfer either its + Contributions or its Contributor Version. + +2.2. Effective Date + +The licenses granted in Section 2.1 with respect to any Contribution +become effective for each Contribution on the date the Contributor first +distributes such Contribution. + +2.3. Limitations on Grant Scope + +The licenses granted in this Section 2 are the only rights granted under +this License. No additional rights or licenses will be implied from the +distribution or licensing of Covered Software under this License. +Notwithstanding Section 2.1(b) above, no patent license is granted by a +Contributor: + +(a) for any code that a Contributor has removed from Covered Software; + or + +(b) for infringements caused by: (i) Your and any other third party's + modifications of Covered Software, or (ii) the combination of its + Contributions with other software (except as part of its Contributor + Version); or + +(c) under Patent Claims infringed by Covered Software in the absence of + its Contributions. + +This License does not grant any rights in the trademarks, service marks, +or logos of any Contributor (except as may be necessary to comply with +the notice requirements in Section 3.4). + +2.4. Subsequent Licenses + +No Contributor makes additional grants as a result of Your choice to +distribute the Covered Software under a subsequent version of this +License (see Section 10.2) or under the terms of a Secondary License (if +permitted under the terms of Section 3.3). + +2.5. Representation + +Each Contributor represents that the Contributor believes its +Contributions are its original creation(s) or it has sufficient rights +to grant the rights to its Contributions conveyed by this License. + +2.6. Fair Use + +This License is not intended to limit any rights You have under +applicable copyright doctrines of fair use, fair dealing, or other +equivalents. + +2.7. Conditions + +Sections 3.1, 3.2, 3.3, and 3.4 are conditions of the licenses granted +in Section 2.1. + +3. Responsibilities +------------------- + +3.1. Distribution of Source Form + +All distribution of Covered Software in Source Code Form, including any +Modifications that You create or to which You contribute, must be under +the terms of this License. You must inform recipients that the Source +Code Form of the Covered Software is governed by the terms of this +License, and how they can obtain a copy of this License. You may not +attempt to alter or restrict the recipients' rights in the Source Code +Form. + +3.2. Distribution of Executable Form + +If You distribute Covered Software in Executable Form then: + +(a) such Covered Software must also be made available in Source Code + Form, as described in Section 3.1, and You must inform recipients of + the Executable Form how they can obtain a copy of such Source Code + Form by reasonable means in a timely manner, at a charge no more + than the cost of distribution to the recipient; and + +(b) You may distribute such Executable Form under the terms of this + License, or sublicense it under different terms, provided that the + license for the Executable Form does not attempt to limit or alter + the recipients' rights in the Source Code Form under this License. + +3.3. Distribution of a Larger Work + +You may create and distribute a Larger Work under terms of Your choice, +provided that You also comply with the requirements of this License for +the Covered Software. If the Larger Work is a combination of Covered +Software with a work governed by one or more Secondary Licenses, and the +Covered Software is not Incompatible With Secondary Licenses, this +License permits You to additionally distribute such Covered Software +under the terms of such Secondary License(s), so that the recipient of +the Larger Work may, at their option, further distribute the Covered +Software under the terms of either this License or such Secondary +License(s). + +3.4. Notices + +You may not remove or alter the substance of any license notices +(including copyright notices, patent notices, disclaimers of warranty, +or limitations of liability) contained within the Source Code Form of +the Covered Software, except that You may alter any license notices to +the extent required to remedy known factual inaccuracies. + +3.5. Application of Additional Terms + +You may choose to offer, and to charge a fee for, warranty, support, +indemnity or liability obligations to one or more recipients of Covered +Software. However, You may do so only on Your own behalf, and not on +behalf of any Contributor. You must make it absolutely clear that any +such warranty, support, indemnity, or liability obligation is offered by +You alone, and You hereby agree to indemnify every Contributor for any +liability incurred by such Contributor as a result of warranty, support, +indemnity or liability terms You offer. You may include additional +disclaimers of warranty and limitations of liability specific to any +jurisdiction. + +4. Inability to Comply Due to Statute or Regulation +--------------------------------------------------- + +If it is impossible for You to comply with any of the terms of this +License with respect to some or all of the Covered Software due to +statute, judicial order, or regulation then You must: (a) comply with +the terms of this License to the maximum extent possible; and (b) +describe the limitations and the code they affect. Such description must +be placed in a text file included with all distributions of the Covered +Software under this License. Except to the extent prohibited by statute +or regulation, such description must be sufficiently detailed for a +recipient of ordinary skill to be able to understand it. + +5. Termination +-------------- + +5.1. The rights granted under this License will terminate automatically +if You fail to comply with any of its terms. However, if You become +compliant, then the rights granted under this License from a particular +Contributor are reinstated (a) provisionally, unless and until such +Contributor explicitly and finally terminates Your grants, and (b) on an +ongoing basis, if such Contributor fails to notify You of the +non-compliance by some reasonable means prior to 60 days after You have +come back into compliance. Moreover, Your grants from a particular +Contributor are reinstated on an ongoing basis if such Contributor +notifies You of the non-compliance by some reasonable means, this is the +first time You have received notice of non-compliance with this License +from such Contributor, and You become compliant prior to 30 days after +Your receipt of the notice. + +5.2. If You initiate litigation against any entity by asserting a patent +infringement claim (excluding declaratory judgment actions, +counter-claims, and cross-claims) alleging that a Contributor Version +directly or indirectly infringes any patent, then the rights granted to +You by any and all Contributors for the Covered Software under Section +2.1 of this License shall terminate. + +5.3. In the event of termination under Sections 5.1 or 5.2 above, all +end user license agreements (excluding distributors and resellers) which +have been validly granted by You or Your distributors under this License +prior to termination shall survive termination. + +************************************************************************ +* * +* 6. Disclaimer of Warranty * +* ------------------------- * +* * +* Covered Software is provided under this License on an "as is" * +* basis, without warranty of any kind, either expressed, implied, or * +* statutory, including, without limitation, warranties that the * +* Covered Software is free of defects, merchantable, fit for a * +* particular purpose or non-infringing. The entire risk as to the * +* quality and performance of the Covered Software is with You. * +* Should any Covered Software prove defective in any respect, You * +* (not any Contributor) assume the cost of any necessary servicing, * +* repair, or correction. This disclaimer of warranty constitutes an * +* essential part of this License. No use of any Covered Software is * +* authorized under this License except under this disclaimer. * +* * +************************************************************************ + +************************************************************************ +* * +* 7. Limitation of Liability * +* -------------------------- * +* * +* Under no circumstances and under no legal theory, whether tort * +* (including negligence), contract, or otherwise, shall any * +* Contributor, or anyone who distributes Covered Software as * +* permitted above, be liable to You for any direct, indirect, * +* special, incidental, or consequential damages of any character * +* including, without limitation, damages for lost profits, loss of * +* goodwill, work stoppage, computer failure or malfunction, or any * +* and all other commercial damages or losses, even if such party * +* shall have been informed of the possibility of such damages. This * +* limitation of liability shall not apply to liability for death or * +* personal injury resulting from such party's negligence to the * +* extent applicable law prohibits such limitation. Some * +* jurisdictions do not allow the exclusion or limitation of * +* incidental or consequential damages, so this exclusion and * +* limitation may not apply to You. * +* * +************************************************************************ + +8. Litigation +------------- + +Any litigation relating to this License may be brought only in the +courts of a jurisdiction where the defendant maintains its principal +place of business and such litigation shall be governed by laws of that +jurisdiction, without reference to its conflict-of-law provisions. +Nothing in this Section shall prevent a party's ability to bring +cross-claims or counter-claims. + +9. Miscellaneous +---------------- + +This License represents the complete agreement concerning the subject +matter hereof. If any provision of this License is held to be +unenforceable, such provision shall be reformed only to the extent +necessary to make it enforceable. Any law or regulation which provides +that the language of a contract shall be construed against the drafter +shall not be used to construe this License against a Contributor. + +10. Versions of the License +--------------------------- + +10.1. New Versions + +Mozilla Foundation is the license steward. Except as provided in Section +10.3, no one other than the license steward has the right to modify or +publish new versions of this License. Each version will be given a +distinguishing version number. + +10.2. Effect of New Versions + +You may distribute the Covered Software under the terms of the version +of the License under which You originally received the Covered Software, +or under the terms of any subsequent version published by the license +steward. + +10.3. Modified Versions + +If you create software not governed by this License, and you want to +create a new license for such software, you may create and use a +modified version of this License if you rename the license and remove +any references to the name of the license steward (except to note that +such modified license differs from this License). + +10.4. Distributing Source Code Form that is Incompatible With Secondary +Licenses + +If You choose to distribute Source Code Form that is Incompatible With +Secondary Licenses under the terms of this version of the License, the +notice described in Exhibit B of this License must be attached. + +Exhibit A - Source Code Form License Notice +------------------------------------------- + + This Source Code Form is subject to the terms of the Mozilla Public + License, v. 2.0. If a copy of the MPL was not distributed with this + file, You can obtain one at http://mozilla.org/MPL/2.0/. + +If it is not possible or desirable to put the notice in a particular +file, then You may include the notice in a location (such as a LICENSE +file in a relevant directory) where a recipient would be likely to look +for such a notice. + +You may add additional accurate notices of copyright ownership. + +Exhibit B - "Incompatible With Secondary Licenses" Notice +--------------------------------------------------------- + + This Source Code Form is "Incompatible With Secondary Licenses", as + defined by the Mozilla Public License, v. 2.0. diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -6,7 +6,7 @@ [![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 a repository of +`life-sync` is a CLI tool that makes it easier to synchronize a repository of personal config files across multiple machines. ## Motivation @@ -41,6 +41,11 @@ ## Installation +There are several ways to install `life` on your machine. +Here are detailed instructions on different approaches. + +### From Hackage/Stackage + Install with one simple command: ```shell @@ -52,6 +57,32 @@ ```shell $ stack install life-sync-1.0 ``` + +### Homebrew + +If you are on MacOS, you can get `life-sync` using +[Homebrew](https://brew.sh/) Kowainik's Tap. + +You need to run the following commands for that: + +```shell +$ brew tap kowainik/tap +$ brew install life-sync +``` + +### Ubuntu + +If you are on Ubuntu, you can get `life-sync` from Kowainik's PPA. + +You need to run the following commands for that: + +```shell +$ sudo add-apt-repository ppa:kowainik/life-sync +$ sudo apt update +$ sudo apt intsall life-sync +``` + +### Setup You can turn on bash auto-completion by running the following command: diff --git a/Setup.hs b/Setup.hs deleted file mode 100644 --- a/Setup.hs +++ /dev/null @@ -1,2 +0,0 @@ -import Distribution.Simple -main = defaultMain diff --git a/app/Main.hs b/app/Main.hs --- a/app/Main.hs +++ b/app/Main.hs @@ -1,24 +1,6 @@ -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) +module Main (main) where -import qualified Data.Set as Set +import Life.Main (lifeMain) 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 +main = lifeMain diff --git a/app/Options.hs b/app/Options.hs deleted file mode 100644 --- a/app/Options.hs +++ /dev/null @@ -1,119 +0,0 @@ -{-# 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 --- a/life-sync.cabal +++ b/life-sync.cabal @@ -1,102 +1,116 @@ +cabal-version: 2.4 name: life-sync -version: 1.0.1 -description: Synchronize personal configs across multiple machines +version: 1.1.0.0 +synopsis: Synchronize personal configs across multiple machines. +description: Synchronize personal configs across multiple machines. + See README for more details. homepage: https://github.com/kowainik/life-sync bug-reports: https://github.com/kowainik/life-sync/issues -license: MIT +license: MPL-2.0 license-file: LICENSE -author: Kowainik -maintainer: xrom.xkov@gmail.com -copyright: 2018 Kowainik -category: Configuration +author: Dmitrii Kovanikov, Veronika Romashkina +maintainer: Kowainik +copyright: 2018-2020 Kowainik +category: Configuration, CLI, CLI Tool, Development 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 + CHANGELOG.md +tested-with: GHC == 8.8.3 source-repository head type: git location: https://github.com/kowainik/life-sync.git +common common-options + build-depends: base ^>= 4.13.0.0 + , relude ^>= 0.6.0.0 + + mixins: base hiding (Prelude) + , relude (Relude as Prelude + , Relude.Extra.Lens + , Relude.Unsafe + ) + + ghc-options: -Wall + -Wincomplete-uni-patterns + -Wincomplete-record-updates + -Wcompat + -Widentities + -Wredundant-constraints + -fhide-source-paths + -Wmissing-export-lists + -Wpartial-fields + if impl(ghc >= 8.8.1) + ghc-options: -Wmissing-deriving-strategies + -Werror=missing-deriving-strategies + + default-language: Haskell2010 + default-extensions: ConstraintKinds + DeriveGeneric + DerivingStrategies + GeneralizedNewtypeDeriving + InstanceSigs + KindSignatures + LambdaCase + OverloadedStrings + RecordWildCards + ScopedTypeVariables + StandaloneDeriving + TupleSections + TypeApplications + ViewPatterns + library + import: common-options hs-source-dirs: src - exposed-modules: Prelude + exposed-modules: Life.Cli Life.Configuration + Life.Core Life.Github + Life.Main + Life.Main.Add + Life.Main.Init + Life.Main.Pull + Life.Main.Push + Life.Main.Remove Life.Message - Life.Shell - Life.Main.Add - Life.Main.Init - Life.Main.Pull - Life.Main.Push - Life.Main.Remove - Life.Validation + Life.Path - build-depends: base-noprelude >= 4.9 && < 5 - , ansi-terminal - , bytestring + build-depends: bytestring + , colourista ^>= 0.0.0.0 , containers , exceptions - , fmt - , microlens-platform + , optparse-applicative ^>= 0.15 , path , path-io , process - , relude >= 0.1.0 - , text >= 1.2 - , tomland ^>= 0.3 - - ghc-options: -Wall - default-language: Haskell2010 - - default-extensions: GeneralizedNewtypeDeriving - LambdaCase - OverloadedStrings - RecordWildCards - ScopedTypeVariables - TypeApplications + , shellmet ^>= 0.0.3.0 + , text ^>= 1.2 + , tomland ^>= 1.2.1.0 + , validation-selective ^>= 0.0.0.0 executable life + import: common-options 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 + build-depends: life-sync + ghc-options: -threaded -rtsopts -with-rtsopts=-N test-suite life-sync-test + import: common-options type: exitcode-stdio-1.0 hs-source-dirs: test main-is: Spec.hs - other-modules: Test.Roundtrip + other-modules: Test.Configuration + ghc-options: -threaded -rtsopts -with-rtsopts=-N - build-tool-depends: tasty-discover:tasty-discover - build-depends: base-noprelude, life-sync + build-depends: life-sync , containers - , filepath - , hedgehog + , filepath ^>= 1.4 + , hedgehog ^>= 1.0 + , hspec ^>= 2.7.1 + , hspec-hedgehog ^>= 0.0.1.1 , path - , tasty - , tasty-hedgehog - - ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N - default-language: Haskell2010 - - default-extensions: LambdaCase - OverloadedStrings - RecordWildCards - TypeApplications + , text diff --git a/src/Life/Cli.hs b/src/Life/Cli.hs new file mode 100644 --- /dev/null +++ b/src/Life/Cli.hs @@ -0,0 +1,125 @@ +{-# LANGUAGE ApplicativeDo #-} + +{- | +Copyright: (c) 2017-2020 Kowainik +SPDX-License-Identifier: MPL-2.0 +Maintainer: Kowainik + +Command line options for @life@. +-} + +module Life.Cli + ( LifeCommand (..) + , PathOptions (..) + , PullOptions (..) + + , parseCommand + ) where + +import Options.Applicative (Parser, ParserInfo, command, execParser, fullDesc, help, helper, info, + long, metavar, progDesc, short, strOption, subparser) + +import Life.Core (LifePath (..), Owner (..)) + + +-- | Commands to execute +data LifeCommand + = Init (Maybe Owner) + | Add PathOptions + | Remove PathOptions + | Push + | Pull PullOptions + deriving stock (Show) + +--------------------------------------------------------------------------- +-- Boilerplate +---------------------------------------------------------------------------- + +commandParser :: Parser LifeCommand +commandParser = subparser $ + command "init" + (info (helper <*> fmap Init (optional 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 + $ strOption + $ metavar "OWNER" + <> help "Your github user name" + +---------------------------------------------------------------------------- +-- life pull +---------------------------------------------------------------------------- + +data PullOptions = PullOptions + { pullOptionsOwner :: Maybe Owner + , pullOptionsNoFiles :: [FilePath] + , pullOptionsNoDirs :: [FilePath] + } deriving stock (Show) + +pullOptionsParser :: Parser PullOptions +pullOptionsParser = do + pullOptionsOwner <- optional 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 +---------------------------------------------------------------------------- + +newtype PathOptions = PathOptions + { pathOptionsPath :: LifePath + } deriving stock (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/src/Life/Configuration.hs b/src/Life/Configuration.hs --- a/src/Life/Configuration.hs +++ b/src/Life/Configuration.hs @@ -1,96 +1,119 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE FunctionalDependencies #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TemplateHaskell #-} +{- | +Copyright: (c) 2017-2020 Kowainik +SPDX-License-Identifier: MPL-2.0 +Maintainer: Kowainik --- | Contains configuration data type. +Contains configuration data type — 'LifeConfiguration'. +-} module Life.Configuration - ( LifePath (..) - - , LifeConfiguration (..) - , singleDirConfig - , singleFileConfig + ( LifeConfiguration (..) + , singleDirConfig + , singleFileConfig + , defaultLifeConfig - , lifeConfigMinus + , lifeConfigMinus --- -- * Parsing exceptions --- , ParseLifeException (..) +-- -- * Parsing exceptions +-- , ParseLifeException (..) - -- * Lenses for 'LifeConfiguration' - , files - , directories + -- * Lenses for 'LifeConfiguration' + , filesL + , directoriesL + , branchL - -- * Parse 'LifeConfiguration' under @~/.life@ - , parseHomeLife - , parseRepoLife - , parseLifeConfiguration + -- * Parse 'LifeConfiguration' under @~/.life@ + , parseHomeLife + , parseRepoLife + , parseLifeConfiguration - -- * Render 'LifeConfiguration' under @~/.life@ - , renderLifeConfiguration - , writeGlobalLife - ) where + -- * Render 'LifeConfiguration' under @~/.life@ + , renderLifeConfiguration + , writeGlobalLife + ) where import Control.Monad.Catch (MonadThrow (..)) -import Fmt (indentF, unlinesF, (+|), (|+)) -import Lens.Micro.Platform (makeFields, (.~), (^.)) import Path (Dir, File, Path, Rel, fromAbsFile, parseRelDir, parseRelFile, toFilePath, ()) -import Toml (AnyValue (..), BiToml, Prism (..), (.=)) +import Relude.Extra.Lens (Lens', lens, (.~), (^.)) +import Toml (TomlCodec, (.=)) -import Life.Shell (lifePath, relativeToHome, repoName) +import Life.Core (Branch (..), master) +import Life.Path (lifePath, relativeToHome, repoName) import qualified Data.Set as Set import qualified Data.Text as T 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 ----------------------------------------------------------------------------- - +-- | The configurations data type. data LifeConfiguration = LifeConfiguration - { lifeConfigurationFiles :: Set (Path Rel File) - , lifeConfigurationDirectories :: Set (Path Rel Dir) - } deriving (Show, Eq) + { lifeConfigurationFiles :: !(Set (Path Rel File)) + , lifeConfigurationDirectories :: !(Set (Path Rel Dir)) + , lifeConfigurationBranch :: !(Last Branch) + } deriving stock (Show, Eq) -makeFields ''LifeConfiguration +-- | Lens for 'lifeConfigurationFiles'. +filesL :: Lens' LifeConfiguration (Set (Path Rel File)) +filesL = lens + lifeConfigurationFiles + (\config newFiles -> config {lifeConfigurationFiles = newFiles}) +-- | Lens for 'lifeConfigurationDirectories'. +directoriesL :: Lens' LifeConfiguration (Set (Path Rel Dir)) +directoriesL = lens + lifeConfigurationDirectories + (\config newDirs -> config {lifeConfigurationDirectories = newDirs}) + +-- | Lens for 'lifeConfigurationBranch'. +branchL :: Lens' LifeConfiguration (Last Branch) +branchL = lens + lifeConfigurationBranch + (\config newBr -> config {lifeConfigurationBranch = newBr}) + ---------------------------------------------------------------------------- -- Algebraic instances and utilities ---------------------------------------------------------------------------- instance Semigroup LifeConfiguration where life1 <> life2 = LifeConfiguration - { lifeConfigurationFiles = life1^.files <> life2^.files - , lifeConfigurationDirectories = life1^.directories <> life2^.directories + { lifeConfigurationFiles = (life1 ^. filesL) <> (life2 ^. filesL) + , lifeConfigurationDirectories = (life1 ^. directoriesL) <> (life2 ^. directoriesL) + , lifeConfigurationBranch = (life1 ^. branchL) <> (life2 ^. branchL) } instance Monoid LifeConfiguration where - mempty = LifeConfiguration mempty mempty + mempty = LifeConfiguration mempty mempty mempty mappend = (<>) +-- | The defaulting 'LifeConfiguration', with the default @master@ branch. +defaultLifeConfig :: LifeConfiguration +defaultLifeConfig = LifeConfiguration + { lifeConfigurationFiles = mempty + , lifeConfigurationDirectories = mempty + , lifeConfigurationBranch = Last $ Just master + } + +-- | Creates a 'LifeConfiguration' with the given file. singleFileConfig :: Path Rel File -> LifeConfiguration -singleFileConfig file = mempty & files .~ one file +singleFileConfig file = mempty & filesL .~ one file +-- | Creates a 'LifeConfiguration' with the given folder. singleDirConfig :: Path Rel Dir -> LifeConfiguration -singleDirConfig dir = mempty & directories .~ one dir +singleDirConfig dir = mempty & directoriesL .~ one dir ---------------------------------------------------------------------------- -- LifeConfiguration difference ---------------------------------------------------------------------------- -lifeConfigMinus :: LifeConfiguration -- ^ repo .life config - -> LifeConfiguration -- ^ global config - -> LifeConfiguration -- ^ configs that are not in global +lifeConfigMinus + :: LifeConfiguration -- ^ Repository @.life@ configuration + -> LifeConfiguration -- ^ Global configuration + -> LifeConfiguration -- ^ Configuration that is not in global lifeConfigMinus dotfiles global = LifeConfiguration - (Set.difference (dotfiles ^. files) (global ^. files)) - (Set.difference (dotfiles ^. directories) (global ^. directories)) + (Set.difference (dotfiles ^. filesL) (global ^. filesL)) + (Set.difference (dotfiles ^. directoriesL) (global ^. directoriesL)) + (Last $ Just master) ---------------------------------------------------------------------------- -- Toml parser for life configuration @@ -101,16 +124,10 @@ , corpseDirectories :: [FilePath] } -corpseConfiguationT :: BiToml CorpseConfiguration +corpseConfiguationT :: TomlCodec CorpseConfiguration corpseConfiguationT = CorpseConfiguration - <$> Toml.arrayOf _String "files" .= corpseFiles - <*> Toml.arrayOf _String "directories" .= corpseDirectories - where - _String :: Prism AnyValue String - _String = Prism - { preview = \(AnyValue t) -> Toml.matchText t >>= pure . toString - , review = AnyValue . Toml.Text . toText - } + <$> Toml.arrayOf Toml._String "files" .= corpseFiles + <*> Toml.arrayOf Toml._String "directories" .= corpseDirectories resurrect :: MonadThrow m => CorpseConfiguration -> m LifeConfiguration resurrect CorpseConfiguration{..} = do @@ -120,6 +137,7 @@ pure $ LifeConfiguration { lifeConfigurationFiles = Set.fromList filePaths , lifeConfigurationDirectories = Set.fromList dirPaths + , lifeConfigurationBranch = Last (Just master) } -- TODO: should tomland one day support this?... @@ -135,22 +153,25 @@ render :: Text -> Set (Path b t) -> Maybe Text render key paths = do let prefix = key <> " = " - let array = renderStringArray (T.length prefix) (map show $ toList paths) - + let array = renderStringArray $ 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 ++ ["]"])) - |+ "" + renderStringArray :: [Text] -> Text + renderStringArray = \case + [] -> "[]" + [x] -> "[" <> x <> "]" + l -> mconcat + [ "\n [ " + , T.intercalate "\n , " l + , "\n ]" + ] writeGlobalLife :: LifeConfiguration -> IO () writeGlobalLife config = do lifeFilePath <- relativeToHome lifePath - writeFile (fromAbsFile lifeFilePath) (renderLifeConfiguration True config) + writeFileText (fromAbsFile lifeFilePath) (renderLifeConfiguration True config) ---------------------------------------------------------------------------- -- Life configuration parsing @@ -163,7 +184,7 @@ parseLife :: Path Rel File -> IO LifeConfiguration parseLife path = relativeToHome path - >>= readFile . fromAbsFile + >>= readFileText . fromAbsFile >>= parseLifeConfiguration -- | Reads 'LifeConfiguration' from @~\/.life@ file. diff --git a/src/Life/Core.hs b/src/Life/Core.hs new file mode 100644 --- /dev/null +++ b/src/Life/Core.hs @@ -0,0 +1,63 @@ +{- | +Copyright: (c) 2017-2020 Kowainik +SPDX-License-Identifier: MPL-2.0 +Maintainer: Kowainik + +Contains main data types used in the project. +-} + +module Life.Core + ( + -- * Git and Github core + Branch (..) + , Owner (..) + , Repo (..) + , CommitMsg (..) + , master + + -- * File system logic + , CopyDirection (..) + , LifePath (..) + ) where + +---------------------------------------------------------------------------- +-- Git and Github core +---------------------------------------------------------------------------- + +-- | Github repository owner. +newtype Owner = Owner + { unOwner :: Text + } deriving stock (Show) + +-- | Git repository. +newtype Repo = Repo + { unRepo :: Text + } deriving stock (Show) + +-- | Git branch. +newtype Branch = Branch + { unBranch :: Text + } deriving stock (Show) + deriving newtype (Eq) + +-- | Git commit message. +newtype CommitMsg = CommitMsg + { unCommitMsg :: Text + } deriving stock (Show) + +-- | Git "master" branch constant. +master :: Branch +master = Branch "master" + +---------------------------------------------------------------------------- +-- File system logic +---------------------------------------------------------------------------- + +data CopyDirection + = FromHomeToRepo + | FromRepoToHome + +data LifePath + = File FilePath + | Dir FilePath + deriving stock (Show) diff --git a/src/Life/Github.hs b/src/Life/Github.hs --- a/src/Life/Github.hs +++ b/src/Life/Github.hs @@ -1,67 +1,88 @@ --- | Utilities to work with GitHub repositories using "hub". +{- | +Copyright: (c) 2017-2020 Kowainik +SPDX-License-Identifier: MPL-2.0 +Maintainer: Kowainik -module Life.Github - ( Owner (..) - , Repo (..) +Utilities to work with GitHub repositories using @hub@. +-} - -- * Repository utils - , checkRemoteSync - , cloneRepo - , insideRepo - , withSynced +module Life.Github + ( + -- * Repository utils + checkRemoteSync + , cloneRepo + , createNewBranch + , doesBranchExist + , insideRepo + , withSynced - -- * Repository manipulation commands - , CopyDirection (..) - , copyLife - , addToRepo - , createRepository - , pullUpdateFromRepo - , removeFromRepo - , updateDotfilesRepo - , updateFromRepo - ) where + -- * Repository manipulation commands + , copyLife + , addToRepo + , createRepository + , pullUpdateFromRepo + , removeFromRepo + , updateDotfilesRepo + , updateFromRepo + , getUserLogin + ) where 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, errorMessage, infoMessage, warningMessage) -import Life.Shell (lifePath, relativeToHome, repoName, ($|)) +import Life.Path (lifePath, relativeToHome, repoName) -newtype Owner = Owner { getOwner :: Text } deriving (Show) -newtype Repo = Repo { getRepo :: Text } deriving (Show) +import qualified Data.Text as Text + ---------------------------------------------------------------------------- -- VSC commands ---------------------------------------------------------------------------- -askToPushka :: Text -> IO () +askToPushka :: CommitMsg -> 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 + then pushka master commitMsg else errorMessage "Abort pushing" >> exitFailure -- | Make a commit and push it. -pushka :: Text -> IO () -pushka commitMsg = do +pushka :: Branch -> CommitMsg -> IO () +pushka (Branch branch) (CommitMsg commitMsg) = do "git" ["add", "."] "git" ["commit", "-m", commitMsg] - "git" ["push", "-u", "origin", "master"] + "git" ["push", "-u", "origin", branch] -- | Creates repository on GitHub inside given folder. -createRepository :: Owner -> Repo -> IO () -createRepository (Owner owner) (Repo repo) = do +createRepository :: Maybe Owner -> Repo -> IO () +createRepository mo (Repo repo) = do + owner <- getOwnerLogin mo let description = ":computer: Configuration files" "git" ["init"] "hub" ["create", "-d", description, owner <> "/" <> repo] - pushka "Create the project" + pushka master $ CommitMsg "Create the project" +-- | Get user login from the local global git config. +getUserLogin :: IO Text +getUserLogin = do + login <- "git" $| ["config", "user.login"] + if login == "" + then errorMessage "user.login is not specified" >> exitFailure + else pure $ toText login + +-- | Consider owner from global git config if Owner is not given +getOwnerLogin :: Maybe Owner -> IO Text +getOwnerLogin = maybe getUserLogin (pure . unOwner) + ---------------------------------------------------------------------------- -- dotfiles workflow ---------------------------------------------------------------------------- @@ -73,29 +94,41 @@ withCurrentDir repoPath action -- | Commits all changes inside 'repoName' and pushes to remote. -pushRepo :: Text -> IO () +pushRepo :: CommitMsg -> IO () pushRepo = insideRepo . askToPushka -- | Clones @dotfiles@ repository assuming it doesn't exist. -cloneRepo :: Owner -> IO () -cloneRepo (Owner owner) = do +cloneRepo :: Maybe Owner -> IO () +cloneRepo mo = do + owner <- getOwnerLogin mo homeDir <- getHomeDir withCurrentDir homeDir $ do infoMessage "Using SSH to clone repo..." "git" ["clone", "git@github.com:" <> owner <> "/dotfiles.git"] +-- | Create new branch with given branch name +createNewBranch :: Branch -> IO () +createNewBranch (Branch branch) = + "git" ["checkout", "-b", branch] + -- | 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"] +checkRemoteSync :: Branch -> IO Bool +checkRemoteSync (Branch branch) = do + "git" ["fetch", "origin", branch] + localHash <- "git" $| ["rev-parse", branch] + remoteHash <- "git" $| ["rev-parse", "origin/" <> branch] pure $ localHash == remoteHash -withSynced :: IO a -> IO a -withSynced action = insideRepo $ do - infoMessage "Checking if repo is synchnorized..." - isSynced <- checkRemoteSync +-- | Check if a branch exists in remote repo +doesBranchExist :: Branch -> IO Bool +doesBranchExist (Branch branch) = do + r <- "git" $| ["ls-remote", "--heads", "origin", branch] + pure $ not (Text.null r) + +withSynced :: Branch -> IO a -> IO a +withSynced branch@(Branch branchname) action = insideRepo $ do + infoMessage "Checking if repo is synchronized..." + isSynced <- checkRemoteSync branch if isSynced then do infoMessage "Repo is up-to-date" action @@ -103,7 +136,7 @@ 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"] + "git" ["rebase", "origin/" <> branchname] action else do errorMessage "Aborting current command because repository is not synchronized with remote" @@ -113,8 +146,6 @@ -- File manipulation ---------------------------------------------------------------------------- -data CopyDirection = FromHomeToRepo | FromRepoToHome - pullUpdateFromRepo :: LifeConfiguration -> IO () pullUpdateFromRepo life = do insideRepo $ "git" ["pull", "-r"] @@ -129,7 +160,7 @@ copyLife FromRepoToHome lifeToLive -updateDotfilesRepo :: Text -> LifeConfiguration -> IO () +updateDotfilesRepo :: CommitMsg -> LifeConfiguration -> IO () updateDotfilesRepo commitMsg life = do copyLife FromHomeToRepo life pushRepo commitMsg @@ -147,13 +178,14 @@ 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 + :: (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 @@ -165,6 +197,13 @@ FromHomeToRepo -> copyAction homePath repoPath FromRepoToHome -> copyAction repoPath homePath +-- | Update .life file +updateLifeFile :: IO () +updateLifeFile = do + lifeFile <- relativeToHome lifePath + repoLifeFile <- relativeToHome (repoName lifePath) + copyFile lifeFile repoLifeFile + -- | 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 @@ -173,12 +212,9 @@ destinationPath <- relativeToHome (repoName path) copyFun sourcePath destinationPath - -- update .life file - lifeFile <- relativeToHome lifePath - repoLifeFile <- relativeToHome (repoName lifePath) - copyFile lifeFile repoLifeFile + updateLifeFile - let commitMsg = "Add: " <> toText (toFilePath path) + let commitMsg = CommitMsg $ "Add: " <> toText (toFilePath path) pushRepo commitMsg -- | Removes file or directory from the repository and commits @@ -187,12 +223,9 @@ absPath <- relativeToHome (repoName path) catch (removeFun absPath) handleNotExist - -- update .life file - lifeFile <- relativeToHome lifePath - repoLifeFile <- relativeToHome (repoName lifePath) - copyFile lifeFile repoLifeFile + updateLifeFile - let commitMsg = "Remove: " <> pathTextName + let commitMsg = CommitMsg $ "Remove: " <> pathTextName pushRepo commitMsg where pathTextName :: Text diff --git a/src/Life/Main.hs b/src/Life/Main.hs new file mode 100644 --- /dev/null +++ b/src/Life/Main.hs @@ -0,0 +1,34 @@ +{- | +Copyright: (c) 2017-2020 Kowainik +SPDX-License-Identifier: MPL-2.0 +Maintainer: Kowainik + +Main entry point for the @life@ executable. +-} + +module Life.Main + ( lifeMain + ) where + +import Path (parseRelDir, parseRelFile) + +import Life.Cli (LifeCommand (..), PathOptions (..), PullOptions (..), parseCommand) +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 qualified Data.Set as Set + + +lifeMain :: IO () +lifeMain = 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/src/Life/Main/Add.hs b/src/Life/Main/Add.hs --- a/src/Life/Main/Add.hs +++ b/src/Life/Main/Add.hs @@ -1,31 +1,37 @@ {-# LANGUAGE Rank2Types #-} --- | Functions to add file/directory to your life. +{- | +Copyright: (c) 2017-2020 Kowainik +SPDX-License-Identifier: MPL-2.0 +Maintainer: Kowainik +Functions to add file/directory to your life. +-} + module Life.Main.Add - ( lifeAdd - ) where + ( lifeAdd + ) where -import Lens.Micro.Platform (Lens', (%~)) import Path (Abs, Dir, File, Path, Rel, parent, toFilePath, ()) import Path.IO (copyDirRecur, copyFile, doesDirExist, doesFileExist, ensureDir, getHomeDir, makeRelative, resolveDir, resolveFile) +import Relude.Extra.Lens (Lens', (%~)) -import Life.Configuration (LifeConfiguration, LifePath (..), directories, files, parseHomeLife, - writeGlobalLife) +import Life.Configuration (LifeConfiguration, directoriesL, filesL, parseHomeLife, writeGlobalLife) +import Life.Core (LifePath (..), master) 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 Life.Path (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 + Both _ _ -> withSynced master addingProcess -- if one of them is missing -- abort OnlyRepo _ -> abortCmd "add" ".life file doesn't exist" @@ -42,28 +48,30 @@ filePath <- resolveFile homeDirPath path whenM (doesFileExist filePath) $ do relativeFile <- makeRelative homeDirPath filePath - resolveConfiguration files checkEqualFiles copyFileWithDir relativeFile + resolveConfiguration filesL checkEqualFiles copyFileWithDir relativeFile (Dir path) -> do dirPath <- resolveDir homeDirPath path whenM (doesDirExist dirPath) $ do relativeDir <- makeRelative homeDirPath dirPath - resolveConfiguration directories checkEqualDirs copyDirRecur relativeDir + resolveConfiguration directoriesL 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 + :: 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 + if isSameAsInRepo + then do let pathText = toText $ toFilePath path infoMessage $ "Path " <> pathText <> " is already latest version in repository" else do @@ -78,19 +86,19 @@ repoFilePath <- relativeToHome (repoName path) isRepoFile <- doesFileExist repoFilePath - if isRepoFile then do - originContent <- LBS.readFile $ toFilePath homeFilePath - repoContent <- LBS.readFile $ toFilePath repoFilePath + if isRepoFile + then do + originContent <- readFileLBS $ toFilePath homeFilePath + repoContent <- readFileLBS $ toFilePath repoFilePath pure $ originContent == repoContent - else - pure False + else pure False checkEqualDirs :: Path Rel Dir -> IO Bool checkEqualDirs _ = do warningMessage "TODO: check directories to be equal" - pure True + pure False --- | Just like 'copyFile' but also creates directory for second file. +-- | Just like 'copyFile' but also creates directory for the 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 --- a/src/Life/Main/Init.hs +++ b/src/Life/Main/Init.hs @@ -1,26 +1,33 @@ {-# LANGUAGE TemplateHaskell #-} --- | Contains function to create repository. +{- | +Copyright: (c) 2017-2020 Kowainik +SPDX-License-Identifier: MPL-2.0 +Maintainer: Kowainik +Contains a function to create the main repository — @dotfiles@. +-} + module Life.Main.Init - ( lifeInit - , lifeInitQuestion - ) where + ( 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.Core (CopyDirection (..), Owner (..), Repo (..), master) +import Life.Github (copyLife, createRepository, insideRepo) import Life.Message (abortCmd, chooseYesNo, infoMessage, promptNonEmpty, skipMessage, successMessage, warningMessage) -import Life.Shell (LifeExistence (..), createDirInHome, lifePath, relativeToHome, repoName, - whatIsLife) +import Life.Path (LifeExistence (..), createDirInHome, lifePath, relativeToHome, repoName, + whatIsLife) import qualified Data.Set as Set + predefinedLifeConfig :: LifeConfiguration predefinedLifeConfig = mempty { lifeConfigurationFiles = Set.fromList @@ -35,7 +42,7 @@ ] } -lifeInit :: Owner -> IO () +lifeInit :: Maybe Owner -> IO () lifeInit owner = whatIsLife >>= \case NoLife -> createLifeFile >>= createDotfilesDir OnlyLife _ -> askCreateLife >>= createDotfilesDir @@ -84,8 +91,8 @@ 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) + pure ( LifeConfiguration (Set.fromList existingFiles) (Set.fromList existingDirs) (Last $ Just master) + , LifeConfiguration (Set.fromList nonExistingFiles) (Set.fromList nonExistingDirs) (Last $ Just master) ) partitionM :: forall f m a . (Monad m, Foldable f) => (a -> m Bool) -> f a -> m ([a], [a]) @@ -109,6 +116,6 @@ infoMessage "Initialization process starts.." skipMessage "Insert your GitHub username:" owner <- promptNonEmpty - lifeInit $ Owner owner + lifeInit $ Just $ 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 --- a/src/Life/Main/Pull.hs +++ b/src/Life/Main/Pull.hs @@ -1,18 +1,26 @@ --- | Command to update local state from remote state. +{- | +Copyright: (c) 2017-2020 Kowainik +SPDX-License-Identifier: MPL-2.0 +Maintainer: Kowainik +Command to update the local state from the remote state. +-} + module Life.Main.Pull - ( lifePull - ) where + ( lifePull + ) where import Path (Dir, File, Path, Rel) -import Life.Configuration (LifeConfiguration (..)) -import Life.Github (Owner, cloneRepo, pullUpdateFromRepo, updateFromRepo) +import Life.Configuration (LifeConfiguration (..), defaultLifeConfig) +import Life.Core (Owner) +import Life.Github (cloneRepo, pullUpdateFromRepo, updateFromRepo) import Life.Main.Init (lifeInitQuestion) import Life.Message (abortCmd, choose, warningMessage) -import Life.Shell (LifeExistence (..), whatIsLife) +import Life.Path (LifeExistence (..), whatIsLife) -lifePull :: Owner -> Set (Path Rel File) -> Set (Path Rel Dir) -> IO () + +lifePull :: Maybe 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 @@ -31,7 +39,10 @@ _ -> error "Impossible choice" life :: LifeConfiguration - life = LifeConfiguration withoutFiles withoutDirs + life = defaultLifeConfig + { lifeConfigurationDirectories = withoutDirs + , lifeConfigurationFiles = withoutFiles + } clone, update, pullUpdate :: IO () clone = cloneRepo owner diff --git a/src/Life/Main/Push.hs b/src/Life/Main/Push.hs --- a/src/Life/Main/Push.hs +++ b/src/Life/Main/Push.hs @@ -1,40 +1,47 @@ -{-# LANGUAGE TupleSections #-} +{- | +Copyright: (c) 2017-2020 Kowainik +SPDX-License-Identifier: MPL-2.0 +Maintainer: Kowainik --- | Functions to update remote repository +Functions to update the remote repository. +-} module Life.Main.Push - ( lifePush - ) where + ( lifePush + ) where -import Lens.Micro.Platform ((^.)) import Path (Abs, Path, Rel, toFilePath, ()) import Path.IO (doesDirExist, doesFileExist, removeDirRecur, removeFile) +import Relude.Extra.Lens ((^.)) +import Validation (Validation (..)) -import Life.Configuration (LifeConfiguration (..), directories, files, lifeConfigMinus, +import Life.Configuration (LifeConfiguration (..), directoriesL, filesL, lifeConfigMinus, parseHomeLife, parseRepoLife) +import Life.Core (CommitMsg (..), master) 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 Life.Path (LifeExistence (..), relativeToHome, repoName, whatIsLife) 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 + Both _ _ -> withSynced master 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 + 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 @@ -44,17 +51,18 @@ -- copy from local files to repo including .life -- commmit & push - updateDotfilesRepo "Push updates" globalConf + updateDotfilesRepo (CommitMsg "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) + eFiles <- traverse (withExist doesFileExist) $ Set.toList (lf ^. filesL) + eDirs <- traverse (withExist doesDirExist) $ Set.toList (lf ^. directoriesL) pure $ LifeConfiguration <$> checkPaths eFiles <*> checkPaths eDirs + <*> Success (Last $ Just master) where withExist :: (Path Abs f -> IO Bool) -> Path Rel f -> IO (Path Rel f, Bool) withExist doesExist path = (path,) <$> (relativeToHome path >>= doesExist) @@ -68,7 +76,7 @@ -- | removes all redundant files from repo folder. removeAll :: LifeConfiguration -> IO () removeAll conf = do - for_ (conf ^. files) $ \f -> + for_ (conf ^. filesL) $ \f -> relativeToHome (repoName f) >>= removeFile - for_ (conf ^. directories) $ \d -> + for_ (conf ^. directoriesL) $ \d -> relativeToHome (repoName d) >>= removeDirRecur diff --git a/src/Life/Main/Remove.hs b/src/Life/Main/Remove.hs --- a/src/Life/Main/Remove.hs +++ b/src/Life/Main/Remove.hs @@ -1,23 +1,30 @@ {-# LANGUAGE Rank2Types #-} --- | Functions to remove from your life. +{- | +Copyright: (c) 2017-2020 Kowainik +SPDX-License-Identifier: MPL-2.0 +Maintainer: Kowainik +Functions to remove from your @life@ repository. +-} + module Life.Main.Remove - ( lifeRemove - ) where + ( lifeRemove + ) where -import Lens.Micro.Platform (Lens', (%~)) import Path (Abs, Path, Rel) import Path.IO (getHomeDir, makeRelative, removeDirRecur, removeFile, resolveDir, resolveFile) +import Relude.Extra.Lens (Lens', (%~)) -import Life.Configuration (LifeConfiguration, LifePath (..), directories, files, parseHomeLife, - writeGlobalLife) +import Life.Configuration (LifeConfiguration, directoriesL, filesL, parseHomeLife, writeGlobalLife) +import Life.Core (LifePath (..), master) import Life.Github (removeFromRepo, withSynced) import Life.Message (abortCmd, warningMessage) -import Life.Shell (LifeExistence (..), whatIsLife) +import Life.Path (LifeExistence (..), whatIsLife) import qualified Data.Set as Set + -- | Remove path from existing life-configuration file. lifeRemove :: LifePath -> IO () lifeRemove lPath = whatIsLife >>= \case @@ -26,26 +33,27 @@ OnlyLife _ -> abortCmd "remove" "dotfiles/ directory doesn't exist" OnlyRepo _ -> abortCmd "remove" ".life file doesn't exist" -- actual life remove process - Both _ _ -> withSynced $ do + Both _ _ -> withSynced master $ do homeDirPath <- getHomeDir case lPath of (File path) -> do filePath <- resolveFile homeDirPath path >>= makeRelative homeDirPath - resolveConfiguration files removeFile filePath + resolveConfiguration filesL removeFile filePath (Dir path) -> do dirPath <- resolveDir homeDirPath path >>= makeRelative homeDirPath - resolveConfiguration directories removeDirRecur dirPath + resolveConfiguration directoriesL removeDirRecur dirPath -resolveConfiguration :: Lens' LifeConfiguration (Set (Path Rel t)) - -> (Path Abs t -> IO ()) -- ^ function to remove object - -> Path Rel t - -> IO () +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 + then warningMessage "File or directory is not tracked" >> exitFailure else do writeGlobalLife newConfiguration removeFromRepo removeFun path diff --git a/src/Life/Message.hs b/src/Life/Message.hs --- a/src/Life/Message.hs +++ b/src/Life/Message.hs @@ -1,30 +1,38 @@ {-# LANGUAGE MultiWayIf #-} {-# LANGUAGE ViewPatterns #-} +{- | +Copyright: (c) 2017-2020 Kowainik +SPDX-License-Identifier: MPL-2.0 +Maintainer: Kowainik + +Contains functions for colorful printing, prompt and other terminal related +messages. +-} + module Life.Message - ( beautyPrint - , boldText - , prompt - , promptNonEmpty - , errorMessage - , warningMessage - , successMessage - , infoMessage - , skipMessage - , abortCmd + ( prompt + , promptNonEmpty + , errorMessage + , warningMessage + , successMessage + , infoMessage + , skipMessage + , abortCmd - -- * Questions - , choose - , chooseYesNo - ) where + -- * Questions + , choose + , chooseYesNo + ) where -import System.Console.ANSI (Color (..), ColorIntensity (Vivid), ConsoleIntensity (BoldIntensity), - ConsoleLayer (Foreground), SGR (..), setSGR) +import Colourista (blue, bold, formatWith) import System.IO (hFlush) +import qualified Colourista import qualified Data.Text as T import qualified Relude.Unsafe as Unsafe + ---------------------------------------------------------------------------- -- Ansi-terminal ---------------------------------------------------------------------------- @@ -35,31 +43,11 @@ 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 - +{- | Read 'Text' from standard input after arrow prompt. +-} prompt :: IO Text prompt = do - setColor Blue - putStrFlush " ⟳ " - reset + putStrFlush $ formatWith [blue] " ⟳ " getLine promptNonEmpty :: IO Text @@ -69,26 +57,20 @@ 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 +boldDefault :: Text -> Text +boldDefault message = formatWith [bold] $ " [" <> message <> "]" errorMessage, warningMessage, successMessage, infoMessage, skipMessage :: Text -> IO () -errorMessage = colorMessage Red -warningMessage = colorMessage Yellow -successMessage = colorMessage Green -infoMessage = colorMessage Blue -skipMessage = colorMessage Cyan +errorMessage = Colourista.errorMessage . indent +warningMessage = Colourista.warningMessage . indent +successMessage = Colourista.successMessage . indent +infoMessage = Colourista.infoMessage . indent +skipMessage = Colourista.skipMessage . indent +-- | Add 2 spaces in front. +indent :: Text -> Text +indent = (" " <>) + -- | Print message and abort current process. abortCmd :: Text -> Text -> IO () abortCmd cmd msg = do @@ -101,12 +83,11 @@ ---------------------------------------------------------------------------- printQuestion :: Text -> [Text] -> IO () +printQuestion question [] = putTextLn question printQuestion question (def:rest) = do let restSlash = T.intercalate "/" rest - putStrFlush question - boldDefault def + putStrFlush $ question <> boldDefault def putTextLn $ "/" <> restSlash -printQuestion question [] = putTextLn question choose :: Text -> [Text] -> IO Text choose question choices = do diff --git a/src/Life/Path.hs b/src/Life/Path.hs new file mode 100644 --- /dev/null +++ b/src/Life/Path.hs @@ -0,0 +1,74 @@ +{-# LANGUAGE TemplateHaskell #-} + +{- | +Copyright: (c) 2017-2020 Kowainik +SPDX-License-Identifier: MPL-2.0 +Maintainer: Kowainik + +This module contains utility functions to work with shell. +-} + +module Life.Path + ( -- * 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) + + +---------------------------------------------------------------------------- +-- 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 +---------------------------------------------------------------------------- + +-- | 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/Shell.hs b/src/Life/Shell.hs deleted file mode 100644 --- a/src/Life/Shell.hs +++ /dev/null @@ -1,87 +0,0 @@ -{-# 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 deleted file mode 100644 --- a/src/Life/Validation.hs +++ /dev/null @@ -1,27 +0,0 @@ -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 deleted file mode 100644 --- a/src/Prelude.hs +++ /dev/null @@ -1,7 +0,0 @@ --- | Uses @relude@ as default prelude. - -module Prelude - ( module Relude - ) where - -import Relude diff --git a/test/Spec.hs b/test/Spec.hs --- a/test/Spec.hs +++ b/test/Spec.hs @@ -1,1 +1,9 @@ -{-# OPTIONS_GHC -F -pgmF tasty-discover #-} +module Main (main) where + +import Test.Hspec (hspec) + +import Test.Configuration (configurationSpec) + +main :: IO () +main = hspec + configurationSpec diff --git a/test/Test/Configuration.hs b/test/Test/Configuration.hs new file mode 100644 --- /dev/null +++ b/test/Test/Configuration.hs @@ -0,0 +1,94 @@ +{-# LANGUAGE QuasiQuotes #-} + +module Test.Configuration + ( configurationSpec + ) where + +import Data.Foldable (foldr1) +import Hedgehog (Gen, PropertyT, forAll, tripping) +import Path (reldir, relfile) +import Path.Internal (Path (Path)) +import Relude.Extra.Lens ((.~)) +import System.FilePath (pathSeparator, ()) +import Test.Hspec (Spec, describe, it, shouldBe) +import Test.Hspec.Hedgehog (hedgehog) + +import Life.Configuration (LifeConfiguration (..), directoriesL, filesL, parseLifeConfiguration, + renderLifeConfiguration) +import Life.Core (master) + +import qualified Data.Set as Set +import qualified Data.Text as T +import qualified Hedgehog.Gen as Gen +import qualified Hedgehog.Range as Range + + +configurationSpec :: Spec +configurationSpec = describe "Configuration tests" $ do + configurationRenderSpec + configurationPropertySpec + +configurationRenderSpec :: Spec +configurationRenderSpec = describe "Pretty rendering" $ do + it "empty configuration" $ + render mempty `shouldBe` emptyTxt + it "non-empty configuration" $ + render nonEmptyCfg `shouldBe` nonEmptyTxt + where + render :: LifeConfiguration -> Text + render = renderLifeConfiguration True + + emptyTxt :: Text + emptyTxt = T.intercalate "\n" + [ "directories = []" + , "files = []" + ] + + nonEmptyCfg :: LifeConfiguration + nonEmptyCfg = mempty + & directoriesL .~ one [reldir|foo/|] + & filesL .~ Set.fromList + [ [relfile|bar.txt|] + , [relfile|quux|] + ] + + nonEmptyTxt :: Text + nonEmptyTxt = T.intercalate "\n" + [ "directories = [\"foo/\"]" + , "files = " + , " [ \"bar.txt\"" + , " , \"quux\"" + , " ]" + ] + + +configurationPropertySpec :: Spec +configurationPropertySpec = describe "Property Tests" $ + it "parseLifeConfiguration . renderLifeConfiguration cfg ≡ Just cfg" + parseRenderSpec + +parseRenderSpec :: PropertyT IO () +parseRenderSpec = hedgehog $ do + cfg <- forAll genLifeConfiguration + tripping cfg (renderLifeConfiguration True) (parseLifeConfiguration @Maybe) + +genLifeConfiguration :: Gen LifeConfiguration +genLifeConfiguration = do + lifeConfigurationFiles <- genPathSet genFilePath + lifeConfigurationDirectories <- genPathSet genDirPath + let lifeConfigurationBranch = Last $ Just master + 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 diff --git a/test/Test/Roundtrip.hs b/test/Test/Roundtrip.hs deleted file mode 100644 --- a/test/Test/Roundtrip.hs +++ /dev/null @@ -1,37 +0,0 @@ -module Test.Roundtrip where - -import Data.Foldable (foldr1) -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