diff --git a/agent/src/Handler/Hosts.hs b/agent/src/Handler/Hosts.hs index d3a6e2955..364d2dca8 100644 --- a/agent/src/Handler/Hosts.hs +++ b/agent/src/Handler/Hosts.hs @@ -5,26 +5,24 @@ module Handler.Hosts where import Startlude hiding ( ask ) import Control.Carrier.Lift ( runM ) -import Control.Carrier.Error.Church import Data.Conduit import qualified Data.Conduit.Binary as CB import Data.Time.ISO8601 import Yesod.Core hiding ( expiresAt ) import Foundation -import Daemon.ZeroConf -import Handler.Register ( produceProofOfKey - , checkExistingPasswordRegistration +import Handler.Register ( checkExistingPasswordRegistration + , getRegistration ) import Handler.Types.Hosts -import Handler.Types.Register import Lib.Crypto import Lib.Error import Lib.Password ( rootAccountName ) import Lib.ProductKey -import Lib.Ssl -import Lib.SystemPaths -import Lib.Tor +import Lib.SystemPaths ( injectFilesystemBaseFromContext + , rootCaCertPath + , SystemPath(relativeTo) + ) import Settings getHostsR :: Handler HostsRes @@ -59,23 +57,7 @@ verifyTimestampNotExpired expirationTimestamp = do Nothing -> throwE $ TTLExpirationE "invalid timestamp" Just expiration -> when (expiration < now) (throwE $ TTLExpirationE "expired") -getRegistration :: (MonadIO m, HasFilesystemBase sig m, Has (Error S9Error) sig m) => Text -> UTCTime -> m RegisterRes -getRegistration productKey registerResClaimedAt = do - torAddress <- getAgentHiddenServiceUrlMaybe >>= \case - Nothing -> throwError $ NotFoundE "prior registration" "torAddress" - Just t -> pure $ t - caCert <- readSystemPath rootCaCertPath >>= \case - Nothing -> throwError $ NotFoundE "prior registration" "cert" - Just t -> pure t - -- create an hmac of the torAddress + caCert for front end - registerResTorAddressSig <- produceProofOfKey productKey torAddress - registerResCertSig <- produceProofOfKey productKey caCert - - let registerResCertName = root_CA_CERT_NAME - registerResLanAddress <- getStart9AgentHostnameLocal - - pure RegisterRes { .. } getCertificateR :: Handler TypedContent getCertificateR = do diff --git a/agent/src/Handler/Register.hs b/agent/src/Handler/Register.hs index 734d821dd..4f295e251 100644 --- a/agent/src/Handler/Register.hs +++ b/agent/src/Handler/Register.hs @@ -5,7 +5,10 @@ module Handler.Register where import Startlude hiding ( ask ) -import Control.Carrier.Error.Either ( runError ) +import Control.Carrier.Error.Either ( runError + , Error + , throwError + ) import Control.Carrier.Lift import Control.Effect.Throw ( liftEither ) import Crypto.Cipher.Types @@ -29,6 +32,7 @@ import Lib.Password import Lib.ProductKey import Lib.Ssl import Lib.SystemPaths +import Lib.Tor import Model import Settings @@ -46,8 +50,11 @@ postRegisterR = handleS9ErrT $ do -- Check for existing registration. checkExistingPasswordRegistration rootAccountName >>= \case - Nothing -> pure () - Just _ -> sendResponseStatus (Status 209 "Preexisting") () + Nothing -> pure () + Just claimedAt -> do + res <- mapExceptT (liftIO . runM . injectFilesystemBaseFromContext settings) + $ getRegistration productKey claimedAt + sendResponseStatus (Status 209 "Preexisting") res -- install new tor hidden service key and restart tor registerResTorAddress <- runM (injectFilesystemBaseFromContext settings $ bootupTor torKeyFileContents) >>= \case @@ -139,3 +146,21 @@ produceProofOfKey key message = do salt <- random16 let hmac = computeHmac key message salt pure $ HmacSig hmac message salt + +getRegistration :: (MonadIO m, HasFilesystemBase sig m, Has (Error S9Error) sig m) => Text -> UTCTime -> m RegisterRes +getRegistration productKey registerResClaimedAt = do + torAddress <- getAgentHiddenServiceUrlMaybe >>= \case + Nothing -> throwError $ NotFoundE "prior registration" "torAddress" + Just t -> pure $ t + caCert <- readSystemPath rootCaCertPath >>= \case + Nothing -> throwError $ NotFoundE "prior registration" "cert" + Just t -> pure t + + -- create an hmac of the torAddress + caCert for front end + registerResTorAddressSig <- produceProofOfKey productKey torAddress + registerResCertSig <- produceProofOfKey productKey caCert + + let registerResCertName = root_CA_CERT_NAME + registerResLanAddress <- getStart9AgentHostnameLocal + + pure RegisterRes { .. }