diff options
author | Andrew Cady <d@jerkface.net> | 2016-01-24 16:22:20 -0500 |
---|---|---|
committer | Andrew Cady <d@jerkface.net> | 2016-01-24 19:47:07 -0500 |
commit | c4b9b52a2ebbc8d113f4829c86834dcd565cd6a3 (patch) | |
tree | d6b8f0d4c2d21970d84bcf6b011d1c5b990cdef0 | |
parent | 7f1b6358cd96d9ea204e36a5b721113635006cac (diff) |
Oops; don't use "show" with DomainName type
-rw-r--r-- | acme-certify.hs | 6 | ||||
-rw-r--r-- | src/Network/ACME.hs | 18 | ||||
-rw-r--r-- | stack.yaml | 2 |
3 files changed, 12 insertions, 14 deletions
diff --git a/acme-certify.hs b/acme-certify.hs index 5a50265..7849b65 100644 --- a/acme-certify.hs +++ b/acme-certify.hs | |||
@@ -14,7 +14,7 @@ module Main where | |||
14 | import BasePrelude | 14 | import BasePrelude |
15 | import qualified Data.ByteString.Lazy.Char8 as LC | 15 | import qualified Data.ByteString.Lazy.Char8 as LC |
16 | import Network.ACME (CSR (..), canProvision, certify, | 16 | import Network.ACME (CSR (..), canProvision, certify, |
17 | ensureWritableDir, (</>)) | 17 | ensureWritableDir, (</>), domainToString) |
18 | import Network.ACME.Encoding (Keys (..), readKeys, toStrict) | 18 | import Network.ACME.Encoding (Keys (..), readKeys, toStrict) |
19 | import Network.URI | 19 | import Network.URI |
20 | import OpenSSL | 20 | import OpenSSL |
@@ -101,10 +101,10 @@ genReq _ [] = error "genReq called with zero domains" | |||
101 | genReq (Keys priv pub) domains@(domain:_) = withOpenSSL $ do | 101 | genReq (Keys priv pub) domains@(domain:_) = withOpenSSL $ do |
102 | Just dig <- getDigestByName "SHA256" | 102 | Just dig <- getDigestByName "SHA256" |
103 | req <- newX509Req | 103 | req <- newX509Req |
104 | setSubjectName req [("CN", show domain)] | 104 | setSubjectName req [("CN", domainToString domain)] |
105 | setVersion req 0 | 105 | setVersion req 0 |
106 | setPublicKey req pub | 106 | setPublicKey req pub |
107 | void $ addExtensions req [(nidSubjectAltName, intercalate ", " (map (("DNS:" ++) . show) domains))] | 107 | void $ addExtensions req [(nidSubjectAltName, intercalate ", " (map (("DNS:" ++) . domainToString) domains))] |
108 | signX509Req req priv (Just dig) | 108 | signX509Req req priv (Just dig) |
109 | CSR . toStrict <$> writeX509ReqDER req | 109 | CSR . toStrict <$> writeX509ReqDER req |
110 | where | 110 | where |
diff --git a/src/Network/ACME.hs b/src/Network/ACME.hs index 116a291..d2216ac 100644 --- a/src/Network/ACME.hs +++ b/src/Network/ACME.hs | |||
@@ -32,7 +32,6 @@ import Network.Wreq (Response, checkStatus, defaults, | |||
32 | import qualified Network.Wreq as W | 32 | import qualified Network.Wreq as W |
33 | import qualified Network.Wreq.Session as WS | 33 | import qualified Network.Wreq.Session as WS |
34 | import OpenSSL.RSA | 34 | import OpenSSL.RSA |
35 | import Pipes | ||
36 | import System.Directory | 35 | import System.Directory |
37 | import Text.Email.Validate | 36 | import Text.Email.Validate |
38 | import Text.Domain.Validate hiding (validate) | 37 | import Text.Domain.Validate hiding (validate) |
@@ -44,15 +43,11 @@ certify directoryUrl keys optEmail terms requestDomains optChallengeDir csrData | |||
44 | runACME directoryUrl keys $ do | 43 | runACME directoryUrl keys $ do |
45 | forM_ optEmail $ register terms >=> statusReport | 44 | forM_ optEmail $ register terms >=> statusReport |
46 | 45 | ||
47 | let producer :: Producer ChallengeRequest ACME () | 46 | let performChallenge (ChallengeRequest nextUri token thumbtoken) = do |
48 | producer = for (each requestDomains) $ challengeRequest >=> statusReport >=> extractCR >=> yield | 47 | liftIO $ BC.writeFile (coerce optChallengeDir </> BC.unpack token) thumbtoken |
49 | consumer :: Consumer ChallengeRequest ACME () | ||
50 | consumer = forever $ await >>= consume1 | ||
51 | consume1 (ChallengeRequest nextUri token thumbtoken) = do | ||
52 | lift $ liftIO $ BC.writeFile (coerce optChallengeDir </> BC.unpack token) thumbtoken | ||
53 | notifyChallenge nextUri thumbtoken >>= statusReport >>= ncErrorReport | 48 | notifyChallenge nextUri thumbtoken >>= statusReport >>= ncErrorReport |
54 | 49 | ||
55 | runEffect $ producer >-> consumer | 50 | forM_ requestDomains $ challengeRequest >=> statusReport >=> extractCR >=> performChallenge |
56 | 51 | ||
57 | retrieveCert csrData >>= statusReport <&> checkCertResponse | 52 | retrieveCert csrData >>= statusReport <&> checkCertResponse |
58 | 53 | ||
@@ -71,6 +66,9 @@ ensureWritableDir file name = do | |||
71 | a </> b = a ++ "/" ++ b | 66 | a </> b = a ++ "/" ++ b |
72 | infixr 5 </> | 67 | infixr 5 </> |
73 | 68 | ||
69 | domainToString :: DomainName -> String | ||
70 | domainToString = T.unpack . decodeUtf8 . Text.Domain.Validate.toByteString | ||
71 | |||
74 | canProvision :: WritableDir -> DomainName -> IO Bool | 72 | canProvision :: WritableDir -> DomainName -> IO Bool |
75 | canProvision challengeDir domain = do | 73 | canProvision challengeDir domain = do |
76 | randomish <- fromString . show <$> getPOSIXTime | 74 | randomish <- fromString . show <$> getPOSIXTime |
@@ -79,7 +77,7 @@ canProvision challengeDir domain = do | |||
79 | relFile = ".test." ++ show randomish | 77 | relFile = ".test." ++ show randomish |
80 | 78 | ||
81 | LC.writeFile absFile randomish | 79 | LC.writeFile absFile randomish |
82 | r <- W.get $ "http://" ++ show domain </> ".well-known/acme-challenge" </> relFile | 80 | r <- W.get $ "http://" ++ domainToString domain </> ".well-known/acme-challenge" </> relFile |
83 | removeFile absFile | 81 | removeFile absFile |
84 | return $ r ^. responseBody == randomish | 82 | return $ r ^. responseBody == randomish |
85 | 83 | ||
@@ -152,7 +150,7 @@ register :: URI -> EmailAddress -> ACME (Response LC.ByteString) | |||
152 | register terms email = sendPayload _newReg (registration email (show terms)) | 150 | register terms email = sendPayload _newReg (registration email (show terms)) |
153 | 151 | ||
154 | challengeRequest :: (MonadIO m, MonadState Nonce m, MonadReader Env m) => DomainName -> m (Response LC.ByteString) | 152 | challengeRequest :: (MonadIO m, MonadState Nonce m, MonadReader Env m) => DomainName -> m (Response LC.ByteString) |
155 | challengeRequest = sendPayload _newAuthz . authz . show | 153 | challengeRequest = sendPayload _newAuthz . authz . domainToString |
156 | 154 | ||
157 | statusLine :: Response body -> String | 155 | statusLine :: Response body -> String |
158 | statusLine r = (r ^. responseStatus . statusCode . to show) ++ " " ++ r ^. responseStatus . statusMessage . to (T.unpack . decodeUtf8) | 156 | statusLine r = (r ^. responseStatus . statusCode . to show) ++ " " ++ r ^. responseStatus . statusMessage . to (T.unpack . decodeUtf8) |
@@ -12,7 +12,7 @@ packages: | |||
12 | extra-dep: true | 12 | extra-dep: true |
13 | - location: | 13 | - location: |
14 | git: git@github.com:afcady/email-validate-hs.git | 14 | git: git@github.com:afcady/email-validate-hs.git |
15 | commit: faf9c1bbb2051de314bce4c159d4dbdbc768b629 | 15 | commit: 6b3d6d232fcddb4f398f7118251a951e26f7b81b |
16 | extra-dep: true | 16 | extra-dep: true |
17 | 17 | ||
18 | # Packages to be pulled from upstream that are not in the resolver (e.g., acme-missiles-0.3) | 18 | # Packages to be pulled from upstream that are not in the resolver (e.g., acme-missiles-0.3) |