packages feed

pfile (empty) → 0.1.0.0

raw patch · 43 files changed

+4477/−0 lines, 43 filesdep +HUnitdep +aesondep +aeson-prettysetup-changed

Dependencies added: HUnit, aeson, aeson-pretty, base, directory, filepath, hspec, mtl, optparse-applicative, pfile, protolude, tasty, tasty-hspec, tasty-quickcheck, temporary, transformers, unordered-containers

Files

+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2024, Illia Shkroba <is@pjwstk.edu.pl>++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 <is@pjwstk.edu.pl> 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.
+ README.md view
@@ -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+<some-service>@<my-account>` or `KEY=<my-private-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.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ app/Main.hs view
@@ -0,0 +1,9 @@+module Main+  ( main+  ) where++import qualified PFile.Main as PFile+import           Protolude++main :: IO ()+main = PFile.main
+ pfile.cabal view
@@ -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 <https://github.com/illia-shkroba/pfile#readme>++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
+ src/PFile/Aeson.hs view
@@ -0,0 +1,29 @@+{- |+Module:      PFile.Aeson+Copyright:   (c) 2024 Illia Shkroba+License:     BSD3+Maintainer:  Illia Shkroba <is@pjwstk.edu.pl>+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 -> "<Utf8 decoding error: " <> show error <> ">") identity+  . decodeUtf8' . toS . Aeson.encodePretty
+ src/PFile/CLI.hs view
@@ -0,0 +1,80 @@+{- |+Module:      PFile.CLI+Copyright:   (c) 2024 Illia Shkroba+License:     BSD3+Maintainer:  Illia Shkroba <is@pjwstk.edu.pl>+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
+ src/PFile/CLI/List.hs view
@@ -0,0 +1,56 @@+{- |+Module:      PFile.CLI.List+Copyright:   (c) 2024 Illia Shkroba+License:     BSD3+Maintainer:  Illia Shkroba <is@pjwstk.edu.pl>+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 }
+ src/PFile/CLI/New.hs view
@@ -0,0 +1,72 @@+{- |+Module:      PFile.CLI.New+Copyright:   (c) 2024 Illia Shkroba+License:     BSD3+Maintainer:  Illia Shkroba <is@pjwstk.edu.pl>+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]+      }
+ src/PFile/CLI/Switch.hs view
@@ -0,0 +1,70 @@+{- |+Module:      PFile.CLI.Switch+Copyright:   (c) 2024 Illia Shkroba+License:     BSD3+Maintainer:  Illia Shkroba <is@pjwstk.edu.pl>+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+      }
+ src/PFile/CLI/Unpack.hs view
@@ -0,0 +1,59 @@+{- |+Module:      PFile.CLI.Unpack+Copyright:   (c) 2024 Illia Shkroba+License:     BSD3+Maintainer:  Illia Shkroba <is@pjwstk.edu.pl>+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 }
+ src/PFile/CLI/Which.hs view
@@ -0,0 +1,42 @@+{- |+Module:      PFile.CLI.Which+Copyright:   (c) 2024 Illia Shkroba+License:     BSD3+Maintainer:  Illia Shkroba <is@pjwstk.edu.pl>+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
+ src/PFile/Completion.hs view
@@ -0,0 +1,33 @@+{- |+Module:      PFile.Completion+Copyright:   (c) 2024 Illia Shkroba+License:     BSD3+Maintainer:  Illia Shkroba <is@pjwstk.edu.pl>+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}
+ src/PFile/Env.hs view
@@ -0,0 +1,97 @@+{- |+Module:      PFile.Env+Copyright:   (c) 2024 Illia Shkroba+License:     BSD3+Maintainer:  Illia Shkroba <is@pjwstk.edu.pl>+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'.+      }
+ src/PFile/Error.hs view
@@ -0,0 +1,79 @@+{- |+Module:      PFile.Error+Copyright:   (c) 2024 Illia Shkroba+License:     BSD3+Maintainer:  Illia Shkroba <is@pjwstk.edu.pl>+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
+ src/PFile/Log.hs view
@@ -0,0 +1,40 @@+{- |+Module:      PFile.Log+Copyright:   (c) 2024 Illia Shkroba+License:     BSD3+Maintainer:  Illia Shkroba <is@pjwstk.edu.pl>+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
+ src/PFile/Main.hs view
@@ -0,0 +1,41 @@+{- |+Module:      PFile.Main+Copyright:   (c) 2024 Illia Shkroba+License:     BSD3+Maintainer:  Illia Shkroba <is@pjwstk.edu.pl>+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
+ src/PFile/Main/List.hs view
@@ -0,0 +1,34 @@+{- |+Module:      PFile.Main.List+Copyright:   (c) 2024 Illia Shkroba+License:     BSD3+Maintainer:  Illia Shkroba <is@pjwstk.edu.pl>+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}
+ src/PFile/Main/New.hs view
@@ -0,0 +1,75 @@+{- |+Module:      PFile.Main.New+Copyright:   (c) 2024 Illia Shkroba+License:     BSD3+Maintainer:  Illia Shkroba <is@pjwstk.edu.pl>+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)
+ src/PFile/Main/Switch.hs view
@@ -0,0 +1,51 @@+{- |+Module:      PFile.Main.Switch+Copyright:   (c) 2024 Illia Shkroba+License:     BSD3+Maintainer:  Illia Shkroba <is@pjwstk.edu.pl>+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}
+ src/PFile/Main/Unpack.hs view
@@ -0,0 +1,40 @@+{- |+Module:      PFile.Main.Unpack+Copyright:   (c) 2024 Illia Shkroba+License:     BSD3+Maintainer:  Illia Shkroba <is@pjwstk.edu.pl>+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}
+ src/PFile/Main/Which.hs view
@@ -0,0 +1,34 @@+{- |+Module:      PFile.Main.Which+Copyright:   (c) 2024 Illia Shkroba+License:     BSD3+Maintainer:  Illia Shkroba <is@pjwstk.edu.pl>+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
+ src/PFile/Mount.hs view
@@ -0,0 +1,210 @@+{- |+Module:      PFile.Mount+Copyright:   (c) 2024 Illia Shkroba+License:     BSD3+Maintainer:  Illia Shkroba <is@pjwstk.edu.pl>+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)
+ src/PFile/Path.hs view
@@ -0,0 +1,656 @@+{- |+Module:      PFile.Path+Copyright:   (c) 2024 Illia Shkroba+License:     BSD3+Maintainer:  Illia Shkroba <is@pjwstk.edu.pl>+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)
+ src/PFile/Profile.hs view
@@ -0,0 +1,74 @@+{- |+Module:      PFile.Profile+Copyright:   (c) 2024 Illia Shkroba+License:     BSD3+Maintainer:  Illia Shkroba <is@pjwstk.edu.pl>+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+  )
+ src/PFile/Profile/Internal/Current.hs view
@@ -0,0 +1,142 @@+{- |+Module:      PFile.Profile.Internal.Current+Copyright:   (c) 2024 Illia Shkroba+License:     BSD3+Maintainer:  Illia Shkroba <is@pjwstk.edu.pl>+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'.
+ src/PFile/Profile/Internal/Lifetime.hs view
@@ -0,0 +1,201 @@+{- |+Module:      PFile.Profile.Internal.Lifetime+Copyright:   (c) 2024 Illia Shkroba+License:     BSD3+Maintainer:  Illia Shkroba <is@pjwstk.edu.pl>+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.+      }
+ src/PFile/Profile/Internal/List.hs view
@@ -0,0 +1,109 @@+{- |+Module:      PFile.Profile.Internal.List+Copyright:   (c) 2024 Illia Shkroba+License:     BSD3+Maintainer:  Illia Shkroba <is@pjwstk.edu.pl>+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.+      }
+ src/PFile/Profile/Internal/Profile.hs view
@@ -0,0 +1,127 @@+{- |+Module:      PFile.Profile.Internal.Profile+Copyright:   (c) 2024 Illia Shkroba+License:     BSD3+Maintainer:  Illia Shkroba <is@pjwstk.edu.pl>+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
+ src/PFile/Profile/Internal/Registry.hs view
@@ -0,0 +1,227 @@+{- |+Module:      PFile.Profile.Internal.Registry+Copyright:   (c) 2024 Illia Shkroba+License:     BSD3+Maintainer:  Illia Shkroba <is@pjwstk.edu.pl>+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'.
+ src/PFile/Profile/Internal/Serialization.hs view
@@ -0,0 +1,112 @@+{- |+Module:      PFile.Profile.Internal.Serialization+Copyright:   (c) 2024 Illia Shkroba+License:     BSD3+Maintainer:  Illia Shkroba <is@pjwstk.edu.pl>+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'.
+ src/PFile/Profile/Internal/Switch.hs view
@@ -0,0 +1,421 @@+{- |+Module:      PFile.Profile.Internal.Switch+Copyright:   (c) 2024 Illia Shkroba+License:     BSD3+Maintainer:  Illia Shkroba <is@pjwstk.edu.pl>+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.+      }
+ src/PFile/Profile/LinkHandling.hs view
@@ -0,0 +1,103 @@+{- |+Module:      PFile.Profile.LinkHandling+Copyright:   (c) 2024 Illia Shkroba+License:     BSD3+Maintainer:  Illia Shkroba <is@pjwstk.edu.pl>+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.
+ src/PFile/TrashCan.hs view
@@ -0,0 +1,242 @@+{- |+Module:      PFile.TrashCan+Copyright:   (c) 2024 Illia Shkroba+License:     BSD3+Maintainer:  Illia Shkroba <is@pjwstk.edu.pl>+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'.+      }
+ test/PFile/Mount/Tests.hs view
@@ -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<t{mg2"+      , "'*_"+      , "*CDy/|\rHh?/!@"+      , "C~(?3|(y/8&"+      , "1t=_rL'/%JB0\"8"+      , "ej/s$\\K.5ZT/Z*6rn-j\t3/x':@bj"+      , "YJ/%X4C$KMr=/z\r"+      , "f~NO*a j@7"+      , "swSgYJUM9r/.EYR\"wADf/*DJd:("+      , " Y(7*/|/<-[6nv3"+      , "yfF~"+      , "zETbVl w7./]^/[m>+"+      , ";)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`-<QrS<9+MT\1044433\DELt\96208\17044\1090040@1PP\147330]K"+      , "/7!SH\98989\183950J\"\138051\161420\35056WE<2F8&~)c\181084&!\78704N_$\15030"+      , "#[&)xPg$nH]9mt60\94378jU=*B^F[\29380x\199030D\92604"+      , "CD\149540\&1TqCL\132951H:,P)^4\2636I&{r?CmS\179807Nf*'"+      , "\SIhFN:CH=OS(2?{A+\GS\SOA\STXG{|nL?8!L_"+      , "CpH`8a?\NAK,\GS\ETXqG\ETXN9\EMa)\\1AYEco3Fd_"+      ]++mountFileTest :: Path.Absolute -> 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"
+ test/PFile/Mount/Tests/Env.hs view
@@ -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
+ test/PFile/Path/Tests.hs view
@@ -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 ()
+ test/PFile/Path/Tests/Env.hs view
@@ -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
+ test/PFile/Profile/LinkHandling/Tests/Env.hs view
@@ -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
+ test/PFile/Tests/Env.hs view
@@ -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)
+ test/PFile/TrashCan/Tests.hs view
@@ -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<t{mg2"+      , "'*_"+      , "*CDy/|\rHh?/!@"+      , "C~(?3|(y/8&"+      , "1t=_rL'/%JB0\"8"+      , "ej/s$\\K.5ZT/Z*6rn-j\t3/x':@bj"+      , "YJ/%X4C$KMr=/z\r"+      , "f~NO*a j@7"+      , "swSgYJUM9r/.EYR\"wADf/*DJd:("+      , " Y(7*/|/<-[6nv3"+      , "yfF~"+      , "zETbVl w7./]^/[m>+"+      , ";)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`-<QrS<9+MT\1044433\DELt\96208\17044\1090040@1PP\147330]K"+      , "/7!SH\98989\183950J\"\138051\161420\35056WE<2F8&~)c\181084&!\78704N_$\15030"+      , "#[&)xPg$nH]9mt60\94378jU=*B^F[\29380x\199030D\92604"+      , "CD\149540\&1TqCL\132951H:,P)^4\2636I&{r?CmS\179807Nf*'"+      , "\SIhFN:CH=OS(2?{A+\GS\SOA\STXG{|nL?8!L_"+      , "CpH`8a?\NAK,\GS\ETXqG\ETXN9\EMa)\\1AYEco3Fd_"+      ]++trashFileTest :: Path.Absolute -> 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"
+ test/PFile/TrashCan/Tests/Env.hs view
@@ -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) <> "}"
+ test/Spec.hs view
@@ -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"