Merge branch 'joeyconfig'
Conflicts: privdata.joey/privdata.gpg
This commit is contained in:
Joey Hess
commit
47fdb99fbb
|
|
@ -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
|
||||
|
||||
|
||||
|
|
|
|||
|
|
@ -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 <id@joeyh.name> Sun, 04 Jan 2015 21:25:42 -0400
|
||||
-- Joey Hess <id@joeyh.name> Thu, 15 Jan 2015 14:02:07 -0400
|
||||
|
||||
propellor (1.3.1) unstable; urgency=medium
|
||||
|
||||
|
|
|
|||
|
|
@ -1,5 +1,5 @@
|
|||
Name: propellor
|
||||
Version: 1.3.1
|
||||
Version: 1.3.2
|
||||
Cabal-Version: >= 1.6
|
||||
License: BSD3
|
||||
Maintainer: Joey Hess <id@joeyh.name>
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
{- applicative stuff
|
||||
-
|
||||
- Copyright 2012 Joey Hess <id@joeyh.name>
|
||||
- Copyright 2012 Joey Hess <joey@kitenet.net>
|
||||
-
|
||||
- License: BSD-2-clause
|
||||
-}
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
{- utilities for simple data types
|
||||
-
|
||||
- Copyright 2013 Joey Hess <id@joeyh.name>
|
||||
- Copyright 2013 Joey Hess <joey@kitenet.net>
|
||||
-
|
||||
- License: BSD-2-clause
|
||||
-}
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
{- portable environment variables
|
||||
-
|
||||
- Copyright 2013 Joey Hess <id@joeyh.name>
|
||||
- Copyright 2013 Joey Hess <joey@kitenet.net>
|
||||
-
|
||||
- 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
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
{- GHC File system encoding handling.
|
||||
-
|
||||
- Copyright 2012-2014 Joey Hess <id@joeyh.name>
|
||||
- Copyright 2012-2014 Joey Hess <joey@kitenet.net>
|
||||
-
|
||||
- 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
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
{- Linux library copier and binary shimmer
|
||||
-
|
||||
- Copyright 2013 Joey Hess <id@joeyh.name>
|
||||
- Copyright 2013 Joey Hess <joey@kitenet.net>
|
||||
-
|
||||
- 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)
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
{- misc utility functions
|
||||
-
|
||||
- Copyright 2010-2011 Joey Hess <id@joeyh.name>
|
||||
- Copyright 2010-2011 Joey Hess <joey@kitenet.net>
|
||||
-
|
||||
- License: BSD-2-clause
|
||||
-}
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
{- monadic stuff
|
||||
-
|
||||
- Copyright 2010-2012 Joey Hess <id@joeyh.name>
|
||||
- Copyright 2010-2012 Joey Hess <joey@kitenet.net>
|
||||
-
|
||||
- License: BSD-2-clause
|
||||
-}
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
{- path manipulation
|
||||
-
|
||||
- Copyright 2010-2014 Joey Hess <id@joeyh.name>
|
||||
- Copyright 2010-2014 Joey Hess <joey@kitenet.net>
|
||||
-
|
||||
- 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
|
||||
|
|
|
|||
|
|
@ -2,7 +2,7 @@
|
|||
-
|
||||
- This is like System.PosixCompat.Files, except with a fixed rename.
|
||||
-
|
||||
- Copyright 2014 Joey Hess <id@joeyh.name>
|
||||
- Copyright 2014 Joey Hess <joey@kitenet.net>
|
||||
-
|
||||
- License: BSD-2-clause
|
||||
-}
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
{- QuickCheck with additional instances
|
||||
-
|
||||
- Copyright 2012-2014 Joey Hess <id@joeyh.name>
|
||||
- Copyright 2012-2014 Joey Hess <joey@kitenet.net>
|
||||
-
|
||||
- License: BSD-2-clause
|
||||
-}
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
{- safely running shell commands
|
||||
-
|
||||
- Copyright 2010-2013 Joey Hess <id@joeyh.name>
|
||||
- Copyright 2010-2013 Joey Hess <joey@kitenet.net>
|
||||
-
|
||||
- License: BSD-2-clause
|
||||
-}
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
{- scheduled activities
|
||||
-
|
||||
- Copyright 2013-2014 Joey Hess <id@joeyh.name>
|
||||
- Copyright 2013-2014 Joey Hess <joey@kitenet.net>
|
||||
-
|
||||
- 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
|
||||
]
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
{- thread scheduling
|
||||
-
|
||||
- Copyright 2012, 2013 Joey Hess <id@joeyh.name>
|
||||
- Copyright 2012, 2013 Joey Hess <joey@kitenet.net>
|
||||
- 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 $
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
{- user info
|
||||
-
|
||||
- Copyright 2012 Joey Hess <id@joeyh.name>
|
||||
- Copyright 2012 Joey Hess <joey@kitenet.net>
|
||||
-
|
||||
- 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
|
||||
|
|
|
|||
Loading…
Reference in New Issue