From 0bb7b5f6884a617301c9ddb0927f5829476483b4 Mon Sep 17 00:00:00 2001 From: Andrew Cady Date: Wed, 27 Jan 2016 20:42:05 -0500 Subject: Re-order some definitions (no semantic changes) --- src/Network/ACME.hs | 220 +++++++++++++++++++++++++++------------------------- 1 file changed, 115 insertions(+), 105 deletions(-) diff --git a/src/Network/ACME.hs b/src/Network/ACME.hs index 2734132..e2c0996 100644 --- a/src/Network/ACME.hs +++ b/src/Network/ACME.hs @@ -49,52 +49,7 @@ import System.Directory import Text.Domain.Validate hiding (validate) import Text.Email.Validate -genReq :: Keys -> [DomainName] -> IO CSR -genReq _ [] = error "genReq called with zero domains" -genReq (Keys priv pub) domains@(domain:_) = withOpenSSL $ do - Just dig <- getDigestByName "SHA256" - req <- newX509Req - setSubjectName req [("CN", domainToString domain)] - setVersion req 0 - setPublicKey req pub - void $ addExtensions req [(nidSubjectAltName, intercalate ", " (map (("DNS:" ++) . domainToString) domains))] - signX509Req req priv (Just dig) - CSR domains . toStrict <$> writeX509ReqDER req - where - nidSubjectAltName = 85 - -data Keys = Keys RSAKeyPair RSAPubKey -readKeys :: String -> IO (Maybe Keys) -readKeys privKeyData = do - keypair :: SomeKeyPair <- readPrivateKey privKeyData PwTTY - let (priv :: Maybe RSAKeyPair) = toKeyPair keypair - pub <- maybe (return Nothing) (fmap Just . rsaCopyPublic) priv - return $ Keys <$> priv <*> pub - -signPayload :: Keys -> String -> ByteString -> IO LC.ByteString -signPayload (Keys priv pub) = signPayload' sign pub - where - sign x = do - Just dig <- getDigestByName "SHA256" - signBS dig priv x - -type HttpProvisioner = URI -> ByteString -> ResIO () -fileProvisioner :: WritableDir -> HttpProvisioner -fileProvisioner challengeDir uri thumbtoken = do - void $ allocate (return f) removeFile - liftIO $ BC.writeFile f thumbtoken - - where - f = (coerce challengeDir ) . takeWhileEnd (/= '/') . uriPath $ uri - takeWhileEnd s = reverse . takeWhile s . reverse - -acmeChallengeURI :: DomainName -> BC.ByteString -> URI -acmeChallengeURI dom tok = URI - "http:" - (Just $ URIAuth "" (domainToString dom) "") - ("/.well-known/acme-challenge" BC.unpack tok) - "" - "" +-- The `certify` function certify :: URI -> Keys -> Maybe (URI, EmailAddress) -> HttpProvisioner -> CSR -> IO (Either String X509) certify directoryUrl keys reg provision certReq = @@ -126,9 +81,17 @@ pollResults (link:links) = do "invalid" -> return . Left $ r ^. responseBody . JSON.key "error" . to extractAcmeError _ -> return . Left $ "unexpected response from ACME server: " ++ show r -data ChallengeRequest = ChallengeRequest { crUri :: String, crToken :: ByteString, crThumbToken :: ByteString } +-- Provisioner callback -data CSR = CSR { csrDomains :: [DomainName], csrData :: ByteString } +type HttpProvisioner = URI -> ByteString -> ResIO () +fileProvisioner :: WritableDir -> HttpProvisioner +fileProvisioner challengeDir uri thumbtoken = do + void $ allocate (return f) removeFile + liftIO $ BC.writeFile f thumbtoken + + where + f = (coerce challengeDir ) . takeWhileEnd (/= '/') . uriPath $ uri + takeWhileEnd s = reverse . takeWhile s . reverse newtype WritableDir = WritableDir String ensureWritableDir :: FilePath -> String -> IO WritableDir @@ -137,13 +100,6 @@ ensureWritableDir file name = do return $ WritableDir file where e n = error $ "Error: " ++ n ++ " is not writable" -() :: String -> String -> String -a b = a ++ "/" ++ b -infixr 5 - -domainToString :: DomainName -> String -domainToString = T.unpack . decodeUtf8 . Text.Domain.Validate.toByteString - canProvision :: WritableDir -> DomainName -> IO Bool canProvision challengeDir domain = do token <- (".test." ++) . show <$> getPOSIXTime @@ -155,7 +111,72 @@ canProvision challengeDir domain = do liftIO $ W.get (show uri) return $ r ^. responseBody == fromString token +-- The ACME monad +data Directory = Directory { + _newCert :: String, + _newAuthz :: String, + _revokeCert :: String, + _newReg :: String +} +newtype Nonce = Nonce String +data Env = Env { getDir :: Directory, getKeys :: Keys, getSession :: WS.Session } +type ACME = RWST Env () Nonce IO + +runACME :: URI -> Keys -> ACME a -> IO a +runACME url keys f = WS.withSession $ \sess -> do + Just (dir, nonce) <- getDirectory sess (show url) + fst <$> evalRWST f (Env dir keys sess) nonce + +post :: (MonadReader Env m, MonadState Nonce m, MonadIO m) => String -> LC.ByteString -> m (Response LC.ByteString) +post url payload = do + sess <- asks getSession + r <- liftIO $ WS.postWith noStatusCheck sess url payload + put $ r ^?! responseHeader "Replay-Nonce" . to (Nonce . T.unpack . decodeUtf8) + return r + where + noStatusCheck = defaults & checkStatus .~ Just nullChecker + nullChecker _ _ _ = Nothing + +sendPayload :: (MonadIO m, MonadState Nonce m, MonadReader Env m) => (Directory -> String) -> ByteString -> m (Response LC.ByteString) +sendPayload reqType payload = do + keys <- asks getKeys + dir <- asks getDir + nonce <- gets coerce + signed <- liftIO $ signPayload keys nonce payload + post (reqType dir) signed + +signPayload :: Keys -> String -> ByteString -> IO LC.ByteString +signPayload (Keys priv pub) = signPayload' sign pub + where + sign x = do + Just dig <- getDigestByName "SHA256" + signBS dig priv x + +-- Generating ACME requests + +getDirectory :: WS.Session -> String -> IO (Maybe (Directory, Nonce)) +getDirectory sess url = do + r <- WS.get sess url + let nonce = r ^? responseHeader "Replay-Nonce" . to (Nonce . T.unpack . decodeUtf8) + k x = r ^? responseBody . JSON.key x . _String . to T.unpack + return $ (,) <$> (Directory <$> k "new-cert" <*> k "new-authz" <*> k "revoke-cert" <*> k "new-reg") <*> nonce + +retrieveCert :: (MonadReader Env m, MonadState Nonce m, MonadIO m) => CSR -> m (Response LC.ByteString) +retrieveCert input = sendPayload _newCert (csr $ csrData input) + +notifyChallenge :: (MonadReader Env m, MonadState Nonce m, MonadIO m) => String -> ByteString -> m (Response LC.ByteString) +notifyChallenge uri thumbtoken = sendPayload (const uri) (challenge thumbtoken) + +register :: URI -> EmailAddress -> ACME (Response LC.ByteString) +register terms email = sendPayload _newReg (registration email (show terms)) + +challengeRequest :: (MonadIO m, MonadState Nonce m, MonadReader Env m) => DomainName -> m (Response LC.ByteString) +challengeRequest = sendPayload _newAuthz . authz . domainToString + +-- Handling ACME responses + +data ChallengeRequest = ChallengeRequest { crUri :: String, crToken :: ByteString, crThumbToken :: ByteString } extractCR :: MonadReader Env m => Response LC.ByteString -> m ChallengeRequest extractCR r = do Keys _ pub <- asks getKeys @@ -195,41 +216,6 @@ checkCertResponse r = where isSuccess n = n >= 200 && n <= 300 -retrieveCert :: (MonadReader Env m, MonadState Nonce m, MonadIO m) => CSR -> m (Response LC.ByteString) -retrieveCert input = sendPayload _newCert (csr $ csrData input) - -notifyChallenge :: (MonadReader Env m, MonadState Nonce m, MonadIO m) => String -> ByteString -> m (Response LC.ByteString) -notifyChallenge uri thumbtoken = sendPayload (const uri) (challenge thumbtoken) - -data Env = Env { getDir :: Directory, getKeys :: Keys, getSession :: WS.Session } - -type ACME = RWST Env () Nonce IO -runACME :: URI -> Keys -> ACME a -> IO a -runACME url keys f = WS.withSession $ \sess -> do - Just (dir, nonce) <- getDirectory sess (show url) - fst <$> evalRWST f (Env dir keys sess) nonce - -data Directory = Directory { - _newCert :: String, - _newAuthz :: String, - _revokeCert :: String, - _newReg :: String -} -newtype Nonce = Nonce String - -getDirectory :: WS.Session -> String -> IO (Maybe (Directory, Nonce)) -getDirectory sess url = do - r <- WS.get sess url - let nonce = r ^? responseHeader "Replay-Nonce" . to (Nonce . T.unpack . decodeUtf8) - k x = r ^? responseBody . JSON.key x . _String . to T.unpack - return $ (,) <$> (Directory <$> k "new-cert" <*> k "new-authz" <*> k "revoke-cert" <*> k "new-reg") <*> nonce - -register :: URI -> EmailAddress -> ACME (Response LC.ByteString) -register terms email = sendPayload _newReg (registration email (show terms)) - -challengeRequest :: (MonadIO m, MonadState Nonce m, MonadReader Env m) => DomainName -> m (Response LC.ByteString) -challengeRequest = sendPayload _newAuthz . authz . domainToString - statusLine :: Response body -> String statusLine r = (r ^. responseStatus . statusCode . to show) ++ " " ++ r ^. responseStatus . statusMessage . to (T.unpack . decodeUtf8) @@ -238,20 +224,44 @@ statusReport r = do liftIO $ putStrLn $ statusLine r return r -sendPayload :: (MonadIO m, MonadState Nonce m, MonadReader Env m) => (Directory -> String) -> ByteString -> m (Response LC.ByteString) -sendPayload reqType payload = do - keys <- asks getKeys - dir <- asks getDir - nonce <- gets coerce - signed <- liftIO $ signPayload keys nonce payload - post (reqType dir) signed +-- OpenSSL operations -post :: (MonadReader Env m, MonadState Nonce m, MonadIO m) => String -> LC.ByteString -> m (Response LC.ByteString) -post url payload = do - sess <- asks getSession - r <- liftIO $ WS.postWith noStatusCheck sess url payload - put $ r ^?! responseHeader "Replay-Nonce" . to (Nonce . T.unpack . decodeUtf8) - return r +data CSR = CSR { csrDomains :: [DomainName], csrData :: ByteString } +genReq :: Keys -> [DomainName] -> IO CSR +genReq _ [] = error "genReq called with zero domains" +genReq (Keys priv pub) domains@(domain:_) = withOpenSSL $ do + Just dig <- getDigestByName "SHA256" + req <- newX509Req + setSubjectName req [("CN", domainToString domain)] + setVersion req 0 + setPublicKey req pub + void $ addExtensions req [(nidSubjectAltName, intercalate ", " (map (("DNS:" ++) . domainToString) domains))] + signX509Req req priv (Just dig) + CSR domains . toStrict <$> writeX509ReqDER req where - noStatusCheck = defaults & checkStatus .~ Just nullChecker - nullChecker _ _ _ = Nothing + nidSubjectAltName = 85 + +data Keys = Keys RSAKeyPair RSAPubKey +readKeys :: String -> IO (Maybe Keys) +readKeys privKeyData = do + keypair :: SomeKeyPair <- readPrivateKey privKeyData PwTTY + let (priv :: Maybe RSAKeyPair) = toKeyPair keypair + pub <- maybe (return Nothing) (fmap Just . rsaCopyPublic) priv + return $ Keys <$> priv <*> pub + +-- General utility + +() :: String -> String -> String +a b = a ++ "/" ++ b +infixr 5 + +domainToString :: DomainName -> String +domainToString = T.unpack . decodeUtf8 . Text.Domain.Validate.toByteString + +acmeChallengeURI :: DomainName -> BC.ByteString -> URI +acmeChallengeURI dom tok = URI + "http:" + (Just $ URIAuth "" (domainToString dom) "") + ("/.well-known/acme-challenge" BC.unpack tok) + "" + "" -- cgit v1.2.3