module Propellor.Property.DebianMirror
( DebianPriority (..)
, showPriority
, mirror
, RsyncExtra (..)
, Method (..)
, DebianMirror
, debianMirrorHostName
, debianMirrorSuites
, debianMirrorArchitectures
, debianMirrorSections
, debianMirrorSourceBool
, debianMirrorPriorities
, debianMirrorMethod
, debianMirrorKeyring
, debianMirrorRsyncExtra
, mkDebianMirror
) where
import Propellor.Base
import qualified Propellor.Property.File as File
import qualified Propellor.Property.Apt as Apt
import qualified Propellor.Property.Cron as Cron
import qualified Propellor.Property.User as User
import Data.List
data DebianPriority = Essential | Required | Important | Standard | Optional |
deriving (Int -> DebianPriority -> ShowS
[DebianPriority] -> ShowS
DebianPriority -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [DebianPriority] -> ShowS
$cshowList :: [DebianPriority] -> ShowS
show :: DebianPriority -> String
$cshow :: DebianPriority -> String
showsPrec :: Int -> DebianPriority -> ShowS
$cshowsPrec :: Int -> DebianPriority -> ShowS
Show, DebianPriority -> DebianPriority -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: DebianPriority -> DebianPriority -> Bool
$c/= :: DebianPriority -> DebianPriority -> Bool
== :: DebianPriority -> DebianPriority -> Bool
$c== :: DebianPriority -> DebianPriority -> Bool
Eq)
showPriority :: DebianPriority -> String
showPriority :: DebianPriority -> String
showPriority DebianPriority
Essential = String
"essential"
showPriority DebianPriority
Required = String
"required"
showPriority DebianPriority
Important = String
"important"
showPriority DebianPriority
Standard = String
"standard"
showPriority DebianPriority
Optional = String
"optional"
showPriority DebianPriority
Extra = String
"extra"
data = Doc | Indices | Tools | Trace
deriving (Int -> RsyncExtra -> ShowS
[RsyncExtra] -> ShowS
RsyncExtra -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [RsyncExtra] -> ShowS
$cshowList :: [RsyncExtra] -> ShowS
show :: RsyncExtra -> String
$cshow :: RsyncExtra -> String
showsPrec :: Int -> RsyncExtra -> ShowS
$cshowsPrec :: Int -> RsyncExtra -> ShowS
Show, RsyncExtra -> RsyncExtra -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: RsyncExtra -> RsyncExtra -> Bool
$c/= :: RsyncExtra -> RsyncExtra -> Bool
== :: RsyncExtra -> RsyncExtra -> Bool
$c== :: RsyncExtra -> RsyncExtra -> Bool
Eq)
showRsyncExtra :: RsyncExtra -> String
RsyncExtra
Doc = String
"doc"
showRsyncExtra RsyncExtra
Indices = String
"indices"
showRsyncExtra RsyncExtra
Tools = String
"tools"
showRsyncExtra RsyncExtra
Trace = String
"trace"
data Method = Ftp | Http | Https | Rsync | MirrorFile
showMethod :: Method -> String
showMethod :: Method -> String
showMethod Method
Ftp = String
"ftp"
showMethod Method
Http = String
"http"
showMethod Method
Https = String
"https"
showMethod Method
Rsync = String
"rsync"
showMethod Method
MirrorFile = String
"file"
data DebianMirror = DebianMirror
{ DebianMirror -> String
_debianMirrorHostName :: HostName
, DebianMirror -> String
_debianMirrorDir :: FilePath
, DebianMirror -> [DebianSuite]
_debianMirrorSuites :: [DebianSuite]
, DebianMirror -> [Architecture]
_debianMirrorArchitectures :: [Architecture]
, DebianMirror -> [String]
_debianMirrorSections :: [Apt.Section]
, DebianMirror -> Bool
_debianMirrorSourceBool :: Bool
, DebianMirror -> [DebianPriority]
_debianMirrorPriorities :: [DebianPriority]
, DebianMirror -> Method
_debianMirrorMethod :: Method
, DebianMirror -> String
_debianMirrorKeyring :: FilePath
, :: [RsyncExtra]
, DebianMirror -> Times
_debianMirrorCronTimes :: Cron.Times
}
mkDebianMirror :: FilePath -> Cron.Times -> DebianMirror
mkDebianMirror :: String -> Times -> DebianMirror
mkDebianMirror String
dir Times
crontimes = DebianMirror
{ _debianMirrorHostName :: String
_debianMirrorHostName = String
"deb.debian.org"
, _debianMirrorDir :: String
_debianMirrorDir = String
dir
, _debianMirrorSuites :: [DebianSuite]
_debianMirrorSuites = []
, _debianMirrorArchitectures :: [Architecture]
_debianMirrorArchitectures = []
, _debianMirrorSections :: [String]
_debianMirrorSections = []
, _debianMirrorSourceBool :: Bool
_debianMirrorSourceBool = Bool
False
, _debianMirrorPriorities :: [DebianPriority]
_debianMirrorPriorities = []
, _debianMirrorMethod :: Method
_debianMirrorMethod = Method
Http
, _debianMirrorKeyring :: String
_debianMirrorKeyring = String
"/usr/share/keyrings/debian-archive-keyring.gpg"
, _debianMirrorRsyncExtra :: [RsyncExtra]
_debianMirrorRsyncExtra = [RsyncExtra
Trace]
, _debianMirrorCronTimes :: Times
_debianMirrorCronTimes = Times
crontimes
}
debianMirrorHostName :: HostName -> DebianMirror -> DebianMirror
debianMirrorHostName :: String -> DebianMirror -> DebianMirror
debianMirrorHostName String
hn DebianMirror
m = DebianMirror
m { _debianMirrorHostName :: String
_debianMirrorHostName = String
hn }
debianMirrorSuites :: [DebianSuite] -> DebianMirror -> DebianMirror
debianMirrorSuites :: [DebianSuite] -> DebianMirror -> DebianMirror
debianMirrorSuites [DebianSuite]
s DebianMirror
m = DebianMirror
m { _debianMirrorSuites :: [DebianSuite]
_debianMirrorSuites = [DebianSuite]
s }
debianMirrorArchitectures :: [Architecture] -> DebianMirror -> DebianMirror
debianMirrorArchitectures :: [Architecture] -> DebianMirror -> DebianMirror
debianMirrorArchitectures [Architecture]
a DebianMirror
m = DebianMirror
m { _debianMirrorArchitectures :: [Architecture]
_debianMirrorArchitectures = [Architecture]
a }
debianMirrorSections :: [Apt.Section] -> DebianMirror -> DebianMirror
debianMirrorSections :: [String] -> DebianMirror -> DebianMirror
debianMirrorSections [String]
s DebianMirror
m = DebianMirror
m { _debianMirrorSections :: [String]
_debianMirrorSections = [String]
s }
debianMirrorSourceBool :: Bool -> DebianMirror -> DebianMirror
debianMirrorSourceBool :: Bool -> DebianMirror -> DebianMirror
debianMirrorSourceBool Bool
s DebianMirror
m = DebianMirror
m { _debianMirrorSourceBool :: Bool
_debianMirrorSourceBool = Bool
s }
debianMirrorPriorities :: [DebianPriority] -> DebianMirror -> DebianMirror
debianMirrorPriorities :: [DebianPriority] -> DebianMirror -> DebianMirror
debianMirrorPriorities [DebianPriority]
p DebianMirror
m = DebianMirror
m { _debianMirrorPriorities :: [DebianPriority]
_debianMirrorPriorities = [DebianPriority]
p }
debianMirrorMethod :: Method -> DebianMirror -> DebianMirror
debianMirrorMethod :: Method -> DebianMirror -> DebianMirror
debianMirrorMethod Method
me DebianMirror
m = DebianMirror
m { _debianMirrorMethod :: Method
_debianMirrorMethod = Method
me }
debianMirrorKeyring :: FilePath -> DebianMirror -> DebianMirror
debianMirrorKeyring :: String -> DebianMirror -> DebianMirror
debianMirrorKeyring String
k DebianMirror
m = DebianMirror
m { _debianMirrorKeyring :: String
_debianMirrorKeyring = String
k }
debianMirrorRsyncExtra :: [RsyncExtra] -> DebianMirror -> DebianMirror
[RsyncExtra]
r DebianMirror
m = DebianMirror
m { _debianMirrorRsyncExtra :: [RsyncExtra]
_debianMirrorRsyncExtra = [RsyncExtra]
r }
mirror :: DebianMirror -> Property DebianLike
mirror :: DebianMirror -> Property DebianLike
mirror DebianMirror
mirror' = forall {k} (metatypes :: k).
SingI metatypes =>
String
-> Props (MetaTypes metatypes) -> Property (MetaTypes metatypes)
propertyList (String
"Debian mirror " forall a. [a] -> [a] -> [a]
++ String
dir) forall a b. (a -> b) -> a -> b
$ Props UnixLike
props
forall {a} p (y :: [a]) (x :: [a]).
(IsProp p, MetaTypes y ~ GetMetaTypes p,
CheckCombinableNote x y (NoteFor ('Text "&"))) =>
Props (MetaTypes x) -> p -> Props (MetaTypes (Combine x y))
& [String] -> Property DebianLike
Apt.installed [String
"debmirror"]
forall {a} p (y :: [a]) (x :: [a]).
(IsProp p, MetaTypes y ~ GetMetaTypes p,
CheckCombinableNote x y (NoteFor ('Text "&"))) =>
Props (MetaTypes x) -> p -> Props (MetaTypes (Combine x y))
& User -> Property DebianLike
User.accountFor (String -> User
User String
"debmirror")
forall {a} p (y :: [a]) (x :: [a]).
(IsProp p, MetaTypes y ~ GetMetaTypes p,
CheckCombinableNote x y (NoteFor ('Text "&"))) =>
Props (MetaTypes x) -> p -> Props (MetaTypes (Combine x y))
& String -> Property UnixLike
File.dirExists String
dir
forall {a} p (y :: [a]) (x :: [a]).
(IsProp p, MetaTypes y ~ GetMetaTypes p,
CheckCombinableNote x y (NoteFor ('Text "&"))) =>
Props (MetaTypes x) -> p -> Props (MetaTypes (Combine x y))
& String -> User -> Group -> Property UnixLike
File.ownerGroup String
dir (String -> User
User String
"debmirror") (String -> Group
Group String
"debmirror")
forall {a} p (y :: [a]) (x :: [a]).
(IsProp p, MetaTypes y ~ GetMetaTypes p,
CheckCombinableNote x y (NoteFor ('Text "&"))) =>
Props (MetaTypes x) -> p -> Props (MetaTypes (Combine x y))
& forall (p :: * -> *) i (m :: * -> *).
(Checkable p i, LiftPropellor m) =>
m Bool -> p i -> Property i
check (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *). Foldable t => t Bool -> Bool
and forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM DebianSuite -> IO Bool
suitemirrored [DebianSuite]
suites)
(String -> [String] -> UncheckedProperty UnixLike
cmdProperty String
"debmirror" [String]
args)
forall p. IsProp p => p -> String -> p
`describe` String
"debmirror setup"
forall {a} p (y :: [a]) (x :: [a]).
(IsProp p, MetaTypes y ~ GetMetaTypes p,
CheckCombinableNote x y (NoteFor ('Text "&"))) =>
Props (MetaTypes x) -> p -> Props (MetaTypes (Combine x y))
& String -> Times -> User -> String -> String -> Property DebianLike
Cron.niceJob (String
"debmirror_" forall a. [a] -> [a] -> [a]
++ String
dir) (DebianMirror -> Times
_debianMirrorCronTimes DebianMirror
mirror') (String -> User
User String
"debmirror") String
"/"
([String] -> String
unwords (String
"/usr/bin/debmirror" forall a. a -> [a] -> [a]
: [String]
args))
where
dir :: String
dir = DebianMirror -> String
_debianMirrorDir DebianMirror
mirror'
suites :: [DebianSuite]
suites = DebianMirror -> [DebianSuite]
_debianMirrorSuites DebianMirror
mirror'
suitemirrored :: DebianSuite -> IO Bool
suitemirrored DebianSuite
suite = String -> IO Bool
doesDirectoryExist forall a b. (a -> b) -> a -> b
$ String
dir String -> ShowS
</> String
"dists" String -> ShowS
</> DebianSuite -> String
Apt.showSuite DebianSuite
suite
architecturearg :: [String] -> String
architecturearg = forall a. [a] -> [[a]] -> [a]
intercalate String
","
suitearg :: String
suitearg = forall a. [a] -> [[a]] -> [a]
intercalate String
"," forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map DebianSuite -> String
Apt.showSuite [DebianSuite]
suites
priorityRegex :: [DebianPriority] -> String
priorityRegex [DebianPriority]
pp = String
"(" forall a. [a] -> [a] -> [a]
++ forall a. [a] -> [[a]] -> [a]
intercalate String
"|" (forall a b. (a -> b) -> [a] -> [b]
map DebianPriority -> String
showPriority [DebianPriority]
pp) forall a. [a] -> [a] -> [a]
++ String
")"
rsyncextraarg :: [RsyncExtra] -> String
rsyncextraarg [] = String
"none"
rsyncextraarg [RsyncExtra]
res = forall a. [a] -> [[a]] -> [a]
intercalate String
"," forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map RsyncExtra -> String
showRsyncExtra [RsyncExtra]
res
args :: [String]
args =
[ String
"--dist" , String
suitearg
, String
"--arch", [String] -> String
architecturearg forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map Architecture -> String
architectureToDebianArchString (DebianMirror -> [Architecture]
_debianMirrorArchitectures DebianMirror
mirror')
, String
"--section", forall a. [a] -> [[a]] -> [a]
intercalate String
"," forall a b. (a -> b) -> a -> b
$ DebianMirror -> [String]
_debianMirrorSections DebianMirror
mirror'
, String
"--limit-priority", String
"\"" forall a. [a] -> [a] -> [a]
++ [DebianPriority] -> String
priorityRegex (DebianMirror -> [DebianPriority]
_debianMirrorPriorities DebianMirror
mirror') forall a. [a] -> [a] -> [a]
++ String
"\""
]
forall a. [a] -> [a] -> [a]
++
(if DebianMirror -> Bool
_debianMirrorSourceBool DebianMirror
mirror' then [] else [String
"--nosource"])
forall a. [a] -> [a] -> [a]
++
[ String
"--host", DebianMirror -> String
_debianMirrorHostName DebianMirror
mirror'
, String
"--method", Method -> String
showMethod forall a b. (a -> b) -> a -> b
$ DebianMirror -> Method
_debianMirrorMethod DebianMirror
mirror'
, String
"--rsync-extra", [RsyncExtra] -> String
rsyncextraarg forall a b. (a -> b) -> a -> b
$ DebianMirror -> [RsyncExtra]
_debianMirrorRsyncExtra DebianMirror
mirror'
, String
"--keyring", DebianMirror -> String
_debianMirrorKeyring DebianMirror
mirror'
, String
dir
]