Re-order some definitions (no semantic changes)

1 files 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)
+                             ""
+                             ""