{-# LANGUAGE TypeFamilies #-}

module Propellor.Property.Tor where

import Propellor.Base
import qualified Propellor.Property.File as File
import qualified Propellor.Property.Apt as Apt
import qualified Propellor.Property.Service as Service
import qualified Propellor.Property.ConfFile as ConfFile
import Utility.DataUnits

import System.Posix.Files
import Data.Char
import Data.List

type HiddenServiceName = String

type NodeName = String

-- | Sets up a tor bridge. (Not a relay or exit node.)
--
-- Uses port 443
isBridge :: Property DebianLike
isBridge :: Property DebianLike
isBridge = [(String, String)] -> Property DebianLike
configured
	[ (String
"BridgeRelay", String
"1")
	, (String
"Exitpolicy", String
"reject *:*")
	, (String
"ORPort", String
"443")
	]
	forall p. IsProp p => p -> String -> p
`describe` String
"tor bridge"
	forall x y. Combines x y => x -> y -> CombinedType x y
`requires` Property DebianLike
server

-- | Sets up a tor relay.
--
-- Uses port 443
isRelay :: Property DebianLike
isRelay :: Property DebianLike
isRelay = [(String, String)] -> Property DebianLike
configured
	[ (String
"BridgeRelay", String
"0")
	, (String
"Exitpolicy", String
"reject *:*")
	, (String
"ORPort", String
"443")
	]
	forall p. IsProp p => p -> String -> p
`describe` String
"tor relay"
	forall x y. Combines x y => x -> y -> CombinedType x y
`requires` Property DebianLike
server

-- | Makes the tor node be named, with a known private key.
--
-- This can be moved to a different IP without needing to wait to
-- accumulate trust.
named :: NodeName -> Property (HasInfo + DebianLike)
named :: String -> Property (HasInfo + DebianLike)
named String
n = [(String, String)] -> Property DebianLike
configured [(String
"Nickname", String
n')]
	forall p. IsProp p => p -> String -> p
`describe` (String
"tor node named " forall a. [a] -> [a] -> [a]
++ String
n')
	forall x y. Combines x y => x -> y -> CombinedType x y
`requires` Context -> Property (HasInfo + DebianLike)
torPrivKey (String -> Context
Context (String
"tor " forall a. [a] -> [a] -> [a]
++ String
n))
  where
	n' :: String
n' = String -> String
saneNickname String
n

-- | Configures tor with secret_id_key, ed25519_master_id_public_key,
-- and ed25519_master_id_secret_key from privdata.
torPrivKey :: Context -> Property (HasInfo + DebianLike)
torPrivKey :: Context -> Property (HasInfo + DebianLike)
torPrivKey Context
context = forall a. Monoid a => [a] -> a
mconcat (forall a b. (a -> b) -> [a] -> [b]
map String
-> CombinedType
     (Property
        (MetaTypes
           '[ 'WithInfo, 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
              'Targeting 'OSArchLinux, 'Targeting 'OSFreeBSD]))
     (Property UnixLike)
go [String]
keyfiles)
	forall x y. Combines x y => x -> y -> CombinedType x y
`onChange` Property DebianLike
restarted
	forall x y. Combines x y => x -> y -> CombinedType x y
`requires` Property DebianLike
torPrivKeyDirExists
  where
	keyfiles :: [String]
keyfiles = forall a b. (a -> b) -> [a] -> [b]
map (String
torPrivKeyDir String -> String -> String
</>)
		[ String
"secret_id_key"
		, String
"ed25519_master_id_public_key"
		, String
"ed25519_master_id_secret_key"
		]
	go :: String
-> CombinedType
     (Property
        (MetaTypes
           '[ 'WithInfo, 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
              'Targeting 'OSArchLinux, 'Targeting 'OSFreeBSD]))
     (Property UnixLike)
go String
f = String
f forall c.
IsContext c =>
String -> c -> Property (HasInfo + UnixLike)
`File.hasPrivContent` Context
context
		forall x y. Combines x y => x -> y -> CombinedType x y
`onChange` String -> User -> Group -> Property UnixLike
File.ownerGroup String
f User
user (User -> Group
userGroup User
user)

torPrivKeyDirExists :: Property DebianLike
torPrivKeyDirExists :: Property DebianLike
torPrivKeyDirExists = String -> Property UnixLike
File.dirExists String
torPrivKeyDir
	forall x y. Combines x y => x -> y -> CombinedType x y
`onChange` Property UnixLike
setperms
	forall x y. Combines x y => x -> y -> CombinedType x y
`requires` Property DebianLike
installed
  where
	setperms :: CombinedType (Property UnixLike) (Property UnixLike)
setperms = String -> User -> Group -> Property UnixLike
File.ownerGroup String
torPrivKeyDir User
user (User -> Group
userGroup User
user)
		forall x y. Combines x y => x -> y -> CombinedType x y
`before` String -> FileMode -> Property UnixLike
File.mode String
torPrivKeyDir FileMode
0O2700

torPrivKeyDir :: FilePath
torPrivKeyDir :: String
torPrivKeyDir = String
"/var/lib/tor/keys"

-- | A tor server (bridge, relay, or exit)
-- Don't use if you just want to run tor for personal use.
server :: Property DebianLike
server :: Property DebianLike
server = [(String, String)] -> Property DebianLike
configured [(String
"SocksPort", String
"0")]
	forall x y. Combines x y => x -> y -> CombinedType x y
`requires` Property DebianLike
installed
	forall x y. Combines x y => x -> y -> CombinedType x y
`requires` [String] -> Property DebianLike
Apt.installed [String
"ntp"]
	forall p. IsProp p => p -> String -> p
`describe` String
"tor server"

installed :: Property DebianLike
installed :: Property DebianLike
installed = [String] -> Property DebianLike
Apt.installed [String
"tor"]

-- | Specifies configuration settings. Any lines in the config file
-- that set other values for the specified settings will be removed,
-- while other settings are left as-is. Tor is restarted when
-- configuration is changed.
configured :: [(String, String)] -> Property DebianLike
configured :: [(String, String)] -> Property DebianLike
configured [(String, String)]
settings = forall c.
(FileContent c, Eq c) =>
String -> (c -> c) -> String -> Property UnixLike
File.fileProperty String
"tor configured" [String] -> [String]
go String
mainConfig
	forall x y. Combines x y => x -> y -> CombinedType x y
`onChange` Property DebianLike
restarted
  where
	ks :: [String]
ks = forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst [(String, String)]
settings
	go :: [String] -> [String]
go [String]
ls = forall a. Ord a => [a] -> [a]
sort forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (String, String) -> String
toconfig forall a b. (a -> b) -> a -> b
$
		forall a. (a -> Bool) -> [a] -> [a]
filter (\(String
k, String
_) -> String
k forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [String]
ks) (forall a b. (a -> b) -> [a] -> [b]
map String -> (String, String)
fromconfig [String]
ls)
		forall a. [a] -> [a] -> [a]
++ [(String, String)]
settings
	toconfig :: (String, String) -> String
toconfig (String
k, String
v) = String
k forall a. [a] -> [a] -> [a]
++ String
" " forall a. [a] -> [a] -> [a]
++ String
v
	fromconfig :: String -> (String, String)
fromconfig = forall a. (a -> Bool) -> [a] -> ([a], [a])
separate (forall a. Eq a => a -> a -> Bool
== Char
' ')

data BwLimit
	= PerSecond String
	| PerDay String
	| PerMonth String

-- | Limit incoming and outgoing traffic to the specified
-- amount each.
--
-- For example, PerSecond "30 kibibytes" is the minimum limit
-- for a useful relay.
bandwidthRate :: BwLimit -> Property DebianLike
bandwidthRate :: BwLimit -> Property DebianLike
bandwidthRate (PerSecond String
s) = String -> ByteSize -> Property DebianLike
bandwidthRate' String
s ByteSize
1
bandwidthRate (PerDay String
s) = String -> ByteSize -> Property DebianLike
bandwidthRate' String
s (ByteSize
24forall a. Num a => a -> a -> a
*ByteSize
60forall a. Num a => a -> a -> a
*ByteSize
60)
bandwidthRate (PerMonth String
s) = String -> ByteSize -> Property DebianLike
bandwidthRate' String
s (ByteSize
31forall a. Num a => a -> a -> a
*ByteSize
24forall a. Num a => a -> a -> a
*ByteSize
60forall a. Num a => a -> a -> a
*ByteSize
60)

bandwidthRate' :: String -> Integer -> Property DebianLike
bandwidthRate' :: String -> ByteSize -> Property DebianLike
bandwidthRate' String
s ByteSize
divby = case [Unit] -> String -> Maybe ByteSize
readSize [Unit]
dataUnits String
s of
	Just ByteSize
sz -> let v :: String
v = forall a. Show a => a -> String
show (ByteSize
sz forall a. Integral a => a -> a -> a
`div` ByteSize
divby) forall a. [a] -> [a] -> [a]
++ String
" bytes"
		in [(String, String)] -> Property DebianLike
configured [(String
"BandwidthRate", String
v)]
			forall p. IsProp p => p -> String -> p
`describe` (String
"tor BandwidthRate " forall a. [a] -> [a] -> [a]
++ String
v)
	Maybe ByteSize
Nothing -> forall {k} (metatypes :: k).
SingI metatypes =>
String -> Propellor Result -> Property (MetaTypes metatypes)
property (String
"unable to parse " forall a. [a] -> [a] -> [a]
++ String
s) Propellor Result
noChange

-- | Enables a hidden service for a given port.
--
-- If used without `hiddenServiceData`, tor will generate a new
-- private key.
hiddenService :: HiddenServiceName -> Port -> Property DebianLike
hiddenService :: String -> Port -> Property DebianLike
hiddenService String
hn Port
port = String -> [Port] -> Property DebianLike
hiddenService' String
hn [Port
port]

hiddenService' :: HiddenServiceName -> [Port] -> Property DebianLike
hiddenService' :: String -> [Port] -> Property DebianLike
hiddenService' String
hn [Port]
ports = String
-> SectionStart
-> SectionStart
-> ([String] -> [String])
-> ([String] -> [String])
-> String
-> Property UnixLike
ConfFile.adjustSection
	([String] -> String
unwords [String
"hidden service", String
hn, String
"available on ports", forall a. [a] -> [[a]] -> [a]
intercalate String
"," (forall a b. (a -> b) -> [a] -> [b]
map forall t. ConfigurableValue t => t -> String
val [Port]
ports')])
	(forall a. Eq a => a -> a -> Bool
== String
oniondir)
	(Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Eq a => [a] -> [a] -> Bool
isPrefixOf String
"HiddenServicePort")
	(forall a b. a -> b -> a
const (String
oniondir forall a. a -> [a] -> [a]
: [String]
onionports))
	(forall a. [a] -> [a] -> [a]
++ String
oniondir forall a. a -> [a] -> [a]
: [String]
onionports)
	String
mainConfig
	forall x y. Combines x y => x -> y -> CombinedType x y
`onChange` Property DebianLike
restarted
  where
	oniondir :: String
oniondir = [String] -> String
unwords [String
"HiddenServiceDir", String
varLib String -> String -> String
</> String
hn]
	onionports :: [String]
onionports = forall a b. (a -> b) -> [a] -> [b]
map forall t. ConfigurableValue t => t -> String
onionport [Port]
ports'
	ports' :: [Port]
ports' = forall a. Ord a => [a] -> [a]
sort [Port]
ports
	onionport :: t -> String
onionport t
port = [String] -> String
unwords [String
"HiddenServicePort", forall t. ConfigurableValue t => t -> String
val t
port, String
"127.0.0.1:" forall a. [a] -> [a] -> [a]
++ forall t. ConfigurableValue t => t -> String
val t
port]

-- | Same as `hiddenService` but also causes propellor to display
-- the onion address of the hidden service.
hiddenServiceAvailable :: HiddenServiceName -> Port -> Property DebianLike
hiddenServiceAvailable :: String -> Port -> Property DebianLike
hiddenServiceAvailable String
hn Port
port = String -> [Port] -> Property DebianLike
hiddenServiceAvailable' String
hn [Port
port]

hiddenServiceAvailable' :: HiddenServiceName -> [Port] -> Property DebianLike
hiddenServiceAvailable' :: String -> [Port] -> Property DebianLike
hiddenServiceAvailable' String
hn [Port]
ports = Property DebianLike -> Property DebianLike
hiddenServiceHostName forall a b. (a -> b) -> a -> b
$ String -> [Port] -> Property DebianLike
hiddenService' String
hn [Port]
ports
  where
	hiddenServiceHostName :: Property DebianLike -> Property DebianLike
hiddenServiceHostName Property DebianLike
p =  forall metatypes.
Property metatypes
-> (Propellor Result -> Propellor Result) -> Property metatypes
adjustPropertySatisfy Property DebianLike
p forall a b. (a -> b) -> a -> b
$ \Propellor Result
satisfy -> do
		Result
r <- Propellor Result
satisfy
		Either IOException String
mh <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a.
MonadCatch m =>
m a -> m (Either IOException a)
tryIO forall a b. (a -> b) -> a -> b
$ String -> IO String
readFile (String
varLib String -> String -> String
</> String
hn String -> String -> String
</> String
"hostname")
		case Either IOException String
mh of
			Right String
h -> forall (m :: * -> *). MonadIO m => [String] -> m ()
infoMessage [String
"hidden service hostname:", String
h]
			Left IOException
_e -> forall (m :: * -> *). MonadIO m => String -> m ()
warningMessage String
"hidden service hostname not available yet"
		forall (m :: * -> *) a. Monad m => a -> m a
return Result
r

-- | Load the private key for a hidden service from the privdata.
hiddenServiceData :: IsContext c => HiddenServiceName -> c -> Property (HasInfo + DebianLike)
hiddenServiceData :: forall c.
IsContext c =>
String -> c -> Property (HasInfo + DebianLike)
hiddenServiceData String
hn c
context = forall {k} (metatypes :: k).
SingI metatypes =>
String
-> Props (MetaTypes metatypes) -> Property (MetaTypes metatypes)
combineProperties String
desc forall a b. (a -> b) -> a -> b
$ Props UnixLike
props
	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 (HasInfo + DebianLike)
installonion String
"hostname"
	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 (HasInfo + DebianLike)
installonion String
"private_key"
  where
	desc :: String
desc = [String] -> String
unwords [String
"hidden service data available in", String
varLib String -> String -> String
</> String
hn]
	installonion :: FilePath -> Property (HasInfo + DebianLike)
	installonion :: String -> Property (HasInfo + DebianLike)
installonion String
basef =
		let f :: String
f = String
varLib String -> String -> String
</> String
hn String -> String -> String
</> String
basef
		in forall c s metatypes.
(IsContext c, IsPrivDataSource s,
 IncludesInfo metatypes ~ 'True) =>
s
-> c
-> (((PrivData -> Propellor Result) -> Propellor Result)
    -> Property metatypes)
-> Property metatypes
withPrivData (String -> PrivDataField
PrivFile String
f) c
context forall a b. (a -> b) -> a -> b
$ \(PrivData -> Propellor Result) -> Propellor Result
getcontent ->
		forall {k} (metatypes :: k).
SingI metatypes =>
String
-> (OuterMetaTypesWitness metatypes -> Propellor Result)
-> Property (MetaTypes metatypes)
property' String
desc forall a b. (a -> b) -> a -> b
$ \OuterMetaTypesWitness
  '[ 'WithInfo, 'Targeting 'OSDebian, 'Targeting 'OSBuntish]
w -> (PrivData -> Propellor Result) -> Propellor Result
getcontent forall a b. (a -> b) -> a -> b
$ \PrivData
privcontent ->
			forall (m :: * -> *) a. Monad m => m Bool -> (m a, m a) -> m a
ifM (forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ String -> IO Bool
doesFileExist String
f)
				( Propellor Result
noChange
				, forall (inner :: [MetaType]) (outer :: [MetaType]).
EnsurePropertyAllowed inner outer =>
OuterMetaTypesWitness outer
-> Property (MetaTypes inner) -> Propellor Result
ensureProperty OuterMetaTypesWitness
  '[ 'WithInfo, 'Targeting 'OSDebian, 'Targeting 'OSBuntish]
w forall a b. (a -> b) -> a -> b
$ forall {k} (metatypes :: k).
SingI metatypes =>
String
-> Props (MetaTypes metatypes) -> Property (MetaTypes metatypes)
propertyList String
desc forall a b. (a -> b) -> a -> b
$ forall {k} (metatypes :: k).
[Property (MetaTypes metatypes)] -> Props (MetaTypes metatypes)
toProps
					[ forall {k} (metatypes :: k).
SingI metatypes =>
String -> Propellor Result -> Property (MetaTypes metatypes)
property String
desc forall a b. (a -> b) -> a -> b
$ IO () -> Propellor Result
makeChange forall a b. (a -> b) -> a -> b
$ do
						Bool -> String -> IO ()
createDirectoryIfMissing Bool
True (String -> String
takeDirectory String
f)
						String -> String -> IO ()
writeFileProtected String
f ([String] -> String
unlines (PrivData -> [String]
privDataLines PrivData
privcontent))
					, String -> FileMode -> Property UnixLike
File.mode (String -> String
takeDirectory String
f) forall a b. (a -> b) -> a -> b
$ [FileMode] -> FileMode
combineModes
						[FileMode
ownerReadMode, FileMode
ownerWriteMode, FileMode
ownerExecuteMode]
					, String -> User -> Group -> Property UnixLike
File.ownerGroup (String -> String
takeDirectory String
f) User
user (User -> Group
userGroup User
user)
					, String -> User -> Group -> Property UnixLike
File.ownerGroup String
f User
user (User -> Group
userGroup User
user)
					]
				)

restarted :: Property DebianLike
restarted :: Property DebianLike
restarted = String -> Property DebianLike
Service.restarted String
"tor"

mainConfig :: FilePath
mainConfig :: String
mainConfig = String
"/etc/tor/torrc"

varLib :: FilePath
varLib :: String
varLib = String
"/var/lib/tor"

varRun :: FilePath
varRun :: String
varRun = String
"/var/run/tor"

user :: User
user :: User
user = String -> User
User String
"debian-tor"

type NickName = String

-- | Convert String to a valid tor NickName.
saneNickname :: String -> NickName
saneNickname :: String -> String
saneNickname String
s
	| forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
n = String
"unnamed"
	| Bool
otherwise = String
n
  where
	legal :: Char -> Bool
legal Char
c = Char -> Bool
isNumber Char
c Bool -> Bool -> Bool
|| Char -> Bool
isAsciiUpper Char
c Bool -> Bool -> Bool
|| Char -> Bool
isAsciiLower Char
c
	n :: String
n = forall a. Int -> [a] -> [a]
take Int
19 forall a b. (a -> b) -> a -> b
$ forall a. (a -> Bool) -> [a] -> [a]
filter Char -> Bool
legal String
s