diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,3 @@ +## Plan B 0.1.0 + +* Initial release. diff --git a/LICENSE.md b/LICENSE.md new file mode 100644 --- /dev/null +++ b/LICENSE.md @@ -0,0 +1,28 @@ +Copyright © 2016 Mark Karpov + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + +* Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer. + +* 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. + +* Neither the name Mark Karpov nor the names of 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 “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 HOLDERS BE LIABLE FOR ANY DIRECT, INDIRECT, +INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, +OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF +LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, +EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,81 @@ +# Plan B + +[![License BSD3](https://img.shields.io/badge/license-BSD3-brightgreen.svg)](http://opensource.org/licenses/BSD-3-Clause) +[![Hackage](https://img.shields.io/hackage/v/plan-b.svg?style=flat)](https://hackage.haskell.org/package/plan-b) +[![Stackage Nightly](http://stackage.org/package/plan-b/badge/nightly)](http://stackage.org/nightly/package/plan-b) +[![Build Status](https://travis-ci.org/mrkkrp/plan-b.svg?branch=master)](https://travis-ci.org/mrkkrp/plan-b) +[![Coverage Status](https://coveralls.io/repos/mrkkrp/plan-b/badge.svg?branch=master&service=github)](https://coveralls.io/github/mrkkrp/plan-b?branch=master) + +This is a Haskell library helping perform failure-tolerant operations on +files and directories. + +## Quick start + +The library allows to create and/or edit files, directories, and +containers. By “container” we mean archive-like object that can contain +representation of a directory inside it. Consequently, we have six functions +available: + +* `withNewFile` +* `withExstingFile` +* `withNewDir` +* `withExistingDir` +* `withNewContainer` +* `withExistingContainer` + +You specify name of object to edit or create, options (more on them below), +and action that is passed `Path` argument with the same type as object you +intend to edit (we use type-safe file paths from +[`path`](https://hackage.haskell.org/package/path) package here to prevent a +certain class of potential bugs). Then, having that path, you can do all +actions you want to and if at some point during this editing an exception is +thrown, state of file system is rolled back — you get no corrupted files, +half-way edited directories, everything is intact as if nothing happened at +all. If, however, the action is executed successfully (i.e. no exceptions +thrown), all your manipulations are reflected in the file system. + +This is a lightweight solution that makes it harder to corrupt sensitive +information. And since file system exists in the real world, all sorts of +bad things *can* (and *will*) happen. *You should always have plan B.* + +Temporary files and back-ups are handled and deleted automatically, however +you can pass options to change default behaviors. Not all options can be +used with every function, but wrong combinations won't type-check, so it's +OK. + +Collection of options is a monoid. `mempty` corresponds to default behavior, +while non-standard behavioral deviations can be `mappend`ed to it. + +By default, when we want to create new object and it already exists, we get +an exception, two alternative options exist (only work when you create new +object): + +* `overrideIfExist` +* `useIfExist` + +There is no way to prevent exception when you want to *edit* object that +does not exist, though. + +All functions make use of temporary directories. You can control certain +aspects of this business: + +* `tempDir dir` — will tell the library to create temporary directories and + files inside `dir`. By default system's standard temporary directory + (e.g. `/tmp/` on Unix-like systems) is used. + +* `nameTemplate template` — specifies template to use for generation of + unique file and directory names. By default `"plan-b"` is used. + +* `preserveCorpse` — if you add this to options, in case of failure + (exception), temporary directory is not automatically deleted and can be + inspected. However, if operation succeeds, temporary directory is *always* + deleted. + +That should be enough for a quick intro, for more information regarding +concrete functions, consult Haddocks. + +## License + +Copyright © 2016 Mark Karpov + +Distributed under BSD 3 clause license. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,6 @@ +module Main (main) where + +import Distribution.Simple + +main :: IO () +main = defaultMain diff --git a/System/PlanB.hs b/System/PlanB.hs new file mode 100644 --- /dev/null +++ b/System/PlanB.hs @@ -0,0 +1,300 @@ +-- | +-- Module : System.PlanB +-- Copyright : © 2016 Mark Karpov +-- License : BSD 3 clause +-- +-- Maintainer : Mark Karpov +-- Stability : experimental +-- Portability : portable +-- +-- Failure-tolerant file and directory editing. All functions here can +-- recover from exceptions thrown while they work. They bring file-system to +-- the state it was in before specific function was called. Temporary files +-- and backups are handled automatically. + +{-# LANGUAGE DataKinds #-} + +module System.PlanB + ( -- * Operations on files + withNewFile + , withExistingFile + -- * Operations on directories + , withNewDir + , withExistingDir + -- * Operations on containers + , withNewContainer + , withExistingContainer + -- * Configuration options + , tempDir + , nameTemplate + , preserveCorpse + , overrideIfExists + , useIfExists ) +where + +import Control.Monad +import Control.Monad.Catch +import Control.Monad.IO.Class (MonadIO (..)) +import Data.Maybe (fromMaybe) +import Path +import System.IO.Error +import System.PlanB.Type +import qualified Path.IO as P + +---------------------------------------------------------------------------- +-- Operations on files + +-- | Create new file. Name of the file is taken as the second argument. The +-- third argument allows to perform actions (in simplest case just creation +-- of file), result of those actions should be new file with given file +-- name. +-- +-- This action throws 'alreadyExistsErrorType' by default instead of +-- silently overwriting already existing file, use 'overrideIfExists' and +-- 'useIfExists' to change this behavior. + +withNewFile :: (MonadIO m, MonadMask m) + => PbConfig 'New -- ^ Configuration + -> Path b File -- ^ Name of file to create + -> (Path Abs File -> m a) -- ^ Given name of temporary file, do it + -> m a +withNewFile pbc fpath action = withTempDir pbc $ \tdir -> do + let apath = constructFilePath tdir fpath + checkExistenceOfFile pbc apath fpath + liftM2 const (action apath) (P.renameFile apath fpath) + +-- | Edit existing file. Name of the file is taken as the second +-- argument. The third argument allows to perform actions on temporary copy +-- of specified file. +-- +-- This action throws 'doesNotExistErrorType' exception if target file does +-- not exist. + +withExistingFile :: (MonadIO m, MonadMask m) + => PbConfig 'Existing -- ^ Configuration + -> Path b File -- ^ Name of file to edit + -> (Path Abs File -> m a) -- ^ Given name of temporary file, do it + -> m a +withExistingFile pbc fpath action = withTempDir pbc $ \tdir -> do + let apath = constructFilePath tdir fpath + copyFile fpath apath + liftM2 const (action apath) (P.renameFile apath fpath) + +---------------------------------------------------------------------------- +-- Operations on directories + +-- | Create new directory. Name of the directory is specified as the second +-- argument. The third argument allows to perform actions in “sandboxed” +-- version of new directory. +-- +-- This action throws 'alreadyExistsErrorType' by default instead of +-- silently overwriting already existing directory, use 'overrideIfExists' +-- and 'useIfExists'to change this behavior. + +withNewDir :: (MonadIO m, MonadMask m) + => PbConfig 'New -- ^ Configuration + -> Path b Dir -- ^ Name of directory to create + -> (Path Abs Dir -> m a) -- ^ Given name of temporary directory, do it + -> m a +withNewDir pbc dpath action = withTempDir pbc $ \tdir -> do + checkExistenceOfDir pbc tdir dpath + liftM2 const (action tdir) (moveDir tdir dpath) + +-- | Edit existing directory. Name of the directory is specified as the +-- second argument. The third argument allows to perform actions in +-- “sandboxed” copy of target directory. +-- +-- This action throws 'doesNotExistErrorType' exception if target directory +-- does not exist. + +withExistingDir :: (MonadIO m, MonadMask m) + => PbConfig 'Existing -- ^ Configuration + -> Path b Dir -- ^ Name of directory to edit + -> (Path Abs Dir -> m a) -- ^ Given name of temporary directory, do it + -> m a +withExistingDir pbc dpath action = withTempDir pbc $ \tdir -> do + copyDir dpath tdir + liftM2 const (action tdir) (moveDir tdir dpath) + +---------------------------------------------------------------------------- +-- Operations on containers + +-- | Create new container file. This is suitable for processing of all sorts +-- of archive-like objects. The first and second arguments specify how to +-- unpack directory from file and pack it back. The fourth argument names +-- new file. The fifth argument allows to perform actions knowing name of +-- temporary directory. +-- +-- This action throws 'alreadyExistsErrorType' by default instead of +-- silently overwriting already existing file, use 'overrideIfExists' and +-- 'useIfExists'to change this behavior. + +withNewContainer :: (MonadIO m, MonadMask m) + => (Path Abs File -> Path Abs Dir -> m ()) + -- ^ How to unpack file into specified directory + -> (Path Abs Dir -> Path b File -> m ()) + -- ^ How to pack specified directory into file + -> PbConfig 'New -- ^ Configuration + -> Path b File -- ^ Name of container to create + -> (Path Abs Dir -> m a) -- ^ Given name of temporary directory, do it + -> m a +withNewContainer unpack pack pbc fpath action = + withTempDir pbc $ \tdir -> do + withTempDir pbc $ \udir -> do + let apath = constructFilePath udir fpath + checkExistenceOfFile pbc apath fpath + using <- P.doesFileExist apath + when using (unpack apath tdir) + liftM2 const (action tdir) (pack tdir fpath) + +-- | Edit existing container file. This is suitable for processing of all +-- sorts of archive-like objects. The first and second arguments specify how +-- to unpack directory from file and pack it back (overwriting old +-- version). Fourth argument names container file to edit. The last argument +-- allows to perform actions knowing name of temporary directory. +-- +-- This action throws 'doesNotExistErrorType' exception if target file does +-- not exist. + +withExistingContainer :: (MonadIO m, MonadMask m) + => (Path b File -> Path Abs Dir -> m ()) + -- ^ How to unpack file into specified directory + -> (Path Abs Dir -> Path b File -> m ()) + -- ^ How to pack specified directory into file + -> PbConfig 'Existing -- ^ Configuration + -> Path b File -- ^ Name of container to edit + -> (Path Abs Dir -> m a) -- ^ Given name of temporary directory, do it + -> m a +withExistingContainer unpack pack pbc fpath action = + withTempDir pbc $ \tdir -> do + unpack fpath tdir + liftM2 const (action tdir) (pack tdir fpath) + +---------------------------------------------------------------------------- +-- Helpers + +-- | Use temporary directory. This action is controlled by supplied +-- configuration, see 'HasTemp'. The temporary directory is removed +-- automatically when given action finishes, although this can be changed +-- via the mentioned configuration value too. If given action finishes +-- successfully, temporary directory is always deleted. + +withTempDir :: (HasTemp c, MonadIO m, MonadMask m) + => c -- ^ Configuration + -> (Path Abs Dir -> m a) -- ^ Action to perform with the temporary file + -> m a +withTempDir pbc action = bracketOnError make freeOptionally $ \dir -> + liftM2 const (action dir) (freeAlways dir) + where + make = do + tsys <- P.getTempDir + let tdir = fromMaybe tsys (getTempDir pbc) + P.createDirIfMissing True tdir + let ntmp = fromMaybe "plan-b" (getNameTemplate pbc) + P.createTempDir tdir ntmp + freeAlways = ignoringIOErrors . P.removeDirRecur + freeOptionally = unless (getPreserveCorpse pbc) . freeAlways + +-- | Construct name of file combining given directory path and file name +-- from path to file. + +constructFilePath + :: Path Abs Dir -- ^ Directory name + -> Path b File -- ^ Get file name from this path + -> Path Abs File -- ^ Resulting path +constructFilePath dir file = dir filename file + +-- | Check existence of file and perform actions according to given +-- configuration. By default we throw 'alreadyExistsErrorType' unless user +-- has specified different 'AlreadyExistsBehavior'. If it's 'AebOverride', +-- then we don't need to do anything, file will be overwritten +-- automatically, if we have 'AebUse', then we should copy it into given +-- directory. + +checkExistenceOfFile :: (CanHandleExisting c, MonadIO m, MonadThrow m) + => c -- ^ Configuration + -> Path Abs File -- ^ Where to copy file (when we have 'AebUse') + -> Path b File -- ^ File to check + -> m () +checkExistenceOfFile pbc apath fpath = liftIO $ do + let ffile = toFilePath fpath + location = "System.PlanB.checkExistenceOfFile" + exists <- P.doesFileExist fpath + when exists $ + case howHandleExisting pbc of + Nothing -> throwM $ + mkIOError alreadyExistsErrorType location Nothing (Just ffile) + Just AebOverride -> return () + Just AebUse -> copyFile fpath apath + +-- | Check existence of directory and perform actions according to given +-- configuration. See 'checkExistenceOfFile', overall behavior is the same. + +checkExistenceOfDir :: (CanHandleExisting c, MonadIO m, MonadThrow m) + => c -- ^ Configuration + -> Path Abs Dir -- ^ Where to copy directory (when we have 'AebUse') + -> Path b Dir -- ^ Directory to check + -> m () +checkExistenceOfDir pbc apath dpath = liftIO $ do + let ddir = toFilePath dpath + location = "System.PlanB.checkExistenceOfDir" + exists <- P.doesDirExist dpath + when exists $ + case howHandleExisting pbc of + Nothing -> throwM $ + mkIOError alreadyExistsErrorType location Nothing (Just ddir) + Just AebOverride -> return () + Just AebUse -> copyDir dpath apath + +-- | Move specified directory to another location. If destination location +-- is already occupied, delete that object first. + +moveDir :: MonadIO m + => Path b0 Dir -- ^ Original location + -> Path b1 Dir -- ^ Where to move + -> m () +moveDir src dest = do + exists <- P.doesDirExist dest + when exists (P.removeDirRecur dest) + P.renameDir src dest + +-- | Copy file to new location. Throw 'doesNotExistErrorType' if it does not +-- exist. + +copyFile :: (MonadIO m, MonadThrow m) + => Path b0 File -- ^ Original location + -> Path b1 File -- ^ Where to put copy of the file + -> m () +copyFile src dest = liftIO $ do + let fsrc = toFilePath src + location = "System.PlanB.copyFile" + exists <- P.doesFileExist src + if exists + then P.copyFile src dest + else throwM $ + mkIOError doesNotExistErrorType location Nothing (Just fsrc) + +-- | Copy contents of one directory into another (recursively). Source +-- directory must exist, otherwise 'doesNotExistErrorType' is +-- thrown. Destination directory will be created if it doesn't exist. + +copyDir :: (MonadIO m, MonadCatch m) + => Path b0 Dir -- ^ Original location + -> Path b1 Dir -- ^ Where to put copy of the directory + -> m () +copyDir src dest = do + let fsrc = toFilePath src + location = "System.PlanB.copyDir" + exists <- P.doesDirExist src + if exists + then P.copyDirRecur src dest + else throwM $ + mkIOError doesNotExistErrorType location Nothing (Just fsrc) + +-- | Perform specified action ignoring IO exceptions it may throw. + +ignoringIOErrors :: MonadCatch m => m () -> m () +ignoringIOErrors ioe = ioe `catch` handler + where + handler :: MonadThrow m => IOError -> m () + handler = const (return ()) diff --git a/System/PlanB/Type.hs b/System/PlanB/Type.hs new file mode 100644 --- /dev/null +++ b/System/PlanB/Type.hs @@ -0,0 +1,128 @@ +-- | +-- Module : System.PlanB.Type +-- Copyright : © 2016 Mark Karpov +-- License : BSD 3 clause +-- +-- Maintainer : Mark Karpov +-- Stability : experimental +-- Portability : portable +-- +-- Types and type classes for “Plan B” library. You usually don't need to +-- import this module because "System.PlanB" already exports everything you +-- need. + +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE KindSignatures #-} + +module System.PlanB.Type + ( Subject (..) + , AlreadyExistsBehavior (..) + , PbConfig + , HasTemp (..) + , CanHandleExisting (..) ) +where + +import Control.Applicative +import Data.Monoid +import Path + +-- | We use this as named kind with two promoted constructors. The +-- constructors are used as phantom types to index 'PbConfig'. + +data Subject = New | Existing + +-- | Custom behavior for cases when something already exists. + +data AlreadyExistsBehavior + = AebOverride -- ^ First delete that object, then do your thing + | AebUse -- ^ Continue to work with that object instead + deriving (Eq, Enum, Bounded) + +-- | The configuration allows to control behavior of the library in +-- details. It's a 'Monoid' and so various configuration settings can be +-- combined using 'mappend' while 'mempty' represents default behavior. +-- +-- When combining conflicting configuration settings, the value on the left +-- side of 'mappend' wins: +-- +-- > overrideIfExists <> useIfExists -- will override + +data PbConfig :: Subject -> * where + PbConfig :: + { pbcTempDir :: Maybe (Path Abs Dir) + , pbcNameTemplate :: Maybe String + , pbcPreserveCorpse :: Any + , pbcAlreadyExists :: Maybe AlreadyExistsBehavior + } -> PbConfig k + +instance Monoid (PbConfig k) where + mempty = PbConfig empty empty mempty empty + x `mappend` y = PbConfig + { pbcTempDir = pbcTempDir x <|> pbcTempDir y + , pbcNameTemplate = pbcNameTemplate x <|> pbcNameTemplate y + , pbcPreserveCorpse = pbcPreserveCorpse x <> pbcPreserveCorpse y + , pbcAlreadyExists = pbcAlreadyExists x <|> pbcAlreadyExists y } + +-- | The type class is for data types that include information specifying +-- how to create temporary files and directories and whether to delete them +-- automatically or not. + +class HasTemp c where + + -- | Specifies name of temporary directory to use. Default is the system + -- temporary directory. If the directory does not exist, it will be + -- created, but not deleted. + + tempDir :: Path Abs Dir -> c + + -- | Specify template to use to name temporary directory, see + -- 'System.Directory.openTempFile', default is @\"plan-b\"@. + + nameTemplate :: String -> c + + -- | 'preserveCorpse' preserves temporary files and directories when + -- exception is thrown (normally they are removed). + + preserveCorpse :: c + + getTempDir :: c -> Maybe (Path Abs Dir) + getNameTemplate :: c -> Maybe String + getPreserveCorpse :: c -> Bool + +instance HasTemp (PbConfig k) where + + tempDir dir = mempty { pbcTempDir = Just dir } + nameTemplate nt = mempty { pbcNameTemplate = Just nt } + preserveCorpse = mempty { pbcPreserveCorpse = Any True } + + getTempDir = pbcTempDir + getNameTemplate = pbcNameTemplate + getPreserveCorpse = getAny . pbcPreserveCorpse + +-- | The type class includes data types that contain information about what +-- to do when some object already exists. There are two scenarios currently +-- supported: override it or use it. + +class CanHandleExisting c where + + -- | The option allows to avoid throwing exception if upon completion of + -- specified action file with given name already exists in the file + -- system. + + overrideIfExists :: c + + -- | The option will copy already existing file into temporary location, + -- so you can edit it instead of creating new file. + + useIfExists :: c + + howHandleExisting :: c -> Maybe AlreadyExistsBehavior + +instance CanHandleExisting (PbConfig 'New) where + + overrideIfExists = mempty { pbcAlreadyExists = Just AebOverride } + useIfExists = mempty { pbcAlreadyExists = Just AebUse } + + howHandleExisting = pbcAlreadyExists diff --git a/plan-b.cabal b/plan-b.cabal new file mode 100644 --- /dev/null +++ b/plan-b.cabal @@ -0,0 +1,85 @@ +-- +-- Cabal configuration for ‘plan-b’. +-- +-- Copyright © 2016 Mark Karpov +-- +-- Redistribution and use in source and binary forms, with or without +-- modification, are permitted provided that the following conditions are +-- met: +-- +-- * Redistributions of source code must retain the above copyright notice, +-- this list of conditions and the following disclaimer. +-- +-- * 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. +-- +-- * Neither the name Mark Karpov nor the names of 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 “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 HOLDERS 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. + +name: plan-b +version: 0.1.0 +cabal-version: >= 1.10 +license: BSD3 +license-file: LICENSE.md +author: Mark Karpov +maintainer: Mark Karpov +homepage: https://github.com/mrkkrp/plan-b +bug-reports: https://github.com/mrkkrp/plan-b/issues +category: System, Filesystem +synopsis: Failure-tolerant file and directory editing +build-type: Simple +description: Failure-tolerant file and directory editing. +extra-source-files: CHANGELOG.md + , README.md + +flag dev + description: Turn on development settings. + manual: True + default: False + +library + build-depends: base >= 4.7 && < 5 + , exceptions >= 0.8 + , path >= 0.5 + , path-io >= 0.2 + , transformers >= 0.3 + exposed-modules: System.PlanB + , System.PlanB.Type + if flag(dev) + ghc-options: -Wall -Werror + else + ghc-options: -O2 -Wall + default-language: Haskell2010 + +test-suite tests + main-is: Main.hs + hs-source-dirs: tests + type: exitcode-stdio-1.0 + if flag(dev) + ghc-options: -Wall -Werror + else + ghc-options: -O2 -Wall + build-depends: base >= 4.7 && < 5 + , hspec >= 2.0 + , path >= 0.5 + , path-io >= 0.2 + , plan-b >= 0.1.0 + default-language: Haskell2010 + +source-repository head + type: git + location: https://github.com/mrkkrp/plan-b.git diff --git a/tests/Main.hs b/tests/Main.hs new file mode 100644 --- /dev/null +++ b/tests/Main.hs @@ -0,0 +1,470 @@ +-- +-- Plan B tests. +-- +-- Copyright © 2016 Mark Karpov +-- +-- Redistribution and use in source and binary forms, with or without +-- modification, are permitted provided that the following conditions are +-- met: +-- +-- * Redistributions of source code must retain the above copyright notice, +-- this list of conditions and the following disclaimer. +-- +-- * 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. +-- +-- * Neither the name Mark Karpov nor the names of 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 “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 HOLDERS 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. + +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE TemplateHaskell #-} + +module Main (main) where + +import Control.Arrow ((***)) +import Control.Exception +import Control.Monad +import Data.List ((\\), delete, sort) +import Data.Monoid +import Data.Typeable (Typeable) +import Path +import System.IO.Error +import System.PlanB +import Test.Hspec +import qualified Path.IO as P + +#if !MIN_VERSION_base(4,8,0) +import Control.Applicative ((<$>), (<$)) +#endif + +main :: IO () +main = hspec . around withSandbox $ do + describe "withNewFile" withNewFileSpec + describe "withExistingFile" withExistingFileSpec + describe "withNewDir" withNewDirSpec + describe "withExistingDir" withExistingDirSpec + describe "withNewContainer" withNewContainerSpec + describe "withExistingConcainer" withExistingContainerSpec + +---------------------------------------------------------------------------- +-- Operations on files + +withNewFileSpec :: SpecWith (Path Abs Dir) +withNewFileSpec = do + + context "when such file already exists" . beforeWith populatedFile $ do + context "when we want to error" $ + it "throws the right exception" $ \file -> do + withNewFile' mempty file pncFile `shouldThrow` isAlreadyExistsError + detectFile (Just oldFileCont) file + context "when we want to override it" $ + it "overrides it" $ \file -> do + withNewFile' overrideIfExists file pncFile + detectFile (Just newFileCont) file + context "when we want to use it" $ + it "makes it available for editing" $ \file -> do + withNewFile' useIfExists file getFileCont `shouldReturn` oldFileCont + detectFile (Just oldFileCont) file + + context "when such file does not exist" . beforeWith missingFile $ do + context "when we throw" $ do + context "when we don't want corpse" $ + it "propagates exception, the corpse is removed" $ \file -> do + withNewFile' mempty file (pncFile >=> throwExc) + `shouldThrow` isExc + detectFile Nothing file + detectCorpse False file + context "when we want corpse" $ + it "propagates exception, the corpse is there" $ \file -> do + withNewFile' preserveCorpse file (pncFile >=> throwExc) + `shouldThrow` isExc + detectFile Nothing file + detectCorpse True file + context "when we finish successfully" $ + it "creates the right file, corpse is always removed" $ \file -> do + withNewFile' preserveCorpse file pncFile + detectFile (Just newFileCont) file + detectCorpse False file + + where + withNewFile' pbc p = withNewFile (tempDir (parent p) <> pbc) p + +withExistingFileSpec :: SpecWith (Path Abs Dir) +withExistingFileSpec = do + + context "when target file exists" . beforeWith populatedFile $ do + context "when we throw" $ do + context "when we don't want corpse" $ + it "propagates exception, the corpse is removed" $ \file -> do + withExistingFile' mempty file (pncFile >=> throwExc) + `shouldThrow` isExc + detectFile (Just oldFileCont) file + detectCorpse False file + context "when we want corpse" $ + it "propagates exception, the corpse is there" $ \file -> do + withExistingFile' preserveCorpse file (pncFile >=> throwExc) + `shouldThrow` isExc + detectFile (Just oldFileCont) file + detectCorpse True file + context "when we finish successfully" $ + it "updates the right file, corpse is always removed" $ \file -> do + withExistingFile' preserveCorpse file pncFile + detectFile (Just newFileCont) file + detectCorpse False file + + context "when target file is missing" . beforeWith missingFile $ + it "throws the right exception" $ \file -> do + withExistingFile' mempty file pncFile `shouldThrow` isDoesNotExistError + detectFile Nothing file + + where + withExistingFile' pbc p = withExistingFile (tempDir (parent p) <> pbc) p + +---------------------------------------------------------------------------- +-- Operations on directories + +withNewDirSpec :: SpecWith (Path Abs Dir) +withNewDirSpec = do + + context "when such directory already exists" . beforeWith populatedDir $ do + context "when we want to error" $ + it "throws the right exception" $ \dir -> do + withNewDir' mempty dir pncDir `shouldThrow` isAlreadyExistsError + detectDir (Just oldDirCont) dir + context "when we want to override it" $ + it "overrides it" $ \dir -> do + withNewDir' overrideIfExists dir pncDir + detectDir (Just newDirCont) dir + context "when we want to use it" $ + it "makes it available for editing" $ \dir -> do + withNewDir' useIfExists dir getDirCont `shouldReturn` oldDirCont + detectDir (Just oldDirCont) dir + + context "when such directory does not exist" . beforeWith missingDir $ do + context "when we throw" $ do + context "when we don't want corpse" $ + it "propagates exception, the corpse is removed" $ \dir -> do + withNewDir' mempty dir (pncDir >=> throwExc) + `shouldThrow` isExc + detectDir Nothing dir + detectCorpse False dir + context "when we want corpse" $ + it "propagates exception, the corpse is there" $ \dir -> do + withNewDir' preserveCorpse dir (pncDir >=> throwExc) + `shouldThrow` isExc + detectDir Nothing dir + detectCorpse True dir + context "when we finish successfully" $ + it "creates the right directory, corpse is always removed" $ \dir -> do + withNewDir' preserveCorpse dir pncDir + detectDir (Just newDirCont) dir + detectCorpse False dir + + where + withNewDir' pbc p = withNewDir (tempDir (parent p) <> pbc) p + +withExistingDirSpec :: SpecWith (Path Abs Dir) +withExistingDirSpec = do + + context "when target directory exists" . beforeWith populatedDir $ do + context "when we throw" $ do + context "when we don't want corpse" $ + it "propagates exception, the corpse is removed" $ \dir -> do + withExistingDir' mempty dir (pncDir >=> throwExc) + `shouldThrow` isExc + detectDir (Just oldDirCont) dir + detectCorpse False dir + context "when we want corpse" $ + it "propagates exception, the corpse is there" $ \dir -> do + withExistingDir' preserveCorpse dir (pncDir >=> throwExc) + `shouldThrow` isExc + detectDir (Just oldDirCont) dir + detectCorpse True dir + context "when we finish successfully" $ + it "updates the right directory, corpse is always removed" $ \dir -> do + withExistingDir' preserveCorpse dir pncDir + detectDir (Just newDirCont) dir + detectCorpse False dir + + context "when target directory is missing" . beforeWith missingDir $ + it "throws the right exception" $ \dir -> do + withExistingDir' mempty dir pncDir `shouldThrow` isDoesNotExistError + detectDir Nothing dir + + where + withExistingDir' pbc p = withExistingDir (tempDir (parent p) <> pbc) p + +---------------------------------------------------------------------------- +-- Operations on containers + +withNewContainerSpec :: SpecWith (Path Abs Dir) +withNewContainerSpec = do + + context "when container already exists" . beforeWith populatedFile $ do + context "when we want to error" $ + it "throws the right exception" $ \file -> do + withNewContainer' mempty file pncDir `shouldThrow` isAlreadyExistsError + detectFile (Just oldFileCont) file + context "when we want to override it" $ + it "overrides it" $ \file -> do + withNewContainer' overrideIfExists file pncDir + detectFile (Just newFileCont) file + context "when we want to use it" $ + it "makes it available for editing" $ \file -> do + withNewContainer' useIfExists file getDirCont `shouldReturn` oldDirCont + detectFile (Just oldFileCont) file + + context "when container does not exist" . beforeWith missingFile $ do + context "when we throw" $ do + context "when we don't want corpse" $ + it "propagates exception, the corpse is removed" $ \file -> do + withNewContainer' mempty file (pncDir >=> throwExc) + `shouldThrow` isExc + detectFile Nothing file + detectCorpse False file + context "when we want corpse" $ + it "propagates exception, the corpse is there" $ \file -> do + withNewContainer' preserveCorpse file (pncDir >=> throwExc) + `shouldThrow` isExc + detectFile Nothing file + detectCorpse True file + context "when we finish successfully" $ + it "creates the right file, corpse is always removed" $ \file -> do + withNewContainer' preserveCorpse file pncDir + detectFile (Just newFileCont) file + detectCorpse False file + + where + withNewContainer' pbc p = + withNewContainer unpack pack (tempDir (parent p) <> pbc) p + +withExistingContainerSpec :: SpecWith (Path Abs Dir) +withExistingContainerSpec = do + + context "when container exists" . beforeWith populatedFile $ do + context "when we throw" $ do + context "when we don't want corpse" $ + it "propagates exception, the corpse is removed" $ \file -> do + withExistingContainer' mempty file (pncDir >=> throwExc) + `shouldThrow` isExc + detectFile (Just oldFileCont) file + detectCorpse False file + context "when we want corpse" $ + it "propagates exception, the corpse is there" $ \file -> do + withExistingContainer' preserveCorpse file (pncDir >=> throwExc) + `shouldThrow` isExc + detectFile (Just oldFileCont) file + detectCorpse True file + context "when we finish successfully" $ + it "updates the container, corpse is always removed" $ \file -> do + withExistingContainer' preserveCorpse file pncDir + detectFile (Just newFileCont) file + detectCorpse False file + + context "when container is missing" . beforeWith missingFile $ + it "throws the right exception" $ \file -> do + withExistingContainer' mempty file pncDir + `shouldThrow` isDoesNotExistError + detectFile Nothing file + + where + withExistingContainer' pbc p = + withExistingContainer unpack pack (tempDir (parent p) <> pbc) p + +---------------------------------------------------------------------------- +-- Helpers + +-- | Create sandbox directory to model some situation in it and run some +-- tests. Note that we're using new unique sandbox directory for each test +-- case to avoid contamination and it's unconditionally deleted after test +-- case finishes. + +withSandbox :: ActionWith (Path Abs Dir) -> IO () +withSandbox = P.withSystemTempDir "plan-b-sandbox" + +-- | Create “old” file in the sandbox directory (its location is passed as +-- the first parameter). Return location of the file to be used in tests. + +populatedFile :: Path Abs Dir -> IO (Path Abs File) +populatedFile dir = path <$ writeFile (toFilePath path) oldFileCont + where path = dir preExistingFile + +-- | Create “old” directory in the sandbox directory. Similar to +-- 'populatedFile', but this thing is a bit more complex because it has +-- several files in it. + +populatedDir :: Path Abs Dir -> IO (Path Abs Dir) +populatedDir dir = do + P.createDirIfMissing True path + forM_ oldDirCont $ \file -> + writeFile (toFilePath $ path file) "" + return path + where path = dir preExistingDir + +-- | Don't create any file, but generate its name and return it, so it can +-- be used in tests. + +missingFile :: Path Abs Dir -> IO (Path Abs File) +missingFile dir = return (dir preExistingFile) + +-- | Similarly, don't create any directory, but generate its name. + +missingDir :: Path Abs Dir -> IO (Path Abs Dir) +missingDir dir = return (dir preExistingDir) + +-- | Unique type of exception that we throw in tests. + +data PlanBException = PlanBException + deriving (Show, Typeable) + +instance Exception PlanBException + +-- | Throw exception of type 'PlanBException'. + +throwExc :: a +throwExc = throw PlanBException + +-- | Selects only 'PlanBException'. + +isExc :: Selector PlanBException +isExc = const True + +-- | If the first argument is 'Nothing', file should not exist, otherwise +-- its content should match given 'String'. Name of file is taken as the +-- second argument. + +detectFile :: Maybe String -> Path Abs File -> Expectation +detectFile mcont file = do + exists <- P.doesFileExist file + case mcont of + Nothing -> + when exists . expectationFailure $ + "target file should not exist, but it does" + Just cont -> do + unless exists . expectationFailure $ + "target file does not exist, but it should" + acont <- readFile (toFilePath file) + unless (cont == acont) . expectationFailure $ + "contents of target file are incorrect:\n" ++ show acont + +-- | If the first argument is 'Nothing', directory should not exist, +-- otherwise its contents should match given collection of files (but no +-- directories allowed in any case). For the sake of simplicity, we do not +-- check contents of those files. Name of directory is taken as the second +-- argument. + +detectDir :: Maybe [Path Rel File] -> Path Abs Dir -> Expectation +detectDir mcont dir = do + exists <- P.doesDirExist dir + case mcont of + Nothing -> + when exists . expectationFailure $ + "target dir should not exist, but it does" + Just cont -> do + unless exists . expectationFailure $ + "target dir does not exist, but it should" + (dirs, files) <- P.listDirRecur dir + files' <- mapM (P.canonicalizePath >=> stripDir dir) files + unless (null dirs && null (cont \\ files')) . expectationFailure $ + "contents of target directory are incorrect:\n" ++ + unlines (show <$> files') + +-- | First argument specifies whether there should be anything in the +-- sandbox directory except for given object. The action checks that +-- expectation. Since we put temporary files (in case of failure these are +-- called corpse and are normally deleted) in the same sandbox as target +-- file, this is a reliable way to check if those temporary files have been +-- deleted. + +detectCorpse :: Bool -> Path Abs t -> Expectation +detectCorpse must file = do + items <- uncurry mappend . (fmap toFilePath *** fmap toFilePath) + <$> P.listDir (parent file) + if null (delete (toFilePath file) items) + then when must . expectationFailure $ + "no corpse detected, but it should exist:\n" ++ + unlines (show <$> items) + else unless must . expectationFailure $ + "there is corpse, although it should not exist:\n" ++ + unlines (show <$> items) + +-- | Get contents of file. + +getFileCont :: Path Abs File -> IO String +getFileCont = readFile . toFilePath + +-- | Get contents of directory, only files and they are sorted. + +getDirCont :: Path Abs Dir -> IO [Path Rel File] +getDirCont dir = sort <$> (P.listDir dir >>= mapM (stripDir dir) . snd) + +-- | “Edit” file — overwrite it with new content. + +pncFile :: Path Abs File -> IO () +pncFile file = writeFile (toFilePath file) newFileCont + +-- | “Edit” directory — write/overwrite it with new content. This is done by +-- deletion of files listed in 'oldDirCont' and creation of files listed in +-- 'newDirCont'. + +pncDir :: Path Abs Dir -> IO () +pncDir dir = do + forM_ ((dir ) <$> oldDirCont) $ \file -> do + exists <- P.doesFileExist file + when exists (P.removeFile file) + forM_ ((dir ) <$> newDirCont) $ \file -> + writeFile (toFilePath file) "" + +-- | When given file has 'oldFileCont', put 'oldDirCont' into specified +-- directory. Otherwise put 'newDirCont' there. + +unpack :: Path Abs File -> Path Abs Dir -> IO () +unpack file dir = do + content <- getFileCont file + forM_ (if content == oldFileCont then oldDirCont else newDirCont) $ \f -> + writeFile (toFilePath $ dir f) "" + +-- | When given directory has 'oldDirCont', write file with 'oldFileCont' to +-- specified path. Otherwise put 'newFileCont' there. + +pack :: Path Abs Dir -> Path Abs File -> IO () +pack dir file = do + content <- getDirCont dir + writeFile (toFilePath file) $ + if content == oldDirCont then oldFileCont else newFileCont + +---------------------------------------------------------------------------- +-- Constants + +preExistingFile :: Path Rel File +preExistingFile = $(mkRelFile "file.txt") + +preExistingDir :: Path Rel Dir +preExistingDir = $(mkRelDir "dir") + +oldFileCont :: String +oldFileCont = "old" + +newFileCont :: String +newFileCont = "new" + +oldDirCont :: [Path Rel File] +oldDirCont = [$(mkRelFile "old-file-0.txt"), $(mkRelFile "old-file-1.txt")] + +newDirCont :: [Path Rel File] +newDirCont = [$(mkRelFile "new-file-0.txt"), $(mkRelFile "new-file-1.txt")]