diff --git a/config-joey.hs b/config-joey.hs index 25dd678..705ad0f 100644 --- a/config-joey.hs +++ b/config-joey.hs @@ -74,6 +74,9 @@ darkstar = host "darkstar.kitenet.net" & Docker.configured ! Docker.docked gitAnnexAndroidDev + & JoeySites.postfixClientRelay (Context "darkstar.kitenet.net") + & JoeySites.dkimMilter + clam :: Host clam = standardSystem "clam.kitenet.net" Unstable "amd64" [ "Unreliable server. Anything here may be lost at any time!" ] @@ -226,7 +229,6 @@ diatom = standardSystem "diatom.kitenet.net" (Stable "wheezy") "amd64" & alias "git.joeyh.name" & JoeySites.gitServer hosts - & alias "downloads.kitenet.net" & JoeySites.annexWebSite "/srv/git/downloads.git" "downloads.kitenet.net" "840760dc-08f0-11e2-8c61-576b7e66acfd" @@ -234,13 +236,18 @@ diatom = standardSystem "diatom.kitenet.net" (Stable "wheezy") "amd64" `requires` Ssh.keyImported SshRsa "joey" (Context "downloads.kitenet.net") `requires` Ssh.knownHost hosts "eubackup.kitenet.net" "joey" & JoeySites.gitAnnexDistributor - & alias "tmp.kitenet.net" + & JoeySites.annexWebSite "/srv/git/joey/tmp.git" "tmp.kitenet.net" "26fd6e38-1226-11e2-a75f-ff007033bdba" [] & JoeySites.twitRss & JoeySites.pumpRss + + & JoeySites.annexWebSite "/srv/git/user-liberation.git" + "user-liberation.joeyh.name" + "da89f112-808b-420a-b468-d990ae2e5b52" + [] & alias "nntp.olduse.net" & alias "resources.olduse.net" @@ -249,10 +256,10 @@ diatom = standardSystem "diatom.kitenet.net" (Stable "wheezy") "amd64" & alias "ns2.kitenet.net" & myDnsPrimary False "kitenet.net" [] & myDnsPrimary True "joeyh.name" [] - & myDnsPrimary False "ikiwiki.info" [] - & myDnsPrimary False "olduse.net" - [ (RelDomain "article", - CNAME $ AbsDomain "virgil.koldfront.dk") ] + & myDnsPrimary True "ikiwiki.info" [] + & myDnsPrimary True "olduse.net" + [ (RelDomain "article", CNAME $ AbsDomain "virgil.koldfront.dk") + ] & alias "ns3.branchable.com" & branchableSecondary @@ -307,6 +314,7 @@ elephant = standardSystem "elephant.kitenet.net" Unstable "amd64" & Docker.docked openidProvider `requires` Apt.serviceInstalledRunning "ntp" & Docker.docked ancientKitenet + & Docker.docked jerryPlay & Docker.garbageCollected `period` (Weekly (Just 1)) -- For https port 443, shellinabox with ssh login to @@ -363,6 +371,15 @@ gitAnnexAndroidDev = GitAnnexBuilder.androidContainer dockerImage "android-git-a & Docker.volume ("/home/joey/src/git-annex:" ++ gitannexdir) where gitannexdir = GitAnnexBuilder.homedir "git-annex" + +jerryPlay :: Docker.Container +jerryPlay = standardContainer "jerryplay" Unstable "amd64" + & alias "jerryplay.kitenet.net" + & Docker.publish "2202:22" + & Docker.publish "8001:80" + & Apt.installed ["ssh"] + & User.hasSomePassword "root" + & Ssh.permitRootLogin True type Motd = [String] @@ -441,6 +458,7 @@ myDnsPrimary dnssec domain extras = (if dnssec then Dns.signedPrimary (Weekly No , (RootDomain, MX 0 $ AbsDomain "kitenet.net") -- SPF only allows IP address of kitenet.net to send mail. , (RootDomain, TXT "v=spf1 a:kitenet.net -all") + , JoeySites.domainKey ] ++ extras diff --git a/debian/changelog b/debian/changelog index c54aa16..4433571 100644 --- a/debian/changelog +++ b/debian/changelog @@ -1,8 +1,10 @@ -propellor (1.3.2) UNRELEASED; urgency=medium +propellor (1.3.2) unstable; urgency=medium * SSHFP records are also generated for CNAMES of hosts. + * Merge Utiity modules from git-annex. + * Ignore bogus DNS when spinning the local host. - -- Joey Hess Sun, 04 Jan 2015 21:25:42 -0400 + -- Joey Hess Thu, 15 Jan 2015 14:02:07 -0400 propellor (1.3.1) unstable; urgency=medium diff --git a/propellor.cabal b/propellor.cabal index a4fca7b..982df52 100644 --- a/propellor.cabal +++ b/propellor.cabal @@ -1,5 +1,5 @@ Name: propellor -Version: 1.3.1 +Version: 1.3.2 Cabal-Version: >= 1.6 License: BSD3 Maintainer: Joey Hess diff --git a/src/Propellor/PrivData.hs b/src/Propellor/PrivData.hs index 2b27f22..6643d81 100644 --- a/src/Propellor/PrivData.hs +++ b/src/Propellor/PrivData.hs @@ -83,7 +83,7 @@ withPrivData' feed srclist c mkprop = addinfo $ mkprop $ \a -> warningMessage $ "Missing privdata " ++ intercalate " or " fieldnames ++ " (for " ++ cname ++ ")" liftIO $ putStrLn $ "Fix this by running:" liftIO $ forM_ srclist $ \src -> do - putStrLn $ " propellor --set '" ++ show (privDataField src) ++ "' '" ++ cname ++ "'" + putStrLn $ " propellor --set '" ++ show (privDataField src) ++ "' '" ++ cname ++ "' \\" maybe noop (\d -> putStrLn $ " " ++ d) (describePrivDataSource src) putStrLn "" return FailedChange diff --git a/src/Propellor/Property/SiteSpecific/JoeySites.hs b/src/Propellor/Property/SiteSpecific/JoeySites.hs index 2df6749..a2eb44b 100644 --- a/src/Propellor/Property/SiteSpecific/JoeySites.hs +++ b/src/Propellor/Property/SiteSpecific/JoeySites.hs @@ -17,7 +17,6 @@ import qualified Propellor.Property.Apache as Apache import qualified Propellor.Property.Postfix as Postfix import Utility.SafeCommand import Utility.FileMode -import Utility.Path import Data.List import System.Posix.Files @@ -193,6 +192,7 @@ annexWebSite :: Git.RepoUrl -> HostName -> AnnexUUID -> [(String, Git.RepoUrl)] annexWebSite origin hn uuid remotes = propertyList (hn ++" website using git-annex") [ Git.cloned "joey" origin dir Nothing `onChange` setup + , alias hn , postupdatehook `File.hasContent` [ "#!/bin/sh" , "exec git update-server-info" @@ -209,6 +209,7 @@ annexWebSite origin hn uuid remotes = propertyList (hn ++" website using git-ann , "git config annex.uuid " ++ shellEscape uuid ] ++ map addremote remotes ++ [ "git annex get" + , "git update-server-info" ] addremote (name, url) = "git remote add " ++ shellEscape name ++ " " ++ shellEscape url setupapache = toProp $ Apache.siteEnabled hn $ apachecfg hn True $ @@ -311,6 +312,7 @@ twitRss = combineProperties "twitter rss" "./twitRss " ++ shellEscape url ++ " > " ++ shellEscape ("../" ++ desc ++ ".rss") -- Work around for expired ssl cert. +-- (no longer expired, TODO remove this and change urls) pumpRss :: Property pumpRss = Cron.job "pump rss" "15 * * * *" "joey" "/srv/web/tmp.kitenet.net/" "wget https://pump2rss.com/feed/joeyh@identi.ca.atom -O pump.atom --no-check-certificate 2>/dev/null" @@ -319,7 +321,7 @@ ircBouncer :: Property ircBouncer = propertyList "IRC bouncer" [ Apt.installed ["znc"] , User.accountFor "znc" - , File.dirExists (parentDir conf) + , File.dirExists (takeDirectory conf) , File.hasPrivContent conf anyContext , File.ownerGroup conf "znc" "znc" , Cron.job "znconboot" "@reboot" "znc" "~" "znc" @@ -443,6 +445,8 @@ kiteMailServer = propertyList "kitenet.net mail server" `describe` "amavisd-milter configured for postfix" , Apt.serviceInstalledRunning "clamav-freshclam" + , dkimInstalled + , Apt.installed ["maildrop"] , "/etc/maildroprc" `File.hasContent` [ "# Global maildrop filter file (deployed with propellor)" @@ -461,8 +465,7 @@ kiteMailServer = propertyList "kitenet.net mail server" , "/etc/aliases" `File.hasPrivContentExposed` ctx `onChange` Postfix.newaliases , hasJoeyCAChain - , "/etc/ssl/certs/postfix.pem" `File.hasPrivContentExposed` ctx - , "/etc/ssl/private/postfix.pem" `File.hasPrivContent` ctx + , hasPostfixCert ctx , "/etc/postfix/mydomain" `File.containsLines` [ "/.*\\.kitenet\\.net/\tOK" @@ -473,13 +476,13 @@ kiteMailServer = propertyList "kitenet.net mail server" `describe` "postfix mydomain file configured" , "/etc/postfix/obscure_client_relay.pcre" `File.hasContent` -- Remove received lines for mails relayed from trusted - -- clients. These can be a privacy vilation, or trigger + -- clients. These can be a privacy violation, or trigger -- spam filters. [ "/^Received: from ([^.]+)\\.kitenet\\.net.*using TLS.*by kitenet\\.net \\(([^)]+)\\) with (E?SMTPS?A?) id ([A-F[:digit:]]+)(.*)/ IGNORE" -- Munge local Received line for postfix running on a -- trusted client that relays through. These can trigger -- spam filters. - , "/^Received: by ([^.]+)\\.kitenet\\.net.*/ REPLACE Received: by kitenet.net" + , "/^Received: by ([^.]+)\\.kitenet\\.net.*/ REPLACE X-Question: 42" ] `onChange` Postfix.reloaded `describe` "postfix obscure_client_relay file configured" @@ -511,9 +514,13 @@ kiteMailServer = propertyList "kitenet.net mail server" , "# Enable postgrey." , "smtpd_recipient_restrictions = permit_tls_clientcerts,permit_mynetworks,reject_unauth_destination,check_policy_service inet:127.0.0.1:10023" - , "# Enable spamass-milter and amavis-milter." - , "smtpd_milters = unix:/spamass/spamass.sock unix:amavis/amavis.sock" + , "# Enable spamass-milter, amavis-milter, opendkim" + , "smtpd_milters = unix:/spamass/spamass.sock unix:amavis/amavis.sock inet:localhost:8891" + , "# opendkim is used for outgoing mail" + , "non_smtpd_milters = inet:localhost:8891" , "milter_connect_macros = j {daemon_name} v {if_name} _" + , "# If a milter is broken, fall back to just accepting mail." + , "milter_default_action = accept" , "# TLS setup -- server" , "smtpd_tls_CAfile = /etc/ssl/certs/joeyca.pem" @@ -581,10 +588,70 @@ kiteMailServer = propertyList "kitenet.net mail server" pinescript = "/usr/local/bin/pine" dovecotusers = "/etc/dovecot/users" +-- Configures postfix to relay outgoing mail to kitenet.net, with +-- verification via tls cert. +postfixClientRelay :: Context -> Property +postfixClientRelay ctx = Postfix.mainCfFile `File.containsLines` + [ "relayhost = kitenet.net" + , "smtp_tls_CAfile = /etc/ssl/certs/joeyca.pem" + , "smtp_tls_cert_file = /etc/ssl/certs/postfix.pem" + , "smtp_tls_key_file = /etc/ssl/private/postfix.pem" + , "smtp_tls_loglevel = 0" + , "smtp_use_tls = yes" + ] + `describe` "postfix client relay" + `onChange` Postfix.dedupMainCf + `onChange` Postfix.reloaded + `requires` hasJoeyCAChain + `requires` hasPostfixCert ctx + +-- Configures postfix to have the dkim milter, and no other milters. +dkimMilter :: Property +dkimMilter = Postfix.mainCfFile `File.containsLines` + [ "smtpd_milters = inet:localhost:8891" + , "non_smtpd_milters = inet:localhost:8891" + , "milter_default_action = accept" + ] + `describe` "postfix dkim milter" + `onChange` Postfix.dedupMainCf + `onChange` Postfix.reloaded + `requires` dkimInstalled + +-- This does not configure postfix to use the dkim milter, +-- nor does it set up domainkey DNS. +dkimInstalled :: Property +dkimInstalled = propertyList "opendkim installed" + [ Apt.serviceInstalledRunning "opendkim" + , File.dirExists "/etc/mail" + , File.hasPrivContent "/etc/mail/dkim.key" (Context "kitenet.net") + , File.ownerGroup "/etc/mail/dkim.key" "opendkim" "opendkim" + , "/etc/default/opendkim" `File.containsLine` + "SOCKET=\"inet:8891@localhost\"" + , "/etc/opendkim.conf" `File.containsLines` + [ "KeyFile /etc/mail/dkim.key" + , "SubDomains yes" + , "Domain *" + , "Selector mail" + ] + ] + `onChange` Service.restarted "opendkim" + +-- This is the dkim public key, corresponding with /etc/mail/dkim.key +-- This value can be included in a domain's additional records to make +-- it use this domainkey. +domainKey :: (BindDomain, Record) +domainKey = (RelDomain "mail._domainkey", TXT "v=DKIM1; k=rsa; t=y; p=MIGfMA0GCSqGSIb3DQEBAQUAA4GNADCBiQKBgQCc+/rfzNdt5DseBBmfB3C6sVM7FgVvf4h1FeCfyfwPpVcmPdW6M2I+NtJsbRkNbEICxiP6QY2UM0uoo9TmPqLgiCCG2vtuiG6XMsS0Y/gGwqKM7ntg/7vT1Go9vcquOFFuLa5PnzpVf8hB9+PMFdS4NPTvWL2c5xxshl/RJzICnQIDAQAB") + hasJoeyCAChain :: Property hasJoeyCAChain = "/etc/ssl/certs/joeyca.pem" `File.hasPrivContentExposed` Context "joeyca.pem" +hasPostfixCert :: Context -> Property +hasPostfixCert ctx = combineProperties "postfix tls cert installed" + [ "/etc/ssl/certs/postfix.pem" `File.hasPrivContentExposed` ctx + , "/etc/ssl/private/postfix.pem" `File.hasPrivContent` ctx + ] + kitenetHttps :: Property kitenetHttps = propertyList "kitenet.net https certs" [ File.hasPrivContent "/etc/ssl/certs/web.pem" ctx diff --git a/src/Propellor/Shim.hs b/src/Propellor/Shim.hs index a97bf5c..da4c96e 100644 --- a/src/Propellor/Shim.hs +++ b/src/Propellor/Shim.hs @@ -9,7 +9,6 @@ module Propellor.Shim (setup, cleanEnv, file) where import Propellor import Utility.LinuxMkLibs import Utility.SafeCommand -import Utility.Path import Utility.FileMode import Utility.FileSystemEncoding @@ -34,7 +33,7 @@ setup propellorbin propellorbinpath dest = checkAlreadyShimmed propellorbin $ do let linker = (dest ++) $ fromMaybe (error "cannot find ld-linux linker") $ headMaybe $ filter ("ld-linux" `isInfixOf`) libs' - let gconvdir = (dest ++) $ parentDir $ + let gconvdir = (dest ++) $ takeDirectory $ fromMaybe (error "cannot find gconv directory") $ headMaybe $ filter ("/gconv/" `isInfixOf`) glibclibs let linkerparams = ["--library-path", intercalate ":" libdirs ] @@ -75,5 +74,5 @@ installFile top f = do createLink f dest `catchIO` (const copy) where copy = void $ boolSystem "cp" [Param "-a", Param f, Param dest] - destdir = inTop top $ parentDir f + destdir = inTop top $ takeDirectory f dest = inTop top f diff --git a/src/Propellor/Spin.hs b/src/Propellor/Spin.hs index a103538..339428b 100644 --- a/src/Propellor/Spin.hs +++ b/src/Propellor/Spin.hs @@ -112,8 +112,14 @@ getSshTarget target hst useip why = case headMaybe configips of Nothing -> return target Just ip -> do - warningMessage $ "DNS seems out of date for " ++ target ++ " (" ++ why ++ "); using IP address from configuration instead." - return ip + -- If we're being asked to run on the local host, + -- ignore DNS. + s <- takeWhile (/= '\n') <$> readProcess "hostname" ["-f"] + if s == target + then return target + else do + warningMessage $ "DNS seems out of date for " ++ target ++ " (" ++ why ++ "); using IP address from configuration instead." + return ip configips = map fromIPAddr $ mapMaybe getIPAddr $ S.toList $ _dns $ hostInfo hst diff --git a/src/Utility/Applicative.hs b/src/Utility/Applicative.hs index fce3c04..fd8944b 100644 --- a/src/Utility/Applicative.hs +++ b/src/Utility/Applicative.hs @@ -1,6 +1,6 @@ {- applicative stuff - - - Copyright 2012 Joey Hess + - Copyright 2012 Joey Hess - - License: BSD-2-clause -} diff --git a/src/Utility/Data.hs b/src/Utility/Data.hs index 5ecd218..2df12b3 100644 --- a/src/Utility/Data.hs +++ b/src/Utility/Data.hs @@ -1,6 +1,6 @@ {- utilities for simple data types - - - Copyright 2013 Joey Hess + - Copyright 2013 Joey Hess - - License: BSD-2-clause -} diff --git a/src/Utility/Env.hs b/src/Utility/Env.hs index dd502fd..ff6644f 100644 --- a/src/Utility/Env.hs +++ b/src/Utility/Env.hs @@ -1,6 +1,6 @@ {- portable environment variables - - - Copyright 2013 Joey Hess + - Copyright 2013 Joey Hess - - License: BSD-2-clause -} @@ -14,6 +14,7 @@ import Utility.Exception import Control.Applicative import Data.Maybe import qualified System.Environment as E +import qualified System.SetEnv #else import qualified System.Posix.Env as PE #endif @@ -39,27 +40,27 @@ getEnvironment = PE.getEnvironment getEnvironment = E.getEnvironment #endif -{- Returns True if it could successfully set the environment variable. +{- Sets an environment variable. To overwrite an existing variable, + - overwrite must be True. - - - There is, apparently, no way to do this in Windows. Instead, - - environment varuables must be provided when running a new process. -} -setEnv :: String -> String -> Bool -> IO Bool + - On Windows, setting a variable to "" unsets it. -} +setEnv :: String -> String -> Bool -> IO () #ifndef mingw32_HOST_OS -setEnv var val overwrite = do - PE.setEnv var val overwrite - return True +setEnv var val overwrite = PE.setEnv var val overwrite #else -setEnv _ _ _ = return False +setEnv var val True = System.SetEnv.setEnv var val +setEnv var val False = do + r <- getEnv var + case r of + Nothing -> setEnv var val True + Just _ -> return () #endif -{- Returns True if it could successfully unset the environment variable. -} -unsetEnv :: String -> IO Bool +unsetEnv :: String -> IO () #ifndef mingw32_HOST_OS -unsetEnv var = do - PE.unsetEnv var - return True +unsetEnv = PE.unsetEnv #else -unsetEnv _ = return False +unsetEnv = System.SetEnv.unsetEnv #endif {- Adds the environment variable to the input environment. If already diff --git a/src/Utility/FileSystemEncoding.hs b/src/Utility/FileSystemEncoding.hs index 4e8f2ff..fa4b39a 100644 --- a/src/Utility/FileSystemEncoding.hs +++ b/src/Utility/FileSystemEncoding.hs @@ -1,6 +1,6 @@ {- GHC File system encoding handling. - - - Copyright 2012-2014 Joey Hess + - Copyright 2012-2014 Joey Hess - - License: BSD-2-clause -} @@ -111,7 +111,7 @@ truncateFilePath :: Int -> FilePath -> FilePath #ifndef mingw32_HOST_OS truncateFilePath n = go . reverse where - go f = + go f = let bytes = decodeW8 f in if length bytes <= n then reverse f diff --git a/src/Utility/LinuxMkLibs.hs b/src/Utility/LinuxMkLibs.hs index d32de1a..6074ba2 100644 --- a/src/Utility/LinuxMkLibs.hs +++ b/src/Utility/LinuxMkLibs.hs @@ -1,6 +1,6 @@ {- Linux library copier and binary shimmer - - - Copyright 2013 Joey Hess + - Copyright 2013 Joey Hess - - License: BSD-2-clause -} @@ -10,6 +10,7 @@ module Utility.LinuxMkLibs where import Control.Applicative import Data.Maybe import System.Directory +import System.FilePath import Data.List.Utils import System.Posix.Files import Data.Char @@ -28,14 +29,14 @@ installLib installfile top lib = ifM (doesFileExist lib) ( do installfile top lib checksymlink lib - return $ Just $ parentDir lib + return $ Just $ takeDirectory lib , return Nothing ) where checksymlink f = whenM (isSymbolicLink <$> getSymbolicLinkStatus (inTop top f)) $ do l <- readSymbolicLink (inTop top f) - let absl = absPathFrom (parentDir f) l - let target = relPathDirToFile (parentDir f) absl + let absl = absPathFrom (takeDirectory f) l + let target = relPathDirToFile (takeDirectory f) absl installfile top absl nukeFile (top ++ f) createSymbolicLink target (inTop top f) diff --git a/src/Utility/Misc.hs b/src/Utility/Misc.hs index e4eccac..949f41e 100644 --- a/src/Utility/Misc.hs +++ b/src/Utility/Misc.hs @@ -1,6 +1,6 @@ {- misc utility functions - - - Copyright 2010-2011 Joey Hess + - Copyright 2010-2011 Joey Hess - - License: BSD-2-clause -} diff --git a/src/Utility/Monad.hs b/src/Utility/Monad.hs index 878e0da..eba3c42 100644 --- a/src/Utility/Monad.hs +++ b/src/Utility/Monad.hs @@ -1,6 +1,6 @@ {- monadic stuff - - - Copyright 2010-2012 Joey Hess + - Copyright 2010-2012 Joey Hess - - License: BSD-2-clause -} diff --git a/src/Utility/Path.hs b/src/Utility/Path.hs index ea62157..7f03491 100644 --- a/src/Utility/Path.hs +++ b/src/Utility/Path.hs @@ -1,6 +1,6 @@ {- path manipulation - - - Copyright 2010-2014 Joey Hess + - Copyright 2010-2014 Joey Hess - - License: BSD-2-clause -} @@ -21,6 +21,7 @@ import Control.Applicative import qualified System.FilePath.Posix as Posix #else import System.Posix.Files +import Utility.Exception #endif import qualified "MissingH" System.Path as MissingH @@ -76,14 +77,12 @@ absNormPathUnix dir path = todos <$> MissingH.absNormPath (fromdos dir) (fromdos todos = replace "/" "\\" #endif -{- Returns the parent directory of a path. - - - - To allow this to be easily used in loops, which terminate upon reaching the - - top, the parent of / is "" -} -parentDir :: FilePath -> FilePath +{- Just the parent directory of a path, or Nothing if the path has no + - parent (ie for "/") -} +parentDir :: FilePath -> Maybe FilePath parentDir dir - | null dirs = "" - | otherwise = joinDrive drive (join s $ init dirs) + | null dirs = Nothing + | otherwise = Just $ joinDrive drive (join s $ init dirs) where -- on Unix, the drive will be "/" when the dir is absolute, otherwise "" (drive, path) = splitDrive dir @@ -93,8 +92,8 @@ parentDir dir prop_parentDir_basics :: FilePath -> Bool prop_parentDir_basics dir | null dir = True - | dir == "/" = parentDir dir == "" - | otherwise = p /= dir + | dir == "/" = parentDir dir == Nothing + | otherwise = p /= Just dir where p = parentDir dir @@ -235,11 +234,11 @@ toCygPath p | null drive = recombine parts | otherwise = recombine $ "/cygdrive" : driveletter drive : parts where - (drive, p') = splitDrive p + (drive, p') = splitDrive p parts = splitDirectories p' - driveletter = map toLower . takeWhile (/= ':') + driveletter = map toLower . takeWhile (/= ':') recombine = fixtrailing . Posix.joinPath - fixtrailing s + fixtrailing s | hasTrailingPathSeparator p = Posix.addTrailingPathSeparator s | otherwise = s #endif @@ -255,7 +254,9 @@ fileNameLengthLimit :: FilePath -> IO Int fileNameLengthLimit _ = return 255 #else fileNameLengthLimit dir = do - l <- fromIntegral <$> getPathVar dir FileNameLimit + -- getPathVar can fail due to statfs(2) overflow + l <- catchDefaultIO 0 $ + fromIntegral <$> getPathVar dir FileNameLimit if l <= 0 then return 255 else return $ minimum [l, 255] @@ -267,12 +268,13 @@ fileNameLengthLimit dir = do - sane FilePath. - - All spaces and punctuation and other wacky stuff are replaced - - with '_', except for '.' "../" will thus turn into ".._", which is safe. + - with '_', except for '.' + - "../" will thus turn into ".._", which is safe. -} sanitizeFilePath :: String -> FilePath sanitizeFilePath = map sanitize where - sanitize c + sanitize c | c == '.' = c | isSpace c || isPunctuation c || isSymbol c || isControl c || c == '/' = '_' | otherwise = c diff --git a/src/Utility/PosixFiles.hs b/src/Utility/PosixFiles.hs index 5a94ead..5abbb57 100644 --- a/src/Utility/PosixFiles.hs +++ b/src/Utility/PosixFiles.hs @@ -2,7 +2,7 @@ - - This is like System.PosixCompat.Files, except with a fixed rename. - - - Copyright 2014 Joey Hess + - Copyright 2014 Joey Hess - - License: BSD-2-clause -} diff --git a/src/Utility/QuickCheck.hs b/src/Utility/QuickCheck.hs index 54200d3..a498ee6 100644 --- a/src/Utility/QuickCheck.hs +++ b/src/Utility/QuickCheck.hs @@ -1,6 +1,6 @@ {- QuickCheck with additional instances - - - Copyright 2012-2014 Joey Hess + - Copyright 2012-2014 Joey Hess - - License: BSD-2-clause -} diff --git a/src/Utility/SafeCommand.hs b/src/Utility/SafeCommand.hs index a555620..86e60db 100644 --- a/src/Utility/SafeCommand.hs +++ b/src/Utility/SafeCommand.hs @@ -1,6 +1,6 @@ {- safely running shell commands - - - Copyright 2010-2013 Joey Hess + - Copyright 2010-2013 Joey Hess - - License: BSD-2-clause -} diff --git a/src/Utility/Scheduled.hs b/src/Utility/Scheduled.hs index 3a1a6cd..4fa3a29 100644 --- a/src/Utility/Scheduled.hs +++ b/src/Utility/Scheduled.hs @@ -1,6 +1,6 @@ {- scheduled activities - - - Copyright 2013-2014 Joey Hess + - Copyright 2013-2014 Joey Hess - - License: BSD-2-clause -} @@ -44,7 +44,7 @@ import Data.Char {- Some sort of scheduled event. -} data Schedule = Schedule Recurrance ScheduledTime - deriving (Eq, Read, Show, Ord) + deriving (Eq, Read, Show, Ord) data Recurrance = Daily @@ -54,7 +54,7 @@ data Recurrance | Divisible Int Recurrance -- ^ Days, Weeks, or Months of the year evenly divisible by a number. -- (Divisible Year is years evenly divisible by a number.) - deriving (Eq, Read, Show, Ord) + deriving (Eq, Read, Show, Ord) type WeekDay = Int type MonthDay = Int @@ -63,7 +63,7 @@ type YearDay = Int data ScheduledTime = AnyTime | SpecificTime Hour Minute - deriving (Eq, Read, Show, Ord) + deriving (Eq, Read, Show, Ord) type Hour = Int type Minute = Int @@ -73,7 +73,7 @@ type Minute = Int data NextTime = NextTimeExactly LocalTime | NextTimeWindow LocalTime LocalTime - deriving (Eq, Read, Show) + deriving (Eq, Read, Show) startTime :: NextTime -> LocalTime startTime (NextTimeExactly t) = t @@ -96,9 +96,9 @@ calcNextTime schedule@(Schedule recurrance scheduledtime) lasttime currenttime NextTimeExactly t -> window (localDay t) (localDay t) | otherwise = NextTimeExactly . startTime <$> findfromtoday False where - findfromtoday anytime = findfrom recurrance afterday today + findfromtoday anytime = findfrom recurrance afterday today where - today = localDay currenttime + today = localDay currenttime afterday = sameaslastrun || toolatetoday toolatetoday = not anytime && localTimeOfDay currenttime >= nexttime sameaslastrun = lastrun == Just today @@ -163,8 +163,8 @@ calcNextTime schedule@(Schedule recurrance scheduledtime) lasttime currenttime Divisible n r'@(Yearly _) -> handlediv n r' ynum Nothing Divisible _ r'@(Divisible _ _) -> findfrom r' afterday candidate where - skip n = findfrom r False (addDays n candidate) - handlediv n r' getval mmax + skip n = findfrom r False (addDays n candidate) + handlediv n r' getval mmax | n > 0 && maybe True (n <=) mmax = findfromwhere r' (divisible n . getval) afterday candidate | otherwise = Nothing @@ -267,7 +267,7 @@ toRecurrance s = case words s of constructor u | "s" `isSuffixOf` u = constructor $ reverse $ drop 1 $ reverse u | otherwise = Nothing - withday sd u = do + withday sd u = do c <- constructor u d <- readish sd Just $ c (Just d) @@ -285,7 +285,7 @@ fromScheduledTime AnyTime = "any time" fromScheduledTime (SpecificTime h m) = show h' ++ (if m > 0 then ":" ++ pad 2 (show m) else "") ++ " " ++ ampm where - pad n s = take (n - length s) (repeat '0') ++ s + pad n s = take (n - length s) (repeat '0') ++ s (h', ampm) | h == 0 = (12, "AM") | h < 12 = (h, "AM") @@ -304,10 +304,10 @@ toScheduledTime v = case words v of (s:[]) -> go s id _ -> Nothing where - h0 h + h0 h | h == 12 = 0 | otherwise = h - go :: String -> (Int -> Int) -> Maybe ScheduledTime + go :: String -> (Int -> Int) -> Maybe ScheduledTime go s adjust = let (h, m) = separate (== ':') s in SpecificTime @@ -363,7 +363,7 @@ instance Arbitrary Recurrance where ] ] where - arbday = oneof + arbday = oneof [ Just <$> nonNegative arbitrary , pure Nothing ] diff --git a/src/Utility/ThreadScheduler.hs b/src/Utility/ThreadScheduler.hs index eb00974..e6a81ae 100644 --- a/src/Utility/ThreadScheduler.hs +++ b/src/Utility/ThreadScheduler.hs @@ -1,6 +1,6 @@ {- thread scheduling - - - Copyright 2012, 2013 Joey Hess + - Copyright 2012, 2013 Joey Hess - Copyright 2011 Bas van Dijk & Roel van Dijk - - License: BSD-2-clause @@ -57,8 +57,7 @@ unboundDelay time = do waitForTermination :: IO () waitForTermination = do #ifdef mingw32_HOST_OS - runEvery (Seconds 600) $ - void getLine + forever $ threadDelaySeconds (Seconds 6000) #else lock <- newEmptyMVar let check sig = void $ diff --git a/src/Utility/UserInfo.hs b/src/Utility/UserInfo.hs index e2c248b..c82f040 100644 --- a/src/Utility/UserInfo.hs +++ b/src/Utility/UserInfo.hs @@ -1,6 +1,6 @@ {- user info - - - Copyright 2012 Joey Hess + - Copyright 2012 Joey Hess - - License: BSD-2-clause -} @@ -13,8 +13,10 @@ module Utility.UserInfo ( myUserGecos, ) where -import Control.Applicative import System.PosixCompat +#ifndef mingw32_HOST_OS +import Control.Applicative +#endif import Utility.Env @@ -40,16 +42,20 @@ myUserName = myVal env userName env = ["USERNAME", "USER", "LOGNAME"] #endif -myUserGecos :: IO String -#ifdef __ANDROID__ -myUserGecos = return "" -- userGecos crashes on Android +myUserGecos :: IO (Maybe String) +-- userGecos crashes on Android and is not available on Windows. +#if defined(__ANDROID__) || defined(mingw32_HOST_OS) +myUserGecos = return Nothing #else -myUserGecos = myVal [] userGecos +myUserGecos = Just <$> myVal [] userGecos #endif myVal :: [String] -> (UserEntry -> String) -> IO String -myVal envvars extract = maybe (extract <$> getpwent) return =<< check envvars +myVal envvars extract = go envvars where - check [] = return Nothing - check (v:vs) = maybe (check vs) (return . Just) =<< getEnv v - getpwent = getUserEntryForID =<< getEffectiveUserID +#ifndef mingw32_HOST_OS + go [] = extract <$> (getUserEntryForID =<< getEffectiveUserID) +#else + go [] = error $ "environment not set: " ++ show envvars +#endif + go (v:vs) = maybe (go vs) return =<< getEnv v