diff options
author | Andrew Cady <d@jerkface.net> | 2016-01-24 01:53:55 -0500 |
---|---|---|
committer | Andrew Cady <d@jerkface.net> | 2016-01-24 01:53:55 -0500 |
commit | fdf06576f7d21392f512492b164df899136f30d3 (patch) | |
tree | bd490b0e629d851660441eb96c34ffb8148a5436 | |
parent | 05817369d9388d2175e942af79888ec01aa4b74a (diff) |
Validate email address
-rw-r--r-- | acme-certify.cabal | 7 | ||||
-rw-r--r-- | acme.hs | 23 | ||||
-rw-r--r-- | src/Network/ACME.hs | 14 |
3 files changed, 28 insertions, 16 deletions
diff --git a/acme-certify.cabal b/acme-certify.cabal index 30fff26..3e90f42 100644 --- a/acme-certify.cabal +++ b/acme-certify.cabal | |||
@@ -16,8 +16,8 @@ library | |||
16 | exposed-modules: Network.ACME | 16 | exposed-modules: Network.ACME |
17 | build-depends: base >= 4.7 && < 5, | 17 | build-depends: base >= 4.7 && < 5, |
18 | cryptonite, aeson, bytestring, base64-bytestring, SHA, | 18 | cryptonite, aeson, bytestring, base64-bytestring, SHA, |
19 | text, HsOpenSSL, wreq, lens, lens-aeson, | 19 | text, HsOpenSSL, wreq, lens, lens-aeson, mtl, time, |
20 | mtl, time | 20 | email-validate |
21 | default-language: Haskell2010 | 21 | default-language: Haskell2010 |
22 | 22 | ||
23 | executable acme-certify | 23 | executable acme-certify |
@@ -27,7 +27,8 @@ executable acme-certify | |||
27 | build-depends: base, acme-certify, | 27 | build-depends: base, acme-certify, |
28 | cryptonite, aeson, bytestring, base64-bytestring, SHA, | 28 | cryptonite, aeson, bytestring, base64-bytestring, SHA, |
29 | text, HsOpenSSL, wreq, lens, lens-aeson, | 29 | text, HsOpenSSL, wreq, lens, lens-aeson, |
30 | optparse-applicative, directory, mtl, time, pipes | 30 | optparse-applicative, directory, mtl, time, pipes, |
31 | email-validate | ||
31 | default-language: Haskell2010 | 32 | default-language: Haskell2010 |
32 | 33 | ||
33 | -- test-suite acme-certify-test | 34 | -- test-suite acme-certify-test |
@@ -44,6 +44,7 @@ import Options.Applicative hiding (header) | |||
44 | import qualified Options.Applicative as Opt | 44 | import qualified Options.Applicative as Opt |
45 | import Pipes | 45 | import Pipes |
46 | import System.Directory | 46 | import System.Directory |
47 | import Text.Email.Validate | ||
47 | 48 | ||
48 | stagingDirectoryUrl, liveDirectoryUrl :: String | 49 | stagingDirectoryUrl, liveDirectoryUrl :: String |
49 | liveDirectoryUrl = "https://acme-v01.api.letsencrypt.org/directory" | 50 | liveDirectoryUrl = "https://acme-v01.api.letsencrypt.org/directory" |
@@ -154,15 +155,21 @@ go CmdOpts { .. } = do | |||
154 | 155 | ||
155 | Just keys <- readKeyFile privKeyFile | 156 | Just keys <- readKeyFile privKeyFile |
156 | 157 | ||
157 | doesFileExist domainCSRFile `otherwiseM` genReq domainKeyFile requestDomains >>= LC.writeFile domainCSRFile | ||
158 | |||
159 | csrData <- B.readFile domainCSRFile | ||
160 | |||
161 | ensureWritable optChallengeDir "challenge directory" | 158 | ensureWritable optChallengeDir "challenge directory" |
162 | ensureWritable domainDir "domain directory" | 159 | ensureWritable domainDir "domain directory" |
163 | 160 | ||
164 | forM_ requestDomains $ canProvision optChallengeDir >=> (`unless` error "Error: cannot provision files to web server via challenge directory") | 161 | forM_ requestDomains $ canProvision optChallengeDir >=> (`unless` error "Error: cannot provision files to web server via challenge directory") |
165 | 162 | ||
163 | csrData <- CSR . toStrict <$> genReq domainKeyFile requestDomains | ||
164 | B.writeFile domainCSRFile (coerce csrData) | ||
165 | |||
166 | let email = either (error . ("Error: invalid email address: " ++)) id . validate . fromString <$> optEmail | ||
167 | |||
168 | certify directoryUrl keys email terms requestDomains optChallengeDir csrData domainCertFile | ||
169 | |||
170 | certify :: String -> Keys -> Maybe EmailAddress -> String -> [String] -> String -> CSR -> FilePath -> IO () | ||
171 | certify directoryUrl keys optEmail terms requestDomains optChallengeDir csrData domainCertFile = | ||
172 | |||
166 | runACME directoryUrl keys $ do | 173 | runACME directoryUrl keys $ do |
167 | forM_ optEmail $ register terms >=> statusReport | 174 | forM_ optEmail $ register terms >=> statusReport |
168 | 175 | ||
@@ -178,6 +185,8 @@ go CmdOpts { .. } = do | |||
178 | 185 | ||
179 | retrieveCert csrData >>= statusReport >>= saveCert domainCertFile | 186 | retrieveCert csrData >>= statusReport >>= saveCert domainCertFile |
180 | 187 | ||
188 | newtype CSR = CSR ByteString | ||
189 | |||
181 | (</>) :: String -> String -> String | 190 | (</>) :: String -> String -> String |
182 | a </> b = a ++ "/" ++ b | 191 | a </> b = a ++ "/" ++ b |
183 | infixr 5 </> | 192 | infixr 5 </> |
@@ -234,8 +243,8 @@ saveCert domainCertFile r = | |||
234 | where | 243 | where |
235 | isSuccess n = n >= 200 && n <= 300 | 244 | isSuccess n = n >= 200 && n <= 300 |
236 | 245 | ||
237 | retrieveCert :: (MonadReader Env m, MonadState Nonce m, MonadIO m) => ByteString -> m (Response LC.ByteString) | 246 | retrieveCert :: (MonadReader Env m, MonadState Nonce m, MonadIO m) => CSR -> m (Response LC.ByteString) |
238 | retrieveCert input = sendPayload _newCert (csr input) | 247 | retrieveCert input = sendPayload _newCert (csr $ coerce input) |
239 | 248 | ||
240 | notifyChallenge :: (MonadReader Env m, MonadState Nonce m, MonadIO m) => String -> ByteString -> m (Response LC.ByteString) | 249 | notifyChallenge :: (MonadReader Env m, MonadState Nonce m, MonadIO m) => String -> ByteString -> m (Response LC.ByteString) |
241 | notifyChallenge crUri thumbtoken = sendPayload (const crUri) (challenge thumbtoken) | 250 | notifyChallenge crUri thumbtoken = sendPayload (const crUri) (challenge thumbtoken) |
@@ -263,7 +272,7 @@ getDirectory sess url = do | |||
263 | k x = r ^? responseBody . JSON.key x . _String . to T.unpack | 272 | k x = r ^? responseBody . JSON.key x . _String . to T.unpack |
264 | return $ (,) <$> (Directory <$> k "new-cert" <*> k "new-authz" <*> k "revoke-cert" <*> k "new-reg") <*> nonce | 273 | return $ (,) <$> (Directory <$> k "new-cert" <*> k "new-authz" <*> k "revoke-cert" <*> k "new-reg") <*> nonce |
265 | 274 | ||
266 | register :: String -> String -> ACME (Response LC.ByteString) | 275 | register :: String -> EmailAddress -> ACME (Response LC.ByteString) |
267 | register terms email = sendPayload _newReg (registration email terms) | 276 | register terms email = sendPayload _newReg (registration email terms) |
268 | 277 | ||
269 | challengeRequest :: (MonadIO m, MonadState Nonce m, MonadReader Env m) => String -> m (Response LC.ByteString) | 278 | challengeRequest :: (MonadIO m, MonadState Nonce m, MonadReader Env m) => String -> m (Response LC.ByteString) |
diff --git a/src/Network/ACME.hs b/src/Network/ACME.hs index ccd0a8c..d6a0f47 100644 --- a/src/Network/ACME.hs +++ b/src/Network/ACME.hs | |||
@@ -1,6 +1,6 @@ | |||
1 | {-# LANGUAGE OverloadedStrings #-} | 1 | {-# LANGUAGE OverloadedStrings #-} |
2 | {-# LANGUAGE RecordWildCards #-} | 2 | {-# LANGUAGE RecordWildCards #-} |
3 | {-# LANGUAGE ScopedTypeVariables #-} | 3 | {-# LANGUAGE ScopedTypeVariables #-} |
4 | 4 | ||
5 | module Network.ACME ( | 5 | module Network.ACME ( |
6 | Keys(..), | 6 | Keys(..), |
@@ -32,6 +32,8 @@ import OpenSSL.EVP.PKey | |||
32 | import OpenSSL.EVP.Sign | 32 | import OpenSSL.EVP.Sign |
33 | import OpenSSL.PEM | 33 | import OpenSSL.PEM |
34 | import OpenSSL.RSA | 34 | import OpenSSL.RSA |
35 | import Text.Email.Validate | ||
36 | import qualified Data.Text as T | ||
35 | 37 | ||
36 | data Keys = Keys RSAKeyPair RSAPubKey | 38 | data Keys = Keys RSAKeyPair RSAPubKey |
37 | readKeys :: String -> IO (Maybe Keys) | 39 | readKeys :: String -> IO (Maybe Keys) |
@@ -69,7 +71,7 @@ header key nonce = (toStrict . encode) | |||
69 | (Header "RS256" (JWK (rsaE key) "RSA" (rsaN key)) (Just nonce)) | 71 | (Header "RS256" (JWK (rsaE key) "RSA" (rsaN key)) (Just nonce)) |
70 | 72 | ||
71 | -- | Registration payload to sign with user key. | 73 | -- | Registration payload to sign with user key. |
72 | registration :: String -> String -> ByteString | 74 | registration :: EmailAddress -> String -> ByteString |
73 | registration emailAddr terms = (b64 . toStrict . encode) (Reg emailAddr terms) | 75 | registration emailAddr terms = (b64 . toStrict . encode) (Reg emailAddr terms) |
74 | 76 | ||
75 | -- | Challenge request payload to sign with user key. | 77 | -- | Challenge request payload to sign with user key. |
@@ -125,7 +127,7 @@ instance ToJSON JWK where | |||
125 | ] | 127 | ] |
126 | 128 | ||
127 | data Reg = Reg | 129 | data Reg = Reg |
128 | { rMail :: String | 130 | { rMail :: EmailAddress |
129 | , rAgreement :: String | 131 | , rAgreement :: String |
130 | } | 132 | } |
131 | deriving Show | 133 | deriving Show |
@@ -133,7 +135,7 @@ data Reg = Reg | |||
133 | instance ToJSON Reg where | 135 | instance ToJSON Reg where |
134 | toJSON Reg{..} = object | 136 | toJSON Reg{..} = object |
135 | [ "resource" .= ("new-reg" :: String) | 137 | [ "resource" .= ("new-reg" :: String) |
136 | , "contact" .= ["mailto:" ++ rMail] | 138 | , "contact" .= ["mailto:" ++ (T.unpack . decodeUtf8 . toByteString $ rMail)] |
137 | , "agreement" .= rAgreement | 139 | , "agreement" .= rAgreement |
138 | ] | 140 | ] |
139 | 141 | ||