plan-b (empty) → 0.1.0

raw patch · 8 files changed

+1101/−0 lines, 8 filesdep +basedep +exceptionsdep +hspecsetup-changed

Dependencies added: base, exceptions, hspec, path, path-io, plan-b, transformers

Files

CHANGELOG.md +3/−0
LICENSE.md +28/−0
README.md +81/−0
Setup.hs +6/−0
System/PlanB.hs +300/−0
System/PlanB/Type.hs +128/−0
plan-b.cabal +85/−0
tests/Main.hs +470/−0

+ CHANGELOG.md view

@@ -0,0 +1,3 @@+## Plan B 0.1.0++* Initial release.

+ LICENSE.md view

@@ -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.

+ README.md view

@@ -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.

+ Setup.hs view

@@ -0,0 +1,6 @@+module Main (main) where++import Distribution.Simple++main :: IO ()+main = defaultMain

+ System/PlanB.hs view

@@ -0,0 +1,300 @@+-- |+-- Module      :  System.PlanB+-- Copyright   :  © 2016 Mark Karpov+-- License     :  BSD 3 clause+--+-- Maintainer  :  Mark Karpov <markkarpov@openmailbox.org>+-- 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 ())

+ System/PlanB/Type.hs view

@@ -0,0 +1,128 @@+-- |+-- Module      :  System.PlanB.Type+-- Copyright   :  © 2016 Mark Karpov+-- License     :  BSD 3 clause+--+-- Maintainer  :  Mark Karpov <markkarpov@openmailbox.org>+-- 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

+ plan-b.cabal view

@@ -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 <markkarpov@opmbx.org>+maintainer:           Mark Karpov <markkarpov@opmbx.org>+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

+ tests/Main.hs view

@@ -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")]