initial check-in

too young to have a name

4 files changed, 187 insertions, 0 deletions

diff --git a/Property/Apt.hs b/Property/Apt.hs
new file mode 100644
index 00000000..5f6f75e3
--- /dev/null
+++ b/Property/Apt.hs
@@ -0,0 +1,87 @@
+module Property.Apt where
+
+import Data.Maybe
+import Control.Applicative
+import Data.List
+
+import Property
+import Utility.SafeCommand
+import Utility.Process
+
+sourcesList :: FilePath
+sourcesList = "/etc/apt/sources.list"
+
+type Url = String
+type Section = String
+
+data Suite = Stable | Testing | Unstable | Experimental
+
+showSuite :: Suite -> String
+showSuite Stable = "stable"
+showSuite Testing = "testing"
+showSuite Unstable = "unstable"
+showSuite Experimental = "experimental"
+
+debLine :: Suite -> Url -> [Section] -> Line
+debLine suite mirror sections = unwords $
+	["deb", mirror, showSuite suite] ++ sections
+
+srcLine :: Line -> Line
+srcLine l = case words l of
+	("deb":rest) -> unwords $ "deb-src" : rest
+	_ -> ""
+
+stdSections = ["main", "contrib", "non-free"]
+
+debCdn :: Suite -> [Line]
+debCdn suite = [l, srcLine l]
+  where
+	l = debLine suite "http://cdn.debian.net/debian" stdSections
+
+{- Makes sources.list have a standard content using the mirror CDN,
+ - with a particular Suite. -}
+stdSourcesList :: Suite -> Property
+stdSourcesList = setSourcesList . debCdn
+
+setSourcesList :: [Line] -> Property
+setSourcesList ls = fileHasContent sourcesList ls `onChange` update
+
+update :: Property
+update = cmdProperty "apt-get" [Param "update"]
+
+upgrade :: Property
+upgrade = cmdProperty "apt-get" [Params "-y safe-update"]
+
+type Package = String
+
+installed :: [Package] -> Property
+installed ps = check (isInstallable ps) go
+  where
+	go = cmdProperty "apt-get" $ 
+		[Param "-y", Param "install"] ++ map Param ps
+
+removed :: [Package] -> Property
+removed ps = check (or <$> isInstalled ps) go
+  where
+	go = cmdProperty "apt-get" $ [Param "-y", Param "remove"] ++ map Param ps
+
+isInstallable :: [Package] -> IO Bool
+isInstallable ps = do
+	l <- isInstalled ps
+	return $ any (== False) l && not (null l)
+
+{- Note that the order of the returned list will not always
+ - correspond to the order of the input list. The number of items may
+ - even vary. If apt does not know about a package at all, it will not
+ - be included in the result list. -}
+isInstalled :: [Package] -> IO [Bool]
+isInstalled ps = catMaybes . map parse . lines
+	<$> readProcess "apt-cache" ("policy":ps)
+  where
+	parse l
+		| "Installed: (none)" `isInfixOf` l = Just False
+		| "Installed: " `isInfixOf` l = Just True
+		| otherwise = Nothing
+
+autoRemove :: Property
+autoRemove = cmdProperty "apt-get" [Param "-y", Param "autoremove"]
diff --git a/Property/GitHome.hs b/Property/GitHome.hs
new file mode 100644
index 00000000..6bbae254
--- /dev/null
+++ b/Property/GitHome.hs
@@ -0,0 +1,37 @@
+module Property.GitHome where
+
+import System.FilePath
+import System.Directory
+import Control.Applicative
+import Control.Monad
+
+import Property
+import Property.User
+import Utility.SafeCommand
+import Utility.Directory
+import Utility.Monad
+import Utility.Exception
+
+{- Clones Joey Hess's git home directory, and runs its fixups script. -}
+installed :: UserName -> Property
+installed user = check (not <$> hasGitDir user) $ 
+	IOProperty ("githome " ++ user) (go =<< homedir user)
+  where
+ 	go Nothing = noChange
+	go (Just home) = do
+		let tmpdir = home </> "githome"
+		ok <- boolSystem "git" [Param "clone", Param url, Param tmpdir]
+			<&&> (and <$> moveout tmpdir home)
+			<&&> (catchBoolIO $ removeDirectory tmpdir >> return True)
+			<&&> boolSystem "su" [Param "-c", Param "cd; bin/fixups", Param user]
+		return $ if ok then MadeChange else FailedChange
+	moveout tmpdir home = do
+		fs <- dirContents tmpdir
+		forM fs $ \f -> boolSystem "mv" [File f, File home]
+	url = "git://git.kitenet.net/joey/home"
+
+hasGitDir :: UserName -> IO Bool
+hasGitDir user = go =<< homedir user
+  where
+	go Nothing = return False
+	go (Just home) = doesDirectoryExist (home </> ".git")
diff --git a/Property/Ssh.hs b/Property/Ssh.hs
new file mode 100644
index 00000000..cca021a4
--- /dev/null
+++ b/Property/Ssh.hs
@@ -0,0 +1,41 @@
+module Property.Ssh where
+
+import Control.Applicative
+import Control.Monad
+import System.FilePath
+
+import Property
+import Property.User
+import Utility.SafeCommand
+import Utility.Exception
+
+sshBool :: Bool -> String
+sshBool True = "yes"
+sshBool False = "no"
+
+sshdConfig :: FilePath
+sshdConfig = "/etc/ssh/sshd_config"
+
+setSshdConfig :: String -> Bool -> Property
+setSshdConfig setting allowed = combineProperties desc
+	[ lineNotInFile sshdConfig (setting ++ sshBool (not allowed))
+	, lineInFile sshdConfig (setting ++ sshBool allowed)
+	] `onChange` restartSshd
+  where
+	desc = unwords [ "ssh config:", setting, sshBool allowed ]
+
+permitRootLogin :: Bool -> Property
+permitRootLogin = setSshdConfig "PermitRootLogin"
+
+passwordAuthentication :: Bool -> Property
+passwordAuthentication = setSshdConfig "PasswordAuthentication"
+
+hasAuthorizedKeys :: UserName -> IO Bool
+hasAuthorizedKeys = go <=< homedir
+  where
+	go Nothing = return False
+	go (Just home) = not . null <$> catchDefaultIO ""
+		(readFile $ home </> ".ssh" </> "authorized_keys")
+
+restartSshd :: Property
+restartSshd = CmdProperty "ssh restart" "service" [Param "sshd", Param "restart"]
diff --git a/Property/User.hs b/Property/User.hs
new file mode 100644
index 00000000..f43c9b20
--- /dev/null
+++ b/Property/User.hs
@@ -0,0 +1,22 @@
+module Property.User where
+
+import Data.List
+import System.Posix
+import Control.Applicative
+import Data.Maybe
+
+import Property
+import Utility.SafeCommand
+import Utility.Exception
+
+type UserName = String
+
+nonsystem :: UserName -> Property
+nonsystem user = check (isNothing <$> homedir user) $ cmdProperty "adduser"
+	[ Param "--disabled-password"
+	, Param "--gecos", Param ""
+	, Param user
+	]
+
+homedir :: UserName -> IO (Maybe FilePath)
+homedir user = catchMaybeIO $ homeDirectory <$> getUserEntryForName user