diff options
author | Andrew Cady <d@jerkface.net> | 2016-01-24 02:18:47 -0500 |
---|---|---|
committer | Andrew Cady <d@jerkface.net> | 2016-01-24 02:18:47 -0500 |
commit | 0a77e9cb30c12a516993013b7ab5f4272bea94f9 (patch) | |
tree | 89286fc44c2b91e72581edaa66b6b50eca321570 /acme.hs | |
parent | fdf06576f7d21392f512492b164df899136f30d3 (diff) |
validate URIs
Diffstat (limited to 'acme.hs')
-rw-r--r-- | acme.hs | 24 |
1 files changed, 13 insertions, 11 deletions
@@ -45,10 +45,11 @@ 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 | import Text.Email.Validate |
48 | import Network.URI | ||
48 | 49 | ||
49 | stagingDirectoryUrl, liveDirectoryUrl :: String | 50 | stagingDirectoryUrl, liveDirectoryUrl :: URI |
50 | liveDirectoryUrl = "https://acme-v01.api.letsencrypt.org/directory" | 51 | Just liveDirectoryUrl = parseAbsoluteURI "https://acme-v01.api.letsencrypt.org/directory" |
51 | stagingDirectoryUrl = "https://acme-staging.api.letsencrypt.org/directory" | 52 | Just stagingDirectoryUrl = parseAbsoluteURI "https://acme-staging.api.letsencrypt.org/directory" |
52 | 53 | ||
53 | main :: IO () | 54 | main :: IO () |
54 | main = execParser opts >>= go | 55 | main = execParser opts >>= go |
@@ -69,8 +70,8 @@ data CmdOpts = CmdOpts { | |||
69 | optStaging :: Bool | 70 | optStaging :: Bool |
70 | } | 71 | } |
71 | 72 | ||
72 | defaultTerms :: String | 73 | defaultTerms :: URI |
73 | defaultTerms = "https://letsencrypt.org/documents/LE-SA-v1.0.1-July-27-2015.pdf" | 74 | Just defaultTerms = parseAbsoluteURI "https://letsencrypt.org/documents/LE-SA-v1.0.1-July-27-2015.pdf" |
74 | 75 | ||
75 | cmdopts :: Parser CmdOpts | 76 | cmdopts :: Parser CmdOpts |
76 | cmdopts = CmdOpts <$> strOption (long "key" <> metavar "FILE" <> | 77 | cmdopts = CmdOpts <$> strOption (long "key" <> metavar "FILE" <> |
@@ -139,7 +140,7 @@ infixl 0 `otherwiseM` | |||
139 | 140 | ||
140 | go :: CmdOpts -> IO () | 141 | go :: CmdOpts -> IO () |
141 | go CmdOpts { .. } = do | 142 | go CmdOpts { .. } = do |
142 | let terms = fromMaybe defaultTerms optTerms | 143 | let terms = fromMaybe defaultTerms (join $ parseAbsoluteURI <$> optTerms) |
143 | directoryUrl = if optStaging then stagingDirectoryUrl else liveDirectoryUrl | 144 | directoryUrl = if optStaging then stagingDirectoryUrl else liveDirectoryUrl |
144 | domainKeyFile = domainDir </> "rsa.key" | 145 | domainKeyFile = domainDir </> "rsa.key" |
145 | domainCSRFile = domainDir </> "csr.der" | 146 | domainCSRFile = domainDir </> "csr.der" |
@@ -167,7 +168,8 @@ go CmdOpts { .. } = do | |||
167 | 168 | ||
168 | certify directoryUrl keys email terms requestDomains optChallengeDir csrData domainCertFile | 169 | certify directoryUrl keys email terms requestDomains optChallengeDir csrData domainCertFile |
169 | 170 | ||
170 | certify :: String -> Keys -> Maybe EmailAddress -> String -> [String] -> String -> CSR -> FilePath -> IO () | 171 | type DomainName = String -- TODO: use validated type |
172 | certify :: URI -> Keys -> Maybe EmailAddress -> URI -> [DomainName] -> String -> CSR -> FilePath -> IO () | ||
171 | certify directoryUrl keys optEmail terms requestDomains optChallengeDir csrData domainCertFile = | 173 | certify directoryUrl keys optEmail terms requestDomains optChallengeDir csrData domainCertFile = |
172 | 174 | ||
173 | runACME directoryUrl keys $ do | 175 | runACME directoryUrl keys $ do |
@@ -252,9 +254,9 @@ notifyChallenge crUri thumbtoken = sendPayload (const crUri) (challenge thumbtok | |||
252 | data Env = Env { getDir :: Directory, getKeys :: Keys, getSession :: WS.Session } | 254 | data Env = Env { getDir :: Directory, getKeys :: Keys, getSession :: WS.Session } |
253 | 255 | ||
254 | type ACME = RWST Env () Nonce IO | 256 | type ACME = RWST Env () Nonce IO |
255 | runACME :: String -> Keys -> ACME a -> IO a | 257 | runACME :: URI -> Keys -> ACME a -> IO a |
256 | runACME url keys f = WS.withSession $ \sess -> do | 258 | runACME url keys f = WS.withSession $ \sess -> do |
257 | Just (dir, nonce) <- getDirectory sess url | 259 | Just (dir, nonce) <- getDirectory sess (show url) |
258 | fst <$> evalRWST f (Env dir keys sess) nonce | 260 | fst <$> evalRWST f (Env dir keys sess) nonce |
259 | 261 | ||
260 | data Directory = Directory { | 262 | data Directory = Directory { |
@@ -272,8 +274,8 @@ getDirectory sess url = do | |||
272 | k x = r ^? responseBody . JSON.key x . _String . to T.unpack | 274 | k x = r ^? responseBody . JSON.key x . _String . to T.unpack |
273 | return $ (,) <$> (Directory <$> k "new-cert" <*> k "new-authz" <*> k "revoke-cert" <*> k "new-reg") <*> nonce | 275 | return $ (,) <$> (Directory <$> k "new-cert" <*> k "new-authz" <*> k "revoke-cert" <*> k "new-reg") <*> nonce |
274 | 276 | ||
275 | register :: String -> EmailAddress -> ACME (Response LC.ByteString) | 277 | register :: URI -> EmailAddress -> ACME (Response LC.ByteString) |
276 | register terms email = sendPayload _newReg (registration email terms) | 278 | register terms email = sendPayload _newReg (registration email (show terms)) |
277 | 279 | ||
278 | challengeRequest :: (MonadIO m, MonadState Nonce m, MonadReader Env m) => String -> m (Response LC.ByteString) | 280 | challengeRequest :: (MonadIO m, MonadState Nonce m, MonadReader Env m) => String -> m (Response LC.ByteString) |
279 | challengeRequest domain = sendPayload _newAuthz (authz domain) | 281 | challengeRequest domain = sendPayload _newAuthz (authz domain) |