split out another module

3 files changed, 193 insertions, 174 deletions

diff --git a/acme-certify.cabal b/acme-certify.cabal
index e7340ea..ec7afbb 100644
--- a/acme-certify.cabal
+++ b/acme-certify.cabal
@@ -13,10 +13,11 @@ cabal-version:       >=1.10
 
 library
   hs-source-dirs:      src
-  exposed-modules:     Network.ACME.Encoding
+  exposed-modules:     Network.ACME, Network.ACME.Encoding
   build-depends:       base >= 4.7 && < 5,
                        cryptonite, aeson, bytestring, base64-bytestring, SHA,
-                       text, HsOpenSSL, time, email-validate
+                       mtl, text, HsOpenSSL, wreq, lens, lens-aeson, time,
+                       email-validate, pipes, directory, network-uri
   default-language:    Haskell2010
 
 executable acme-certify
@@ -25,9 +26,8 @@ executable acme-certify
   ghc-options:         -threaded -rtsopts -with-rtsopts=-N -Wall
   build-depends:       base, acme-certify,
                        cryptonite, aeson, bytestring, base64-bytestring, SHA,
-                       text, HsOpenSSL, wreq, lens, lens-aeson,
-                       optparse-applicative, directory, mtl, time, pipes,
-                       email-validate, network-uri
+                       text, HsOpenSSL, optparse-applicative, time,
+                       email-validate, network-uri, directory
   default-language:    Haskell2010
 
 -- test-suite acme-certify-test
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
-
diff --git a/src/Network/ACME.hs b/src/Network/ACME.hs
new file mode 100644
index 0000000..116a291
--- /dev/null
+++ b/src/Network/ACME.hs
@@ -0,0 +1,181 @@
+{-# LANGUAGE FlexibleContexts      #-}
+{-# LANGUAGE OverloadedStrings     #-}
+{-# LANGUAGE ScopedTypeVariables   #-}
+
+--------------------------------------------------------------------------------
+-- | Get a certificate from Let's Encrypt using the ACME protocol.
+--
+-- https://github.com/ietf-wg-acme/acme/blob/master/draft-ietf-acme-acme.md
+
+module Network.ACME 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.Char8      as BC
+import qualified Data.ByteString.Lazy       as LB
+import qualified Data.ByteString.Lazy.Char8 as LC
+import           Data.Coerce
+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           OpenSSL.RSA
+import           Pipes
+import           System.Directory
+import           Text.Email.Validate
+import           Text.Domain.Validate hiding (validate)
+import           Network.URI
+
+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
+
+data ChallengeRequest = ChallengeRequest { crUri :: String, crToken :: ByteString, crThumbToken :: ByteString }
+
+newtype CSR = CSR ByteString
+
+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"
+
+(</>) :: 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
+
+
+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