diff options
author | Andrew Cady <d@jerkface.net> | 2016-01-20 12:58:12 -0500 |
---|---|---|
committer | Andrew Cady <d@jerkface.net> | 2016-01-20 12:58:12 -0500 |
commit | 455eca5425738ebdba00c843d921c58af1689584 (patch) | |
tree | 0301ee51bdb0ca108179919a5b12380b9631834b | |
parent | 1d1190635c6de041eb9490d530cd32cad31c25e1 (diff) |
Minor code reorg
"register" function was tested in ghci.
-rw-r--r-- | acme.hs | 38 |
1 files changed, 25 insertions, 13 deletions
@@ -63,27 +63,28 @@ cmdopts = CmdOpts <$> strOption (long "key" <> metavar "FILE" <> help "filename | |||
63 | genKey :: String -> IO () | 63 | genKey :: String -> IO () |
64 | genKey privKeyFile = readProcess "openssl" (words "genrsa 4096 -out" ++ [privKeyFile]) "" >>= writeFile privKeyFile | 64 | genKey privKeyFile = readProcess "openssl" (words "genrsa 4096 -out" ++ [privKeyFile]) "" >>= writeFile privKeyFile |
65 | 65 | ||
66 | data Keys = Keys SomeKeyPair RSAPubKey | ||
67 | readKeys :: String -> IO Keys | ||
68 | readKeys privKeyFile = do | ||
69 | priv <- readFile privKeyFile >>= flip readPrivateKey PwTTY | ||
70 | pub <- rsaCopyPublic $ fromMaybe (error "Error: failed to parse RSA key.") (toKeyPair priv :: Maybe RSAKeyPair) | ||
71 | return $ Keys priv pub | ||
72 | |||
66 | go :: CmdOpts -> IO () | 73 | go :: CmdOpts -> IO () |
67 | go (CmdOpts privKeyFile domain email termOverride) = do | 74 | go (CmdOpts privKeyFile domain email termOverride) = do |
68 | |||
69 | doesFileExist privKeyFile >>= flip unless (genKey privKeyFile) | 75 | doesFileExist privKeyFile >>= flip unless (genKey privKeyFile) |
70 | 76 | keys@(Keys _ pub) <- readKeys privKeyFile | |
71 | priv <- readFile privKeyFile >>= flip readPrivateKey PwTTY | ||
72 | mbPub <- maybe (return Nothing) (rsaCopyPublic >=> return . Just) | ||
73 | (toKeyPair priv :: Maybe RSAKeyPair) | ||
74 | 77 | ||
75 | let terms = fromMaybe defaultTerms termOverride | 78 | let terms = fromMaybe defaultTerms termOverride |
76 | pub :: RSAPubKey | ||
77 | pub = fromMaybe (error "Error: failed to parse RSA key.") mbPub | ||
78 | 79 | ||
79 | Just nonce_ <- getNonce | 80 | Just nonce_ <- getNonce |
80 | 81 | ||
81 | -- Create user account | 82 | -- Create user account |
82 | forM_ email $ \m -> | 83 | forM_ email $ \m -> |
83 | LB.writeFile "registration.body" =<< signPayload priv pub nonce_ (registration m terms) | 84 | LB.writeFile "registration.body" =<< signPayload keys nonce_ (registration m terms) |
84 | 85 | ||
85 | -- Obtain a challenge | 86 | -- Obtain a challenge |
86 | LB.writeFile "challenge-request.body" =<< signPayload priv pub nonce_ (authz domain) | 87 | LB.writeFile "challenge-request.body" =<< signPayload keys nonce_ (authz domain) |
87 | 88 | ||
88 | -- Answser the challenge | 89 | -- Answser the challenge |
89 | let thumb = thumbprint (JWK (rsaE pub) "RSA" (rsaN pub)) | 90 | let thumb = thumbprint (JWK (rsaE pub) "RSA" (rsaN pub)) |
@@ -95,14 +96,17 @@ go (CmdOpts privKeyFile domain email termOverride) = do | |||
95 | putStrLn ("With content:\n" ++ BC.unpack thumbtoken) | 96 | putStrLn ("With content:\n" ++ BC.unpack thumbtoken) |
96 | 97 | ||
97 | -- Notify Let's Encrypt we answsered the challenge | 98 | -- Notify Let's Encrypt we answsered the challenge |
98 | LB.writeFile "challenge-response.body" =<< signPayload priv pub nonce_ (challenge thumbtoken) | 99 | LB.writeFile "challenge-response.body" =<< signPayload keys nonce_ (challenge thumbtoken) |
99 | 100 | ||
100 | -- Wait for challenge validation Send a CSR and get a certificate | 101 | -- Wait for challenge validation Send a CSR and get a certificate |
101 | csr_ <- B.readFile (domain ++ ".csr.der") | 102 | csr_ <- B.readFile (domain ++ ".csr.der") |
102 | LB.writeFile "csr-request.body" =<< signPayload priv pub nonce_ (csr csr_) | 103 | LB.writeFile "csr-request.body" =<< signPayload keys nonce_ (csr csr_) |
103 | 104 | ||
104 | return () | 105 | return () |
105 | 106 | ||
107 | register :: Keys -> String -> String -> IO (Response LC.ByteString) | ||
108 | register keys email terms = sendPayload keys _newReg (registration email terms) | ||
109 | |||
106 | data Directory = Directory { | 110 | data Directory = Directory { |
107 | _newCert :: String, | 111 | _newCert :: String, |
108 | _newAuthz :: String, | 112 | _newAuthz :: String, |
@@ -123,13 +127,21 @@ getNonce = fmap _nonce <$> getDirectory directoryUrl | |||
123 | 127 | ||
124 | -------------------------------------------------------------------------------- | 128 | -------------------------------------------------------------------------------- |
125 | -- | Sign and write a payload to a file with a nonce-protected header. | 129 | -- | Sign and write a payload to a file with a nonce-protected header. |
126 | signPayload :: (RSAKey k, KeyPair kp) => kp -> k -> String -> ByteString -> IO LC.ByteString | 130 | signPayload :: Keys -> String -> ByteString -> IO LC.ByteString |
127 | signPayload priv pub nonce_ payload = withOpenSSL $ do | 131 | signPayload (Keys priv pub) nonce_ payload = withOpenSSL $ do |
128 | let protected = b64 (header pub nonce_) | 132 | let protected = b64 (header pub nonce_) |
129 | Just dig <- getDigestByName "SHA256" | 133 | Just dig <- getDigestByName "SHA256" |
130 | sig <- b64 <$> signBS dig priv (B.concat [protected, ".", payload]) | 134 | sig <- b64 <$> signBS dig priv (B.concat [protected, ".", payload]) |
131 | return $ buildBody pub protected payload sig | 135 | return $ buildBody pub protected payload sig |
132 | 136 | ||
137 | sendPayload :: Keys -> (Directory -> String) -> ByteString -> IO (Response LC.ByteString) | ||
138 | sendPayload keys reqType payload = do | ||
139 | dir <- fromMaybe (error "Error fetching directory") <$> getDirectory directoryUrl | ||
140 | let nonce = _nonce dir | ||
141 | url = reqType dir | ||
142 | signed <- signPayload keys nonce payload | ||
143 | post url signed | ||
144 | |||
133 | buildBody :: RSAKey k => k -> ByteString -> ByteString -> ByteString -> LC.ByteString | 145 | buildBody :: RSAKey k => k -> ByteString -> ByteString -> ByteString -> LC.ByteString |
134 | buildBody key protected payload sig = encode (Request (header' key) protected payload sig) | 146 | buildBody key protected payload sig = encode (Request (header' key) protected payload sig) |
135 | 147 | ||