From c78e210dc38c5c5df7134d74b137cdc3827f806a Mon Sep 17 00:00:00 2001 From: Andrew Cady Date: Sun, 24 Jan 2016 14:15:02 -0500 Subject: split out another module --- acme-certify.hs | 176 +++----------------------------------------------------- 1 file changed, 7 insertions(+), 169 deletions(-) (limited to 'acme-certify.hs') diff --git a/acme-certify.hs b/acme-certify.hs index fecd632..07c2942 100644 --- a/acme-certify.hs +++ b/acme-certify.hs @@ -10,31 +10,15 @@ module Main where -import Control.Lens hiding (each, (.=)) import Control.Monad -import Control.Monad.RWS.Strict -import Data.Aeson (Value) -import Data.Aeson.Lens hiding (key) -import qualified Data.Aeson.Lens as JSON -import Data.ByteString (ByteString) import qualified Data.ByteString as B -import qualified Data.ByteString.Char8 as BC -import qualified Data.ByteString.Lazy as LB import qualified Data.ByteString.Lazy.Char8 as LC import Data.Coerce import Data.List import Data.Maybe import Data.String (fromString) -import qualified Data.Text as T -import Data.Text.Encoding (decodeUtf8, encodeUtf8) -import Data.Time.Clock.POSIX (getPOSIXTime) -import Network.ACME.Encoding -import Network.Wreq (Response, checkStatus, defaults, - responseBody, responseHeader, - responseStatus, statusCode, - statusMessage) -import qualified Network.Wreq as W -import qualified Network.Wreq.Session as WS +import Network.ACME (certify, readKeyFile, (), ensureWritableDir, canProvision, CSR(..)) +import Network.ACME.Encoding (Keys(..), toStrict) import OpenSSL import OpenSSL.EVP.Digest import OpenSSL.PEM @@ -42,7 +26,6 @@ import OpenSSL.RSA import OpenSSL.X509.Request import Options.Applicative hiding (header) import qualified Options.Applicative as Opt -import Pipes import System.Directory import Text.Email.Validate import Text.Domain.Validate hiding (validate) @@ -115,10 +98,9 @@ genKey privKeyFile = withOpenSSL $ do pem <- writePKCS8PrivateKey kp Nothing writeFile privKeyFile pem -genReq :: FilePath -> [DomainName] -> IO LC.ByteString +genReq :: Keys -> [DomainName] -> IO CSR genReq _ [] = error "genReq called with zero domains" -genReq domainKeyFile domains@(domain:_) = withOpenSSL $ do - Just (Keys priv pub) <- readKeyFile domainKeyFile +genReq (Keys priv pub) domains@(domain:_) = withOpenSSL $ do Just dig <- getDigestByName "SHA256" req <- newX509Req setSubjectName req [("CN", show domain)] @@ -126,15 +108,10 @@ genReq domainKeyFile domains@(domain:_) = withOpenSSL $ do setPublicKey req pub void $ addExtensions req [(nidSubjectAltName, intercalate ", " (map (("DNS:" ++) . show) domains))] signX509Req req priv (Just dig) - writeX509ReqDER req + CSR . toStrict <$> writeX509ReqDER req where nidSubjectAltName = 85 -readKeyFile :: FilePath -> IO (Maybe Keys) -readKeyFile = readFile >=> readKeys - -data ChallengeRequest = ChallengeRequest { crUri :: String, crToken :: ByteString, crThumbToken :: ByteString } - otherwiseM :: Monad m => m Bool -> m () -> m () a `otherwiseM` b = a >>= flip unless b infixl 0 `otherwiseM` @@ -162,7 +139,8 @@ go CmdOpts { .. } = do forM_ requestDomains $ canProvision challengeDir >=> (`unless` error "Error: cannot provision files to web server via challenge directory") - csrData <- CSR . toStrict <$> genReq domainKeyFile requestDomains + csrData <- fromMaybe (error "Error: failed to read domain key file") <$> + readKeyFile domainKeyFile >>= flip genReq requestDomains B.writeFile domainCSRFile (coerce csrData) let email = either (error . ("Error: invalid email address: " ++)) id . validate . fromString <$> optEmail @@ -171,143 +149,3 @@ go CmdOpts { .. } = do either (error . ("Error: " ++)) (LC.writeFile domainCertFile) certificate -certify :: URI -> Keys -> Maybe EmailAddress -> URI -> [DomainName] -> WritableDir -> CSR -> IO (Either String LC.ByteString) -certify directoryUrl keys optEmail terms requestDomains optChallengeDir csrData = - - runACME directoryUrl keys $ do - forM_ optEmail $ register terms >=> statusReport - - let producer :: Producer ChallengeRequest ACME () - producer = for (each requestDomains) $ challengeRequest >=> statusReport >=> extractCR >=> yield - consumer :: Consumer ChallengeRequest ACME () - consumer = forever $ await >>= consume1 - consume1 (ChallengeRequest nextUri token thumbtoken) = do - lift $ liftIO $ BC.writeFile (coerce optChallengeDir BC.unpack token) thumbtoken - notifyChallenge nextUri thumbtoken >>= statusReport >>= ncErrorReport - - runEffect $ producer >-> consumer - - retrieveCert csrData >>= statusReport <&> checkCertResponse - -newtype CSR = CSR ByteString - -() :: String -> String -> String -a b = a ++ "/" ++ b -infixr 5 - -canProvision :: WritableDir -> DomainName -> IO Bool -canProvision challengeDir domain = do - randomish <- fromString . show <$> getPOSIXTime - - let absFile = coerce challengeDir relFile - relFile = ".test." ++ show randomish - - LC.writeFile absFile randomish - r <- W.get $ "http://" ++ show domain ".well-known/acme-challenge" relFile - removeFile absFile - return $ r ^. responseBody == randomish - - -newtype WritableDir = WritableDir String -ensureWritableDir :: FilePath -> String -> IO WritableDir -ensureWritableDir file name = do - (writable <$> getPermissions file) >>= flip unless (err name) - return $ WritableDir file - where err n = error $ "Error: " ++ n ++ " is not writable" - -extractCR :: MonadReader Env m => Response LC.ByteString -> m ChallengeRequest -extractCR r = do - Keys _ pub <- asks getKeys - let httpChallenge :: (Value -> Const (Endo s) Value) -> Response LC.ByteString -> Const (Endo s) (Response LC.ByteString) - httpChallenge = responseBody . - JSON.key "challenges" . - to universe . - traverse . - (filtered . has $ ix "type" . only "http-01") - - token = r ^?! httpChallenge . JSON.key "token" . _String . to encodeUtf8 - crUri = r ^?! httpChallenge . JSON.key "uri" . _String . to T.unpack - - thumb = thumbprint (JWK (rsaE pub) "RSA" (rsaN pub)) - thumbtoken = toStrict (LB.fromChunks [token, ".", thumb]) - - return $ ChallengeRequest crUri token thumbtoken - -ncErrorReport :: (Show body, AsValue body, MonadIO m) => Response body -> m () -ncErrorReport r = - when (Just "pending" /= r ^? responseBody . JSON.key "status" . _String) $ liftIO $ do - putStrLn "Unexpected response to challenge-response request:" - print r - -checkCertResponse :: Response LC.ByteString -> Either String LC.ByteString -checkCertResponse r = - if isSuccess $ r ^. responseStatus . statusCode - then Right $ r ^. responseBody - else - let (summary, details) = (k "type", k "detail") - k x = r ^?! responseBody . JSON.key x . _String . to T.unpack - in Left $ summary ++ " ---- " ++ details - 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 $ coerce input) - -notifyChallenge :: (MonadReader Env m, MonadState Nonce m, MonadIO m) => String -> ByteString -> m (Response LC.ByteString) -notifyChallenge crUri thumbtoken = sendPayload (const crUri) (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 . show - -statusLine :: Response body -> String -statusLine r = (r ^. responseStatus . statusCode . to show) ++ " " ++ r ^. responseStatus . statusMessage . to (T.unpack . decodeUtf8) - -statusReport :: MonadIO m => Response body -> m (Response body) -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 - -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 - -- cgit v1.2.3