1 files changed, 7 insertions, 169 deletions

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
-