-- | This module gets LetsEncrypt <https://letsencrypt.org/> certificates 
-- using CertBot <https://certbot.eff.org/>

module Propellor.Property.LetsEncrypt where

import Propellor.Base
import qualified Propellor.Property.Apt as Apt

import System.Posix.Files

installed :: Property DebianLike
installed :: Property DebianLike
installed = [Package] -> Property DebianLike
Apt.installed [Package
"certbot"]

-- | Tell the letsencrypt client that you agree with the Let's Encrypt
-- Subscriber Agreement. Providing an email address is recommended,
-- so that letcencrypt can contact you about problems.
data AgreeTOS = AgreeTOS (Maybe Email)

type Email = String

type WebRoot = FilePath

-- | Uses letsencrypt to obtain a certificate for a domain.
--
-- This should work with any web server, as long as letsencrypt can
-- write its temp files to the web root. The letsencrypt client does
-- not modify the web server's configuration in any way; this only obtains
-- the certificate it does not make the web server use it.
-- 
-- This also handles renewing the certificate.
-- For renewel to work well, propellor needs to be
-- run periodically (at least a couple times per month).
--
-- This property returns `MadeChange` when the certificate is initially
-- obtained, and when it's renewed. So, it can be combined with a property
-- to make the webserver (or other server) use the certificate:
--
-- > letsEncrypt (AgreeTOS (Just "me@example.com")) "example.com" "/var/www"
-- > 	`onChange` Apache.reload
--
-- See `Propellor.Property.Apache.httpsVirtualHost` for a more complete
-- integration of apache with letsencrypt, that's built on top of this.
letsEncrypt :: AgreeTOS -> Domain -> WebRoot -> Property DebianLike
letsEncrypt :: AgreeTOS -> Package -> Package -> Property DebianLike
letsEncrypt AgreeTOS
tos Package
domain = AgreeTOS -> Package -> [Package] -> Package -> Property DebianLike
letsEncrypt' AgreeTOS
tos Package
domain []

-- | Like `letsEncrypt`, but the certificate can be obtained for multiple
-- domains.
letsEncrypt' :: AgreeTOS -> Domain -> [Domain] -> WebRoot -> Property DebianLike
letsEncrypt' :: AgreeTOS -> Package -> [Package] -> Package -> Property DebianLike
letsEncrypt' (AgreeTOS Maybe Package
memail) Package
domain [Package]
domains Package
webroot =
	Property UnixLike
prop Property UnixLike
-> Property DebianLike
-> CombinedType (Property UnixLike) (Property DebianLike)
forall x y. Combines x y => x -> y -> CombinedType x y
`requires` Property DebianLike
installed
  where
	prop :: Property UnixLike
	prop :: Property UnixLike
prop = Package -> Propellor Result -> Property UnixLike
forall k (metatypes :: k).
SingI metatypes =>
Package -> Propellor Result -> Property (MetaTypes metatypes)
property Package
desc (Propellor Result -> Property UnixLike)
-> Propellor Result -> Property UnixLike
forall a b. (a -> b) -> a -> b
$ do
		[[Maybe (FileID, DeviceID, FileMode, FileOffset, EpochTime)]]
startstats <- IO [[Maybe (FileID, DeviceID, FileMode, FileOffset, EpochTime)]]
-> Propellor
     [[Maybe (FileID, DeviceID, FileMode, FileOffset, EpochTime)]]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO [[Maybe (FileID, DeviceID, FileMode, FileOffset, EpochTime)]]
getstats
		(Package
transcript, Bool
ok) <- IO (Package, Bool) -> Propellor (Package, Bool)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Package, Bool) -> Propellor (Package, Bool))
-> IO (Package, Bool) -> Propellor (Package, Bool)
forall a b. (a -> b) -> a -> b
$
			Package -> [Package] -> Maybe Package -> IO (Package, Bool)
processTranscript Package
"letsencrypt" [Package]
params Maybe Package
forall a. Maybe a
Nothing
		if Bool
ok
			then do
				[[Maybe (FileID, DeviceID, FileMode, FileOffset, EpochTime)]]
endstats <- IO [[Maybe (FileID, DeviceID, FileMode, FileOffset, EpochTime)]]
-> Propellor
     [[Maybe (FileID, DeviceID, FileMode, FileOffset, EpochTime)]]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO [[Maybe (FileID, DeviceID, FileMode, FileOffset, EpochTime)]]
getstats
				if [[Maybe (FileID, DeviceID, FileMode, FileOffset, EpochTime)]]
startstats [[Maybe (FileID, DeviceID, FileMode, FileOffset, EpochTime)]]
-> [[Maybe (FileID, DeviceID, FileMode, FileOffset, EpochTime)]]
-> Bool
forall a. Eq a => a -> a -> Bool
/= [[Maybe (FileID, DeviceID, FileMode, FileOffset, EpochTime)]]
endstats
					then Result -> Propellor Result
forall (m :: * -> *) a. Monad m => a -> m a
return Result
MadeChange
					else Result -> Propellor Result
forall (m :: * -> *) a. Monad m => a -> m a
return Result
NoChange
			else do
				IO () -> Propellor ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Propellor ()) -> IO () -> Propellor ()
