-- | Maintainer: Félix Sipma <felix+propellor@gueux.org>

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 | Extra
	deriving (Int -> DebianPriority -> ShowS
[DebianPriority] -> ShowS
DebianPriority -> String
(Int -> DebianPriority -> ShowS)
-> (DebianPriority -> String)
-> ([DebianPriority] -> ShowS)
-> Show DebianPriority
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
(DebianPriority -> DebianPriority -> Bool)
-> (DebianPriority -> DebianPriority -> Bool) -> Eq DebianPriority
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 RsyncExtra = Doc | Indices | Tools | Trace
	deriving (Int -> RsyncExtra -> ShowS
[RsyncExtra] -> ShowS
RsyncExtra -> String
(Int -> RsyncExtra -> ShowS)
-> (RsyncExtra -> String)
-> ([RsyncExtra] -> ShowS)
-> Show RsyncExtra
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
(RsyncExtra -> RsyncExtra -> Bool)
-> (RsyncExtra -> RsyncExtra -> Bool) -> Eq RsyncExtra
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
showRsyncExtra :: RsyncExtra -> String
showRsyncExtra 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"

-- | To get a new DebianMirror and set options, use:
--
-- > mkDebianMirror mymirrordir mycrontimes
-- > 	. debianMirrorHostName "otherhostname"
-- > 	. debianMirrorSourceBool True

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
	, DebianMirror -> [RsyncExtra]
_debianMirrorRsyncExtra :: [RsyncExtra]
	, DebianMirror -> Times
_debianMirrorCronTimes :: Cron.Times
	}

mkDebianMirror :: FilePath -> Cron.Times -> DebianMirror
mkDebianMirror :: String -> Times -> DebianMirror
mkDebianMirror String
dir Times
crontimes = DebianMirror :: String
-> String
-> [DebianSuite]
-> [Architecture]
-> [String]
-> Bool
-> [DebianPriority]
-> Method
-> String
-> [RsyncExtra]
-> Times
-> DebianMirror
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
debianMirrorRsyncExtra :: [RsyncExtra] -> DebianMirror -> DebianMirror
debianMirrorRsyncExtra [RsyncExtra]
r DebianMirror
m = DebianMirror
m { _debianMirrorRsyncExtra :: [RsyncExtra]
_debianMirrorRsyncExtra = [RsyncExtra]
r }

mirror :: DebianMirror -> Property DebianLike
mirror :: DebianMirror -> Property DebianLike
mirror DebianMirror
mirror' = String -> Props DebianLike -> Property DebianLike
forall k (metatypes :: k).
SingI metatypes =>
String
-> Props (MetaTypes metatypes) -> Property (MetaTypes metatypes)
propertyList (String
"Debian mirror " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
dir) (Props DebianLike -> Property DebianLike)
-> Props DebianLike -> Property DebianLike
forall a b. (a -> b) -> a -> b
$ Props UnixLike
props
	Props UnixLike
-> Property DebianLike
-> Props
     (MetaTypes
        (Combine
           '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
              'Targeting 'OSArchLinux, 'Targeting 'OSFreeBSD]
           '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish]))
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"]
	Props DebianLike
-> Property DebianLike
-> Props
     (MetaTypes
        (Combine
           '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish]
           '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish]))
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")
	Props DebianLike
-> Property UnixLike
-> Props
     (MetaTypes
        (Combine
           '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish]
           '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
              'Targeting 'OSArchLinux, 'Targeting 'OSFreeBSD]))
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
	Props DebianLike
-> Property UnixLike
-> Props
     (MetaTypes
        (Combine
           '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish]
           '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
              'Targeting 'OSArchLinux, 'Targeting 'OSFreeBSD]))
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")
	Props DebianLike
-> Property UnixLike
-> Props
     (MetaTypes
        (Combine
           '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish]
           '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
              'Targeting 'OSArchLinux, 'Targeting 'OSFreeBSD]))
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))
& IO Bool -> UncheckedProperty UnixLike -> Property UnixLike
forall (p :: * -> *) i (m :: * -> *).
(Checkable p i, LiftPropellor m) =>
m Bool -> p i -> Property i
check (Bool -> Bool
not (Bool -> Bool) -> ([Bool] -> Bool) -> [Bool] -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
and ([Bool] -> Bool) -> IO [Bool] -> IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (DebianSuite -> IO Bool) -> [DebianSuite] -> IO [Bool]
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)
			Property UnixLike -> String -> Property UnixLike
forall p. IsProp p => p -> String -> p
`describe` String
"debmirror setup"
	Props DebianLike
-> Property DebianLike
-> Props
     (MetaTypes
        (Combine
           '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish]
           '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish]))
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_" String -> ShowS
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" String -> [String] -> [String]
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 (String -> IO Bool) -> String -> IO Bool
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 = String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
","
	suitearg :: String
suitearg = String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
"," ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ (DebianSuite -> String) -> [DebianSuite] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map DebianSuite -> String
Apt.showSuite [DebianSuite]
suites
	priorityRegex :: [DebianPriority] -> String
priorityRegex [DebianPriority]
pp = String
"(" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
"|" ((DebianPriority -> String) -> [DebianPriority] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map DebianPriority -> String
showPriority [DebianPriority]
pp) String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
")"
	rsyncextraarg :: [RsyncExtra] -> String
rsyncextraarg [] = String
"none"
	rsyncextraarg [RsyncExtra]
res = String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
"," ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ (RsyncExtra -> String) -> [RsyncExtra] -> [String]
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 ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ (Architecture -> String) -> [Architecture] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map Architecture -> String
architectureToDebianArchString (DebianMirror -> [Architecture]
_debianMirrorArchitectures DebianMirror
mirror')
		, String
"--section", String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
"," ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ DebianMirror -> [String]
_debianMirrorSections DebianMirror
mirror'
		, String
"--limit-priority", String
"\"" String -> ShowS
forall a. [a] -> [a] -> [a]
++ [DebianPriority] -> String
priorityRegex (DebianMirror -> [DebianPriority]
_debianMirrorPriorities DebianMirror
mirror') String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"\""
		]
		[String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++
		(if DebianMirror -> Bool
_debianMirrorSourceBool DebianMirror
mirror' then [] else [String
"--nosource"])
		[String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++
		[ String
"--host", DebianMirror -> String
_debianMirrorHostName DebianMirror
mirror'
		, String
"--method", Method -> String
showMethod (Method -> String) -> Method -> String
forall a b. (a -> b) -> a -> b
$ DebianMirror -> Method
_debianMirrorMethod DebianMirror
mirror'
		, String
"--rsync-extra", [RsyncExtra] -> String
rsyncextraarg ([RsyncExtra] -> String) -> [RsyncExtra] -> String
forall a b. (a -> b) -> a -> b
$ DebianMirror -> [RsyncExtra]
_debianMirrorRsyncExtra DebianMirror
mirror'
		, String
"--keyring", DebianMirror -> String
_debianMirrorKeyring DebianMirror
mirror'
		, String
dir
		]