diff options
author | Andrew Cady <d@jerkface.net> | 2016-04-08 23:50:58 -0400 |
---|---|---|
committer | Andrew Cady <d@jerkface.net> | 2016-04-08 23:50:58 -0400 |
commit | b8493e549fe472021a545b665e49fff779fb4241 (patch) | |
tree | ffce62d971202750625992062ad174b56c36d404 | |
parent | 76cd49c6568bcf909f6ec31bfb8d6ed320e546bb (diff) |
More renames/cleanup related to HttpProvisioner
-rw-r--r-- | acme-certify.hs | 12 | ||||
-rw-r--r-- | src/Network/ACME.hs | 36 |
2 files changed, 25 insertions, 23 deletions
diff --git a/acme-certify.hs b/acme-certify.hs index 84b7f85..c0116ea 100644 --- a/acme-certify.hs +++ b/acme-certify.hs | |||
@@ -13,9 +13,9 @@ | |||
13 | module Main where | 13 | module Main where |
14 | 14 | ||
15 | import BasePrelude | 15 | import BasePrelude |
16 | import Network.ACME (HttpProvisioner', Keys (..), | 16 | import Network.ACME (HttpProvisioner, Keys (..), |
17 | canProvision, certify, | 17 | canProvisionDir, certify, |
18 | dispatchProvisioner', ensureWritableDir, | 18 | dispatchProvisioner, ensureWritableDir, |
19 | genReq, provisionViaFile, readKeys, | 19 | genReq, provisionViaFile, readKeys, |
20 | (</>)) | 20 | (</>)) |
21 | import Network.ACME.Issuer (letsEncryptX1CrossSigned) | 21 | import Network.ACME.Issuer (letsEncryptX1CrossSigned) |
@@ -59,7 +59,7 @@ data CmdOpts = CmdOpts { | |||
59 | } | 59 | } |
60 | 60 | ||
61 | data AcmeCertRequest = AcmeCertRequest { | 61 | data AcmeCertRequest = AcmeCertRequest { |
62 | acrDomains :: [(DomainName, HttpProvisioner')], | 62 | acrDomains :: [(DomainName, HttpProvisioner)], |
63 | acrSkipDH :: Bool, | 63 | acrSkipDH :: Bool, |
64 | acrCertificateDir :: FilePath, | 64 | acrCertificateDir :: FilePath, |
65 | acrUserKeys :: Keys | 65 | acrUserKeys :: Keys |
@@ -127,7 +127,7 @@ go CmdOpts { .. } = do | |||
127 | Just keys <- getOrCreateKeys privKeyFile | 127 | Just keys <- getOrCreateKeys privKeyFile |
128 | 128 | ||
129 | unless optSkipProvisionCheck $ | 129 | unless optSkipProvisionCheck $ |
130 | forM_ requestDomains $ canProvision (const $ Just challengeDir) >=> | 130 | forM_ requestDomains $ canProvisionDir challengeDir >=> |
131 | (`unless` error "Error: cannot provision files to web server via challenge directory") | 131 | (`unless` error "Error: cannot provision files to web server via challenge directory") |
132 | 132 | ||
133 | let req = AcmeCertRequest {..} | 133 | let req = AcmeCertRequest {..} |
@@ -140,7 +140,7 @@ go CmdOpts { .. } = do | |||
140 | go' :: URI -> URI -> Maybe EmailAddress -> X509 -> AcmeCertRequest -> IO (Either String ()) | 140 | go' :: URI -> URI -> Maybe EmailAddress -> X509 -> AcmeCertRequest -> IO (Either String ()) |
141 | go' directoryUrl terms email issuerCert acr@AcmeCertRequest{..} = do | 141 | go' directoryUrl terms email issuerCert acr@AcmeCertRequest{..} = do |
142 | let domainKeyFile = acrCertificateDir </> "rsa.key" | 142 | let domainKeyFile = acrCertificateDir </> "rsa.key" |
143 | let provision = dispatchProvisioner' acrDomains | 143 | let provision = dispatchProvisioner acrDomains |
144 | 144 | ||
145 | Just domainKeys <- getOrCreateKeys domainKeyFile | 145 | Just domainKeys <- getOrCreateKeys domainKeyFile |
146 | dh <- saveDhParams acr | 146 | dh <- saveDhParams acr |
diff --git a/src/Network/ACME.hs b/src/Network/ACME.hs index c7e1535..120248c 100644 --- a/src/Network/ACME.hs +++ b/src/Network/ACME.hs | |||
@@ -52,7 +52,7 @@ import Text.Email.Validate | |||
52 | 52 | ||
53 | -- The `certify` function | 53 | -- The `certify` function |
54 | 54 | ||
55 | certify :: URI -> Keys -> Maybe (URI, EmailAddress) -> HttpProvisioner -> CSR -> IO (Either String X509) | 55 | certify :: URI -> Keys -> Maybe (URI, EmailAddress) -> DispatchHttpProvisioner -> CSR -> IO (Either String X509) |
56 | certify directoryUrl keys reg provision certReq = | 56 | certify directoryUrl keys reg provision certReq = |
57 | (mapM readDerX509 =<<) $ runACME directoryUrl keys $ do | 57 | (mapM readDerX509 =<<) $ runACME directoryUrl keys $ do |
58 | forM_ reg $ uncurry register >=> statusReport | 58 | forM_ reg $ uncurry register >=> statusReport |
@@ -84,21 +84,21 @@ pollResults (link:links) = do | |||
84 | 84 | ||
85 | -- Provisioner callback | 85 | -- Provisioner callback |
86 | 86 | ||
87 | type HttpProvisioner = DomainName -> ByteString -> ByteString -> ResIO () | 87 | type DispatchHttpProvisioner = DomainName -> ByteString -> ByteString -> ResIO () |
88 | fileProvisioner :: (DomainName -> Maybe WritableDir) -> HttpProvisioner | 88 | fileProvisioner :: WritableDir -> DispatchHttpProvisioner |
89 | fileProvisioner challengeDir (challengeDir -> Just dir) tok thumbtoken = provisionViaFile dir tok thumbtoken | 89 | fileProvisioner challengeDir _ = provisionViaFile challengeDir |
90 | fileProvisioner _ dom _ _ = liftIO $ fail $ "fileProvisioner: no writable directory for domain: " ++ show dom | ||
91 | 90 | ||
92 | type HttpProvisioner' = ByteString -> ByteString -> ResIO () | 91 | type HttpProvisioner = ByteString -> ByteString -> ResIO () |
93 | dispatchProvisioner :: (DomainName -> Maybe HttpProvisioner') -> HttpProvisioner | ||
94 | dispatchProvisioner dispatch (dispatch -> Just provision) = provision | ||
95 | dispatchProvisioner _ dom = const . const . liftIO $ fail errmsg | ||
96 | where errmsg = "No means specified to provision files over HTTP for domain: " ++ show dom | ||
97 | 92 | ||
98 | dispatchProvisioner' :: [(DomainName, HttpProvisioner')] -> HttpProvisioner | 93 | dispatchProvisioner :: [(DomainName, HttpProvisioner)] -> DispatchHttpProvisioner |
99 | dispatchProvisioner' xs = dispatchProvisioner (`lookup` xs) | 94 | dispatchProvisioner xs = dispatch (`lookup` xs) |
95 | where | ||
96 | dispatch :: (DomainName -> Maybe HttpProvisioner) -> DispatchHttpProvisioner | ||
97 | dispatch dispatchFunc (dispatchFunc -> Just provision) = provision | ||
98 | dispatch _ dom = const . const . liftIO $ fail errmsg | ||
99 | where errmsg = "No means specified to provision files over HTTP for domain: " ++ show dom | ||
100 | 100 | ||
101 | provisionViaFile :: WritableDir -> HttpProvisioner' | 101 | provisionViaFile :: WritableDir -> HttpProvisioner |
102 | provisionViaFile dir tok thumbtoken = do | 102 | provisionViaFile dir tok thumbtoken = do |
103 | void $ allocate (return f) removeFile | 103 | void $ allocate (return f) removeFile |
104 | liftIO $ BC.writeFile f thumbtoken | 104 | liftIO $ BC.writeFile f thumbtoken |
@@ -113,15 +113,17 @@ ensureWritableDir file name = do | |||
113 | return $ WritableDir file | 113 | return $ WritableDir file |
114 | where e n = error $ "Error: " ++ n ++ " is not writable" | 114 | where e n = error $ "Error: " ++ n ++ " is not writable" |
115 | 115 | ||
116 | canProvision :: (DomainName -> Maybe WritableDir) -> DomainName -> IO Bool | 116 | canProvision :: DomainName -> HttpProvisioner -> IO Bool |
117 | canProvision challengeDir domain = do | 117 | canProvision domain provision = do |
118 | token <- (".test." ++) . show <$> getPOSIXTime | 118 | token <- (".test." ++) . show <$> getPOSIXTime |
119 | |||
120 | r <- runResourceT $ do | 119 | r <- runResourceT $ do |
121 | fileProvisioner challengeDir domain (fromString token) (fromString token) | 120 | provision (fromString token) (fromString token) |
122 | liftIO $ W.get $ show $ acmeChallengeURI domain (fromString token) | 121 | liftIO $ W.get $ show $ acmeChallengeURI domain (fromString token) |
123 | return $ r ^. responseBody == fromString token | 122 | return $ r ^. responseBody == fromString token |
124 | 123 | ||
124 | canProvisionDir :: WritableDir -> DomainName -> IO Bool | ||
125 | canProvisionDir challengeDir domain = canProvision domain (provisionViaFile challengeDir) | ||
126 | |||
125 | -- The ACME monad | 127 | -- The ACME monad |
126 | 128 | ||
127 | data Directory = Directory { | 129 | data Directory = Directory { |