diff options
author | Andrew Cady <d@jerkface.net> | 2016-04-08 20:42:17 -0400 |
---|---|---|
committer | Andrew Cady <d@jerkface.net> | 2016-04-08 21:30:42 -0400 |
commit | a5da398526bc5c3bb2f4dade1235e458f3dab31c (patch) | |
tree | 31afe595eaa1b7cf0d726f7894d4f185bb775fa9 | |
parent | 6db17bc0e35641b9b039ee5498eb62c7c585ae2b (diff) |
Change type of HttpProvisioner
Now it is parameterized on domain name. This will allow to provision to
a different directory for each (sub)domain.
-rw-r--r-- | acme-certify.hs | 5 | ||||
-rw-r--r-- | src/Network/ACME.hs | 21 |
2 files changed, 13 insertions, 13 deletions
diff --git a/acme-certify.hs b/acme-certify.hs index 2b666af..4fa16a0 100644 --- a/acme-certify.hs +++ b/acme-certify.hs | |||
@@ -122,14 +122,15 @@ go CmdOpts { .. } = do | |||
122 | Just keys <- getOrCreateKeys privKeyFile | 122 | Just keys <- getOrCreateKeys privKeyFile |
123 | 123 | ||
124 | unless optSkipProvisionCheck $ | 124 | unless optSkipProvisionCheck $ |
125 | forM_ requestDomains $ canProvision challengeDir >=> | 125 | forM_ requestDomains $ canProvision (const $ Just challengeDir) >=> |
126 | (`unless` error "Error: cannot provision files to web server via challenge directory") | 126 | (`unless` error "Error: cannot provision files to web server via challenge directory") |
127 | 127 | ||
128 | certReq <- genReq domainKeys requestDomains | 128 | certReq <- genReq domainKeys requestDomains |
129 | 129 | ||
130 | dh <- if optSkipDH then return Nothing else Just <$> getOrCreateDH domainDhFile | 130 | dh <- if optSkipDH then return Nothing else Just <$> getOrCreateDH domainDhFile |
131 | 131 | ||
132 | certificate <- certify directoryUrl keys ((,) terms <$> email) (fileProvisioner challengeDir) certReq | 132 | let provision = fileProvisioner (const $ Just challengeDir) |
133 | certificate <- certify directoryUrl keys ((,) terms <$> email) provision certReq | ||
133 | 134 | ||
134 | let save = saveCertificate issuerCert dh domainKeys domainCombinedFile domainCertFile | 135 | let save = saveCertificate issuerCert dh domainKeys domainCombinedFile domainCertFile |
135 | mapM save certificate | 136 | mapM save certificate |
diff --git a/src/Network/ACME.hs b/src/Network/ACME.hs index 2c58bac..2312389 100644 --- a/src/Network/ACME.hs +++ b/src/Network/ACME.hs | |||
@@ -2,6 +2,7 @@ | |||
2 | {-# LANGUAGE MultiParamTypeClasses #-} | 2 | {-# LANGUAGE MultiParamTypeClasses #-} |
3 | {-# LANGUAGE OverloadedStrings #-} | 3 | {-# LANGUAGE OverloadedStrings #-} |
4 | {-# LANGUAGE ScopedTypeVariables #-} | 4 | {-# LANGUAGE ScopedTypeVariables #-} |
5 | {-# LANGUAGE ViewPatterns #-} | ||
5 | 6 | ||
6 | -------------------------------------------------------------------------------- | 7 | -------------------------------------------------------------------------------- |
7 | -- | Get a certificate from Let's Encrypt using the ACME protocol. | 8 | -- | Get a certificate from Let's Encrypt using the ACME protocol. |
@@ -57,7 +58,7 @@ certify directoryUrl keys reg provision certReq = | |||
57 | forM_ reg $ uncurry register >=> statusReport | 58 | forM_ reg $ uncurry register >=> statusReport |
58 | 59 | ||
59 | let performChallenge domain (ChallengeRequest nextUri token thumbtoken) = do | 60 | let performChallenge domain (ChallengeRequest nextUri token thumbtoken) = do |
60 | liftResourceT $ provision (acmeChallengeURI domain token) thumbtoken | 61 | liftResourceT $ provision domain token thumbtoken |
61 | notifyChallenge nextUri thumbtoken >>= statusReport >>= ncErrorReport | 62 | notifyChallenge nextUri thumbtoken >>= statusReport >>= ncErrorReport |
62 | 63 | ||
63 | cr dom = challengeRequest dom >>= statusReport >>= extractCR >>= performChallenge dom | 64 | cr dom = challengeRequest dom >>= statusReport >>= extractCR >>= performChallenge dom |
@@ -83,15 +84,15 @@ pollResults (link:links) = do | |||
83 | 84 | ||
84 | -- Provisioner callback | 85 | -- Provisioner callback |
85 | 86 | ||
86 | type HttpProvisioner = URI -> ByteString -> ResIO () | 87 | type HttpProvisioner = DomainName -> ByteString -> ByteString -> ResIO () |
87 | fileProvisioner :: WritableDir -> HttpProvisioner | 88 | fileProvisioner :: (DomainName -> Maybe WritableDir) -> HttpProvisioner |
88 | fileProvisioner challengeDir uri thumbtoken = do | 89 | fileProvisioner challengeDir (challengeDir -> Just dir) tok thumbtoken = do |
89 | void $ allocate (return f) removeFile | 90 | void $ allocate (return f) removeFile |
90 | liftIO $ BC.writeFile f thumbtoken | 91 | liftIO $ BC.writeFile f thumbtoken |
91 | 92 | ||
92 | where | 93 | where |
93 | f = (coerce challengeDir </>) . takeWhileEnd (/= '/') . uriPath $ uri | 94 | f = (coerce dir </>) (T.unpack $ decodeUtf8 tok) |
94 | takeWhileEnd s = reverse . takeWhile s . reverse | 95 | fileProvisioner _ dom _ _ = liftIO $ fail $ "fileProvisioner: no writable directory for domain: " ++ show dom |
95 | 96 | ||
96 | newtype WritableDir = WritableDir String | 97 | newtype WritableDir = WritableDir String |
97 | ensureWritableDir :: FilePath -> String -> IO WritableDir | 98 | ensureWritableDir :: FilePath -> String -> IO WritableDir |
@@ -100,15 +101,13 @@ ensureWritableDir file name = do | |||
100 | return $ WritableDir file | 101 | return $ WritableDir file |
101 | where e n = error $ "Error: " ++ n ++ " is not writable" | 102 | where e n = error $ "Error: " ++ n ++ " is not writable" |
102 | 103 | ||
103 | canProvision :: WritableDir -> DomainName -> IO Bool | 104 | canProvision :: (DomainName -> Maybe WritableDir) -> DomainName -> IO Bool |
104 | canProvision challengeDir domain = do | 105 | canProvision challengeDir domain = do |
105 | token <- (".test." ++) . show <$> getPOSIXTime | 106 | token <- (".test." ++) . show <$> getPOSIXTime |
106 | 107 | ||
107 | let uri = acmeChallengeURI domain (fromString token) | ||
108 | |||
109 | r <- runResourceT $ do | 108 | r <- runResourceT $ do |
110 | fileProvisioner challengeDir uri (fromString token) | 109 | fileProvisioner challengeDir domain (fromString token) (fromString token) |
111 | liftIO $ W.get (show uri) | 110 | liftIO $ W.get $ show $ acmeChallengeURI domain (fromString token) |
112 | return $ r ^. responseBody == fromString token | 111 | return $ r ^. responseBody == fromString token |
113 | 112 | ||
114 | -- The ACME monad | 113 | -- The ACME monad |