propellor/src/Propellor/Property/Tor.hs

153 lines
4.3 KiB
Haskell

module Propellor.Property.Tor where
import Propellor
import qualified Propellor.Property.File as File
import qualified Propellor.Property.Apt as Apt
import qualified Propellor.Property.Service as Service
import Utility.FileMode
import System.Posix.Files
import Data.Char
type HiddenServiceName = String
type NodeName = String
-- | Sets up a tor bridge. (Not a relay or exit node.)
--
-- Uses port 443
isBridge :: Property NoInfo
isBridge = isBridge' []
isBridge' :: [String] -> Property NoInfo
isBridge' extraconfig = server config
`describe` "tor bridge"
where
config =
[ "BridgeRelay 1"
, "Exitpolicy reject *:*"
, "ORPort 443"
] ++ extraconfig
-- | Sets up a tor relay.
--
-- Uses port 443
isRelay :: Property NoInfo
isRelay = isRelay' []
isRelay' :: [String] -> Property NoInfo
isRelay' extraconfig = server config
`describe` "tor relay"
where
config =
[ "BridgeRelay 0"
, "Exitpolicy reject *:*"
, "ORPort 443"
] ++ extraconfig
-- | Converts a property like isBridge' or isRelay' to be a named
-- node, with a known private key.
--
-- This can be moved to a different IP without needing to wait to
-- accumulate trust.
--
-- The base property can be used to start out and then upgraded to
-- a named property later.
named :: NodeName -> ([String] -> Property NoInfo) -> Property HasInfo
named n basep = p `describe` (getDesc p ++ " " ++ n)
where
p = basep ["Nickname " ++ saneNickname n]
`requires` torPrivKey (Context ("tor " ++ n))
-- | A tor server (bridge, relay, or exit)
-- Don't use if you just want to run tor for personal use.
server :: [String] -> Property NoInfo
server extraconfig = setup
`requires` Apt.installed ["tor", "ntp"]
`describe` "tor server"
where
setup = mainConfig `File.hasContent` config
`onChange` restarted
config =
[ "SocksPort 0"
] ++ extraconfig
torPrivKey :: Context -> Property HasInfo
torPrivKey context = f `File.hasPrivContent` context
`onChange` File.ownerGroup f user user
-- install tor first, so the directory exists with right perms
`requires` Apt.installed ["tor"]
where
f = "/var/lib/tor/keys/secret_id_key"
hiddenServiceAvailable :: HiddenServiceName -> Int -> Property NoInfo
hiddenServiceAvailable hn port = hiddenServiceHostName prop
where
prop = mainConfig `File.containsLines`
[ unwords ["HiddenServiceDir", varLib </> hn]
, unwords ["HiddenServicePort", show port, "127.0.0.1:" ++ show port]
]
`describe` "hidden service available"
`onChange` Service.reloaded "tor"
hiddenServiceHostName p = adjustPropertySatisfy p $ \satisfy -> do
r <- satisfy
h <- liftIO $ readFile (varLib </> hn </> "hostname")
warningMessage $ unwords ["hidden service hostname:", h]
return r
hiddenService :: HiddenServiceName -> Int -> Property NoInfo
hiddenService hn port = mainConfig `File.containsLines`
[ unwords ["HiddenServiceDir", varLib </> hn]
, unwords ["HiddenServicePort", show port, "127.0.0.1:" ++ show port]
]
`describe` unwords ["hidden service available:", hn, show port]
`onChange` restarted
hiddenServiceData :: IsContext c => HiddenServiceName -> c -> Property HasInfo
hiddenServiceData hn context = combineProperties desc
[ installonion "hostname"
, installonion "private_key"
]
where
desc = unwords ["hidden service data available in", varLib </> hn]
installonion f = withPrivData (PrivFile $ varLib </> hn </> f) context $ \getcontent ->
property desc $ getcontent $ install $ varLib </> hn </> f
install f content = ifM (liftIO $ doesFileExist f)
( noChange
, ensureProperties
[ property desc $ makeChange $ do
createDirectoryIfMissing True (takeDirectory f)
writeFileProtected f content
, File.mode (takeDirectory f) $ combineModes
[ownerReadMode, ownerWriteMode, ownerExecuteMode]
, File.ownerGroup (takeDirectory f) user user
, File.ownerGroup f user user
]
)
restarted :: Property NoInfo
restarted = Service.restarted "tor"
mainConfig :: FilePath
mainConfig = "/etc/tor/torrc"
varLib :: FilePath
varLib = "/var/lib/tor"
varRun :: FilePath
varRun = "/var/run/tor"
user :: UserName
user = "debian-tor"
type NickName = String
-- | Convert String to a valid tor NickName.
saneNickname :: String -> NickName
saneNickname s
| null n = "unnamed"
| otherwise = n
where
legal c = isNumber c || isAsciiUpper c || isAsciiLower c
n = take 19 $ filter legal s