forall a b. (a -> b) -> a -> b
$ Handle -> Package -> IO ()
hPutStr Handle
stderr Package
transcript
				Result -> Propellor Result
forall (m :: * -> *) a. Monad m => a -> m a
return Result
FailedChange
	
	desc :: Package
desc = Package
"letsencrypt " Package -> Package -> Package
forall a. [a] -> [a] -> [a]
++ [Package] -> Package
unwords [Package]
alldomains
	alldomains :: [Package]
alldomains = Package
domain Package -> [Package] -> [Package]
forall a. a -> [a] -> [a]
: [Package]
domains
	params :: [Package]
params =
		[ Package
"certonly"
		, Package
"--agree-tos"
		, case Maybe Package
memail of
			Just Package
email -> Package
"--email="Package -> Package -> Package
forall a. [a] -> [a] -> [a]
++Package
email
			Maybe Package
Nothing -> Package
"--register-unsafely-without-email"
		, Package
"--webroot"
		, Package
"--webroot-path", Package
webroot
		, Package
"--text"
		, Package
"--noninteractive"
		, Package
"--keep-until-expiring"
		-- The list of domains may be changed, adding more, so
		-- always request expansion.
		, Package
"--expand"
		] [Package] -> [Package] -> [Package]
forall a. [a] -> [a] -> [a]
++ (Package -> Package) -> [Package] -> [Package]
forall a b. (a -> b) -> [a] -> [b]
map (\Package
d -> Package
"--domain="Package -> Package -> Package
forall a. [a] -> [a] -> [a]
++Package
d) [Package]
alldomains

	getstats :: IO [[Maybe (FileID, DeviceID, FileMode, FileOffset, EpochTime)]]
getstats = (Package
 -> IO [Maybe (FileID, DeviceID, FileMode, FileOffset, EpochTime)])
-> [Package]
-> IO [[Maybe (FileID, DeviceID, FileMode, FileOffset, EpochTime)]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Package
-> IO [Maybe (FileID, DeviceID, FileMode, FileOffset, EpochTime)]
statcertfiles [Package]
alldomains
	statcertfiles :: Package
-> IO [Maybe (FileID, DeviceID, FileMode, FileOffset, EpochTime)]
statcertfiles Package
d = (Package
 -> IO (Maybe (FileID, DeviceID, FileMode, FileOffset, EpochTime)))
-> [Package]
-> IO [Maybe (FileID, DeviceID, FileMode, FileOffset, EpochTime)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Package
-> IO (Maybe (FileID, DeviceID, FileMode, FileOffset, EpochTime))
statfile
		[ Package -> Package
certFile Package
d
		, Package -> Package
privKeyFile Package
d
		, Package -> Package
chainFile Package
d
		, Package -> Package
fullChainFile Package
d
		]
	statfile :: Package
-> IO (Maybe (FileID, DeviceID, FileMode, FileOffset, EpochTime))
statfile Package
f = IO (FileID, DeviceID, FileMode, FileOffset, EpochTime)
-> IO (Maybe (FileID, DeviceID, FileMode, FileOffset, EpochTime))
forall (m :: * -> *) a. MonadCatch m => m a -> m (Maybe a)
catchMaybeIO (IO (FileID, DeviceID, FileMode, FileOffset, EpochTime)
 -> IO (Maybe (FileID, DeviceID, FileMode, FileOffset, EpochTime)))
-> IO (FileID, DeviceID, FileMode, FileOffset, EpochTime)
-> IO (Maybe (FileID, DeviceID, FileMode, FileOffset, EpochTime))
forall a b. (a -> b) -> a -> b
$ do
		FileStatus
s <- Package -> IO FileStatus
getFileStatus Package
f
		(FileID, DeviceID, FileMode, FileOffset, EpochTime)
-> IO (FileID, DeviceID, FileMode, FileOffset, EpochTime)
forall (m :: * -> *) a. Monad m => a -> m a
return (FileStatus -> FileID
fileID FileStatus
s, FileStatus -> DeviceID
deviceID FileStatus
s, FileStatus -> FileMode
fileMode FileStatus
s, FileStatus -> FileOffset
fileSize FileStatus
s, FileStatus -> EpochTime
modificationTime FileStatus
s)

-- | The cerificate files that letsencrypt will make available for a domain.
liveCertDir :: Domain -> FilePath
liveCertDir :: Package -> Package
liveCertDir Package
d = Package
"/etc/letsencrypt/live" Package -> Package -> Package
</> Package
d

certFile :: Domain -> FilePath
certFile :: Package -> Package
certFile Package
d = Package -> Package
liveCertDir Package
d Package -> Package -> Package
</> Package
"cert.pem"

privKeyFile :: Domain -> FilePath
privKeyFile :: Package -> Package
privKeyFile Package
d = Package -> Package
liveCertDir Package
d Package -> Package -> Package
</> Package
"privkey.pem"

chainFile :: Domain -> FilePath
chainFile :: Package -> Package
chainFile Package
d = Package -> Package
liveCertDir Package
d Package -> Package -> Package
</> Package
"chain.pem"

fullChainFile :: Domain -> FilePath
fullChainFile :: Package -> Package
fullChainFile Package
d = Package -> Package
liveCertDir Package
d Package -> Package -> Package
</> Package
"fullchain.pem"