propellor

propellor config for hosts.
git clone git://git.ricketyspace.net/propellor.git
Log | Files | Refs | LICENSE

Atomic.hs (5654B)


      1 {-# LANGUAGE DataKinds #-}
      2 {-# LANGUAGE TypeFamilies #-}
      3 
      4 module Propellor.Property.Atomic (
      5 	atomicDirUpdate,
      6 	atomicDirSync,
      7 	atomicUpdate,
      8 	AtomicResourcePair(..),
      9 	flipAtomicResourcePair,
     10 	SwapAtomicResourcePair,
     11 	CheckAtomicResourcePair,
     12 ) where
     13 
     14 import Propellor.Base
     15 import Propellor.Types.Core
     16 import Propellor.Types.MetaTypes
     17 import Propellor.EnsureProperty
     18 import Propellor.Property.File
     19 import Propellor.Property.Rsync (syncDir)
     20 
     21 import System.Posix.Files
     22 
     23 -- | A pair of resources, one active and one inactive, which can swap
     24 -- positions atomically.
     25 data AtomicResourcePair a = AtomicResourcePair
     26 	{ activeAtomicResource :: a
     27 	, inactiveAtomicResource :: a
     28 	}
     29 
     30 flipAtomicResourcePair :: AtomicResourcePair a -> AtomicResourcePair a
     31 flipAtomicResourcePair a = AtomicResourcePair
     32 	{ activeAtomicResource = inactiveAtomicResource a
     33 	, inactiveAtomicResource = activeAtomicResource a
     34 	}
     35 
     36 -- | Action that activates the inactiveAtomicResource, and deactivates
     37 -- the activeAtomicResource. This action must be fully atomic.
     38 type SwapAtomicResourcePair a = AtomicResourcePair a -> Propellor Bool
     39 
     40 -- | Checks which of the pair of resources is currently active and
     41 -- which is inactive, and puts them in the correct poisition in
     42 -- the AtomicResourcePair.
     43 type CheckAtomicResourcePair a = AtomicResourcePair a -> Propellor (AtomicResourcePair a)
     44 
     45 -- | Makes a non-atomic Property be atomic, by applying it to the 
     46 -- inactiveAtomicResource, and if it was successful,
     47 -- atomically activating that resource.
     48 atomicUpdate
     49 	-- Constriaint inherited from ensureProperty.
     50 	:: EnsurePropertyAllowed t t
     51 	=> SingI t
     52 	=> AtomicResourcePair a
     53 	-> CheckAtomicResourcePair a
     54 	-> SwapAtomicResourcePair a
     55 	-> (a -> Property (MetaTypes t))
     56 	-> Property (MetaTypes t)
     57 atomicUpdate rbase rcheck rswap mkp = property' d $ \w -> do
     58 	r <- rcheck rbase
     59 	res <- ensureProperty w $ mkp $ inactiveAtomicResource r
     60 	case res of
     61 		FailedChange -> return FailedChange
     62 		NoChange -> return NoChange
     63 		MadeChange -> do
     64 			ok <- rswap r
     65 			if ok
     66 				then return res
     67 				else return FailedChange
     68   where
     69 	d = getDesc $ mkp $ activeAtomicResource rbase
     70 
     71 -- | Applies a Property to a directory such that the directory is updated
     72 -- fully atomically; there is no point in time in which the directory will
     73 -- be in an inconsistent state.
     74 --
     75 -- For example, git repositories are not usually updated atomically,
     76 -- and so while the repository is being updated, the files in it can be a
     77 -- mixture of two different versions, which could cause unexpected
     78 -- behavior to consumers. To avoid such problems:
     79 --
     80 -- >	& atomicDirUpdate "/srv/web/example.com"
     81 -- >		(\d -> Git.pulled "joey" "http://.." d Nothing)
     82 --
     83 -- This operates by making a second copy of the directory, and passing it
     84 -- to the Property, which can make whatever changes it needs to that copy,
     85 -- non-atomically. After the Property successfully makes a change, the
     86 -- copy is swapped into place, fully atomically.
     87 --
     88 -- This necessarily uses double the disk space, since there are two copies
     89 -- of the directory. The parent directory will actually contain three
     90 -- children: a symlink with the name of the directory itself, and two copies
     91 -- of the directory, with names suffixed with ".1" and ".2"
     92 atomicDirUpdate
     93 	-- Constriaint inherited from ensureProperty.
     94 	:: EnsurePropertyAllowed t t
     95 	=> SingI t
     96 	=> FilePath
     97 	-> (FilePath -> Property (MetaTypes t))
     98 	-> Property (MetaTypes t)
     99 atomicDirUpdate d = atomicUpdate (mkDirLink d) (checkDirLink d) (swapDirLink d)
    100 
    101 mkDirLink :: FilePath -> AtomicResourcePair FilePath
    102 mkDirLink d = AtomicResourcePair
    103 	{ activeAtomicResource = addext ".1"
    104 	, inactiveAtomicResource = addext ".2"
    105 	}
    106   where
    107 	addext = addExtension (dropTrailingPathSeparator d)
    108 
    109 inactiveLinkTarget :: AtomicResourcePair FilePath -> FilePath
    110 inactiveLinkTarget = takeFileName . inactiveAtomicResource
    111 
    112 swapDirLink :: FilePath -> SwapAtomicResourcePair FilePath
    113 swapDirLink d rp = liftIO $ do
    114 	v <- tryIO $ createSymbolicLink (inactiveLinkTarget rp)
    115 		`viaStableTmp` d
    116 	case v of
    117 		Right () -> return True
    118 		Left e -> do
    119 			warningMessage $ "Unable to update symlink at " ++ d ++ " (" ++ show e ++ ")"
    120 			return False
    121 
    122 checkDirLink :: FilePath -> CheckAtomicResourcePair FilePath
    123 checkDirLink d rp = liftIO $ do
    124 	v <- tryIO $ readSymbolicLink d
    125 	return $ case v of
    126 		Right t | t == inactiveLinkTarget rp ->
    127 			flipAtomicResourcePair rp
    128 		_ -> rp
    129 
    130 -- | This can optionally be used after atomicDirUpdate to rsync the changes
    131 -- that were made over to the other copy of the directory. It's not
    132 -- necessary to use this, but it can improve efficiency.
    133 --
    134 -- For example:
    135 --
    136 -- >	& atomicDirUpdate "/srv/web/example.com"
    137 -- >		(\d -> Git.pulled "joey" "http://.." d Nothing)
    138 -- >		`onChange` atomicDirSync "/srv/web/example.com"
    139 --
    140 -- Using atomicDirSync in the above example lets git only download
    141 -- the changes once, rather than the same changes being downloaded a second
    142 -- time to update the other copy of the directory the next time propellor
    143 -- runs.
    144 --
    145 -- Suppose that a web server program is run from the git repository,
    146 -- and needs to be restarted after the pull. That restart should be done
    147 -- after the atomicDirUpdate, but before the atomicDirSync. That way,
    148 -- the old web server process will not have its files changed out from
    149 -- under it.
    150 --
    151 -- >	& atomicDirUpdate "/srv/web/example.com"
    152 -- >		(\d -> Git.pulled "joey" "http://.." d Nothing)
    153 -- >		`onChange` (webServerRestart `before` atomicDirSync "/srv/web/example.com")
    154 atomicDirSync :: FilePath -> Property (DebianLike + ArchLinux)
    155 atomicDirSync d = syncDir (activeAtomicResource rp) (inactiveAtomicResource rp)
    156   where
    157 	rp = mkDirLink d