diff options
author | Andrew Cady <d@jerkface.net> | 2016-01-21 17:00:00 -0500 |
---|---|---|
committer | Andrew Cady <d@jerkface.net> | 2016-01-21 17:14:38 -0500 |
commit | c8f622463afa168dba3183bd0a025ef17965cffb (patch) | |
tree | c8fe57ebcf1e192f6edd1b3d7200795bb9c522f4 | |
parent | 56fe46ef1d40d6da12b52728ee3a8263eba2f7a7 (diff) |
Fail earlier
Checks that the output dirs are writable and that writing to the
challenge dir results in a file hosted at the proper URL.
I once had a linksys router that would forward incoming TCP connections
to a machine on my LAN, but would not route connections from that
machine to itself over the public IP. This check would break on such
a configuration; I suppose it might be made optional.
-rw-r--r-- | acme-encrypt.cabal | 2 | ||||
-rw-r--r-- | acme.hs | 50 |
2 files changed, 37 insertions, 15 deletions
diff --git a/acme-encrypt.cabal b/acme-encrypt.cabal index 66b80ec..229fe77 100644 --- a/acme-encrypt.cabal +++ b/acme-encrypt.cabal | |||
@@ -24,7 +24,7 @@ executable acme-encrypt-exe | |||
24 | build-depends: base, | 24 | build-depends: base, |
25 | cryptonite, aeson, bytestring, base64-bytestring, SHA, | 25 | cryptonite, aeson, bytestring, base64-bytestring, SHA, |
26 | text, HsOpenSSL, process, wreq, lens, lens-aeson, | 26 | text, HsOpenSSL, process, wreq, lens, lens-aeson, |
27 | optparse-applicative, directory, mtl, process-extras | 27 | optparse-applicative, directory, mtl, process-extras, time |
28 | -- , acme-encrypt | 28 | -- , acme-encrypt |
29 | default-language: Haskell2010 | 29 | default-language: Haskell2010 |
30 | 30 | ||
@@ -28,12 +28,15 @@ import qualified Data.ByteString.Lazy.Char8 as LC | |||
28 | import Data.Coerce | 28 | import Data.Coerce |
29 | import Data.Digest.Pure.SHA (bytestringDigest, sha256) | 29 | import Data.Digest.Pure.SHA (bytestringDigest, sha256) |
30 | import Data.Maybe | 30 | import Data.Maybe |
31 | import Data.String (fromString) | ||
31 | import qualified Data.Text as T | 32 | import qualified Data.Text as T |
32 | import Data.Text.Encoding (decodeUtf8, encodeUtf8) | 33 | import Data.Text.Encoding (decodeUtf8, encodeUtf8) |
34 | import Data.Time.Clock.POSIX (getPOSIXTime) | ||
33 | import Network.Wreq (Response, checkStatus, defaults, | 35 | import Network.Wreq (Response, checkStatus, defaults, |
34 | responseBody, responseHeader, | 36 | responseBody, responseHeader, |
35 | responseStatus, statusCode, | 37 | responseStatus, statusCode, |
36 | statusMessage) | 38 | statusMessage) |
39 | import qualified Network.Wreq as W | ||
37 | import qualified Network.Wreq.Session as WS | 40 | import qualified Network.Wreq.Session as WS |
38 | import OpenSSL | 41 | import OpenSSL |
39 | import OpenSSL.EVP.Digest | 42 | import OpenSSL.EVP.Digest |
@@ -129,42 +132,61 @@ readKeys privKeyFile = do | |||
129 | data ChallengeRequest = ChallengeRequest { crUri :: String, crToken :: ByteString, crThumbToken :: ByteString } | 132 | data ChallengeRequest = ChallengeRequest { crUri :: String, crToken :: ByteString, crThumbToken :: ByteString } |
130 | 133 | ||
131 | go :: CmdOpts -> IO () | 134 | go :: CmdOpts -> IO () |
132 | go (CmdOpts privKeyFile domain challengeDir altDomainDir email termOverride staging) = do | 135 | go CmdOpts{..} = do |
133 | let terms = fromMaybe defaultTerms termOverride | 136 | let terms = fromMaybe defaultTerms optTerms |
134 | directoryUrl = if staging then stagingDirectoryUrl else liveDirectoryUrl | 137 | directoryUrl = if optStaging then stagingDirectoryUrl else liveDirectoryUrl |
135 | domainKeyFile = domainDir </> "rsa.key" | 138 | domainKeyFile = domainDir </> "rsa.key" |
136 | domainCSRFile = domainDir </> "csr.der" | 139 | domainCSRFile = domainDir </> "csr.der" |
137 | domainCertFile = domainDir </> "cert.der" | 140 | domainCertFile = domainDir </> "cert.der" |
138 | domainDir = fromMaybe domain altDomainDir | 141 | domainDir = fromMaybe optDomain optDomainDir |
142 | privKeyFile = optKeyFile | ||
139 | 143 | ||
140 | doesFileExist privKeyFile >>= flip unless (genKey privKeyFile) | 144 | doesFileExist privKeyFile >>= flip unless (genKey privKeyFile) |
141 | 145 | ||
142 | doesDirectoryExist domain >>= flip unless (createDirectory domainDir) | 146 | doesDirectoryExist optDomain >>= flip unless (createDirectory domainDir) |
143 | doesFileExist domainKeyFile >>= flip unless (genKey domainKeyFile) | 147 | doesFileExist domainKeyFile >>= flip unless (genKey domainKeyFile) |
144 | 148 | ||
145 | keys <- readKeys privKeyFile | 149 | keys <- readKeys privKeyFile |
146 | 150 | ||
147 | doesFileExist domainCSRFile >>= flip unless (genReq domainKeyFile domain >>= B.writeFile domainCSRFile) | 151 | doesFileExist domainCSRFile >>= flip unless (genReq domainKeyFile optDomain >>= B.writeFile domainCSRFile) |
148 | 152 | ||
149 | csrData <- B.readFile domainCSRFile | 153 | csrData <- B.readFile domainCSRFile |
150 | 154 | ||
151 | -- TODO: verify that challengeDir is writable before continuing. | 155 | ensureWritable optChallengeDir "challenge directory" |
156 | ensureWritable domainDir "domain directory" | ||
152 | 157 | ||
153 | runACME directoryUrl keys $ do | 158 | canProvision optDomain optChallengeDir >>= flip unless (error "Error: cannot provision files to web server via challenge directory") |
154 | forM_ email $ register terms >=> statusReport | ||
155 | 159 | ||
156 | (ChallengeRequest nextUri token thumbtoken) <- challengeRequest domain >>= statusReport >>= extractCR | 160 | runACME directoryUrl keys $ do |
161 | forM_ optEmail $ register terms >=> statusReport | ||
157 | 162 | ||
158 | liftIO $ BC.writeFile (challengeDir </> BC.unpack token) thumbtoken | 163 | (ChallengeRequest nextUri token thumbtoken) <- challengeRequest optDomain >>= statusReport >>= extractCR |
159 | 164 | ||
160 | -- TODO: first hit the local server to test whether this is valid | 165 | liftIO $ BC.writeFile (optChallengeDir </> BC.unpack token) thumbtoken |
161 | 166 | ||
162 | notifyChallenge nextUri thumbtoken >>= statusReport >>= ncErrorReport | 167 | notifyChallenge nextUri thumbtoken >>= statusReport >>= ncErrorReport |
163 | 168 | ||
164 | retrieveCert csrData >>= statusReport >>= saveCert domainCertFile | 169 | retrieveCert csrData >>= statusReport >>= saveCert domainCertFile |
165 | 170 | ||
166 | where | 171 | (</>) :: String -> String -> String |
167 | a </> b = a ++ "/" ++ b | 172 | a </> b = a ++ "/" ++ b |
173 | |||
174 | canProvision :: String -> FilePath -> IO Bool | ||
175 | canProvision domain challengeDir = do | ||
176 | randomish <- fromString . show <$> getPOSIXTime | ||
177 | |||
178 | let absFile = challengeDir </> relFile | ||
179 | relFile = ".test." ++ show randomish | ||
180 | |||
181 | LC.writeFile absFile randomish | ||
182 | r <- W.get $ "http://" ++ domain </> ".well-known/acme-challenge" </> relFile | ||
183 | removeFile absFile | ||
184 | return $ r ^. responseBody == randomish | ||
185 | |||
186 | |||
187 | ensureWritable :: FilePath -> String -> IO () | ||
188 | ensureWritable file name = (writable <$> getPermissions file) >>= flip unless (err name) | ||
189 | where err n = error $ "Error: " ++ n ++ " is not writable" | ||
168 | 190 | ||
169 | extractCR :: MonadReader Env m => Response LC.ByteString -> m ChallengeRequest | 191 | extractCR :: MonadReader Env m => Response LC.ByteString -> m ChallengeRequest |
170 | extractCR r = do | 192 | extractCR r = do |