diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c) 2024, Illia Shkroba + +All rights reserved. + +Redistribution and use in source and binary forms, with or without modification, +are permitted provided that the following conditions are met: + +1. Redistributions of source code must retain the above copyright notice, this + list of conditions and the following disclaimer. + +2. Redistributions in binary form must reproduce the above copyright notice, + this list of conditions and the following disclaimer in the documentation + and/or other materials provided with the distribution. + +3. Neither the name of Illia Shkroba nor the names of other + contributors may be used to endorse or promote products derived from this + software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +HOLDER OR OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, +INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, +BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS +OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND +ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR +TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE +USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH +DAMAGE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,163 @@ +# PFile + +**PFile** is a CLI program that manages different sets of filesystem's objects +(directories, directory links, files, file links) called "profiles". + +With **PFile** you could define multiple profiles (especially for the same sets +of files) and switch between them. + +## Usage + +Let's say you want to manage multiple versions of your Shell's history and +Browser's history/cookies. One version is for your private use and the second is +for your work. + +With **PFile** you could use the `new` command to create a new profile: + +```sh +pfile new private -- ~/.cache/zsh/ ~/.config/BraveSoftware/ +``` + +This command would __move__ the *\~/.cache/zsh/* and *\~/.config/BraveSoftware/* +into the new profile called "private". After running the `new` command, the +*\~/.cache/zsh/* and *\~/.config/BraveSoftware/* are gone from their original +locations. But no worries, they are still available inside of the +*\~/.local/share/pfile/profiles/private/absolute/* directory. + +After creating the "private" profile, you could use the `switch` command to +switch to it: + +```sh +pfile switch private +``` + +This would create the following links in place of the original directories: + +```sh +readlink -e -- ~/.cache/zsh/ ~/.config/BraveSoftware/ +# /home/is/.local/share/pfile/profiles/private/absolute/home/is/.cache/zsh +# /home/is/.local/share/pfile/profiles/private/absolute/home/is/.config/BraveSoftware +``` + +The *\~/.cache/zsh/* and *\~/.config/BraveSoftware/* have become links pointing +at "private" profile's entries: + +```sh +ls "$(readlink -e -- ~/.cache/zsh/)" +# history +ls "$(readlink -e -- ~/.config/BraveSoftware/)" +# Brave-Browser +``` + +Now let's try to create an another profile called "work" for the same files: + +```sh +pfile new work -- ~/.cache/zsh/ ~/.config/BraveSoftware/ +``` + +This command would __copy__ the contents of *\~/.cache/zsh/* and +*\~/.config/BraveSoftware/* into the new profile called "work". The "private" +profile will remain untouched. The `new` command performed __copy__ this time +instead of __move__, because it has detected that the provided filesystem's +objects are symbolic __links__. + +You could check which profile is currently set with the `which` command: + +```sh +pfile which +# private +``` + +You can see that the `new` command did not perform a switch. If you want to +switch to the "work" profile, you could use the `switch` command: + +```sh +pfile switch work +pfile which +# work +``` + +If you don't want to copy the contents of *\~/.cache/zsh/* and +*\~/.config/BraveSoftware/* into a new profile, you could pass the `-e` (or +`--empty`) option to the `new` command. This option would cause `new` command to +create empty directories for *\~/.cache/zsh/* and *\~/.config/BraveSoftware/* +inside of the new profile. Note that the `--empty` option only affects links. +Other directories and files you provide would be moved to the new profile. + +```sh +pfile new -e work2 -- ~/.cache/zsh/ ~/.config/BraveSoftware/ +pfile switch work2 +``` + +You could try now to reopen your Shell/Browser. You will notice that there is no +history. + +If you want to bring the directories back to their original locations, you could +use the `unpack` command: + +```sh +pfile unpack +pfile which +# No current profile set. Use `pfile new` to create a profile and `pfile switch` to switch to it. +``` + +After using the `unpack` command, the directories are brought back to their +original locations, but their copies are still kept inside of the profile: + +```sh +readlink -e -- ~/.cache/zsh/ ~/.config/BraveSoftware/ +# /home/is/.cache/zsh +# /home/is/.config/BraveSoftware + +readlink -e -- /home/is/.local/share/pfile/profiles/work2/absolute/home/is/.cache/zsh +# /home/is/.local/share/pfile/profiles/work2/absolute/home/is/.cache/zsh +readlink -e -- /home/is/.local/share/pfile/profiles/work2/absolute/home/is/.config/BraveSoftware +# /home/is/.local/share/pfile/profiles/work2/absolute/home/is/.config/BraveSoftware +``` + +If you would try to switch back to the "private" profile, you would get this +error: + +```sh +pfile switch private +# Unable to link origin "/home/is/.cache/zsh" to entry "/home/is/.local/share/pfile/profiles/private/absolute/home/is/.cache/zsh" because the origin is occupied. +``` + +This happens because *\~/.cache/zsh/* has become a directory instead of +a directory link pointing at the profile's entry. Thus, **PFile** refuses to +overwrite it. You could remove (or move) the directory manually or if you want +to forcibly remove it with **PFile**, you could use `-f` (or +`--force-remove-occupied`) option of the `switch` command: + +```sh +pfile switch -f private +``` + +This would forcibly remove both: + +* Filesystem's objects where the current profile's links are expected to be + placed (only if the current profile is set). +* Filesystem's objects where the next profile's (the one you provide to the + `switch` command) links are expected to be placed. + +## Motivation + +I work as an academic teacher and often use my terminal during lectures. When +using keybindings like *CTRL-R* in my Shell to search for a recent command from +my history, sometimes my private commands could pop-up like `pass insert +@` or `KEY= ansible...` or `mpv +'https://www.youtube.com/watch?v=dQw4w9WgXcQ'`. The same goes for my Browser's +history. + +At first, I wanted to solve this issue by creating a separate user on my system +specifically for lecture purposes. But then I've realized that: + +1. All of my personal configs that I wish to use during lectures like Neovim, + Xmonad and Qutebrowser configs should be copied to the new user's home + directory. +2. When I change one of the configs on my main user, I should `rsync` the new + configs to the other user. +3. Permissions of resources (e.g.: directories and files) that I use on both + users should be handled. + +The **PFile** program solves the issue for me. 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,9 @@ +module Main + ( main + ) where + +import qualified PFile.Main as PFile +import Protolude + +main :: IO () +main = PFile.main diff --git a/pfile.cabal b/pfile.cabal new file mode 100644 --- /dev/null +++ b/pfile.cabal @@ -0,0 +1,148 @@ +cabal-version: 2.2 +name: pfile +version: 0.1.0.0 +license: BSD-3-Clause +license-file: LICENSE +copyright: 2024 Illia Shkroba +maintainer: is@pjwstk.edu.pl +author: Illia Shkroba +homepage: https://github.com/illia-shkroba/pfile#readme +bug-reports: https://github.com/illia-shkroba/pfile/issues +synopsis: CLI program for profiles management. +description: + Please see the README on GitHub at + +category: Filesystem +build-type: Simple +extra-source-files: README.md + +source-repository head + type: git + location: https://github.com/illia-shkroba/pfile + +library + exposed-modules: + PFile.Aeson + PFile.CLI + PFile.CLI.List + PFile.CLI.New + PFile.CLI.Switch + PFile.CLI.Unpack + PFile.CLI.Which + PFile.Completion + PFile.Env + PFile.Error + PFile.Log + PFile.Main + PFile.Main.List + PFile.Main.New + PFile.Main.Switch + PFile.Main.Unpack + PFile.Main.Which + PFile.Mount + PFile.Path + PFile.Profile + PFile.Profile.Internal.Current + PFile.Profile.Internal.Lifetime + PFile.Profile.Internal.List + PFile.Profile.Internal.Profile + PFile.Profile.Internal.Registry + PFile.Profile.Internal.Serialization + PFile.Profile.Internal.Switch + PFile.Profile.LinkHandling + PFile.TrashCan + + hs-source-dirs: src + other-modules: Paths_pfile + autogen-modules: Paths_pfile + default-language: Haskell2010 + default-extensions: NoImplicitPrelude + ghc-options: + -Wall -Wcompat -Widentities -Wincomplete-record-updates + -Wincomplete-uni-patterns -Wmissing-export-lists + -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints + + build-depends: + HUnit >=1.6.2 && <1.7, + aeson >=2.1.2 && <2.2, + aeson-pretty >=0.8.9 && <0.9, + base >=4.7 && <5, + directory >=1.3.7 && <1.4, + filepath >=1.4.2 && <1.5, + mtl >=2.2.2 && <2.3, + optparse-applicative >=0.17.1 && <0.18, + protolude >=0.3.3 && <0.4, + temporary >=1.3 && <1.4, + transformers >=0.5.6 && <0.6, + unordered-containers >=0.2.19 && <0.3 + +executable pfile + main-is: Main.hs + hs-source-dirs: app + other-modules: Paths_pfile + autogen-modules: Paths_pfile + default-language: Haskell2010 + default-extensions: NoImplicitPrelude + ghc-options: + -Wall -Wcompat -Widentities -Wincomplete-record-updates + -Wincomplete-uni-patterns -Wmissing-export-lists + -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints + -threaded -rtsopts -with-rtsopts=-N + + build-depends: + HUnit >=1.6.2 && <1.7, + aeson >=2.1.2 && <2.2, + aeson-pretty >=0.8.9 && <0.9, + base >=4.7 && <5, + directory >=1.3.7 && <1.4, + filepath >=1.4.2 && <1.5, + mtl >=2.2.2 && <2.3, + optparse-applicative >=0.17.1 && <0.18, + pfile, + protolude >=0.3.3 && <0.4, + temporary >=1.3 && <1.4, + transformers >=0.5.6 && <0.6, + unordered-containers >=0.2.19 && <0.3 + +test-suite pfile-test + type: exitcode-stdio-1.0 + main-is: Spec.hs + hs-source-dirs: test + other-modules: + PFile.Mount.Tests + PFile.Mount.Tests.Env + PFile.Path.Tests + PFile.Path.Tests.Env + PFile.Profile.LinkHandling.Tests.Env + PFile.Tests.Env + PFile.TrashCan.Tests + PFile.TrashCan.Tests.Env + Paths_pfile + + autogen-modules: Paths_pfile + default-language: Haskell2010 + default-extensions: NoImplicitPrelude + ghc-options: + -Wall -Wcompat -Widentities -Wincomplete-record-updates + -Wincomplete-uni-patterns -Wmissing-export-lists + -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints + -threaded -rtsopts -with-rtsopts=-N + + build-depends: + HUnit >=1.6.2 && <1.7, + aeson >=2.1.2 && <2.2, + aeson-pretty >=0.8.9 && <0.9, + base >=4.7 && <5, + directory >=1.3.7 && <1.4, + filepath >=1.4.2 && <1.5, + hspec >=2.10.10 && <2.11, + mtl >=2.2.2 && <2.3, + optparse-applicative >=0.17.1 && <0.18, + pfile, + protolude >=0.3.3 && <0.4, + tasty >=1.4.3 && <1.5, + tasty-hspec >=1.2.0.3 && <1.3, + tasty-quickcheck >=0.10.2 && <0.11, + temporary >=1.3 && <1.4, + transformers >=0.5.6 && <0.6, + unordered-containers >=0.2.19 && <0.3 diff --git a/src/PFile/Aeson.hs b/src/PFile/Aeson.hs new file mode 100644 --- /dev/null +++ b/src/PFile/Aeson.hs @@ -0,0 +1,29 @@ +{- | +Module: PFile.Aeson +Copyright: (c) 2024 Illia Shkroba +License: BSD3 +Maintainer: Illia Shkroba +Stability: unstable +Portability: non-portable (Non-Unix systems are not supported) + +Helper functions for 'Data.Aeson'. +-} + +{-# LANGUAGE OverloadedStrings #-} + +module PFile.Aeson + ( encodePretty + ) where + +import Data.Aeson (ToJSON) +import qualified Data.Aeson.Encode.Pretty as Aeson +import Protolude + +-- | Wrapper over 'Data.Aeson.Encode.Pretty.encodePretty' that returns 'Text' +-- instead of 'ByteString'. +-- +-- @since 0.1.0.0 +encodePretty :: ToJSON a => a -> Text +encodePretty + = either (\error -> " show error <> ">") identity + . decodeUtf8' . toS . Aeson.encodePretty diff --git a/src/PFile/CLI.hs b/src/PFile/CLI.hs new file mode 100644 --- /dev/null +++ b/src/PFile/CLI.hs @@ -0,0 +1,80 @@ +{- | +Module: PFile.CLI +Copyright: (c) 2024 Illia Shkroba +License: BSD3 +Maintainer: Illia Shkroba +Stability: unstable +Portability: non-portable (Non-Unix systems are not supported) + +PFile's CLI definition. +-} + +{-# LANGUAGE ApplicativeDo #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} + +module PFile.CLI + ( parserInfo + , parser + , Options (..) + , Command (..) + ) where + +import Options.Applicative + ( Parser + , ParserInfo + , fullDesc + , header + , helper + , info + , long + , progDesc + , short + , subparser + , switch + ) +import qualified Options.Applicative +import qualified PFile.CLI.List as List +import qualified PFile.CLI.New as New +import qualified PFile.CLI.Switch as Switch +import qualified PFile.CLI.Unpack as Unpack +import qualified PFile.CLI.Which as Which +import Protolude + +parserInfo :: ParserInfo Options +parserInfo = info (parser <**> helper) + $ fullDesc + <> header "pfile - manage profiles defined for a set of filesystem's objects" + <> progDesc description + where + description + = "Manage profiles defined for a set of filesystem's objects" + <> " (directories, directory links, files, file links). Profiles could be" + <> " defined with `pfile new`. Switch between multiple profiles with" + <> " `pfile switch`. In order to revert the `pfile new`/`pfile switch`," + <> " use `pfile unpack`." + +parser :: Parser Options +parser = do + verbose <- switch (short 'v' <> long "verbose") + command <- subparser . fold $ + [ Options.Applicative.command "new" (New <$> New.parserInfo) + , Options.Applicative.command "switch" (Switch <$> Switch.parserInfo) + , Options.Applicative.command "unpack" (Unpack <$> Unpack.parserInfo) + , Options.Applicative.command "ls" (List <$> List.parserInfo) + , Options.Applicative.command "which" (Which <$> Which.parserInfo) + ] + pure Options {..} + +data Options + = Options + { verbose :: !Bool + , command :: !Command + } + +data Command + = New New.Options + | Switch Switch.Options + | Unpack Unpack.Options + | List List.Options + | Which Which.Options diff --git a/src/PFile/CLI/List.hs b/src/PFile/CLI/List.hs new file mode 100644 --- /dev/null +++ b/src/PFile/CLI/List.hs @@ -0,0 +1,56 @@ +{- | +Module: PFile.CLI.List +Copyright: (c) 2024 Illia Shkroba +License: BSD3 +Maintainer: Illia Shkroba +Stability: unstable +Portability: non-portable (Non-Unix systems are not supported) + +Options for `pfile ls`. +-} + +{-# LANGUAGE ApplicativeDo #-} +{-# LANGUAGE RecordWildCards #-} + +module PFile.CLI.List + ( parserInfo + , parser + , Options (..) + ) where + +import Options.Applicative + ( Parser + , ParserInfo + , fullDesc + , header + , help + , helper + , info + , long + , progDesc + , short + , switch + ) +import Protolude + +parserInfo :: ParserInfo Options +parserInfo = info (parser <**> helper) + $ fullDesc + <> header "pfile ls - list available profiles" + <> progDesc description + where + description + = "List available profiles. Use `--all` option to list dangling profiles" + <> " -- profiles that were \"partially\" initialized (an error was" + <> " encountered during `pfile new` which couldn't be rollbacked)." + +parser :: Parser Options +parser = do + shouldFilterDangling <- fmap not . switch + $ short 'a' + <> long "all" + <> help "Include dangling profiles" + pure Options {..} + +newtype Options + = Options { shouldFilterDangling :: Bool } diff --git a/src/PFile/CLI/New.hs b/src/PFile/CLI/New.hs new file mode 100644 --- /dev/null +++ b/src/PFile/CLI/New.hs @@ -0,0 +1,72 @@ +{- | +Module: PFile.CLI.New +Copyright: (c) 2024 Illia Shkroba +License: BSD3 +Maintainer: Illia Shkroba +Stability: unstable +Portability: non-portable (Non-Unix systems are not supported) + +Options for `pfile new`. +-} + +{-# LANGUAGE ApplicativeDo #-} +{-# LANGUAGE RecordWildCards #-} + +module PFile.CLI.New + ( parserInfo + , parser + , Options (..) + ) where + +import Options.Applicative + ( Parser + , ParserInfo + , action + , argument + , flag + , fullDesc + , header + , help + , helper + , info + , long + , metavar + , progDesc + , short + , str + ) +import qualified PFile.Profile.LinkHandling as LinkHandling +import Protolude + +parserInfo :: ParserInfo Options +parserInfo = info (parser <**> helper) + $ fullDesc + <> header "pfile new - create a new PROFILE for a set of OBJECTS" + <> progDesc description + where + description + = "Create a PROFILE with a set of OBJECTS moved into it. After PROFILE's" + <> " creation, entries origins (\"OBJECTS...\") are removed. Current" + <> " profile (set with `pfile switch`) is always reverted afterwards. So" + <> " if one of the OBJECTS is a link pointing at current profile's entry," + <> " the link will be recovered. By default when an entry is a link, the" + <> " target of the link is copied into the PROFILE. When `--empty` flag" + <> " is passed and an entry is a link, an empty entry is created in the" + <> " PROFILE." + +parser :: Parser Options +parser = do + linkHandlingStrategy <- flag LinkHandling.CopyFromOrigin LinkHandling.CreateEmpty + $ short 'e' + <> long "empty" + <> help "Make empty entries in PROFILE instead of copying links targets" + profileName <- argument str (metavar "PROFILE") + paths <- many $ argument str (metavar "OBJECTS..." <> action "file") + pure Options {..} + +data Options + = Options + { linkHandlingStrategy :: !LinkHandling.Strategy + , profileName :: !Text + , paths :: ![FilePath] + } diff --git a/src/PFile/CLI/Switch.hs b/src/PFile/CLI/Switch.hs new file mode 100644 --- /dev/null +++ b/src/PFile/CLI/Switch.hs @@ -0,0 +1,70 @@ +{- | +Module: PFile.CLI.Switch +Copyright: (c) 2024 Illia Shkroba +License: BSD3 +Maintainer: Illia Shkroba +Stability: unstable +Portability: non-portable (Non-Unix systems are not supported) + +Options for `pfile switch`. +-} + +{-# LANGUAGE ApplicativeDo #-} +{-# LANGUAGE RecordWildCards #-} + +module PFile.CLI.Switch + ( parserInfo + , parser + , Options (..) + ) where + +import Options.Applicative + ( Parser + , ParserInfo + , argument + , completer + , fullDesc + , header + , help + , helper + , info + , listIOCompleter + , long + , metavar + , progDesc + , short + , str + , switch + ) +import qualified PFile.Completion as Completion +import Protolude + +parserInfo :: ParserInfo Options +parserInfo = info (parser <**> helper) + $ fullDesc + <> header "pfile switch - switch to PROFILE" + <> progDesc description + where + description + = "Switch to PROFILE. The current profile is unlinked first (links" + <> " pointing at current profile's entries are removed) and then the" + <> " PROFILE is linked (links pointing at PROFILE profile's entries are" + <> " made). If the current profile was not set yet, the first step is" + <> " skipped. `pfile switch` could be reverted with `pfile unpack`." + +parser :: Parser Options +parser = do + forceRemoveOccupied <- switch + $ short 'f' + <> long "force-remove-occupied" + <> help "Force remove of paths occupying current/PROFILE profile's link paths" + nextProfileName <- argument str + $ metavar "PROFILE" + <> completer (listIOCompleter Completion.profileNames) + pure Options {..} + +data Options + = Options + { forceRemoveOccupied :: !Bool + , nextProfileName :: !Text + } diff --git a/src/PFile/CLI/Unpack.hs b/src/PFile/CLI/Unpack.hs new file mode 100644 --- /dev/null +++ b/src/PFile/CLI/Unpack.hs @@ -0,0 +1,59 @@ +{- | +Module: PFile.CLI.Unpack +Copyright: (c) 2024 Illia Shkroba +License: BSD3 +Maintainer: Illia Shkroba +Stability: unstable +Portability: non-portable (Non-Unix systems are not supported) + +Options for `pfile unpack`. +-} + +{-# LANGUAGE ApplicativeDo #-} +{-# LANGUAGE RecordWildCards #-} + +module PFile.CLI.Unpack + ( parserInfo + , parser + , Options (..) + ) where + +import Options.Applicative + ( Parser + , ParserInfo + , fullDesc + , header + , help + , helper + , info + , long + , progDesc + , short + , switch + ) +import Protolude + +parserInfo :: ParserInfo Options +parserInfo = info (parser <**> helper) + $ fullDesc + <> header "pfile unpack - revert `pfile new` and `pfile switch`" + <> progDesc description + where + description + = "Substitute links pointing at entries in the current profile with" + <> " entries themselves. This substitution \"reverts\" `pfile switch`" + <> " (removes links & unsets current profile) and `pfile new` (unpacks" + <> " entries from profile). `pfile unpack` will not change the profile --" + <> " entries that were added to the profile will remain unchanged. `pfile" + <> " unpack` could be reverted with `pfile switch -f PROFILE`." + +parser :: Parser Options +parser = do + forceRemoveOccupied <- switch + $ short 'f' + <> long "force-remove-occupied" + <> help "Force remove of paths occupying current profile's link paths" + pure Options {..} + +newtype Options + = Options { forceRemoveOccupied :: Bool } diff --git a/src/PFile/CLI/Which.hs b/src/PFile/CLI/Which.hs new file mode 100644 --- /dev/null +++ b/src/PFile/CLI/Which.hs @@ -0,0 +1,42 @@ +{- | +Module: PFile.CLI.Which +Copyright: (c) 2024 Illia Shkroba +License: BSD3 +Maintainer: Illia Shkroba +Stability: unstable +Portability: non-portable (Non-Unix systems are not supported) + +Options for `pfile which`. +-} + +module PFile.CLI.Which + ( parserInfo + , parser + , Options (..) + ) where + +import Options.Applicative + ( Parser + , ParserInfo + , fullDesc + , header + , helper + , info + , progDesc + ) +import Protolude + +parserInfo :: ParserInfo Options +parserInfo = info (parser <**> helper) + $ fullDesc + <> header "pfile which - show current profile name" + <> progDesc description + where + description + = "Show current profile name." + +parser :: Parser Options +parser = pure Options + +data Options + = Options diff --git a/src/PFile/Completion.hs b/src/PFile/Completion.hs new file mode 100644 --- /dev/null +++ b/src/PFile/Completion.hs @@ -0,0 +1,33 @@ +{- | +Module: PFile.Completion +Copyright: (c) 2024 Illia Shkroba +License: BSD3 +Maintainer: Illia Shkroba +Stability: unstable +Portability: non-portable (Non-Unix systems are not supported) + +Completions for PFile. +-} + +module PFile.Completion + ( profileNames + , profiles + ) where + +import qualified PFile.Env as Env +import PFile.Profile (Profile) +import qualified PFile.Profile as Profile +import Protolude + +profileNames :: IO [[Char]] +profileNames = profiles <&> fmap (toS . Profile.unName . Profile.name) + +profiles :: IO [Profile] +profiles = do + env <- Env.resolve Env.Options {Env.verbose = False} + Profile.list listOptions + & flip runReaderT env + & runExceptT >>= either (const $ pure []) pure + where + listOptions :: Profile.ListOptions + listOptions = Profile.ListOptions {Profile.shouldFilterDangling = True} diff --git a/src/PFile/Env.hs b/src/PFile/Env.hs new file mode 100644 --- /dev/null +++ b/src/PFile/Env.hs @@ -0,0 +1,97 @@ +{- | +Module: PFile.Env +Copyright: (c) 2024 Illia Shkroba +License: BSD3 +Maintainer: Illia Shkroba +Stability: unstable +Portability: non-portable (Non-Unix systems are not supported) + +Types and functions for managing PFile's environment. +-} + +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} + +module PFile.Env + ( resolve + , description + , Options (..) + , Env (..) + ) where + +import Control.Monad.Trans.Maybe (MaybeT (..)) +import PFile.Error (onIOError) +import PFile.Path (()) +import qualified PFile.Path as Path +import Protolude +import System.Directory + ( XdgDirectory (..) + , doesDirectoryExist + , getXdgDirectory + , makeAbsolute + ) +import System.Environment (lookupEnv) + +-- | Deduce PFile's 'dataHomeDirPath' in the following order: +-- +-- * Lookup in "$PFILE_DATA_HOME" environment variable if exists. +-- * Use ".pfile" directory from the current working directory if exists. +-- * Use "$XDG_DATA_HOME/pfile" directory. +-- +-- Based on the 'dataHomeDirPath' other fields of 'Env' are resolved. +-- +-- @since 0.1.0.0 +resolve :: MonadIO m => Options -> m Env +resolve options@Options {verbose} = liftIO do + resolved <- + runMaybeT . asum . map MaybeT $ + [ lookupEnv "PFILE_DATA_HOME" + , doesDirectoryExist ".pfile" `onIOError` pure False + <&> bool Nothing (Just ".pfile") + ] + dataHomeDirPath <- + maybe (getXdgDirectory XdgData "pfile") makeAbsolute resolved + <&> Path.Absolute + pure + Env + { dataHomeDirPath + , profilesHomeDirPath = dataHomeDirPath "profiles" + , currentLinkPath = dataHomeDirPath "current" + , PFile.Env.print = bool (const $ pure ()) putErrLn verbose + , options + } + +-- | Describe an 'Env'. +-- +-- @since 0.1.0.0 +description :: Env -> Text +description Env {dataHomeDirPath} + = "PFile uses data home directory: " + <> Path.showAbsolute dataHomeDirPath <> "." + +-- | 'Env' options. +-- +-- @since 0.1.0.0 +newtype Options + = Options + { verbose :: Bool + -- ^ Whether logging should be enabled. + } + +-- | PFile's environment that effects its behavior. +-- +-- @since 0.1.0.0 +data Env + = Env + { dataHomeDirPath :: !Path.Absolute + -- ^ PFile's home directory. + , profilesHomeDirPath :: !Path.Absolute + -- ^ Profiles home directory. + , currentLinkPath :: !Path.Absolute + -- ^ Path to a current profile's link. + , print :: !(Text -> IO ()) + -- ^ Function used by logging functions. + , options :: !Options + -- ^ 'Options' that were used to create the 'Env'. + } diff --git a/src/PFile/Error.hs b/src/PFile/Error.hs new file mode 100644 --- /dev/null +++ b/src/PFile/Error.hs @@ -0,0 +1,79 @@ +{- | +Module: PFile.Error +Copyright: (c) 2024 Illia Shkroba +License: BSD3 +Maintainer: Illia Shkroba +Stability: unstable +Portability: non-portable (Non-Unix systems are not supported) + +Functions for error handling. +-} + +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeApplications #-} + +module PFile.Error + ( modifyError + , tellError + , liftIOWithError + , onIOError + , consumeWriterT + , fallback + , untilError + ) where + +import Control.Monad.Writer (MonadWriter (..), WriterT (..)) +import Protolude + +-- | Modify error in @ExceptT e1 m@ with a @(e1 -> e2)@ function and then +-- 'throwError' the new error in @m@. +-- +-- @since 0.1.0.0 +modifyError :: MonadError e2 m => (e1 -> e2) -> ExceptT e1 m a -> m a +modifyError f = runExceptT >=> either (throwError . f) pure + +-- | Modify error in @ExceptT e1 m@ with a @(e1 -> e2)@ function and then +-- 'tell' the new error as a singleton list in @m@. +-- +-- @since 0.1.0.0 +tellError :: MonadWriter [e2] m => (e1 -> e2) -> ExceptT e1 m a -> m () +tellError f = runExceptT >=> either (tell . (: []) . f) (const $ pure ()) + +-- | Catch 'IOException' of 'IO', modify it with a @(IOException -> e)@ +-- function and then 'throwError' the new error in @m@ (lifted 'IO'). +-- +-- @since 0.1.0.0 +liftIOWithError :: (MonadError e m, MonadIO m) => IO a -> (IOException -> e) -> m a +liftIOWithError action f = liftIO (try action) >>= either (throwError . f) pure + +-- | Catch 'IOException' of the first 'IO', ignore it and call the second 'IO'. +-- The second 'IO' will not be called if the first 'IO' doesn't throw. +-- +-- @since 0.1.0.0 +onIOError :: IO a -> IO a -> IO a +onIOError action f = action `catch` const @_ @IOException f + +-- | Unpack inner @WriterT w m@ of @ExceptT e (WriterT w m)@ and consume its +-- @w@ with @(w -> m ())@ function. +-- +-- @since 0.1.0.0 +consumeWriterT :: + Monad m => (w -> m ()) -> ExceptT e (WriterT w m) a -> ExceptT e m a +consumeWriterT f = mapExceptT $ runWriterT >=> \(y, w) -> y <$ f w + +-- | When @ExceptT e (WriterT w m)@ throws an error, pass its error @e@ and +-- writer's result @w@ to @(e -> w -> m b)@ function. A result of @(e -> w -> +-- m b)@ is ignored. Always return @w@. +-- +-- @since 0.1.0.0 +fallback :: Monad m => (e -> w -> m b) -> ExceptT e (WriterT w m) a -> m w +fallback f action = do + (maybeCause, result) <- untilError action + maybeCause & maybe (pure result) (\cause -> result <$ f cause result) + +-- | Unpack @ExceptT e (WriterT w m)@. A result @a@ of @ExceptT e (WriterT w m) +-- a@ is ignored. +-- +-- @since 0.1.0.0 +untilError :: Functor m => ExceptT e (WriterT w m) a -> m (Maybe e, w) +untilError action = action & runWriterT . runExceptT <&> first leftToMaybe diff --git a/src/PFile/Log.hs b/src/PFile/Log.hs new file mode 100644 --- /dev/null +++ b/src/PFile/Log.hs @@ -0,0 +1,40 @@ +{- | +Module: PFile.Log +Copyright: (c) 2024 Illia Shkroba +License: BSD3 +Maintainer: Illia Shkroba +Stability: unstable +Portability: non-portable (Non-Unix systems are not supported) + +Types and functions for logging. +-} + +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} + +module PFile.Log + ( info + , warning + , error + , panic + ) where + +import PFile.Env (Env (..)) +import Protolude hiding (panic, print) + +info :: (MonadReader Env m, MonadIO m) => Text -> m () +info message = do + Env {print} <- ask + liftIO $ print $ "[INFO] " <> message + +warning :: (MonadReader Env m, MonadIO m) => Text -> m () +warning message = do + Env {print} <- ask + liftIO $ print $ "[WARNING] " <> message + +error :: MonadIO m => Text -> m () +error = putErrLn + +panic :: MonadIO m => Text -> m a +panic message = error message >> liftIO exitFailure diff --git a/src/PFile/Main.hs b/src/PFile/Main.hs new file mode 100644 --- /dev/null +++ b/src/PFile/Main.hs @@ -0,0 +1,41 @@ +{- | +Module: PFile.Main +Copyright: (c) 2024 Illia Shkroba +License: BSD3 +Maintainer: Illia Shkroba +Stability: unstable +Portability: non-portable (Non-Unix systems are not supported) + +PFile's Main. +-} + +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE NamedFieldPuns #-} + +module PFile.Main + ( main + ) where + +import Options.Applicative (execParser) +import PFile.CLI (Command (..), Options (..), parserInfo) +import qualified PFile.Env as Env +import qualified PFile.Log as Log +import qualified PFile.Main.List as List +import qualified PFile.Main.New as New +import qualified PFile.Main.Switch as Switch +import qualified PFile.Main.Unpack as Unpack +import qualified PFile.Main.Which as Which +import Protolude + +main :: IO () +main = do + Options {verbose, command} <- execParser parserInfo + env <- Env.resolve Env.Options {Env.verbose} + flip runReaderT env do + Log.info $ Env.description env + case command of + New options -> New.main options + Switch options -> Switch.main options + Unpack options -> Unpack.main options + List options -> List.main options + Which options -> Which.main options diff --git a/src/PFile/Main/List.hs b/src/PFile/Main/List.hs new file mode 100644 --- /dev/null +++ b/src/PFile/Main/List.hs @@ -0,0 +1,34 @@ +{- | +Module: PFile.Main.List +Copyright: (c) 2024 Illia Shkroba +License: BSD3 +Maintainer: Illia Shkroba +Stability: unstable +Portability: non-portable (Non-Unix systems are not supported) + +Main for `pfile ls`. +-} + +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE NamedFieldPuns #-} + +module PFile.Main.List + ( main + ) where + +import PFile.CLI.List (Options (..)) +import PFile.Env (Env) +import PFile.Error (modifyError) +import qualified PFile.Log as Log +import qualified PFile.Profile as Profile +import Protolude + +main :: (MonadReader Env m, MonadIO m) => Options -> m () +main Options {shouldFilterDangling} = + either Log.panic pure <=< runExceptT $ + Profile.list listOptions + & modifyError Profile.showListError + >>= traverse_ (putStrLn . Profile.unName . Profile.name) + where + listOptions :: Profile.ListOptions + listOptions = Profile.ListOptions {Profile.shouldFilterDangling} diff --git a/src/PFile/Main/New.hs b/src/PFile/Main/New.hs new file mode 100644 --- /dev/null +++ b/src/PFile/Main/New.hs @@ -0,0 +1,75 @@ +{- | +Module: PFile.Main.New +Copyright: (c) 2024 Illia Shkroba +License: BSD3 +Maintainer: Illia Shkroba +Stability: unstable +Portability: non-portable (Non-Unix systems are not supported) + +Main for `pfile new`. +-} + +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module PFile.Main.New + ( main + ) where + +import qualified Data.List as List +import PFile.CLI.New (Options (..)) +import PFile.Env (Env) +import PFile.Error (modifyError) +import qualified PFile.Log as Log +import qualified PFile.Path as Path +import qualified PFile.Profile as Profile +import Protolude + +main :: (MonadReader Env m, MonadIO m) => Options -> m () +main Options {linkHandlingStrategy, profileName, paths} = do + parsedPaths <- traverse Path.parseAbsolute paths >>= ensureAllPathsParsed paths + either Log.panic pure <=< runExceptT $ do + Profile.create createOptions (Profile.Name profileName) parsedPaths + & modifyError Profile.showCreateError + & void + Profile.loadCurrent & runExceptT >>= \case + Left error -> Log.info $ Profile.showLoadCurrentError error + Right currentProfile -> + Profile.link switchOptions currentProfile + & modifyError Profile.showLinkError + where + createOptions :: Profile.CreateOptions + createOptions = Profile.CreateOptions {Profile.linkHandlingStrategy} + + switchOptions :: Profile.SwitchOptions + switchOptions = Profile.SwitchOptions {Profile.forceRemoveOccupied = True} + +ensureAllPathsParsed :: + forall m. (MonadReader Env m, MonadIO m) + => [FilePath] + -> [Maybe Path.Absolute] + -> m [Path.Absolute] +ensureAllPathsParsed inputPaths maybeParsedPaths = do + (unparsed, parsed) <- foldlM go ([], []) $ zip inputPaths maybeParsedPaths + if List.null unparsed + then pure parsed + else Log.panic "Invalid input paths provided." + where + go :: + ([FilePath], [Path.Absolute]) + -> (FilePath, Maybe Path.Absolute) + -> m ([FilePath], [Path.Absolute]) + go (unparsed, parsed) (inputPath, maybeParsedPath) = + case maybeParsedPath of + Nothing -> do + Log.error $ "Unable to parse path: \"" <> toS inputPath <> "\"" + pure (inputPath : unparsed, parsed) + Just parsedPath -> do + Log.info + $ "Parsed input path \"" <> toS inputPath <> "\"" + <> " as " <> Path.showAbsolute parsedPath + pure (unparsed, parsedPath : parsed) diff --git a/src/PFile/Main/Switch.hs b/src/PFile/Main/Switch.hs new file mode 100644 --- /dev/null +++ b/src/PFile/Main/Switch.hs @@ -0,0 +1,51 @@ +{- | +Module: PFile.Main.Switch +Copyright: (c) 2024 Illia Shkroba +License: BSD3 +Maintainer: Illia Shkroba +Stability: unstable +Portability: non-portable (Non-Unix systems are not supported) + +Main for `pfile switch`. +-} + +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} + +module PFile.Main.Switch + ( main + ) where + +import PFile.CLI.Switch (Options (..)) +import PFile.Env (Env) +import PFile.Error (modifyError) +import qualified PFile.Log as Log +import qualified PFile.Profile as Profile +import Protolude + +main :: (MonadReader Env m, MonadIO m) => Options -> m () +main Options {forceRemoveOccupied, nextProfileName} = + either Log.panic pure <=< runExceptT $ do + nextProfile <- + Profile.load (Profile.Name nextProfileName) & runExceptT >>= \case + Left error -> do + Log.info $ Profile.showLoadError error + Log.panic $ "Unable to load profile: \"" <> nextProfileName <> "\"" + Right profile -> pure profile + + Profile.loadCurrent & runExceptT >>= \case + Left error -> do + Log.info $ Profile.showLoadCurrentError error + Profile.link switchOptions nextProfile + & modifyError Profile.showLinkError + Right currentProfile -> + Profile.switch switchOptions currentProfile nextProfile + & modifyError Profile.showSwitchError + + Profile.setCurrent nextProfile + & modifyError Profile.showSetCurrentError + where + switchOptions :: Profile.SwitchOptions + switchOptions = Profile.SwitchOptions {Profile.forceRemoveOccupied} diff --git a/src/PFile/Main/Unpack.hs b/src/PFile/Main/Unpack.hs new file mode 100644 --- /dev/null +++ b/src/PFile/Main/Unpack.hs @@ -0,0 +1,40 @@ +{- | +Module: PFile.Main.Unpack +Copyright: (c) 2024 Illia Shkroba +License: BSD3 +Maintainer: Illia Shkroba +Stability: unstable +Portability: non-portable (Non-Unix systems are not supported) + +Main for `pfile unpack`. +-} + +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} + +module PFile.Main.Unpack + ( main + ) where + +import PFile.CLI.Unpack (Options (..)) +import PFile.Env (Env) +import PFile.Error (modifyError) +import qualified PFile.Log as Log +import qualified PFile.Profile as Profile +import Protolude + +main :: (MonadReader Env m, MonadIO m) => Options -> m () +main Options {forceRemoveOccupied} = + either Log.panic pure <=< runExceptT $ do + Profile.loadCurrent & runExceptT >>= \case + Left error -> Log.panic $ Profile.showLoadCurrentError error + Right currentProfile -> + Profile.unpack switchOptions currentProfile + & modifyError Profile.showUnpackError + + Profile.unsetCurrent + & modifyError Profile.showUnsetCurrentError + where + switchOptions :: Profile.SwitchOptions + switchOptions = Profile.SwitchOptions {Profile.forceRemoveOccupied} diff --git a/src/PFile/Main/Which.hs b/src/PFile/Main/Which.hs new file mode 100644 --- /dev/null +++ b/src/PFile/Main/Which.hs @@ -0,0 +1,34 @@ +{- | +Module: PFile.Main.Which +Copyright: (c) 2024 Illia Shkroba +License: BSD3 +Maintainer: Illia Shkroba +Stability: unstable +Portability: non-portable (Non-Unix systems are not supported) + +Main for `pfile which`. +-} + +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} + +module PFile.Main.Which + ( main + ) where + +import PFile.CLI.Which (Options (..)) +import PFile.Env (Env) +import qualified PFile.Log as Log +import qualified PFile.Profile as Profile +import Protolude + +main :: (MonadReader Env m, MonadIO m) => Options -> m () +main Options = + Profile.loadCurrent & runExceptT >>= \case + Left error -> do + Log.info $ Profile.showLoadCurrentError error + Log.panic + $ "No current profile set. Use `pfile new` to create a profile and" + <> " `pfile switch` to switch to it." + Right Profile.Profile {Profile.name = Profile.Name name} -> putStrLn name diff --git a/src/PFile/Mount.hs b/src/PFile/Mount.hs new file mode 100644 --- /dev/null +++ b/src/PFile/Mount.hs @@ -0,0 +1,210 @@ +{- | +Module: PFile.Mount +Copyright: (c) 2024 Illia Shkroba +License: BSD3 +Maintainer: Illia Shkroba +Stability: unstable +Portability: non-portable (Non-Unix systems are not supported) + +Types and functions for mounting filesystem's objects under some "root" +directory. +-} + +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} + +module PFile.Mount + ( mount + , mountPath + , showMountError + , MountError (..) + , unmount + , originPath + , showUnmountError + , UnmountError (..) + , showOriginResolveError + , OriginResolveError (..) + , Root (..) + , Mount (..) + ) where + +import Data.Aeson (FromJSON, ToJSON) +import PFile.Error (liftIOWithError, modifyError) +import PFile.Path + ( dropDrive + , makeRelative + , move + , pathIsSymbolicLink + , () + ) +import qualified PFile.Path as Path +import qualified PFile.Profile.LinkHandling as LinkHandling +import Protolude +import System.FilePath (joinDrive, takeDrive) + +-- | Mount a 'PFile.Path.Absolute' inside of a 'Root' with a chosen +-- 'PFile.Profile.LinkHandling.Strategy' for links. 'mount' does the following: +-- +-- 1. Moves (renames) 'PFile.Path.Absolute' into 'mountPath' under 'Root'. If +-- the move fails due to cross-device move attempt, the +-- 'PFile.Path.Absolute' is copied instead. +-- 2. Removes 'PFile.Path.Absolute' at its original location. +-- 3. Handles links with 'PFile.Profile.LinkHandling.handle'. +-- +-- @since 0.1.0.0 +mount :: + (MonadError MountError m, MonadIO m) + => LinkHandling.Strategy + -> Root + -> Path.Absolute + -> m Mount +mount linkHandlingStrategy root src = do + ifM (pathIsSymbolicLink src `liftIOWithError` OriginMissingError src) + do + LinkHandling.handle linkHandlingStrategy src dest + & modifyError LinkHandlingMountError + Path.remove src + & modifyError OriginLinkRemoveError + (move src dest & modifyError OriginMoveError) + pure $ Mount dest + where + Mount dest = mountPath root src + +-- | Mount path of a 'PFile.Path.Absolute' inside of a 'Root'. 'mountPath' uses +-- 'PFile.Path.dropDrive' on the 'PFile.Path.Absolute' and then appends the +-- result to the 'Root'. For example: +-- +-- >>> mountPath (Root $ Path.Absolute "/a/b/c/") (Path.Absolute "/d/e/f.txt") == Mount (Path.Absolute "/a/b/c/d/e/f.txt") +-- True +-- +-- @since 0.1.0.0 +mountPath :: Root -> Path.Absolute -> Mount +mountPath (Root root) path = Mount $ root dropDrive path + +showMountError :: MountError -> Text +showMountError = \case + OriginMissingError path cause + -> "Unable to find origin file " <> Path.showAbsolute path + <> " because of: " <> show cause + LinkHandlingMountError cause -> LinkHandling.showError cause + OriginLinkRemoveError cause + -> "Unable to remove link because of: " <> Path.showRemoveError cause + OriginMoveError cause -> Path.showMoveError cause + +-- | Error thrown by 'mount'. +-- +-- @since 0.1.0.0 +data MountError + = OriginMissingError !Path.Absolute !IOException + -- ^ 'PFile.Path.Absolute' is missing. 'IOException' is captured from + -- 'pathIsSymbolicLink'. + | LinkHandlingMountError !LinkHandling.Error + -- ^ Error was encountered during 'PFile.Profile.LinkHandling.handle'. + | OriginLinkRemoveError !Path.RemoveError + -- ^ Unable to remove 'PFile.Path.Absolute'. This error is thrown after the + -- 'PFile.Path.Absolute' got copied under 'Root'. + | OriginMoveError !Path.MoveError + -- ^ Error was encountered during 'PFile.Path.move'. + +-- | Unmount a 'Mount' from a 'Root' back to its original location. 'unmount' +-- does the following: +-- +-- 1. Moves (renames) 'Mount' into 'originPath' from the 'Root'. If the move +-- fails due to cross-device move attempt, the 'Mount' is copied instead. +-- 2. Removes 'Mount' at its original location. +-- 3. Handles links with 'PFile.Profile.LinkHandling.handle +-- PFile.Profile.LinkHandling.CopyLink'. +-- +-- @since 0.1.0.0 +unmount :: + (MonadError UnmountError m, MonadIO m) => Root -> Mount -> m Path.Absolute +unmount root (Mount src) = do + dest <- originPath root (Mount src) + & modifyError OriginResolveError + ifM (pathIsSymbolicLink src `liftIOWithError` MountMissingError src) + do + LinkHandling.handle LinkHandling.CopyLink src dest + & modifyError LinkHandlingUnmountError + Path.remove src + & modifyError MountLinkRemoveError + (move src dest & modifyError MountMoveError) + pure dest + +-- | Origin path of a 'Mount' outside of a 'Root'. 'originPath' is an inverse +-- of 'mountPath'. Here is an example usage: +-- +-- >>> r = originPath (Root $ Path.Absolute "/a/b/c/") (Mount $ Path.Absolute "/a/b/c/d/e/f.txt") & runExcept +-- >>> r & either (const False) (== Path.Absolute "/d/e/f.txt") +-- True +-- +-- 'originPath' works only for Posix paths. Windows paths are not supported +-- currently. +-- +-- @since 0.1.0.0 +originPath :: MonadError OriginResolveError m => Root -> Mount -> m Path.Absolute +originPath (Root root) (Mount path) = do + let relativePath = makeRelative root path + when (relativePath == Path.unAbsolute path) . throwError + $ OriginOutsideOfRootError (Mount path) (Root root) + relativePath + -- Dirty hack that works for Posix paths + & joinDrive (takeDrive $ Path.unAbsolute root) + & pure . Path.Absolute + +showUnmountError :: UnmountError -> Text +showUnmountError = \case + OriginResolveError cause -> showOriginResolveError cause + MountMissingError path cause + -> "Unable to find mount file " <> Path.showAbsolute path + <> " because of: " <> show cause + LinkHandlingUnmountError cause -> LinkHandling.showError cause + MountLinkRemoveError cause + -> "Unable to remove link because of: " <> Path.showRemoveError cause + MountMoveError cause -> Path.showMoveError cause + +-- | Error thrown by 'unmount'. +-- +-- @since 0.1.0.0 +data UnmountError + = OriginResolveError !OriginResolveError + -- ^ Error was encountered during 'originPath'. + | MountMissingError !Path.Absolute !IOException + -- ^ 'Mount' is missing. 'IOException' is captured from 'pathIsSymbolicLink'. + | LinkHandlingUnmountError !LinkHandling.Error + -- ^ Error was encountered during 'PFile.Profile.LinkHandling.handle'. + | MountLinkRemoveError !Path.RemoveError + -- ^ Unable to remove 'Mount'. This error is thrown after the 'Mount' got + -- copied back to its original location. + | MountMoveError !Path.MoveError + -- ^ Error was encountered during 'PFile.Path.move'. + +showOriginResolveError :: OriginResolveError -> Text +showOriginResolveError = \case + OriginOutsideOfRootError (Mount path) (Root root) + -> "Expected path " <> Path.showAbsolute path + <> " to be relative to: " <> Path.showAbsolute root <> "." + +-- | Error thrown by 'originPath'. +-- +-- @since 0.1.0.0 +data OriginResolveError + = OriginOutsideOfRootError !Mount !Root + -- ^ 'Mount' is outside of the 'Root'. + +-- | Root for 'mount'ed 'PFile.Path.Absolute's. +-- +-- @since 0.1.0.0 +newtype Root + = Root Path.Absolute + +-- | 'mount'ed 'PFile.Path.Absolute'. +-- +-- @since 0.1.0.0 +newtype Mount + = Mount { absolute :: Path.Absolute } + deriving (Eq) + deriving newtype (FromJSON, ToJSON) diff --git a/src/PFile/Path.hs b/src/PFile/Path.hs new file mode 100644 --- /dev/null +++ b/src/PFile/Path.hs @@ -0,0 +1,656 @@ +{- | +Module: PFile.Path +Copyright: (c) 2024 Illia Shkroba +License: BSD3 +Maintainer: Illia Shkroba +Stability: unstable +Portability: non-portable (Non-Unix systems are not supported) + +Wrapper of 'System.Directory' and 'System.FilePath'. +-} + +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE ViewPatterns #-} + +module PFile.Path + ( findDirectories + , findFiles + , find + , FindResult (..) + , () + , parseAbsolute + , canonicalizePath + , copy + , copyDirectory + , copyDirectoryLink + , copyFile + , copyFileLink + , copyLink + , showCopyError + , CopyError (..) + , showCopyLinkError + , CopyLinkError (..) + , showCopyFileError + , CopyFileError (..) + , createDirectory + , showCreateDirectoryError + , CreateDirectoryError (..) + , createDirectoryLink + , showCreateDirectoryLinkError + , CreateDirectoryLinkError (..) + , createEmptyFile + , createFileLink + , showCreateFileLinkError + , CreateFileLinkError (..) + , createLink + , showCreateLinkError + , CreateLinkError (..) + , createParent + , showCreateParentError + , CreateParentError (..) + , doesDirectoryExist + , doesFileExist + , doesPathExist + , dropDrive + , dropFileName + , dropTrailingPathSeparator + , getSymbolicLinkTarget + , listDirectory + , makeRelative + , move + , moveDirectory + , moveDirectoryLink + , moveFile + , moveFileLink + , showMoveError + , MoveError (..) + , showMoveDirectoryError + , MoveDirectoryError (..) + , showMoveDirectoryLinkError + , MoveDirectoryLinkError (..) + , showMoveFileError + , MoveFileError (..) + , showMoveFileLinkError + , MoveFileLinkError (..) + , pathIsSymbolicLink + , remove + , showRemoveError + , RemoveError (..) + , renameDirectory + , renameFile + , takeBaseName + , typeOf + , showType + , Type (..) + , PFile.Path.writeFile + , showWriteFileError + , WriteFileError (..) + , showAbsolute + , Absolute (..) + ) where + +import Data.Aeson (FromJSON, ToJSON) +import Data.HashSet (HashSet) +import qualified Data.HashSet as HashSet +import GHC.IO.Exception (IOErrorType (..)) +import PFile.Error (liftIOWithError, modifyError, onIOError) +import Protolude hiding (Type, find, typeOf) +import qualified System.Directory as Directory +import System.Directory (makeAbsolute) +import qualified System.FilePath as FilePath +import System.FilePath (()) +import System.IO.Error (ioeGetErrorType, tryIOError) + +findDirectories :: MonadIO m => Absolute -> m [Absolute] +findDirectories root = HashSet.toList . dirs <$> find root + +findFiles :: MonadIO m => Absolute -> m [Absolute] +findFiles root = HashSet.toList . files <$> find root + +find :: + forall m. MonadIO m + => Absolute + -> m FindResult +find = go FindResult {files = HashSet.empty, dirs = HashSet.empty} + where + go :: FindResult -> Absolute -> m FindResult + go acc@FindResult {files, dirs} root = do + path <- canonicalizePath root + ifM (doesFileExist path) + (pure acc {files = HashSet.insert path files}) + if path `HashSet.member` dirs + then pure acc + else tryIOError (listDirectory path) & liftIO >>= either + (const $ pure acc) + (foldlM go acc {dirs = HashSet.insert path dirs}) + +data FindResult + = FindResult + { files :: !(HashSet Absolute) + , dirs :: !(HashSet Absolute) + } + +infixr 5 + +() :: Absolute -> FilePath -> Absolute +() (Absolute x) y = Absolute $ x y + +parseAbsolute :: MonadIO m => FilePath -> m (Maybe Absolute) +parseAbsolute inputPath = + makeAbsolute inputPath & tryIOError & liftIO + >>= either (const $ pure Nothing) \(Absolute -> path) -> + doesPathExist path <&> bool Nothing (Just $ dropTrailingPathSeparator path) + +canonicalizePath :: MonadIO m => Absolute -> m Absolute +canonicalizePath (Absolute path) = + Directory.canonicalizePath path <&> Absolute & liftIO + +copy :: (MonadError CopyError m, MonadIO m) => Absolute -> Absolute -> m () +copy src dest = + typeOf src >>= maybe (throwError $ SourceTypeResolveCopyError src) \case + Directory -> copyDirectory src dest + DirectoryLink -> copyDirectoryLink src dest & modifyError CopyLinkError + File -> copyFile src dest & modifyError CopyFileError + FileLink -> copyFileLink src dest & modifyError CopyLinkError + +copyDirectory :: + (MonadError CopyError m, MonadIO m) => Absolute -> Absolute -> m () +copyDirectory src dest = do + paths <- Directory.listDirectory (unAbsolute src) + `liftIOWithError` ListDirectoryError src + if null paths + then createDirectory dest & modifyError CreateDirectoryInCopyError + else zipWithM_ copy ((src ) <$> paths) ((dest ) <$> paths) + +copyDirectoryLink :: + (MonadError CopyLinkError m, MonadIO m) => Absolute -> Absolute -> m () +copyDirectoryLink src dest = do + createParent dest + & modifyError CreateParentInCopyLinkError + target <- getSymbolicLinkTarget src + `liftIOWithError` LinkTargetResolveError src + createDirectoryLink target dest + & modifyError CreateDirectoryLinkInCopyLinkError + +copyFile :: + (MonadError CopyFileError m, MonadIO m) => Absolute -> Absolute -> m () +copyFile src dest = do + createParent dest + & modifyError CreateParentInCopyFileError + Directory.copyFileWithMetadata (unAbsolute src) (unAbsolute dest) + `liftIOWithError` CopyFileWithMetadataError src dest + +copyFileLink :: + (MonadError CopyLinkError m, MonadIO m) => Absolute -> Absolute -> m () +copyFileLink src dest = do + createParent dest + & modifyError CreateParentInCopyLinkError + target <- getSymbolicLinkTarget src + `liftIOWithError` LinkTargetResolveError src + createFileLink target dest + & modifyError CreateFileLinkInCopyLinkError + +copyLink :: + (MonadError CopyLinkError m, MonadIO m) => Absolute -> Absolute -> m () +copyLink src dest = + ifM (doesDirectoryExist src) + (copyDirectoryLink src dest) + (copyFileLink src dest) + +showCopyError :: CopyError -> Text +showCopyError = \case + SourceTypeResolveCopyError path + -> "Unable to resolve type of path: " <> showAbsolute path <> "." + ListDirectoryError path cause + -> "Unable to list directory " <> showAbsolute path + <> " because of: " <> show cause + CreateDirectoryInCopyError cause -> showCreateDirectoryError cause + CopyLinkError cause -> showCopyLinkError cause + CopyFileError cause -> showCopyFileError cause + +data CopyError + = SourceTypeResolveCopyError !Absolute + | ListDirectoryError !Absolute !IOException + | CreateDirectoryInCopyError !CreateDirectoryError + | CopyLinkError !CopyLinkError + | CopyFileError !CopyFileError + +showCopyLinkError :: CopyLinkError -> Text +showCopyLinkError = \case + CreateParentInCopyLinkError cause -> showCreateParentError cause + LinkTargetResolveError path cause + -> "Unable to resolve link of path " <> showAbsolute path + <> " because of: " <> show cause + CreateDirectoryLinkInCopyLinkError cause -> showCreateDirectoryLinkError cause + CreateFileLinkInCopyLinkError cause -> showCreateFileLinkError cause + +data CopyLinkError + = CreateParentInCopyLinkError !CreateParentError + | LinkTargetResolveError !Absolute !IOException + | CreateDirectoryLinkInCopyLinkError !CreateDirectoryLinkError + | CreateFileLinkInCopyLinkError !CreateFileLinkError + +showCopyFileError :: CopyFileError -> Text +showCopyFileError = \case + CreateParentInCopyFileError cause -> showCreateParentError cause + CopyFileWithMetadataError src dest cause + -> "Unable to copy file " <> showAbsolute src + <> " into " <> showAbsolute dest + <> " because of: " <> show cause + +data CopyFileError + = CreateParentInCopyFileError !CreateParentError + | CopyFileWithMetadataError !Absolute !Absolute !IOException + +createDirectory :: + (MonadError CreateDirectoryError m, MonadIO m) => Absolute -> m () +createDirectory path = + Directory.createDirectoryIfMissing True (unAbsolute path) + `liftIOWithError` CreateDirectoryError path + +showCreateDirectoryError :: CreateDirectoryError -> Text +showCreateDirectoryError = \case + CreateDirectoryError path cause + -> "Unable to create directory " <> showAbsolute path + <> " because of: " <> show cause + +data CreateDirectoryError + = CreateDirectoryError !Absolute !IOException + +createDirectoryLink :: + (MonadError CreateDirectoryLinkError m, MonadIO m) + => Absolute + -> Absolute + -> m () +createDirectoryLink + (dropTrailingPathSeparator -> dest) + (dropTrailingPathSeparator -> src) = do + createParent src + & modifyError CreateParentInCreateDirectoryLinkError + Directory.createDirectoryLink (unAbsolute dest) (unAbsolute src) + `liftIOWithError` CreateDirectoryLinkError dest src + +showCreateDirectoryLinkError :: CreateDirectoryLinkError -> Text +showCreateDirectoryLinkError = \case + CreateParentInCreateDirectoryLinkError cause -> showCreateParentError cause + CreateDirectoryLinkError dest src cause + -> "Unable to link " <> showAbsolute src + <> " to " <> showAbsolute dest + <> " because of: " <> show cause + +data CreateDirectoryLinkError + = CreateParentInCreateDirectoryLinkError !CreateParentError + | CreateDirectoryLinkError !Absolute !Absolute !IOException + +createEmptyFile :: (MonadError WriteFileError m, MonadIO m) => Absolute -> m () +createEmptyFile path = PFile.Path.writeFile path "" + +createFileLink :: + (MonadError CreateFileLinkError m, MonadIO m) + => Absolute + -> Absolute + -> m () +createFileLink + (dropTrailingPathSeparator -> dest) + (dropTrailingPathSeparator -> src) = do + createParent src + & modifyError CreateParentInCreateFileLinkError + Directory.createFileLink (unAbsolute dest) (unAbsolute src) + `liftIOWithError` CreateFileLinkError dest src + +showCreateFileLinkError :: CreateFileLinkError -> Text +showCreateFileLinkError = \case + CreateParentInCreateFileLinkError cause -> showCreateParentError cause + CreateFileLinkError dest src cause + -> "Unable to link " <> showAbsolute src + <> " to " <> showAbsolute dest + <> " because of: " <> show cause + +data CreateFileLinkError + = CreateParentInCreateFileLinkError !CreateParentError + | CreateFileLinkError !Absolute !Absolute !IOException + +createLink :: + (MonadError CreateLinkError m, MonadIO m) => Absolute -> Absolute -> m () +createLink dest src = + ifM (doesDirectoryExist dest) + (createDirectoryLink dest src & modifyError DirectoryLinkError) + (createFileLink dest src & modifyError FileLinkError) + +showCreateLinkError :: CreateLinkError -> Text +showCreateLinkError = \case + DirectoryLinkError cause -> showCreateDirectoryLinkError cause + FileLinkError cause -> showCreateFileLinkError cause + +data CreateLinkError + = DirectoryLinkError !CreateDirectoryLinkError + | FileLinkError !CreateFileLinkError + +createParent :: (MonadError CreateParentError m, MonadIO m) => Absolute -> m () +createParent (dropTrailingPathSeparator -> path) = + createDirectory (dropFileName path) + & modifyError (CreateParentError path) + +showCreateParentError :: CreateParentError -> Text +showCreateParentError = \case + CreateParentError path (CreateDirectoryError _ cause) + -> "Unable to create parent directory for " <> showAbsolute path + <> " because of: " <> show cause + +data CreateParentError + = CreateParentError !Absolute !CreateDirectoryError + +doesDirectoryExist :: MonadIO m => Absolute -> m Bool +doesDirectoryExist (Absolute path) = + Directory.doesDirectoryExist path `onIOError` pure False & liftIO + +doesFileExist :: MonadIO m => Absolute -> m Bool +doesFileExist (Absolute path) = + Directory.doesFileExist path `onIOError` pure False & liftIO + +doesPathExist :: MonadIO m => Absolute -> m Bool +doesPathExist (Absolute path) = + Directory.doesPathExist path `onIOError` pure False & liftIO + +dropDrive :: Absolute -> FilePath +dropDrive (Absolute path) = FilePath.dropDrive path + +dropFileName :: Absolute -> Absolute +dropFileName (Absolute path) = Absolute $ FilePath.dropFileName path + +dropTrailingPathSeparator :: Absolute -> Absolute +dropTrailingPathSeparator (Absolute path) = + Absolute $ FilePath.dropTrailingPathSeparator path + +getSymbolicLinkTarget :: MonadIO m => Absolute -> m Absolute +getSymbolicLinkTarget (dropTrailingPathSeparator -> Absolute path) = + Directory.getSymbolicLinkTarget path <&> Absolute & liftIO + +listDirectory :: MonadIO m => Absolute -> m [Absolute] +listDirectory path + = Directory.listDirectory (unAbsolute path) + <&> fmap (path ) & liftIO + +makeRelative :: Absolute -> Absolute -> FilePath +makeRelative (Absolute root) (Absolute path) = FilePath.makeRelative root path + +move :: (MonadError MoveError m, MonadIO m) => Absolute -> Absolute -> m () +move src dest = + typeOf src >>= maybe (throwError $ SourceTypeResolveMoveError src) \case + Directory -> moveDirectory src dest & modifyError MoveDirectoryError + DirectoryLink -> moveDirectoryLink src dest & modifyError MoveDirectoryLinkError + File -> moveFile src dest & modifyError MoveFileError + FileLink -> moveFileLink src dest & modifyError MoveFileLinkError + +moveDirectory :: + (MonadError MoveDirectoryError m, MonadIO m) + => Absolute + -> Absolute + -> m () +moveDirectory src dest = do + createParent dest + & modifyError CreateParentInMoveDirectoryError + tryIOError (renameDirectory src dest) & liftIO + >>= flip either (const $ pure ()) \cause -> + if isCrossDeviceLinkError cause + then do + copyDirectory src dest + & modifyError FallbackCopyDirectoryError + remove src + & modifyError SourceDirectoryRemoveError + else throwError $ RenameDirectoryError src dest cause + +moveDirectoryLink :: + (MonadError MoveDirectoryLinkError m, MonadIO m) + => Absolute + -> Absolute + -> m () +moveDirectoryLink src dest = do + createParent dest + & modifyError CreateParentInMoveDirectoryLinkError + tryIOError (renameDirectory src dest) & liftIO + >>= flip either (const $ pure ()) \cause -> + if isCrossDeviceLinkError cause + then do + copyDirectoryLink src dest + & modifyError FallbackCopyDirectoryLinkError + remove src + & modifyError SourceDirectoryLinkRemoveError + else throwError $ RenameDirectoryLinkError src dest cause + +moveFile :: + (MonadError MoveFileError m, MonadIO m) => Absolute -> Absolute -> m () +moveFile src dest = do + createParent dest + & modifyError CreateParentInMoveFileError + tryIOError (renameFile src dest) & liftIO + >>= flip either (const $ pure ()) \cause -> + if isCrossDeviceLinkError cause + then do + copyFile src dest + & modifyError FallbackCopyFileError + remove src + & modifyError SourceFileRemoveError + else throwError $ RenameFileError src dest cause + +moveFileLink :: + (MonadError MoveFileLinkError m, MonadIO m) => Absolute -> Absolute -> m () +moveFileLink src dest = do + createParent dest + & modifyError CreateParentInMoveFileLinkError + tryIOError (renameFile src dest) & liftIO + >>= flip either (const $ pure ()) \cause -> + if isCrossDeviceLinkError cause + then do + copyFileLink src dest + & modifyError FallbackCopyFileLinkError + remove src + & modifyError SourceFileLinkRemoveError + else throwError $ RenameFileLinkError src dest cause + +showMoveError :: MoveError -> Text +showMoveError = \case + SourceTypeResolveMoveError path + -> "Unable to resolve type of path: " <> showAbsolute path <> "." + MoveDirectoryError cause -> showMoveDirectoryError cause + MoveDirectoryLinkError cause -> showMoveDirectoryLinkError cause + MoveFileError cause -> showMoveFileError cause + MoveFileLinkError cause -> showMoveFileLinkError cause + +data MoveError + = SourceTypeResolveMoveError !Absolute + | MoveDirectoryError !MoveDirectoryError + | MoveDirectoryLinkError !MoveDirectoryLinkError + | MoveFileError !MoveFileError + | MoveFileLinkError !MoveFileLinkError + +showMoveDirectoryError :: MoveDirectoryError -> Text +showMoveDirectoryError = \case + CreateParentInMoveDirectoryError cause -> showCreateParentError cause + FallbackCopyDirectoryError cause -> showCopyError cause + SourceDirectoryRemoveError cause + -> "Unable to remove source because of: " <> showRemoveError cause + RenameDirectoryError src dest cause + -> "Unable to rename directory " <> showAbsolute src + <> " to " <> showAbsolute dest + <> " because of: " <> show cause + +data MoveDirectoryError + = CreateParentInMoveDirectoryError !CreateParentError + | FallbackCopyDirectoryError !CopyError + | SourceDirectoryRemoveError !RemoveError + | RenameDirectoryError !Absolute !Absolute !IOException + +showMoveDirectoryLinkError :: MoveDirectoryLinkError -> Text +showMoveDirectoryLinkError = \case + CreateParentInMoveDirectoryLinkError cause -> showCreateParentError cause + FallbackCopyDirectoryLinkError cause -> showCopyLinkError cause + SourceDirectoryLinkRemoveError cause + -> "Unable to remove source because of: " <> showRemoveError cause + RenameDirectoryLinkError src dest cause + -> "Unable to rename directory link " <> showAbsolute src + <> " to " <> showAbsolute dest + <> " because of: " <> show cause + +data MoveDirectoryLinkError + = CreateParentInMoveDirectoryLinkError !CreateParentError + | FallbackCopyDirectoryLinkError !CopyLinkError + | SourceDirectoryLinkRemoveError !RemoveError + | RenameDirectoryLinkError !Absolute !Absolute !IOException + +showMoveFileError :: MoveFileError -> Text +showMoveFileError = \case + CreateParentInMoveFileError cause -> showCreateParentError cause + FallbackCopyFileError cause -> showCopyFileError cause + SourceFileRemoveError cause + -> "Unable to remove source because of: " <> showRemoveError cause + RenameFileError src dest cause + -> "Unable to rename file " <> showAbsolute src + <> " to " <> showAbsolute dest + <> " because of: " <> show cause + +data MoveFileError + = CreateParentInMoveFileError !CreateParentError + | FallbackCopyFileError !CopyFileError + | SourceFileRemoveError !RemoveError + | RenameFileError !Absolute !Absolute !IOException + +showMoveFileLinkError :: MoveFileLinkError -> Text +showMoveFileLinkError = \case + CreateParentInMoveFileLinkError cause -> showCreateParentError cause + FallbackCopyFileLinkError cause -> showCopyLinkError cause + SourceFileLinkRemoveError cause + -> "Unable to remove source because of: " <> showRemoveError cause + RenameFileLinkError src dest cause + -> "Unable to rename file link " <> showAbsolute src + <> " to " <> showAbsolute dest + <> " because of: " <> show cause + +data MoveFileLinkError + = CreateParentInMoveFileLinkError !CreateParentError + | FallbackCopyFileLinkError !CopyLinkError + | SourceFileLinkRemoveError !RemoveError + | RenameFileLinkError !Absolute !Absolute !IOException + +isCrossDeviceLinkError :: IOException -> Bool +isCrossDeviceLinkError e + = ioeGetErrorType e == UnsupportedOperation + && (toLower <$> "Invalid cross-device link") `isInfixOf` (toLower <$> show e) + +pathIsSymbolicLink :: MonadIO m => Absolute -> m Bool +pathIsSymbolicLink (dropTrailingPathSeparator -> Absolute path) = + Directory.pathIsSymbolicLink path & liftIO + +-- | 'remove' should be used instead of the 'Directory.removePathForcibly' to properly +-- remove a path without messing up permissions of a target in case of links +remove :: (MonadError RemoveError m, MonadIO m) => Absolute -> m () +remove (dropTrailingPathSeparator -> path) = + typeOf path >>= maybe (pure ()) \case + Directory -> + Directory.removeDirectoryRecursive (unAbsolute path) + `liftIOWithError` RemoveDirectoryError path + DirectoryLink -> + Directory.removeDirectoryLink (unAbsolute path) + `liftIOWithError` RemoveDirectoryLinkError path + File -> + Directory.removeFile (unAbsolute path) + `liftIOWithError` RemoveFileError path + FileLink -> + Directory.removeFile (unAbsolute path) + `liftIOWithError` RemoveFileLinkError path + +showRemoveError :: RemoveError -> Text +showRemoveError = \case + RemoveDirectoryError path cause + -> "Unable to remove directory " <> showAbsolute path + <> " because of: " <> show cause + RemoveDirectoryLinkError path cause + -> "Unable to remove directory link " <> showAbsolute path + <> " because of: " <> show cause + RemoveFileError path cause + -> "Unable to remove file " <> showAbsolute path + <> " because of: " <> show cause + RemoveFileLinkError path cause + -> "Unable to remove file link " <> showAbsolute path + <> " because of: " <> show cause + +data RemoveError + = RemoveDirectoryError !Absolute !IOException + | RemoveDirectoryLinkError !Absolute !IOException + | RemoveFileError !Absolute !IOException + | RemoveFileLinkError !Absolute !IOException + +renameDirectory :: MonadIO m => Absolute -> Absolute -> m () +renameDirectory (Absolute src) (Absolute dest) = + Directory.renameDirectory src dest & liftIO + +renameFile :: MonadIO m => Absolute -> Absolute -> m () +renameFile (Absolute src) (Absolute dest) = + Directory.renameFile src dest & liftIO + +takeBaseName :: Absolute -> FilePath +takeBaseName (Absolute path) = FilePath.takeBaseName path + +typeOf :: MonadIO m => Absolute -> m (Maybe Type) +typeOf path = + ifM (doesFileExist path) + do + tryIOError (pathIsSymbolicLink path) & liftIO + <&> either (const Nothing) (Just . bool File FileLink) + do + ifM (doesDirectoryExist path) + do + tryIOError (pathIsSymbolicLink path) & liftIO + <&> either (const Nothing) (Just . bool Directory DirectoryLink) + do + pure Nothing + +showType :: Type -> Text +showType = \case + Directory -> "dir" + DirectoryLink -> "dir link" + File -> "file" + FileLink -> "file link" + +data Type + = Directory + | DirectoryLink + | File + | FileLink + +writeFile :: + (MonadError WriteFileError m, MonadIO m) => Absolute -> Text -> m () +writeFile path contents = do + createParent path + & modifyError CreateParentInWriteFileError + Protolude.writeFile (unAbsolute path) contents + `liftIOWithError` WriteFileError path + +showWriteFileError :: WriteFileError -> Text +showWriteFileError = \case + CreateParentInWriteFileError cause -> showCreateParentError cause + WriteFileError path cause + -> "Unable to write to a file " <> showAbsolute path + <> " because of: " <> show cause + +data WriteFileError + = CreateParentInWriteFileError !CreateParentError + | WriteFileError !Absolute !IOException + +showAbsolute :: Absolute -> Text +showAbsolute (Absolute path) = "\"" <> toS path <> "\"" + +-- | Absolute 'FilePath' to a filesystem's object. +-- +-- @since 0.1.0.0 +newtype Absolute + = Absolute { unAbsolute :: FilePath } + deriving (Eq) + deriving newtype (FromJSON, Hashable, ToJSON) diff --git a/src/PFile/Profile.hs b/src/PFile/Profile.hs new file mode 100644 --- /dev/null +++ b/src/PFile/Profile.hs @@ -0,0 +1,74 @@ +{- | +Module: PFile.Profile +Copyright: (c) 2024 Illia Shkroba +License: BSD3 +Maintainer: Illia Shkroba +Stability: unstable +Portability: non-portable (Non-Unix systems are not supported) + +Types and functions for managing profiles defined for a set of entries. + +(A note on naming: `pfile` is an abbreviation for "profile".) +-} + +module PFile.Profile + ( module PFile.Profile.Internal.Current + , module PFile.Profile.Internal.Lifetime + , module PFile.Profile.Internal.List + , module PFile.Profile.Internal.Profile + , module PFile.Profile.Internal.Serialization + , module PFile.Profile.Internal.Switch + ) where + +import PFile.Profile.Internal.Current + ( LoadCurrentError (..) + , SetCurrentError (..) + , UnsetCurrentError (..) + , loadCurrent + , setCurrent + , showLoadCurrentError + , showSetCurrentError + , showUnsetCurrentError + , unsetCurrent + ) +import PFile.Profile.Internal.Lifetime + ( CreateError (..) + , CreateOptions (..) + , create + , showCreateError + ) +import PFile.Profile.Internal.List + ( ListError (..) + , ListOptions (..) + , list + , showListError + ) +import PFile.Profile.Internal.Profile + ( Entry (..) + , Name (..) + , Profile (..) + , State (..) + , absoluteRoot + , profileRoot + , profileState + ) +import PFile.Profile.Internal.Serialization + ( DumpError (..) + , LoadError (..) + , dump + , load + , showDumpError + , showLoadError + ) +import PFile.Profile.Internal.Switch + ( LinkError (..) + , SwitchError (..) + , SwitchOptions (..) + , UnpackError (..) + , link + , showLinkError + , showSwitchError + , showUnpackError + , switch + , unpack + ) diff --git a/src/PFile/Profile/Internal/Current.hs b/src/PFile/Profile/Internal/Current.hs new file mode 100644 --- /dev/null +++ b/src/PFile/Profile/Internal/Current.hs @@ -0,0 +1,142 @@ +{- | +Module: PFile.Profile.Internal.Current +Copyright: (c) 2024 Illia Shkroba +License: BSD3 +Maintainer: Illia Shkroba +Stability: unstable +Portability: non-portable (Non-Unix systems are not supported) + +Types and functions for managing current profile. +-} + +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} + +module PFile.Profile.Internal.Current + ( loadCurrent + , showLoadCurrentError + , LoadCurrentError (..) + , setCurrent + , unsetCurrent + , showSetCurrentError + , SetCurrentError (..) + , showUnsetCurrentError + , UnsetCurrentError (..) + ) where + +import PFile.Env (Env (..)) +import PFile.Error + ( liftIOWithError + , modifyError + ) +import qualified PFile.Log as Log +import PFile.Path + ( canonicalizePath + , createDirectoryLink + , takeBaseName + ) +import qualified PFile.Path as Path +import PFile.Profile.Internal.Profile + ( Name (..) + , Profile (..) + , profileRoot + ) +import PFile.Profile.Internal.Serialization + ( LoadError + , load + , showLoadError + ) +import Protolude + +-- | 'PFile.Profile.Internal.Serialization.load' current 'Profile'. Current +-- 'Profile' is resolved via 'PFile.Env.currentLinkPath'. +-- +-- @since 0.1.0.0 +loadCurrent :: + (MonadReader Env m, MonadError LoadCurrentError m, MonadIO m) => m Profile +loadCurrent = do + Env {currentLinkPath} <- ask + Log.info "Canonicalize link pointing at current profile" + currentPath <- canonicalizePath currentLinkPath + `liftIOWithError` CanonicalizeCurrentError currentLinkPath + Log.info + $ "Canonicalized link pointing at current profile: " + <> Path.showAbsolute currentPath + currentPath + & Name . toS . takeBaseName + & load + & modifyError LoadCurrentError + +showLoadCurrentError :: LoadCurrentError -> Text +showLoadCurrentError = \case + CanonicalizeCurrentError path cause + -> "Unable to resolve current link " <> Path.showAbsolute path + <> " because of: " <> show cause + LoadCurrentError cause -> showLoadError cause + +-- | Error thrown by 'loadCurrent'. +-- +-- @since 0.1.0.0 +data LoadCurrentError + = CanonicalizeCurrentError !Path.Absolute !IOException + -- ^ Unable to canonicalize 'PFile.Env.currentLinkPath'. + | LoadCurrentError !LoadError + -- ^ Error was encountered during + -- 'PFile.Profile.Internal.Serialization.load'. + +-- | Set current 'Profile'. Previously set 'Profile' is unset via +-- 'unsetCurrent' and then 'PFile.Env.currentLinkPath' is set to point at a new +-- current 'Profile'. +-- +-- @since 0.1.0.0 +setCurrent :: + (MonadReader Env m, MonadError SetCurrentError m, MonadIO m) + => Profile + -> m () +setCurrent Profile {name} = do + Env {currentLinkPath} <- ask + unsetCurrent + & modifyError UnsetCurrentError + root <- profileRoot name + createDirectoryLink root currentLinkPath + & modifyError CurrentLinkError + +-- | Unset current 'Profile'. 'PFile.Env.currentLinkPath' is removed. +-- +-- @since 0.1.0.0 +unsetCurrent :: + (MonadReader Env m, MonadError UnsetCurrentError m, MonadIO m) => m () +unsetCurrent = do + Env {currentLinkPath} <- ask + Path.remove currentLinkPath + & modifyError CurrentLinkRemoveError + +showSetCurrentError :: SetCurrentError -> Text +showSetCurrentError = \case + UnsetCurrentError cause -> showUnsetCurrentError cause + CurrentLinkError cause -> Path.showCreateDirectoryLinkError cause + +-- | Error thrown by 'setCurrent'. +-- +-- @since 0.1.0.0 +data SetCurrentError + = UnsetCurrentError !UnsetCurrentError + -- ^ Error was encountered during 'unsetCurrent'. + | CurrentLinkError !Path.CreateDirectoryLinkError + -- ^ Unable to create a directory link 'PFile.Env.currentLinkPath' pointing + -- at a new current 'Profile'. + +showUnsetCurrentError :: UnsetCurrentError -> Text +showUnsetCurrentError = \case + CurrentLinkRemoveError cause + -> "Unable to remove current profile link because of: " + <> Path.showRemoveError cause + +-- | Error thrown by 'unsetCurrent'. +-- +-- @since 0.1.0.0 +newtype UnsetCurrentError + = CurrentLinkRemoveError Path.RemoveError + -- ^ Unable to remove a directory link 'PFile.Env.currentLinkPath'. diff --git a/src/PFile/Profile/Internal/Lifetime.hs b/src/PFile/Profile/Internal/Lifetime.hs new file mode 100644 --- /dev/null +++ b/src/PFile/Profile/Internal/Lifetime.hs @@ -0,0 +1,201 @@ +{- | +Module: PFile.Profile.Internal.Lifetime +Copyright: (c) 2024 Illia Shkroba +License: BSD3 +Maintainer: Illia Shkroba +Stability: unstable +Portability: non-portable (Non-Unix systems are not supported) + +Types and functions for managing profiles lifetime. +-} + +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TupleSections #-} + +module PFile.Profile.Internal.Lifetime + ( create + , showCreateError + , CreateError (..) + , showCreateRollbackCause + , CreateRollbackCause (..) + , CreateOptions (..) + ) where + +import Control.Monad.Writer (execWriterT) +import PFile.Env (Env) +import PFile.Error + ( fallback + , modifyError + , tellError + ) +import qualified PFile.Log as Log +import qualified PFile.Mount as Mount +import qualified PFile.Path as Path +import PFile.Profile.Internal.Profile + ( Entry (..) + , Name (..) + , Profile (..) + , State (..) + , profileRoot + ) +import PFile.Profile.Internal.Registry + ( PopError + , PushError + , pop + , pushAll + , showPopError + , showPushError + ) +import PFile.Profile.Internal.Serialization + ( DumpError + , dump + , load + , showDumpError + , showLoadError + ) +import qualified PFile.Profile.LinkHandling as LinkHandling +import Protolude hiding (state) + +-- | Create a new profile called 'PFile.Profile.Internal.Profile.Name' with +-- a list of 'PFile.Path.Absolute' filesystem's objects to be +-- 'PFile.Profile.Internal.Registry.push'ed inside of +-- a 'PFile.Env.profilesHomeDirPath' directory. When an error is encountered +-- during 'PFile.Profile.Internal.Registry.pushAll', 'create' attempts to +-- rollback. If the rollback fails, the profile is considered +-- 'PFile.Profile.Internal.Profile.Dangling'. Only +-- 'PFile.Profile.Internal.Profile.Valid' profiles are returned. +-- +-- @since 0.1.0.0 +create :: + forall m. (MonadReader Env m, MonadError CreateError m, MonadIO m) + => CreateOptions + -- ^ Options that control 'create' behaviour (currently only + -- 'linkHandlingStrategy'). + -> Name + -- ^ 'PFile.Profile.Internal.Profile.Name' of a profile to be created. The + -- name will be used as a directory name for the profile in + -- 'PFile.Env.profilesHomeDirPath'. + -> [Path.Absolute] + -- ^ List of 'PFile.Path.Absolute' paths of filesystem's objects to be + -- 'PFile.Profile.Internal.Registry.push'ed into a profile. + -> m Profile +create CreateOptions {linkHandlingStrategy} name originPaths = do + load name & runExceptT >>= either + (Log.info . showLoadError) + (const . throwError $ ProfileAlreadyExistsError name) + entries <- pushAll linkHandlingStrategy name originPaths + & fallback rollbackMounts . modifyError PushError + let profile = Profile {name, state = Valid, entries} + dump profile & runExceptT >>= flip either pure + \error -> rollbackMounts (DumpError error) entries + pure profile + where + rollbackMounts :: CreateRollbackCause -> [Entry] -> m () + rollbackMounts cause entries = do + root <- profileRoot name + entries + & traverse_ (\entry -> pop name (mountPath entry) & tellError (entry, )) + & execWriterT >>= \case + errors@(_:_) -> + -- Since we were unable to rollback all the 'mount' calls, some of + -- the paths are still in the profile. Thus, we should: + -- + -- * allow user to retrieve the paths from the created profile, + -- * dump the profile as "dangling", since it wasn't fully created + -- + -- 'dump' of "dangling" profile could also fail. In this case, the + -- user should be informed appropriately. + dump Profile {name, state = Dangling, entries = fst <$> errors} + & fmap leftToMaybe . runExceptT + <&> PushRollbackError cause errors root + >>= throwError + [] -> do + -- Since we were able to rollback all the 'mount' calls, we can + -- remove partially created profile and then interrupt. + Path.remove root + & void . runExceptT + throwError $ PushCreateError cause + +showCreateError :: CreateError -> Text +showCreateError = \case + ProfileAlreadyExistsError (Name name) + -> "Profile named \"" <> name <> "\" already exists." + PushRollbackError rollbackCause rollbackErrors root maybeDumpError + -> "`new` has failed" + <> " with the following error: " <> showCreateRollbackCause rollbackCause + <> "\nAttempt to unmount paths has failed" + <> " with the following errors:\n" <> showRollbackErrors rollbackErrors + <> "Dangling profile with mounted paths could be found here: " + <> Path.showAbsolute root + <> maybe "." showDumpDanglingError maybeDumpError + PushCreateError cause -> showCreateRollbackCause cause + where + showRollbackErrors :: [(Entry, PopError)] -> Text + showRollbackErrors = unlines . fmap + \(Entry {mountPath = Mount.Mount mountPath, originPath}, error) + -> Path.showAbsolute originPath + <> " -> " <> Path.showAbsolute mountPath <> " (" + <> showPopError error <> ")" + + showDumpDanglingError :: DumpError -> Text + showDumpDanglingError cause + = "\nThe profile was not marked as dangling, so you would have to" + <> " remove it (and recover entries stored in it) manually: " + <> showDumpError cause + +-- | Error thrown by 'create'. +-- +-- @since 0.1.0.0 +data CreateError + = ProfileAlreadyExistsError !Name + -- ^ 'PFile.Profile.Internal.Profile.Profile with + -- 'PFile.Profile.Internal.Profile.Name' was found in + -- 'PFile.Env.profilesHomeDirPath'. + | PushRollbackError + -- ^ 'create' attempted to rollback due to 'CreateRollbackCause'. The + -- rollback has failed with a list of + -- 'PFile.Profile.Internal.Registry.PopError's. Since the rollback has + -- failed, the profile passed to 'create' is considered + -- 'PFile.Profile.Internal.Profile.Dangling'. + !CreateRollbackCause + -- ^ Cause of rollback. + ![(Entry, PopError)] + -- ^ List of errors encountered during rollback. + !Path.Absolute + -- ^ Path to a profile's root directory. + !(Maybe DumpError) + -- ^ Possible error that could appear during + -- 'PFile.Profile.Internal.Serialization.dump' attempt of the profile. + | PushCreateError !CreateRollbackCause + -- ^ 'create' attempted to rollback due to 'CreateRollbackCause'. The + -- rollback has succeeded. The profile passed to 'create' was not created. + +showCreateRollbackCause :: CreateRollbackCause -> Text +showCreateRollbackCause = \case + PushError cause -> showPushError cause + DumpError cause -> showDumpError cause + +-- | 'create' rollback cause. +-- +-- @since 0.1.0.0 +data CreateRollbackCause + = PushError !PushError + -- ^ Error was encountered during 'PFile.Profile.Internal.Registry.pushAll'. + | DumpError !DumpError + -- ^ Error was encountered during + -- 'PFile.Profile.Internal.Serialization.dump'. + +-- | 'create' options. +-- +-- @since 0.1.0.0 +newtype CreateOptions + = CreateOptions + { linkHandlingStrategy :: LinkHandling.Strategy + -- ^ 'PFile.Profile.LinkHandling.Strategy' to be used when + -- 'PFile.Profile.Internal.Registry.push'ing a link into a profile. + } diff --git a/src/PFile/Profile/Internal/List.hs b/src/PFile/Profile/Internal/List.hs new file mode 100644 --- /dev/null +++ b/src/PFile/Profile/Internal/List.hs @@ -0,0 +1,109 @@ +{- | +Module: PFile.Profile.Internal.List +Copyright: (c) 2024 Illia Shkroba +License: BSD3 +Maintainer: Illia Shkroba +Stability: unstable +Portability: non-portable (Non-Unix systems are not supported) + +Types and functions for listing profiles. +-} + +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module PFile.Profile.Internal.List + ( list + , showListError + , ListError (..) + , ListOptions (..) + ) where + +import PFile.Env (Env (..)) +import PFile.Error (liftIOWithError) +import qualified PFile.Log as Log +import PFile.Path + ( doesPathExist + , listDirectory + , takeBaseName + ) +import qualified PFile.Path as Path +import PFile.Profile.Internal.Profile + ( Name (..) + , Profile (..) + , State (..) + ) +import PFile.Profile.Internal.Serialization (load, showLoadError) +import Protolude hiding (list, state) + +-- | List profiles in 'PFile.Env.profilesHomeDirPath' directory. +-- +-- @since 0.1.0.0 +list :: + forall m. (MonadReader Env m, MonadError ListError m, MonadIO m) + => ListOptions + -- ^ Options that control 'list' behaviour (currently only + -- 'shouldFilterDangling'). + -> m [Profile] +list ListOptions {shouldFilterDangling} = do + Env {profilesHomeDirPath} <- ask + unlessM (doesPathExist profilesHomeDirPath) . throwError + $ ProfilesHomeDirDoesNotExistError profilesHomeDirPath + Log.info + $ "List profile names in " + <> Path.showAbsolute profilesHomeDirPath + names <- listDirectory profilesHomeDirPath + `liftIOWithError` ListDirectoryError profilesHomeDirPath + <&> fmap (Name . toS . takeBaseName) + Log.info $ "Load profiles: " <> show (unName <$> names) + profiles <- catMaybes <$> forM names \name -> + load name & runExceptT >>= \case + Left error -> do + Log.warning $ showLoadError error + pure Nothing + Right profile -> pure $ Just profile + if shouldFilterDangling + then do + Log.info "Filter Dangling profiles" + filterDangling profiles + else pure profiles + where + filterDangling :: [Profile] -> m [Profile] + filterDangling = filterM \Profile {name, state} -> + case state of + Dangling -> do + Log.warning $ "Found Dangling profile: \"" <> unName name <> "\"" + pure False + Valid -> pure True + +showListError :: ListError -> Text +showListError = \case + ProfilesHomeDirDoesNotExistError path + -> "Profiles home directory " <> Path.showAbsolute path + <> " does not exist." + ListDirectoryError path cause + -> "Unable to list profiles home directory " <> Path.showAbsolute path + <> " because of: " <> show cause + +-- | Error thrown by 'list'. +-- +-- @since 0.1.0.0 +data ListError + = ProfilesHomeDirDoesNotExistError !Path.Absolute + -- ^ 'PFile.Env.profilesHomeDirPath' does not exist. + | ListDirectoryError !Path.Absolute !IOException + -- ^ 'IOException' was encountered during directory listing. + +-- | 'list' options. +-- +-- @since 0.1.0.0 +newtype ListOptions + = ListOptions + { shouldFilterDangling :: Bool + -- ^ Whether 'list' should filter out + -- 'PFile.Profile.Internal.Profile.Dangling' profiles. + } diff --git a/src/PFile/Profile/Internal/Profile.hs b/src/PFile/Profile/Internal/Profile.hs new file mode 100644 --- /dev/null +++ b/src/PFile/Profile/Internal/Profile.hs @@ -0,0 +1,127 @@ +{- | +Module: PFile.Profile.Internal.Profile +Copyright: (c) 2024 Illia Shkroba +License: BSD3 +Maintainer: Illia Shkroba +Stability: unstable +Portability: non-portable (Non-Unix systems are not supported) + +Core types and functions related to profiles. +-} + +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} + +module PFile.Profile.Internal.Profile + ( absoluteRoot + , profileState + , profileRoot + , Profile (..) + , Name (..) + , State (..) + , Entry (..) + ) where + +import Control.Monad (MonadFail (..)) +import Data.Aeson (FromJSON (..), ToJSON (..), withText) +import PFile.Env (Env (..)) +import qualified PFile.Mount as Mount +import PFile.Path (()) +import qualified PFile.Path as Path +import Protolude hiding (State) + +-- | Get directory path where entries of a 'Profile' named 'Name' are stored. +-- +-- @since 0.1.0.0 +absoluteRoot :: MonadReader Env m => Name -> m Mount.Root +absoluteRoot name = do + root <- profileRoot name + root "absolute" + & pure . Mount.Root + +-- | Get file path where serialized 'Profile' named 'Name' is stored. +-- +-- @since 0.1.0.0 +profileState :: MonadReader Env m => Name -> m Path.Absolute +profileState name = profileRoot name <&> ( "state.json") + +-- | Get directory path where 'absoluteRoot' and 'profileState' of a 'Profile' +-- named 'Name' are located. +-- +-- @since 0.1.0.0 +profileRoot :: MonadReader Env m => Name -> m Path.Absolute +profileRoot (Name name) = do + Env {profilesHomeDirPath} <- ask + pure $ profilesHomeDirPath toS name + +-- | 'Profile' holds a list of 'Entry'ies. +-- +-- @since 0.1.0.0 +data Profile + = Profile + { name :: !Name + -- ^ 'Name' of a 'Profile'. + , state :: !State + -- ^ Current 'State' of a 'Profile'. + , entries :: ![Entry] + -- ^ List of a 'Profile' 'Entry'ies. + } + deriving (Generic) + +instance FromJSON Profile +instance ToJSON Profile + +-- | 'Name' of a 'Profile'. +-- +-- @since 0.1.0.0 +newtype Name + = Name { unName :: Text } + deriving newtype (FromJSON, ToJSON) + +-- | 'Profile's state. +-- +-- @since 0.1.0.0 +data State + = Dangling + -- ^ When an error is encountered during + -- 'PFile.Profile.Internal.Registry.pushAll', + -- 'PFile.Profile.Internal.Lifetime.create' attempts to rollback. If the + -- rollback fails, the profile is considered 'Dangling'. + | Valid + -- ^ When 'PFile.Profile.Internal.Lifetime.create' succeeds, the created + -- profile has 'Valid' state. + +instance FromJSON State where + parseJSON = withText "State" \case + "dangling" -> pure Dangling + "valid" -> pure Valid + s -> fail . toS $ "Unable to parse State: " <> s + +instance ToJSON State where + toJSON = \case + Dangling -> "dangling" + Valid -> "valid" + +-- | 'Entry' represents a filesystem's object (directory, directory link, file, +-- file link) that is 'PFile.Mount.mount'ed (or +-- 'PFile.Profile.Internal.Registry.push'ed) inside of a 'Profile'. +-- +-- @since 0.1.0.0 +data Entry + = Entry + { mountPath :: !Mount.Mount + -- ^ Path to a filesystem's object mounted inside of a 'Profile'. + , originPath :: !Path.Absolute + -- ^ Path to a filesystem's object original location before + -- 'PFile.Profile.Internal.Registry.push'ing to a 'Profile'. + } + deriving (Generic) + +instance FromJSON Entry +instance ToJSON Entry diff --git a/src/PFile/Profile/Internal/Registry.hs b/src/PFile/Profile/Internal/Registry.hs new file mode 100644 --- /dev/null +++ b/src/PFile/Profile/Internal/Registry.hs @@ -0,0 +1,227 @@ +{- | +Module: PFile.Profile.Internal.Registry +Copyright: (c) 2024 Illia Shkroba +License: BSD3 +Maintainer: Illia Shkroba +Stability: unstable +Portability: non-portable (Non-Unix systems are not supported) + +Types and functions for managing profiles entries. +-} + +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} + +module PFile.Profile.Internal.Registry + ( pushAll + , push + , showPushError + , PushError (..) + , pop + , showPopError + , PopError (..) + , linkAll + , link + , showLinkError + , LinkError (..) + , unpackAll + , unpack + , showUnpackError + , UnpackError (..) + ) where + +import Control.Monad.Writer (MonadWriter (..)) +import PFile.Env (Env) +import PFile.Error (modifyError) +import qualified PFile.Log as Log +import qualified PFile.Mount as Mount +import PFile.Path + ( CopyError + , copy + , createLink + , showCopyError + ) +import qualified PFile.Path as Path +import PFile.Profile.Internal.Profile (Entry, Name (..), absoluteRoot) +import qualified PFile.Profile.Internal.Profile as Entry (Entry (..)) +import qualified PFile.Profile.LinkHandling as LinkHandling +import Protolude hiding (link) + +-- | 'push' a list of 'PFile.Path.Absolute' inside of +-- a 'PFile.Profile.Internal.Profile.Profile' named 'Name' with a chosen +-- 'PFile.Profile.LinkHandling.Strategy' for links. When an error is +-- encountered during 'push', 'pushAll' terminates and provides successfully +-- 'push'ed entries via a 'MonadWriter'. +-- +-- @since 0.1.0.0 +pushAll :: + ( MonadReader Env m + , MonadError PushError m + , MonadWriter [Entry] m + , MonadIO m + ) + => LinkHandling.Strategy + -> Name + -> [Path.Absolute] + -> m () +pushAll linkHandlingStrategy name = traverse_ \originPath -> + push linkHandlingStrategy name originPath + >>= \mountPath -> tell [Entry.Entry {Entry.mountPath, Entry.originPath}] + +-- | 'PFile.Mount.mount' a 'PFile.Path.Absolute' inside of +-- a 'PFile.Profile.Internal.Profile.Profile' named 'Name' with a chosen +-- 'PFile.Profile.LinkHandling.Strategy' for links. +-- +-- @since 0.1.0.0 +push :: + (MonadReader Env m, MonadError PushError m, MonadIO m) + => LinkHandling.Strategy + -> Name + -> Path.Absolute + -> m Mount.Mount +push linkHandlingStrategy name originPath = do + type_ <- Path.typeOf originPath + Log.info + $ "Push " + <> Path.showAbsolute originPath + <> " (" <> maybe "unknown" Path.showType type_ <> ")" + <> " into profile \"" <> unName name <> "\"" + <> " with link handling strategy " + <> "\"" <> LinkHandling.showStrategy linkHandlingStrategy <> "\"" + root <- absoluteRoot name + mountPath <- Mount.mount linkHandlingStrategy root originPath + & modifyError PushError + Log.info + $ "Pushed " + <> Path.showAbsolute originPath + <> " into profile \"" <> unName name <> "\"" + pure mountPath + +showPushError :: PushError -> Text +showPushError = \case + PushError cause -> Mount.showMountError cause + +-- | Error thrown by 'push'. +-- +-- @since 0.1.0.0 +newtype PushError + = PushError Mount.MountError + -- ^ Error was encountered during 'PFile.Mount.mount'. + +-- | 'PFile.Mount.unmount' a 'PFile.Mount.Mount' from +-- a 'PFile.Profile.Internal.Profile.Profile' named 'Name' back to its original +-- location at 'PFile.Path.Absolute'. +-- +-- @since 0.1.0.0 +pop :: + (MonadReader Env m, MonadError PopError m, MonadIO m) + => Name + -> Mount.Mount + -> m Path.Absolute +pop name mountPath = do + type_ <- Path.typeOf . Mount.absolute $ mountPath + Log.info + $ "Pop " + <> Path.showAbsolute (Mount.absolute mountPath) + <> " (" <> maybe "unknown" Path.showType type_ <> ")" + <> " from profile \"" <> unName name <> "\"" + root <- absoluteRoot name + originPath <- Mount.unmount root mountPath + & modifyError PopError + Log.info + $ "Popped " + <> Path.showAbsolute (Mount.absolute mountPath) + <> " from profile \"" <> unName name <> "\"" + pure originPath + +showPopError :: PopError -> Text +showPopError = \case + PopError cause -> Mount.showUnmountError cause + +-- | Error thrown by 'pop'. +-- +-- @since 0.1.0.0 +newtype PopError + = PopError Mount.UnmountError + -- ^ Error was encountered during 'PFile.Mount.unmount'. + +-- | 'link' a list of 'Entry'ies. For each 'Entry' a link at +-- 'PFile.Profile.Internal.Profile.originPath' will be created pointing at +-- 'PFile.Profile.Internal.Profile.mountPath'. When an error is encountered +-- during 'link', 'linkAll' terminates and provides successfully 'link'ed +-- entries via a 'MonadWriter'. +-- +-- @since 0.1.0.0 +linkAll :: + (MonadError LinkError m, MonadWriter [Path.Absolute] m, MonadIO m) + => [Entry] + -> m () +linkAll = traverse_ \Entry.Entry {Entry.mountPath, Entry.originPath} -> + [originPath] <$ link mountPath originPath >>= tell + +-- | Create a link at 'PFile.Path.Absolute' pointing at 'PFile.Mount.Mount'. +-- +-- @since 0.1.0.0 +link :: + (MonadError LinkError m, MonadIO m) + => Mount.Mount + -> Path.Absolute + -> m () +link mountPath originPath = + createLink (Mount.absolute mountPath) originPath + & modifyError LinkError + +showLinkError :: LinkError -> Text +showLinkError = \case + LinkError cause -> Path.showCreateLinkError cause + +-- | Error thrown by 'link'. +-- +-- @since 0.1.0.0 +newtype LinkError + = LinkError Path.CreateLinkError + -- ^ Unable to create a link at 'PFile.Path.Absolute' pointing at + -- 'PFile.Mount.Mount'. + +-- | 'unpack' a list of 'Entry'ies. For each 'Entry' +-- a 'PFile.Profile.Internal.Profile.mountPath' will be copied to +-- 'PFile.Profile.Internal.Profile.originPath'. When an error is encountered +-- during 'unpack', 'unpackAll' terminates and provides successfully 'unpack'ed +-- entries via a 'MonadWriter'. +-- +-- @since 0.1.0.0 +unpackAll :: + (MonadError UnpackError m, MonadWriter [Path.Absolute] m, MonadIO m) + => [Entry] + -> m () +unpackAll = traverse_ \Entry.Entry {Entry.mountPath, Entry.originPath} -> + [originPath] <$ unpack mountPath originPath >>= tell + +-- | Copy filesystem's object at 'PFile.Mount.Mount' to 'PFile.Path.Absolute'. +-- +-- @since 0.1.0.0 +unpack :: + (MonadError UnpackError m, MonadIO m) + => Mount.Mount + -> Path.Absolute + -> m () +unpack mountPath originPath = + copy (Mount.absolute mountPath) originPath + & modifyError (UnpackError mountPath originPath) + +showUnpackError :: UnpackError -> Text +showUnpackError = \case + UnpackError (Mount.Mount src) dest cause + -> "Unable to unpack " <> Path.showAbsolute src + <> " to " <> Path.showAbsolute dest + <> " because of: " <> showCopyError cause + +-- | Error thrown by 'unpack'. +-- +-- @since 0.1.0.0 +data UnpackError + = UnpackError !Mount.Mount !Path.Absolute !CopyError + -- ^ Unable to copy 'PFile.Mount.Mount' to 'PFile.Path.Absolute'. diff --git a/src/PFile/Profile/Internal/Serialization.hs b/src/PFile/Profile/Internal/Serialization.hs new file mode 100644 --- /dev/null +++ b/src/PFile/Profile/Internal/Serialization.hs @@ -0,0 +1,112 @@ +{- | +Module: PFile.Profile.Internal.Serialization +Copyright: (c) 2024 Illia Shkroba +License: BSD3 +Maintainer: Illia Shkroba +Stability: unstable +Portability: non-portable (Non-Unix systems are not supported) + +Types and functions for profiles serialization. +-} + +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} + +module PFile.Profile.Internal.Serialization + ( load + , showLoadError + , LoadError (..) + , dump + , showDumpError + , DumpError (..) + ) where + +import Data.Aeson + ( eitherDecodeFileStrict + , encodeFile + ) +import PFile.Aeson (encodePretty) +import PFile.Env (Env) +import PFile.Error (liftIOWithError, modifyError) +import qualified PFile.Log as Log +import qualified PFile.Path as Path +import PFile.Profile.Internal.Profile + ( Name (..) + , Profile (..) + , profileState + ) +import Protolude + +-- | Load 'Profile' named 'Name' from its +-- 'PFile.Profile.Internal.Profile.profileState'. +-- +-- @since 0.1.0.0 +load :: + (MonadReader Env m, MonadError LoadError m, MonadIO m) => Name -> m Profile +load name = do + statePath <- profileState name + Log.info + $ "Load profile \"" <> unName name <> "\" from state: " + <> Path.showAbsolute statePath + profile <- eitherDecodeFileStrict (Path.unAbsolute statePath) + `liftIOWithError` LoadError statePath + >>= either (throwError . DecodeError statePath) pure + Log.info + $ "Loaded profile \"" <> unName name <> "\":\n" + <> encodePretty profile + pure profile + +showLoadError :: LoadError -> Text +showLoadError = \case + LoadError path cause + -> "Unable to load profile from " <> Path.showAbsolute path + <> " because of: " <> show cause + DecodeError path cause + -> "Unable to decode profile from " <> Path.showAbsolute path + <> " because of: \"" <> toS cause <> "\"." + +-- | Error thrown by 'load'. +-- +-- @since 0.1.0.0 +data LoadError + = LoadError !Path.Absolute !IOException + -- ^ 'IOException' was encountered during 'eitherDecodeFileStrict'. + | DecodeError !Path.Absolute ![Char] + -- ^ Decoding error was encountered during 'eitherDecodeFileStrict'. + +-- | Dump 'Profile' to its 'PFile.Profile.Internal.Profile.profileState'. +-- +-- @since 0.1.0.0 +dump :: + (MonadReader Env m, MonadError DumpError m, MonadIO m) => Profile -> m () +dump profile@Profile {name} = do + Log.info + $ "Dump profile \"" <> unName name <> "\":\n" + <> encodePretty profile + statePath <- profileState name + Path.createParent statePath + & modifyError CreateParentInDumpError + encodeFile (Path.unAbsolute statePath) profile + `liftIOWithError` DumpError statePath + Log.info + $ "Dumped profile \"" <> unName name <> "\" to state: " + <> Path.showAbsolute statePath + +showDumpError :: DumpError -> Text +showDumpError = \case + CreateParentInDumpError cause -> Path.showCreateParentError cause + DumpError path cause + -> "Unable to dump profile to " <> Path.showAbsolute path + <> " because of: " <> show cause + +-- | Error thrown by 'dump'. +-- +-- @since 0.1.0.0 +data DumpError + = CreateParentInDumpError !Path.CreateParentError + -- ^ Unable to create a parent directory for + -- 'PFile.Profile.Internal.Profile.profileState'. + | DumpError !Path.Absolute !IOException + -- ^ 'IOException' was encountered during 'encodeFile'. diff --git a/src/PFile/Profile/Internal/Switch.hs b/src/PFile/Profile/Internal/Switch.hs new file mode 100644 --- /dev/null +++ b/src/PFile/Profile/Internal/Switch.hs @@ -0,0 +1,421 @@ +{- | +Module: PFile.Profile.Internal.Switch +Copyright: (c) 2024 Illia Shkroba +License: BSD3 +Maintainer: Illia Shkroba +Stability: unstable +Portability: non-portable (Non-Unix systems are not supported) + +Types and functions for profiles switching. +-} + +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TupleSections #-} + +module PFile.Profile.Internal.Switch + ( switch + , unlink + , validateLinkedEntry + , link + , unpack + , validateUnlinkedEntry + , purge + , showSwitchError + , SwitchError (..) + , showUnlinkError + , UnlinkError (..) + , showLinkedEntryValidateError + , LinkedEntryValidateError (..) + , showLinkError + , LinkError (..) + , showUnpackError + , UnpackError (..) + , showUnlinkedEntryValidateError + , UnlinkedEntryValidateError (..) + , showPurgeError + , PurgeError (..) + , SwitchOptions (..) + ) where + +import Control.Monad.Writer (execWriterT) +import PFile.Error + ( fallback + , liftIOWithError + , modifyError + , tellError + ) +import qualified PFile.Mount as Mount +import PFile.Path + ( canonicalizePath + , doesPathExist + ) +import qualified PFile.Path as Path +import PFile.Profile.Internal.Profile + ( Entry (..) + , Name (..) + , Profile (..) + ) +import PFile.Profile.Internal.Registry (linkAll, unpackAll) +import qualified PFile.Profile.Internal.Registry as Registry +import PFile.TrashCan (TrashCan (..)) +import qualified PFile.TrashCan as TrashCan +import Protolude hiding (link) + +-- | Switch from the current profile to the next profile. 'switch' 'unlink's +-- the current profile and then 'link's the next profile. +-- +-- @since 0.1.0.0 +switch :: + (MonadError SwitchError m, MonadIO m) + => SwitchOptions + -- ^ Options that control 'switch' behaviour (currently only + -- 'forceRemoveOccupied'). + -> Profile + -- ^ Current profile. + -> Profile + -- ^ Next profile. + -> m () +switch options current next = do + unlink options current + & modifyError UnlinkCurrentError + link options next + & modifyError LinkNextError + +-- | Remove links pointing at entries inside of the 'Profile'. 'unlink' only +-- remove links that are know to PFile. +-- +-- @since 0.1.0.0 +unlink :: + (MonadError UnlinkError m, MonadIO m) + => SwitchOptions + -> Profile + -> m () +unlink SwitchOptions {forceRemoveOccupied} profile@Profile {entries} = do + unless forceRemoveOccupied + $ forM_ entries + (modifyError ValidateUnlinkError . validateLinkedEntry) + purge profile + & modifyError PurgeUnlinkError + +-- | Validate that 'Entry's 'originPath' is a link pointing at 'mountPath'. +-- +-- @since 0.1.0.0 +validateLinkedEntry :: + (MonadError LinkedEntryValidateError m, MonadIO m) => Entry -> m () +validateLinkedEntry entry@Entry {mountPath = Mount.Mount mountPath, originPath} = do + unlessM (doesPathExist originPath) . throwError + $ OriginDoesNotExistError originPath + canonicalizedPath <- canonicalizePath originPath + `liftIOWithError` OriginCanonicalizeError originPath + unless (canonicalizedPath == mountPath) . throwError + $ OriginChangedError entry canonicalizedPath + +-- | Create links pointing at 'Entry'ies inside of the 'Profile' with +-- 'PFile.Profile.Internal.Registry.linkAll'. +-- +-- @since 0.1.0.0 +link :: + forall m. (MonadError LinkError m, MonadIO m) + => SwitchOptions + -> Profile + -> m () +link SwitchOptions {forceRemoveOccupied} profile@Profile {entries} = do + if forceRemoveOccupied + then + purge profile + & modifyError PurgeLinkError + else + forM_ entries + (modifyError ValidateLinkError . validateUnlinkedEntry) + linkAll entries + & void . fallback rollbackLinks + where + rollbackLinks :: Registry.LinkError -> [Path.Absolute] -> m () + rollbackLinks cause originPaths = originPaths + & traverse_ (\p -> Path.remove p & tellError (p, )) + & execWriterT >>= \case + errors@(_:_) -> throwError $ LinkRollbackError cause errors profile + [] -> throwError $ LinkError cause + +-- | Unpack 'Profile's entries back to their original locations with +-- 'PFile.Profile.Internal.Registry.unpackAll'. +-- +-- @since 0.1.0.0 +unpack :: + forall m. (MonadError UnpackError m, MonadIO m) + => SwitchOptions + -> Profile + -> m () +unpack options@SwitchOptions {forceRemoveOccupied} profile@Profile {entries} = do + if forceRemoveOccupied + then + purge profile + & modifyError PurgeUnpackError + else + unlink options profile + & modifyError UnlinkUnpackError + unpackAll entries + & void . fallback rollbackUnpacked + where + rollbackUnpacked :: Registry.UnpackError -> [Path.Absolute] -> m () + rollbackUnpacked cause originPaths = originPaths + & traverse_ (\p -> Path.remove p & tellError (p, )) + & execWriterT >>= \case + errors@(_:_) -> throwError $ UnpackRollbackError cause errors profile + [] -> throwError $ UnpackError cause + +-- | Validate that 'Entry's 'originPath' does not exist. +-- +-- @since 0.1.0.0 +validateUnlinkedEntry :: + (MonadError UnlinkedEntryValidateError m, MonadIO m) => Entry -> m () +validateUnlinkedEntry entry@Entry {originPath} = + whenM (doesPathExist originPath) . throwError + $ OriginOccupiedError entry + +-- | Forcibly remove 'originPath's of a 'Profile's 'Entry'ies. +-- +-- @since 0.1.0.0 +purge :: + forall m. (MonadError PurgeError m, MonadIO m) + => Profile + -> m () +purge profile@Profile {entries} = do + trashCan <- TrashCan.create + & modifyError TrashCanCreateError + trashOrigins trashCan entries + `catchError` rollbackTrashOrigins trashCan + TrashCan.remove trashCan + & modifyError TrashCanRemoveError + where + trashOrigins :: TrashCan -> [Entry] -> m () + trashOrigins trashCan = traverse_ \Entry {originPath} -> + TrashCan.trash originPath trashCan + & hushMissingError + & modifyError TrashError + + hushMissingError :: MonadError TrashCan.TrashError m' => m' () -> m' () + hushMissingError = flip catchError \case + TrashCan.MountError Mount.OriginMissingError {} -> pure () + e -> throwError e + + rollbackTrashOrigins :: TrashCan -> PurgeError -> m () + rollbackTrashOrigins trashCan cause = + TrashCan.restoreAll trashCan & execWriterT >>= \case + errors@(_:_) -> TrashCan.dumpTrashed trashCan & runExceptT + >>= either (const $ TrashCan.trashed trashCan <&> Left) (pure . Right) + >>= throwError . PurgeRollbackError cause errors profile trashCan + [] -> do + TrashCan.remove trashCan + & modifyError TrashCanRemoveError + throwError cause + +showSwitchError :: SwitchError -> Text +showSwitchError = \case + UnlinkCurrentError cause -> showUnlinkError cause + LinkNextError cause -> showLinkError cause + +-- | Error thrown by 'switch'. +-- +-- @since 0.1.0.0 +data SwitchError + = UnlinkCurrentError !UnlinkError + -- ^ Error was encountered during 'unlink'. + | LinkNextError !LinkError + -- ^ Error was encountered during 'link'. + +showUnlinkError :: UnlinkError -> Text +showUnlinkError = \case + ValidateUnlinkError cause -> showLinkedEntryValidateError cause + PurgeUnlinkError cause -> showPurgeError cause + +-- | Error thrown by 'unlink'. +-- +-- @since 0.1.0.0 +data UnlinkError + = ValidateUnlinkError !LinkedEntryValidateError + -- ^ Validation error of entries was encountered. + | PurgeUnlinkError !PurgeError + -- ^ Error was encountered during 'purge'. + +showLinkedEntryValidateError :: LinkedEntryValidateError -> Text +showLinkedEntryValidateError = \case + OriginDoesNotExistError path + -> "Origin " <> Path.showAbsolute path <> " does not exist." + OriginCanonicalizeError path cause + -> "Unable to resolve path " <> Path.showAbsolute path + <> " because of: " <> show cause + OriginChangedError Entry {mountPath = Mount.Mount mountPath, originPath} actual + -> "Expected " <> Path.showAbsolute originPath + <> " to be a link pointing at " <> Path.showAbsolute mountPath + <> ". Instead it resolves to " <> Path.showAbsolute actual <> "." + +-- | Error thrown by 'validateLinkedEntry'. +-- +-- @since 0.1.0.0 +data LinkedEntryValidateError + = OriginDoesNotExistError !Path.Absolute + -- ^ 'Entry's 'originPath' does not exist. + | OriginCanonicalizeError !Path.Absolute !IOException + -- ^ Unable to canonicalize 'originPath'. + | OriginChangedError !Entry !Path.Absolute + -- ^ 'originPath' is not a link pointing at 'mountPath'. + +showLinkError :: LinkError -> Text +showLinkError = \case + PurgeLinkError cause -> showPurgeError cause + ValidateLinkError cause -> showUnlinkedEntryValidateError cause + LinkRollbackError rollbackCause rollbackErrors Profile {name = Name name} + -> "Linking of the \"" <> name <> "\" profile has failed" + <> " with the following error: " <> Registry.showLinkError rollbackCause + <> "\nAttempt to remove linked paths has failed" + <> " with the following errors:\n" <> showRollbackErrors rollbackErrors + <> "Please fix the errors above and then remove the links manually." + <> "\n`pfile` is not tracking these links." + LinkError cause -> Registry.showLinkError cause + where + showRollbackErrors :: [(Path.Absolute, Path.RemoveError)] -> Text + showRollbackErrors = unlines . fmap \(originPath, error) -> + Path.showAbsolute originPath <> " (" <> Path.showRemoveError error <> ")" + +-- | Error thrown by 'link'. +-- +-- @since 0.1.0.0 +data LinkError + = PurgeLinkError !PurgeError + -- ^ Error was encountered during 'purge'. + | ValidateLinkError !UnlinkedEntryValidateError + -- ^ Validation error of entries was encountered. + | LinkRollbackError + -- ^ 'link' attempted to rollback due to 'Registry.LinkError'. The rollback + -- has failed with a list of 'PFile.Path.RemoveError's. Since the rollback + -- has failed, the profile passed to 'link' was partially linked - some links + -- were created and should be removed manually. + !Registry.LinkError + -- ^ Cause of rollback. + ![(Path.Absolute, Path.RemoveError)] + -- ^ List of errors encountered during rollback. + !Profile + -- ^ 'Profile' passed to 'link'. + | LinkError !Registry.LinkError + -- ^ 'link' attempted to rollback due to 'Registry.LinkError'. The rollback + -- has succeeded. The profile passed to 'link' was not linked. + +showUnpackError :: UnpackError -> Text +showUnpackError = \case + PurgeUnpackError cause -> showPurgeError cause + UnlinkUnpackError cause -> showUnlinkError cause + UnpackRollbackError rollbackCause rollbackErrors Profile {name = Name name} + -> "Unpacking of the \"" <> name <> "\" profile has failed" + <> " with the following error: " <> Registry.showUnpackError rollbackCause + <> "\nAttempt to remove unpacked paths has failed" + <> " with the following errors:\n" <> showRollbackErrors rollbackErrors + <> "Please fix the errors above and then remove the unpacked paths manually." + <> "\n`pfile` is not tracking these unpacked paths." + UnpackError cause -> Registry.showUnpackError cause + where + showRollbackErrors :: [(Path.Absolute, Path.RemoveError)] -> Text + showRollbackErrors = unlines . fmap \(originPath, error) -> + Path.showAbsolute originPath <> " (" <> Path.showRemoveError error <> ")" + +-- | Error thrown by 'unpack'. +-- +-- @since 0.1.0.0 +data UnpackError + = PurgeUnpackError !PurgeError + -- ^ Error was encountered during 'purge'. + | UnlinkUnpackError !UnlinkError + -- ^ Error was encountered during 'unlink'. + | UnpackRollbackError + -- ^ 'unpack' attempted to rollback due to 'Registry.UnpackError'. The + -- rollback has failed with a list of 'PFile.Path.RemoveError's. Since the + -- rollback has failed, the profile passed to 'unpack' was partially unpacked + -- - some entries were unpacked and should be removed manually. + !Registry.UnpackError + -- ^ Cause of rollback. + ![(Path.Absolute, Path.RemoveError)] + -- ^ List of errors encountered during rollback. + !Profile + -- ^ 'Profile' passed to 'unpack'. + | UnpackError !Registry.UnpackError + +showUnlinkedEntryValidateError :: UnlinkedEntryValidateError -> Text +showUnlinkedEntryValidateError = \case + OriginOccupiedError Entry {mountPath = Mount.Mount mountPath, originPath} + -> "Unable to link origin " <> Path.showAbsolute originPath + <> " to entry " <> Path.showAbsolute mountPath + <> " because the origin is occupied." + +-- | Error thrown by 'validateUnlinkedEntry'. +-- +-- @since 0.1.0.0 +newtype UnlinkedEntryValidateError + = OriginOccupiedError Entry + -- ^ 'Entry's 'originPath' is occupied. + +showPurgeError :: PurgeError -> Text +showPurgeError = \case + TrashCanCreateError cause -> TrashCan.showCreateError cause + TrashError cause -> TrashCan.showTrashError cause + PurgeRollbackError + rollbackCause + rollbackErrors + Profile {name = Name name} + TrashCan {root} + trashed + -> "Purge of the profile's \"" <> name <> "\" origins has failed" + <> " with the following error: " <> showPurgeError rollbackCause + <> "\nTrashed origins restoring has failed with the following errors:\n" + <> (rollbackErrors <&> TrashCan.showRestoreEntryError & unlines) + <> "Trash can with trashed origins could be found here: " + <> Path.showAbsolute root + <> ".\nA list of trashed origins could be found " + <> either + (\paths -> "below:\n" <> unlines (Path.showAbsolute <$> paths)) + (\path -> "in the file: " <> Path.showAbsolute path <> ".") + trashed + TrashCanRemoveError cause -> TrashCan.showRemoveError cause + +-- | Error thrown by 'purge'. +-- +-- @since 0.1.0.0 +data PurgeError + = TrashCanCreateError !TrashCan.CreateError + -- ^ Error was encountered during 'TrashCan.create'. + | TrashError !TrashCan.TrashError + -- ^ Error was encountered during 'TrashCan.trash'. + | PurgeRollbackError + -- ^ 'purge' attempted to rollback due to 'PurgeError'. The rollback has + -- failed with a list of 'TrashCan.RestoreEntryError's. Since the rollback + -- has failed, the 'TrashCan.trash'ed entries of the 'Profile' are still kept + -- inside of the 'TrashCan'. + !PurgeError + -- ^ Cause of rollback. + ![TrashCan.RestoreEntryError] + -- ^ List of errors encountered during rollback. + !Profile + -- ^ 'Profile' passed to 'purge'. + !TrashCan + -- ^ 'TrashCan' where 'TrashCan.trash'ed entries of the 'Profile' are kept. + !(Either [Path.Absolute] Path.Absolute) + -- ^ 'TrashCan's list of 'TrashCan.trash'ed entries is either dumped to + -- a file with 'TrashCan.dumpTrashed' or provided as-is due to + -- 'TrashCan.dumpTrashed' failure. + | TrashCanRemoveError !TrashCan.RemoveError + -- ^ Error was encountered during 'TrashCan.remove'. + +-- | 'switch' options. +-- +-- @since 0.1.0.0 +newtype SwitchOptions + = SwitchOptions + { forceRemoveOccupied :: Bool + -- ^ When 'forceRemoveOccupied' is set, forcibly remove a filesystem's + -- object where a link pointing at an entry inside of the 'Profile' is + -- expected. + } diff --git a/src/PFile/Profile/LinkHandling.hs b/src/PFile/Profile/LinkHandling.hs new file mode 100644 --- /dev/null +++ b/src/PFile/Profile/LinkHandling.hs @@ -0,0 +1,103 @@ +{- | +Module: PFile.Profile.LinkHandling +Copyright: (c) 2024 Illia Shkroba +License: BSD3 +Maintainer: Illia Shkroba +Stability: unstable +Portability: non-portable (Non-Unix systems are not supported) + +Types and functions for handling links. +-} + +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} + +module PFile.Profile.LinkHandling + ( handle + , showError + , Error (..) + , showStrategy + , Strategy (..) + ) where + +import PFile.Error (modifyError) +import PFile.Path + ( copyDirectory + , copyFile + , copyLink + , createDirectory + , createEmptyFile + , doesDirectoryExist + ) +import qualified PFile.Path as Path +import Protolude hiding (handle) + +-- | Handle links relocation with 'Strategy': +-- +-- * 'CopyFromOrigin' - copy source link's target to destination. +-- * 'CreateEmpty' - create an empty directory at destination when source +-- link's target is a directory or create an empty file at destination when +-- source link's target is a file. +-- * 'CopyLink' - copy source link to destination. +-- +-- @since 0.1.0.0 +handle :: + (MonadError Error m, MonadIO m) + => Strategy + -> Path.Absolute + -> Path.Absolute + -> m () +handle strategy src dest = + case strategy of + CopyFromOrigin -> + ifM (doesDirectoryExist src) + (copyDirectory src dest & modifyError CopyDirectoryFromOriginError) + (copyFile src dest & modifyError CopyFileFromOriginError) + CreateEmpty -> + ifM (doesDirectoryExist src) + (createDirectory dest & modifyError CreateEmptyDirectoryError) + (createEmptyFile dest & modifyError CreateEmptyFileError) + CopyLink -> copyLink src dest & modifyError CopyLinkError + +showError :: Error -> Text +showError = \case + CopyDirectoryFromOriginError cause -> Path.showCopyError cause + CopyFileFromOriginError cause -> Path.showCopyFileError cause + CreateEmptyDirectoryError cause -> Path.showCreateDirectoryError cause + CreateEmptyFileError cause -> Path.showWriteFileError cause + CopyLinkError cause -> Path.showCopyLinkError cause + +-- | Error thrown by 'handle'. +-- +-- @since 0.1.0.0 +data Error + = CopyDirectoryFromOriginError !Path.CopyError + -- ^ Error was encountered during 'PFile.Path.copyDirectory'. + | CopyFileFromOriginError !Path.CopyFileError + -- ^ Error was encountered during 'PFile.Path.copyFile'. + | CreateEmptyDirectoryError !Path.CreateDirectoryError + -- ^ Error was encountered during 'PFile.Path.createDirectory'. + | CreateEmptyFileError !Path.WriteFileError + -- ^ Error was encountered during 'PFile.Path.createEmptyFile'. + | CopyLinkError !Path.CopyLinkError + -- ^ Error was encountered during 'PFile.Path.copyLink'. + +showStrategy :: Strategy -> Text +showStrategy = \case + CopyFromOrigin -> "copy from origin" + CreateEmpty -> "create empty" + CopyLink -> "copy link" + +-- | Link handling strategy for directory/file links to be used by 'handle'. +-- +-- @since 0.1.0.0 +data Strategy + = CopyFromOrigin + -- ^ Copy source link's target to destination. + | CreateEmpty + -- ^ Create an empty directory at destination when source link's target is + -- a directory or create an empty file at destination when source link's + -- target is a file. + | CopyLink + -- ^ Copy source link to destination. diff --git a/src/PFile/TrashCan.hs b/src/PFile/TrashCan.hs new file mode 100644 --- /dev/null +++ b/src/PFile/TrashCan.hs @@ -0,0 +1,242 @@ +{- | +Module: PFile.TrashCan +Copyright: (c) 2024 Illia Shkroba +License: BSD3 +Maintainer: Illia Shkroba +Stability: unstable +Portability: non-portable (Non-Unix systems are not supported) + +Types and functions for trashing filesystem's objects. +-} + +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ViewPatterns #-} + +module PFile.TrashCan + ( create + , showCreateError + , CreateError (..) + , trash + , showTrashError + , TrashError (..) + , restoreAll + , restore + , showRestoreEntryError + , RestoreEntryError (..) + , showRestoreError + , RestoreError (..) + , remove + , showRemoveError + , RemoveError (..) + , dumpTrashed + , showDumpTrashedError + , DumpTrashedError (..) + , trashed + , TrashCan (TrashCan, root, dataRoot) + ) where + +import Control.Monad.Writer (MonadWriter) +import Data.IORef + ( IORef + , modifyIORef' + , newIORef + , readIORef + ) +import Data.List (delete) +import PFile.Error + ( liftIOWithError + , modifyError + , tellError + ) +import qualified PFile.Mount as Mount +import PFile.Path (doesPathExist, ()) +import qualified PFile.Path as Path +import qualified PFile.Profile.LinkHandling as LinkHandling +import Protolude +import System.Directory (getTemporaryDirectory) +import System.IO.Temp (createTempDirectory) + +-- | Create a new trash can. +-- +-- @since 0.1.0.0 +create :: (MonadError CreateError m, MonadIO m) => m TrashCan +create = do + temporaryRoot <- getTemporaryDirectory + `liftIOWithError` TemporaryDirectoryResolveError + createTempDirectory temporaryRoot "pfile" + `liftIOWithError` TemporaryDirectoryCreateError (Path.Absolute temporaryRoot) + >>= \(Path.Absolute -> root) -> do + _trashed <- newIORef [] & liftIO + pure TrashCan {root, dataRoot = root "data", _trashed} + +showCreateError :: CreateError -> Text +showCreateError = \case + TemporaryDirectoryResolveError cause + -> "Unable to resolve temporary directory because of: " <> show cause + TemporaryDirectoryCreateError path cause + -> "Unable to create temporary directory in " <> Path.showAbsolute path + <> " because of: " <> show cause + +-- | Error thrown by 'create'. +-- +-- @since 0.1.0.0 +data CreateError + = TemporaryDirectoryResolveError !IOException + -- ^ 'IOException' was encountered during temporary directory resolving. + | TemporaryDirectoryCreateError !Path.Absolute !IOException + -- ^ 'IOException' was encountered during temporary directory creation. + +-- | 'PFile.Mount.mount' 'PFile.Path.Absolute' inside of a 'TrashCan' with +-- 'PFile.Profile.LinkHandling.CopyLink' strategy for links. +-- +-- @since 0.1.0.0 +trash :: + (MonadError TrashError m, MonadIO m) => Path.Absolute -> TrashCan -> m () +trash originPath trashCan@TrashCan {dataRoot, _trashed} = do + let Mount.Mount trashPath = Mount.mountPath (Mount.Root dataRoot) originPath + whenM (doesPathExist trashPath) . throwError + $ AlreadyTrashedError originPath trashCan + Mount.mount LinkHandling.CopyLink (Mount.Root dataRoot) originPath + & modifyError MountError + & void + modifyIORef' _trashed (trashPath :) & liftIO + +showTrashError :: TrashError -> Text +showTrashError = \case + AlreadyTrashedError path TrashCan {root} + -> "Path " <> Path.showAbsolute path + <> " is already trashed in: " <> Path.showAbsolute root <> "." + MountError cause -> Mount.showMountError cause + +-- | Error thrown by 'trash'. +-- +-- @since 0.1.0.0 +data TrashError + = AlreadyTrashedError !Path.Absolute !TrashCan + -- ^ 'PFile.Path.Absolute' is already trashed. + | MountError !Mount.MountError + -- ^ Error was encountered during 'PFile.Mount.mount'. + +-- | 'restore' all 'trash'ed filesystem's objects back to their original +-- locations. When an error is encountered during 'restore', 'restoreAll' +-- terminates and provides successfully 'restore'ed entries via +-- a 'MonadWriter'. +-- +-- @since 0.1.0.0 +restoreAll :: (MonadWriter [RestoreEntryError] m, MonadIO m) => TrashCan -> m () +restoreAll trashCan = trashed trashCan >>= traverse_ \path -> + restore trashCan path + & tellError (RestoreEntryError path) + +-- | 'PFile.Mount.unmount' 'PFile.Path.Absolute' (turned into +-- 'PFile.Mount.Mount') from a 'TrashCan' back to its original location (before +-- 'trash'). +-- +-- @since 0.1.0.0 +restore :: + (MonadError RestoreError m, MonadIO m) => TrashCan -> Path.Absolute -> m () +restore TrashCan {dataRoot, _trashed} path = do + Mount.unmount (Mount.Root dataRoot) (Mount.Mount path) + & modifyError UnmountError + & void + modifyIORef' _trashed (delete path) & liftIO + +showRestoreEntryError :: RestoreEntryError -> Text +showRestoreEntryError = \case + RestoreEntryError path cause + -> "Unable to restore entry " <> Path.showAbsolute path + <> " because of: " <> showRestoreError cause + +-- | Error provided via 'MonadWriter' by 'restoreAll'. +-- +-- @since 0.1.0.0 +data RestoreEntryError + = RestoreEntryError !Path.Absolute !RestoreError + -- ^ Error was encountered during 'restore'. + +showRestoreError :: RestoreError -> Text +showRestoreError = \case + UnmountError cause -> Mount.showUnmountError cause + +-- | Error thrown by 'restore'. +-- +-- @since 0.1.0.0 +newtype RestoreError + = UnmountError Mount.UnmountError + -- ^ Error was encountered during 'PFile.Mount.unmount'. + +-- | Remove a 'TrashCan' forcibly. +-- +-- @since 0.1.0.0 +remove :: (MonadError RemoveError m, MonadIO m) => TrashCan -> m () +remove TrashCan {root} = + Path.remove root + & modifyError TemporaryDirectoryRemoveError + +showRemoveError :: RemoveError -> Text +showRemoveError = \case + TemporaryDirectoryRemoveError cause + -> "Unable to remove temporary directory because of: " + <> Path.showRemoveError cause + +-- | Error thrown by 'remove'. +-- +-- @since 0.1.0.0 +newtype RemoveError + = TemporaryDirectoryRemoveError Path.RemoveError + -- ^ Error was encountered during temporary directory removal. + +-- | Dump 'trashed' to a file inside of the 'root' directory. +-- +-- @since 0.1.0.0 +dumpTrashed :: + (MonadError DumpTrashedError m, MonadIO m) => TrashCan -> m Path.Absolute +dumpTrashed trashCan@TrashCan {root} = do + paths <- trashed trashCan + let dumped = unlines $ toS . Path.unAbsolute <$> paths + Path.writeFile trashedPath dumped + & modifyError DumpTrashedError + pure trashedPath + where + trashedPath :: Path.Absolute + trashedPath = root "trashed.txt" + +showDumpTrashedError :: DumpTrashedError -> Text +showDumpTrashedError = \case + DumpTrashedError cause -> case cause of + Path.CreateParentInWriteFileError {} -> Path.showWriteFileError cause + Path.WriteFileError path ioCause + -> "Unable to dump a list of trashed paths to " <> Path.showAbsolute path + <> " because of: " <> show ioCause + +-- | Error thrown by 'dumpTrashed'. +-- +-- @since 0.1.0.0 +newtype DumpTrashedError + = DumpTrashedError Path.WriteFileError + -- ^ Error was encountered during writing to a "trashed.txt" file inside of + -- the 'root' directory. + +-- | List of 'trash'ed filesystem's objects. +-- +-- @since 0.1.0.0 +trashed :: MonadIO m => TrashCan -> m [Path.Absolute] +trashed TrashCan {_trashed} = readIORef _trashed & liftIO + +-- | Trash can for filesystem's objects. +-- +-- @since 0.1.0.0 +data TrashCan + = TrashCan + { root :: !Path.Absolute + -- ^ Root directory of a 'TrashCan'. + , dataRoot :: !Path.Absolute + -- ^ Directory of a 'TrashCan' where 'trash'ed filesystem's objects are + -- located. + , _trashed :: !(IORef [Path.Absolute]) + -- ^ List of 'trash'ed filesystem's objects in 'IORef'. + } diff --git a/test/PFile/Mount/Tests.hs b/test/PFile/Mount/Tests.hs new file mode 100644 --- /dev/null +++ b/test/PFile/Mount/Tests.hs @@ -0,0 +1,184 @@ +{-# OPTIONS_GHC -Wno-name-shadowing #-} + +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} + +module PFile.Mount.Tests + ( tests + ) where + +import qualified Data.HashSet as Set +import PFile.Mount + ( Mount (..) + , Root (..) + , mount + , mountPath + , originPath + , unmount + ) +import PFile.Mount.Tests.Env () +import PFile.Path + ( doesPathExist + , dropDrive + , findFiles + , () + ) +import qualified PFile.Path as Path +import PFile.Path.Tests (ensureWriteFile) +import qualified PFile.Profile.LinkHandling as LinkHandling +import PFile.Tests.Env (withTempDirectory) +import Protolude +import System.FilePath (()) +import Test.Hspec + ( around + , describe + , it + , shouldBe + , shouldReturn + ) +import Test.HUnit (assertFailure) +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.Hspec (testSpec) +import Test.Tasty.QuickCheck (testProperty) + +tests :: IO TestTree +tests = do + unitTests_ <- unitTests + pure $ testGroup "PFile.Mount" [properties, unitTests_] + +properties :: TestTree +properties = + testGroup + "Properties" + [ testProperty + "`mountPath` removes drive from `path` and attaches result under `root`" + \(Root root) path -> + mountPath (Root root) path == Mount (root dropDrive path) + , testProperty + "`originPath` is an inverse of `mountPath`" + \(Root root) path -> + originPath (Root root) (mountPath (Root root) path) + & either (const False) (== path) + ] + +unitTests :: IO TestTree +unitTests = testSpec "Unit Tests" $ + around withTempDirectory do + describe "mount" do + it "mounts a file properly" \temporaryRoot -> + (,) <$> filesNames <*> filesContents & traverse_ \(name, contents) -> + mountFileTest temporaryRoot (temporaryRoot "origin" name) contents + it "mounts a directory properly" \temporaryRoot -> + mountDirectoryTest temporaryRoot + $ zip filesNames filesContents + describe "unmount" do + it "unmounts a file properly" \temporaryRoot -> + (,) <$> filesNames <*> filesContents & traverse_ \(name, contents) -> + unmountFileTest temporaryRoot (temporaryRoot "origin" name) contents + it "unmounts a directory properly" \temporaryRoot -> + unmountDirectoryTest temporaryRoot + $ zip filesNames filesContents + where + filesNames :: [FilePath] + filesNames = + [ "9h(ILN:/b+" + , ";)A/:H'^og@GB" + , "\\g2\n( M#/scIU/o^A/Nj>/nC,ASzz7q" + , "SB$N/;F" + , "?,@Zo\tz/*|1%%\tWm}/ k>oAV_7M/yGn$+c 7AS" + , "\"\\_" + , "4g/M;FD901" + , "\t$sL;G9/3zZ|p[1/w\\6f]/=926UD" + ] + + filesContents :: [Text] + filesContents = + [ "\54951\170056NU+\"\92881a-\142680\177134\SOXKE\1097408\63631hq\1021187\ETBd\1019100#\1028440\1041796\1000925Gat" + , "RD\177342\1036654\1084661\189502\1096769 \1011758\96759\67362\1058870\96334\74438o\1094509>\1095213[,\37703SFb\147814\25819F\153345#b" + , "\SUB\170178\178560yv\1011719Q/\\$>L\GS7\1048669\&1z\1093012\1086214r\199200P,\nOrG{\1002826L" + , "et\39933\152786\71222\51388WFY\DC1'il9kH\132409E\\C\1024119\68094]\991083B\11343\DC1Ez\18164" + , "!dB\999918\SUBo`- Path.Absolute -> Text -> IO () +mountFileTest temporaryRoot originPath contents = do + let root = temporaryRoot "root" + ensureWriteFile originPath contents + mount LinkHandling.CopyLink (Root root) originPath & runExceptT >>= \case + Left error -> assertFailure + $ "Expected mount to succeed, instead got an error: " <> show error + Right (Mount mountPath) -> do + mountPath `shouldBe` root dropDrive originPath + readFile (Path.unAbsolute mountPath) `shouldReturn` contents + whenM (doesPathExist originPath) . assertFailure + $ "Expected file \"" <> Path.unAbsolute originPath <> "\" to not exist" + +mountDirectoryTest :: Path.Absolute -> [(FilePath, Text)] -> IO () +mountDirectoryTest temporaryRoot files = do + let root = temporaryRoot "root" + originPath = temporaryRoot "origin" + files & traverse_ \(fileName, contents) -> + ensureWriteFile (originPath fileName) contents + mount LinkHandling.CopyLink (Root root) originPath & runExceptT >>= \case + Left error -> assertFailure + $ "Expected mount to succeed, instead got an error: " <> show error + Right (Mount mountPath) -> do + mountPath `shouldBe` root dropDrive originPath + actualPaths <- findFiles mountPath + let expectedPaths = files <&> \(fileName, _) -> mountPath fileName + Set.fromList actualPaths `shouldBe` Set.fromList expectedPaths + files & traverse_ \(fileName, contents) -> + readFile (Path.unAbsolute $ mountPath fileName) `shouldReturn` contents + whenM (doesPathExist originPath) . assertFailure + $ "Expected directory \"" <> Path.unAbsolute originPath <> "\" to not exist" + +unmountFileTest :: Path.Absolute -> Path.Absolute -> Text -> IO () +unmountFileTest temporaryRoot originPath contents = do + let root = temporaryRoot "root" + mountPath = root dropDrive originPath + ensureWriteFile mountPath contents + unmount (Root root) (Mount mountPath) & runExceptT >>= \case + Left error -> assertFailure + $ "Expected unmount to succeed, instead got an error: " <> show error + Right newOriginPath -> do + newOriginPath `shouldBe` originPath + readFile (Path.unAbsolute newOriginPath) `shouldReturn` contents + whenM (doesPathExist mountPath) . assertFailure + $ "Expected file \"" <> Path.unAbsolute mountPath <> "\" to not exist" + +unmountDirectoryTest :: Path.Absolute -> [(FilePath, Text)] -> IO () +unmountDirectoryTest temporaryRoot files = do + let root = temporaryRoot "root" + originPath = temporaryRoot "origin" + mountPath = root dropDrive originPath + files & traverse_ \(fileName, contents) -> + ensureWriteFile (mountPath fileName) contents + unmount (Root root) (Mount mountPath) & runExceptT >>= \case + Left error -> assertFailure + $ "Expected unmount to succeed, instead got an error: " <> show error + Right newOriginPath -> do + newOriginPath `shouldBe` originPath + actualPaths <- findFiles newOriginPath + let expectedPaths = files <&> \(fileName, _) -> newOriginPath fileName + Set.fromList actualPaths `shouldBe` Set.fromList expectedPaths + files & traverse_ \(fileName, contents) -> + readFile (Path.unAbsolute $ newOriginPath fileName) `shouldReturn` contents + whenM (doesPathExist mountPath) . assertFailure + $ "Expected directory \"" <> Path.unAbsolute mountPath <> "\" to not exist" diff --git a/test/PFile/Mount/Tests/Env.hs b/test/PFile/Mount/Tests/Env.hs new file mode 100644 --- /dev/null +++ b/test/PFile/Mount/Tests/Env.hs @@ -0,0 +1,32 @@ +{-# OPTIONS_GHC -Wno-orphans #-} + +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE StandaloneDeriving #-} + +module PFile.Mount.Tests.Env + ( + ) where + +import PFile.Mount + ( Mount (..) + , MountError (..) + , OriginResolveError (..) + , Root (..) + , UnmountError (..) + ) +import PFile.Path.Tests.Env () +import PFile.Profile.LinkHandling.Tests.Env () +import Protolude +import Test.Tasty.QuickCheck (Arbitrary) + +deriving instance Arbitrary Root +deriving instance Show Root + +deriving instance Arbitrary Mount +deriving instance Show Mount + +deriving instance Show MountError + +deriving instance Show UnmountError + +deriving instance Show OriginResolveError diff --git a/test/PFile/Path/Tests.hs b/test/PFile/Path/Tests.hs new file mode 100644 --- /dev/null +++ b/test/PFile/Path/Tests.hs @@ -0,0 +1,16 @@ +{-# LANGUAGE LambdaCase #-} + +module PFile.Path.Tests + ( ensureWriteFile + ) where + +import PFile.Path (Absolute, writeFile) +import PFile.Path.Tests.Env () +import Protolude hiding (writeFile) +import Test.HUnit (assertFailure) + +ensureWriteFile :: Absolute -> Text -> IO () +ensureWriteFile path contents = writeFile path contents & runExceptT >>= \case + Left error -> assertFailure + $ "Expected writeFile to succeed, instead got an error: " <> show error + Right () -> pure () diff --git a/test/PFile/Path/Tests/Env.hs b/test/PFile/Path/Tests/Env.hs new file mode 100644 --- /dev/null +++ b/test/PFile/Path/Tests/Env.hs @@ -0,0 +1,73 @@ +{-# OPTIONS_GHC -Wno-orphans #-} + +{-# LANGUAGE StandaloneDeriving #-} + +module PFile.Path.Tests.Env + ( + ) where + +import PFile.Path + ( Absolute (..) + , CopyError (..) + , CopyFileError (..) + , CopyLinkError (..) + , CreateDirectoryError (..) + , CreateDirectoryLinkError (..) + , CreateFileLinkError (..) + , CreateParentError (..) + , MoveDirectoryError (..) + , MoveDirectoryLinkError (..) + , MoveError (..) + , MoveFileError (..) + , MoveFileLinkError (..) + , RemoveError (..) + , WriteFileError (..) + ) +import Protolude +import System.FilePath (joinDrive, joinPath) +import Test.Tasty.QuickCheck + ( Arbitrary (..) + , Gen + , chooseInt + , elements + ) + +deriving instance Show CopyError +deriving instance Show CopyFileError +deriving instance Show CopyLinkError +deriving instance Show CreateDirectoryError +deriving instance Show CreateDirectoryLinkError +deriving instance Show CreateFileLinkError +deriving instance Show CreateParentError +deriving instance Show MoveDirectoryError +deriving instance Show MoveDirectoryLinkError +deriving instance Show MoveError +deriving instance Show MoveFileError +deriving instance Show MoveFileLinkError +deriving instance Show WriteFileError + +deriving instance Show RemoveError + +instance Arbitrary Absolute where + arbitrary = do + n <- chooseInt (1, 30) + replicateM n word + <&> Absolute . joinDrive "/" . joinPath + where + word :: Gen [Char] + word = do + n <- chooseInt (1, 1023) + replicateM n $ elements posixFilePathAllowedCharacters + +posixFilePathAllowedCharacters :: [Char] +posixFilePathAllowedCharacters = concat + [ ['A' .. 'Z'] + , ['a' .. 'z'] + , ['0' .. '9'] + , [' ', '\t', '\n', '\r'] + , ['+', '-', '=', '|', '~', '(', ')', '<', '>', '{', '}', '\\'] + , ['?', ',', '.', '!', ';', ':', '\'', '"', '[', ']'] + , ['&', '%', '$', '#', '@', '^', '*', '_'] + ] + +deriving instance Show Absolute diff --git a/test/PFile/Profile/LinkHandling/Tests/Env.hs b/test/PFile/Profile/LinkHandling/Tests/Env.hs new file mode 100644 --- /dev/null +++ b/test/PFile/Profile/LinkHandling/Tests/Env.hs @@ -0,0 +1,13 @@ +{-# OPTIONS_GHC -Wno-orphans #-} + +{-# LANGUAGE StandaloneDeriving #-} + +module PFile.Profile.LinkHandling.Tests.Env + ( + ) where + +import PFile.Path.Tests.Env () +import PFile.Profile.LinkHandling (Error (..)) +import Protolude + +deriving instance Show Error diff --git a/test/PFile/Tests/Env.hs b/test/PFile/Tests/Env.hs new file mode 100644 --- /dev/null +++ b/test/PFile/Tests/Env.hs @@ -0,0 +1,13 @@ +module PFile.Tests.Env + ( withTempDirectory + ) where + +import qualified PFile.Path as Path +import Protolude +import System.Directory (getTemporaryDirectory) +import qualified System.IO.Temp as Temp + +withTempDirectory :: (Path.Absolute -> IO a) -> IO a +withTempDirectory callback = do + temporaryRoot <- getTemporaryDirectory + Temp.withTempDirectory temporaryRoot "pfile-test" (callback . Path.Absolute) diff --git a/test/PFile/TrashCan/Tests.hs b/test/PFile/TrashCan/Tests.hs new file mode 100644 --- /dev/null +++ b/test/PFile/TrashCan/Tests.hs @@ -0,0 +1,182 @@ +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} + +module PFile.TrashCan.Tests + ( tests + ) where + +import Control.Monad.Writer (execWriterT) +import qualified Data.HashSet as Set +import PFile.Path (doesPathExist, ()) +import qualified PFile.Path as Path +import PFile.Path.Tests (ensureWriteFile) +import PFile.Tests.Env (withTempDirectory) +import PFile.TrashCan (TrashCan (..)) +import qualified PFile.TrashCan as TrashCan +import PFile.TrashCan.Tests.Env () +import Protolude +import System.FilePath (()) +import Test.Hspec + ( around + , describe + , it + , shouldBe + , shouldReturn + ) +import Test.HUnit (assertFailure) +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.Hspec (testSpec) + +tests :: IO TestTree +tests = do + unitTests_ <- unitTests + pure $ testGroup "PFile.TrashCan" [unitTests_] + +unitTests :: IO TestTree +unitTests = testSpec "Unit Tests" $ + around withTempDirectory do + describe "trash" do + it "trashes a file properly" \temporaryRoot -> + (,) <$> filesNames <*> filesContents & traverse_ \(name, contents) -> + trashFileTest (temporaryRoot "origin" name) contents + describe "restore" do + it "restores a file properly" \temporaryRoot -> + (,) <$> filesNames <*> filesContents & traverse_ \(name, contents) -> + restoreFileTest (temporaryRoot "origin" name) contents + describe "restoreAll" do + it "restores all files properly" \temporaryRoot -> + restoreAllTest + $ zip + (filesNames <&> \name -> temporaryRoot "origin" name) + filesContents + describe "remove" do + it "removes empty trashCan properly" \_ -> + removeTest [] + it "removes non-empty trashCan properly" \temporaryRoot -> + removeTest + $ zip + (filesNames <&> \name -> temporaryRoot "origin" name) + filesContents + describe "dumpTrashed" do + it "dumps trashed list properly" \temporaryRoot -> + dumpTrashedTest + $ zip + (filesNames <&> \name -> temporaryRoot "origin" name) + filesContents + where + filesNames :: [FilePath] + filesNames = + [ "9h(ILN:/b+" + , ";)A/:H'^og@GB" + , "\\g2\n( M#/scIU/o^A/Nj>/nC,ASzz7q" + , "SB$N/;F" + , "?,@Zo\tz/*|1%%\tWm}/ k>oAV_7M/yGn$+c 7AS" + , "\"\\_" + , "4g/M;FD901" + , "\t$sL;G9/3zZ|p[1/w\\6f]/=926UD" + ] + + filesContents :: [Text] + filesContents = + [ "\54951\170056NU+\"\92881a-\142680\177134\SOXKE\1097408\63631hq\1021187\ETBd\1019100#\1028440\1041796\1000925Gat" + , "RD\177342\1036654\1084661\189502\1096769 \1011758\96759\67362\1058870\96334\74438o\1094509>\1095213[,\37703SFb\147814\25819F\153345#b" + , "\SUB\170178\178560yv\1011719Q/\\$>L\GS7\1048669\&1z\1093012\1086214r\199200P,\nOrG{\1002826L" + , "et\39933\152786\71222\51388WFY\DC1'il9kH\132409E\\C\1024119\68094]\991083B\11343\DC1Ez\18164" + , "!dB\999918\SUBo`- Text -> IO () +trashFileTest path contents = withTrashCan \trashCan -> do + ensureWriteFile path contents + ensureTrash path trashCan + +restoreFileTest :: Path.Absolute -> Text -> IO () +restoreFileTest originPath contents = withTrashCan \trashCan -> do + ensureWriteFile originPath contents + ensureTrash originPath trashCan + TrashCan.trashed trashCan >>= \case + [mountPath] -> TrashCan.restore trashCan mountPath & runExceptT >>= \case + Left error -> assertFailure + $ "Expected restore to succeed, instead got an error: " <> show error + Right () -> readFile (Path.unAbsolute originPath) `shouldReturn` contents + xs -> assertFailure + $ "Expected single path in trashed list, instead got: " <> show xs + +restoreAllTest :: [(Path.Absolute, Text)] -> IO () +restoreAllTest files = withTrashCan \trashCan -> do + files & traverse_ (uncurry ensureWriteFile) + files & traverse_ \(originPath, _) -> ensureTrash originPath trashCan + length <$> TrashCan.trashed trashCan `shouldReturn` length files + TrashCan.restoreAll trashCan & execWriterT >>= \case + errors@(_:_) -> assertFailure + $ "Expected restoreAll to succeed, instead got errors: " <> show errors + [] -> files & traverse_ \(originPath, contents) -> + readFile (Path.unAbsolute originPath) `shouldReturn` contents + +removeTest :: [(Path.Absolute, Text)] -> IO () +removeTest files = withTrashCan \trashCan -> do + files & traverse_ (uncurry ensureWriteFile) + files & traverse_ \(originPath, _) -> ensureTrash originPath trashCan + ensureRemove trashCan + +dumpTrashedTest :: [(Path.Absolute, Text)] -> IO () +dumpTrashedTest files = withTrashCan \trashCan -> do + files & traverse_ (uncurry ensureWriteFile) + files & traverse_ \(originPath, _) -> ensureTrash originPath trashCan + TrashCan.dumpTrashed trashCan & runExceptT >>= \case + Left error -> assertFailure + $ "Expected dumpTrashed to succeed, instead got an error: " <> show error + Right trashedPath -> do + unlessM (doesPathExist trashedPath) . assertFailure + $ "Expected file \"" <> Path.unAbsolute trashedPath <> "\" to exist" + actualPaths <- + readFile (Path.unAbsolute trashedPath) + <&> fmap (Path.Absolute . toS) . lines + expectedPaths <- TrashCan.trashed trashCan + Set.fromList actualPaths `shouldBe` Set.fromList expectedPaths + +withTrashCan :: (TrashCan -> IO a) -> IO a +withTrashCan callback = do + trashCan <- ensureCreate + result <- callback trashCan + ensureRemove trashCan + pure result + +ensureCreate :: IO TrashCan +ensureCreate = runExceptT TrashCan.create >>= \case + Left error -> assertFailure + $ "Expected create to succeed, instead got an error: " <> show error + Right trashCan -> pure trashCan + +ensureRemove :: TrashCan -> IO () +ensureRemove trashCan@TrashCan {root} = + TrashCan.remove trashCan & runExceptT >>= \case + Left error -> assertFailure + $ "Expected remove to succeed, instead got an error: " <> show error + Right () -> whenM (doesPathExist root) . assertFailure + $ "Expected directory \"" <> Path.unAbsolute root <> "\" to not exist" + +ensureTrash :: Path.Absolute -> TrashCan -> IO () +ensureTrash path trashCan = TrashCan.trash path trashCan & runExceptT >>= \case + Left error -> assertFailure + $ "Expected trash to succeed, instead got an error: " <> show error + Right () -> whenM (doesPathExist path) . assertFailure + $ "Expected file \"" <> Path.unAbsolute path <> "\" to not exist" diff --git a/test/PFile/TrashCan/Tests/Env.hs b/test/PFile/TrashCan/Tests/Env.hs new file mode 100644 --- /dev/null +++ b/test/PFile/TrashCan/Tests/Env.hs @@ -0,0 +1,42 @@ +{-# OPTIONS_GHC -Wno-orphans #-} + +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE StandaloneDeriving #-} + +module PFile.TrashCan.Tests.Env + ( + ) where + +import PFile.Mount.Tests.Env () +import PFile.Path.Tests.Env () +import PFile.TrashCan + ( CreateError (..) + , DumpTrashedError (..) + , RemoveError (..) + , RestoreEntryError (..) + , RestoreError (..) + , TrashCan (..) + , TrashError (..) + , trashed + ) +import Protolude +import System.IO.Unsafe (unsafePerformIO) +import qualified Text.Show (Show (show)) + +deriving instance Show CreateError + +deriving instance Show TrashError + +deriving instance Show RestoreError + +deriving instance Show RestoreEntryError + +deriving instance Show RemoveError + +deriving instance Show DumpTrashedError + +instance Show TrashCan where + show trashCan@TrashCan {root, dataRoot} + = "TrashCan {root = " <> show root + <> ", dataRoot = " <> show dataRoot + <> ", _trashed = " <> show (unsafePerformIO $ trashed trashCan) <> "}" diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,14 @@ +module Main + ( main + ) where + +import qualified PFile.Mount.Tests as PFile.Mount +import qualified PFile.TrashCan.Tests as PFile.TrashCan +import Protolude +import Test.Tasty (defaultMain, testGroup) + +main :: IO () +main = + [PFile.Mount.tests, PFile.TrashCan.tests] + & sequenceA + >>= defaultMain . testGroup "Tests"