mirror of
https://github.com/Start9Labs/start-os.git
synced 2026-03-26 02:11:53 +00:00
86 lines
3.5 KiB
Haskell
86 lines
3.5 KiB
Haskell
{-# LANGUAGE NamedFieldPuns #-}
|
|
{-# LANGUAGE RecordWildCards #-}
|
|
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.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 Settings
|
|
|
|
getHostsR :: Handler HostsRes
|
|
getHostsR = handleS9ErrT $ do
|
|
settings <- getsYesod appSettings
|
|
productKey <- liftIO . getProductKey . appFilesystemBase $ settings
|
|
hostParams <- extractHostsQueryParams
|
|
|
|
verifyHmac productKey hostParams
|
|
verifyTimestampNotExpired $ hostsParamsExpiration hostParams
|
|
|
|
mClaimedAt <- checkExistingPasswordRegistration rootAccountName
|
|
case mClaimedAt of
|
|
Nothing -> pure $ NullReply
|
|
Just claimedAt -> do
|
|
fmap HostsRes . mapExceptT (liftIO . runM . injectFilesystemBaseFromContext settings) $ getRegistration
|
|
productKey
|
|
claimedAt
|
|
|
|
verifyHmac :: MonadIO m => Text -> HostsParams -> S9ErrT m ()
|
|
verifyHmac productKey params = do
|
|
let computedHmacDigest = computeHmac productKey hostsParamsExpiration hostsParamsSalt
|
|
unless (hostsParamsHmac == computedHmacDigest) $ throwE unauthorizedHmac
|
|
where
|
|
HostsParams { hostsParamsHmac, hostsParamsExpiration, hostsParamsSalt } = params
|
|
unauthorizedHmac = ClientCryptographyE "Unauthorized hmac"
|
|
|
|
verifyTimestampNotExpired :: MonadIO m => Text -> S9ErrT m ()
|
|
verifyTimestampNotExpired expirationTimestamp = do
|
|
now <- liftIO getCurrentTime
|
|
case parseISO8601 . toS $ expirationTimestamp of
|
|
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
|
|
base <- getsYesod $ appFilesystemBase . appSettings
|
|
respondSource "application/x-x509-ca-cert"
|
|
$ CB.sourceFile (toS $ rootCaCertPath `relativeTo` base)
|
|
.| awaitForever sendChunkBS
|