From a6bee6cc973ed346d9dbd2a45ebef336ced75009 Mon Sep 17 00:00:00 2001 From: Chris Penner Date: Mon, 15 Jul 2024 14:00:29 -0700 Subject: [PATCH 1/6] Bump unison sub-dep --- unison | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/unison b/unison index 9b11d96..7019595 160000 --- a/unison +++ b/unison @@ -1 +1 @@ -Subproject commit 9b11d96cbba5157bd35c7d6a48d88da8e3e3a011 +Subproject commit 7019595b7ba9fffea3dcb295a72fdbf0a1c147ca From 77f034966729895c31c15ef9e2d8c1b5671c5b78 Mon Sep 17 00:00:00 2001 From: Chris Penner Date: Mon, 15 Jul 2024 14:29:16 -0700 Subject: [PATCH 2/6] Upgrade lts and fix imports --- package.yaml | 1 - share-api.cabal | 4 +- share-auth/share-auth.cabal | 3 +- share-auth/src/Share/JWT.hs | 36 ++++++++--------- .../src/Share/OAuth/IdentityProvider/Share.hs | 14 +++---- share-auth/src/Share/OAuth/Orphans.hs | 22 ++++++++++ share-auth/src/Share/OAuth/PKCE.hs | 4 +- share-auth/src/Share/OAuth/ServiceProvider.hs | 9 +++-- share-auth/src/Share/OAuth/Session.hs | 36 ++++++++--------- src/Share/App.hs | 2 - src/Share/Backend.hs | 2 +- src/Share/Prelude.hs | 5 +-- src/Share/Web/Authentication/JWT.hs | 8 ++-- src/Unison/PrettyPrintEnvDecl/Postgres.hs | 2 +- src/Unison/Server/NameSearch/Postgres.hs | 2 +- src/Unison/Server/Share/Definitions.hs | 2 +- src/Unison/Server/Share/Docs.hs | 2 +- stack.yaml | 10 ++--- stack.yaml.lock | 40 +++++++++---------- 19 files changed, 111 insertions(+), 93 deletions(-) create mode 100644 share-auth/src/Share/OAuth/Orphans.hs diff --git a/package.yaml b/package.yaml index c38a0cf..8bdb42e 100644 --- a/package.yaml +++ b/package.yaml @@ -41,7 +41,6 @@ dependencies: - bytes - case-insensitive - clock -- connection - containers - cookie - cryptonite diff --git a/share-api.cabal b/share-api.cabal index e32df19..05047a1 100644 --- a/share-api.cabal +++ b/share-api.cabal @@ -1,6 +1,6 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.35.2. +-- This file has been generated from package.yaml by hpack version 0.36.0. -- -- see: https://github.com/sol/hpack @@ -195,7 +195,6 @@ library , bytestring , case-insensitive , clock - , connection , containers , cookie , cryptonite @@ -335,7 +334,6 @@ executable share-api , bytestring , case-insensitive , clock - , connection , containers , cookie , cryptonite diff --git a/share-auth/share-auth.cabal b/share-auth/share-auth.cabal index 839ba5d..4176738 100644 --- a/share-auth/share-auth.cabal +++ b/share-auth/share-auth.cabal @@ -1,6 +1,6 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.35.2. +-- This file has been generated from package.yaml by hpack version 0.36.0. -- -- see: https://github.com/sol/hpack @@ -29,6 +29,7 @@ library Share.OAuth.Errors Share.OAuth.IdentityProvider.Share Share.OAuth.IdentityProvider.Types + Share.OAuth.Orphans Share.OAuth.PKCE Share.OAuth.Redis Share.OAuth.Scopes diff --git a/share-auth/src/Share/JWT.hs b/share-auth/src/Share/JWT.hs index ff63b08..8d917eb 100644 --- a/share-auth/src/Share/JWT.hs +++ b/share-auth/src/Share/JWT.hs @@ -18,10 +18,8 @@ where import Control.Lens import Control.Monad.Except -import Crypto.JOSE as Jose +import Crypto.JOSE qualified as Jose import Crypto.JOSE.JWK qualified as JWK -import Crypto.JWT -import Crypto.JWT as Jose import Crypto.JWT qualified as CryptoJWT import Crypto.JWT qualified as JWT import Data.Aeson (FromJSON (..), ToJSON (..)) @@ -35,10 +33,12 @@ import Data.Text qualified as Text import Data.Text.Lazy qualified as TL import Data.Text.Lazy.Encoding qualified as TL import Data.Typeable (Typeable, typeRep) -import Share.Utils.Servant.Cookies qualified as Cookies -import Share.Utils.Show (Censored (..)) import Servant import Servant.Auth.Server qualified as ServantAuth +import Share.OAuth.Orphans () +import Share.Utils.Servant.Cookies qualified as Cookies +import Share.Utils.Show (Censored (..)) +import UnliftIO (MonadIO (..)) -- | @JWTSettings@ are used to generate and verify JWTs. data JWTSettings = JWTSettings @@ -48,7 +48,7 @@ data JWTSettings = JWTSettings validationKeys :: IO Jose.JWKSet, -- | An @aud@ predicate. The @aud@ is a string or URI that identifies the -- intended recipient of the JWT. - audienceMatches :: Jose.StringOrURI -> Bool, + audienceMatches :: JWT.StringOrURI -> Bool, -- | The set of audiences the app accepts tokens for. acceptedAudiences :: Set URI, issuer :: URI @@ -70,14 +70,14 @@ defaultJWTSettings hs256Key acceptedAudiences issuer = { jwk, validationKeys = pure $ Jose.JWKSet [jwk], audienceMatches = \s -> - (review stringOrUri s) `Set.member` (Set.map (show @URI) acceptedAudiences), + (review JWT.stringOrUri s) `Set.member` (Set.map (show @URI) acceptedAudiences), acceptedAudiences, issuer } where jwk = JWK.fromOctets hs256Key -newtype JWTParam = JWTParam SignedJWT +newtype JWTParam = JWTParam JWT.SignedJWT deriving (Show) via (Censored JWTParam) instance ToHttpApiData JWTParam where @@ -102,18 +102,18 @@ instance Binary JWTParam where ) -- | Encode a signed JWT as text. -signedJWTToText :: SignedJWT -> Text +signedJWTToText :: JWT.SignedJWT -> Text signedJWTToText = - TL.toStrict . TL.decodeUtf8 . encodeCompact + TL.toStrict . TL.decodeUtf8 . JWT.encodeCompact -textToSignedJWT :: Text -> Either JWTError SignedJWT -textToSignedJWT jwtText = decodeCompact (TL.encodeUtf8 . TL.fromStrict $ jwtText) +textToSignedJWT :: Text -> Either JWT.JWTError JWT.SignedJWT +textToSignedJWT jwtText = JWT.decodeCompact (TL.encodeUtf8 . TL.fromStrict $ jwtText) -- | Signs and encodes a JWT using the given 'JWTSettings'. -signJWT :: (MonadIO m, ServantAuth.ToJWT v) => JWTSettings -> v -> m (Either JWTError SignedJWT) +signJWT :: (MonadIO m, ServantAuth.ToJWT v) => JWTSettings -> v -> m (Either JWT.JWTError JWT.SignedJWT) signJWT JWTSettings {jwk} v = do let claimsSet = ServantAuth.encodeJWT v - liftIO $ runExceptT (signClaims jwk jwtHeader claimsSet) + liftIO $ runExceptT (JWT.signClaims jwk jwtHeader claimsSet) jwtHeader :: JWT.JWSHeader () jwtHeader = JWT.newJWSHeader ((), jwtAlgorithm) @@ -130,13 +130,13 @@ jwtAlgorithm = JWT.HS256 -- * signature -- -- Any other checks should be performed on the returned claims. -verifyJWT :: forall claims m. (Typeable claims, MonadIO m, ServantAuth.FromJWT claims) => JWTSettings -> SignedJWT -> m (Either JWTError claims) +verifyJWT :: forall claims m. (Typeable claims, MonadIO m, ServantAuth.FromJWT claims) => JWTSettings -> JWT.SignedJWT -> m (Either JWT.JWTError claims) verifyJWT JWTSettings {jwk, issuer, acceptedAudiences} signedJWT = do - result :: Either JWTError ClaimsSet <- liftIO . runExceptT $ JWT.verifyClaims validators jwk signedJWT + result :: Either JWT.JWTError JWT.ClaimsSet <- liftIO . runExceptT $ JWT.verifyClaims validators jwk signedJWT pure $ do claimsSet <- result case ServantAuth.decodeJWT claimsSet of - Left err -> Left . JWTClaimsSetDecodeError $ "Failed to decode " <> show (typeRep (Proxy @claims)) <> ": " <> Text.unpack err + Left err -> Left . JWT.JWTClaimsSetDecodeError $ "Failed to decode " <> show (typeRep (Proxy @claims)) <> ": " <> Text.unpack err Right claims -> Right claims where auds :: [CryptoJWT.StringOrURI] @@ -154,7 +154,7 @@ verifyJWT JWTSettings {jwk, issuer, acceptedAudiences} signedJWT = do ) -- | Create a signed session cookie using a ToJWT instance. -createSignedCookie :: (MonadIO m, ServantAuth.ToJWT session) => JWTSettings -> Cookies.CookieSettings -> Text -> session -> m (Either JWTError Cookies.SetCookie) +createSignedCookie :: (MonadIO m, ServantAuth.ToJWT session) => JWTSettings -> Cookies.CookieSettings -> Text -> session -> m (Either JWT.JWTError Cookies.SetCookie) createSignedCookie jwtSettings cookieSettings sessionName value = runExceptT do signedJWT <- ExceptT (signJWT jwtSettings value) pure $ Cookies.newSetCookie cookieSettings sessionName (signedJWTToText signedJWT) diff --git a/share-auth/src/Share/OAuth/IdentityProvider/Share.hs b/share-auth/src/Share/OAuth/IdentityProvider/Share.hs index ff1bee6..37e2c28 100644 --- a/share-auth/src/Share/OAuth/IdentityProvider/Share.hs +++ b/share-auth/src/Share/OAuth/IdentityProvider/Share.hs @@ -13,6 +13,11 @@ where import Data.Function ((&)) import Data.Maybe (fromJust) import Data.Text (Text) +import Network.HTTP.Client.TLS qualified as HTTP +import Network.URI qualified as URI +import Servant +import Servant.Client +import Servant.Client.Core.Auth (AuthenticatedRequest (..)) import Share.OAuth.API import Share.OAuth.IdentityProvider.Types (IdentityProviderConfig (..)) import Share.OAuth.Scopes @@ -20,15 +25,10 @@ import Share.OAuth.Session import Share.OAuth.Types import Share.Utils.Deployment (Deployment (..)) import Share.Utils.URI (URIParam (..), addQueryParam) -import Network.HTTP.Client.TLS qualified as HTTP -import Network.URI qualified as URI -import Servant -import Servant.Client -import Servant.Client.Core.Auth (AuthenticatedRequest (..)) import UnliftIO import Web.Cookie (SetCookie) -runClientEither :: MonadIO m => BaseUrl -> ClientM a -> m (Either ClientError a) +runClientEither :: (MonadIO m) => BaseUrl -> ClientM a -> m (Either ClientError a) runClientEither baseURL m = do httpClient <- liftIO $ HTTP.getGlobalManager let env = mkClientEnv httpClient baseURL @@ -104,7 +104,7 @@ mkShareIdentityProvider baseShareURL baseAuthorizationURI = ClientM (Headers '[Header "Cache-Control" String] TokenResponse) (_authorizationClient :<|> tokenClient) = client identityProviderAPI - exchangeCodeForToken :: MonadIO m => OAuthClientId -> OAuthClientSecret -> Code -> URI -> PKCEVerifier -> m (Either ClientError TokenResponse) + exchangeCodeForToken :: (MonadIO m) => OAuthClientId -> OAuthClientSecret -> Code -> URI -> PKCEVerifier -> m (Either ClientError TokenResponse) exchangeCodeForToken clientId clientSecret code redirectURI pkceVerifier = runClientEither baseShareURL $ do getResponse <$> tokenClient diff --git a/share-auth/src/Share/OAuth/Orphans.hs b/share-auth/src/Share/OAuth/Orphans.hs new file mode 100644 index 0000000..4e2f036 --- /dev/null +++ b/share-auth/src/Share/OAuth/Orphans.hs @@ -0,0 +1,22 @@ +{-# OPTIONS_GHC -Wno-orphans #-} + +module Share.OAuth.Orphans () where + +import Control.Monad.Except +import Control.Monad.IO.Class +import Crypto.JWT qualified as JWT +import Data.Aeson (ToJSON (..), FromJSON (..)) +import Data.Aeson qualified as Aeson +import Data.Text qualified as Text +import Network.URI (URI, parseURI) + +instance JWT.MonadRandom (ExceptT e IO) where + getRandomBytes = liftIO . JWT.getRandomBytes + +instance ToJSON URI where + toJSON = Aeson.String . Text.pack . show @URI + +instance FromJSON URI where + parseJSON = Aeson.withText "URI" $ \t -> case parseURI (Text.unpack t) of + Just uri -> pure uri + Nothing -> fail "Invalid URI" diff --git a/share-auth/src/Share/OAuth/PKCE.hs b/share-auth/src/Share/OAuth/PKCE.hs index c83ac78..fa0b019 100644 --- a/share-auth/src/Share/OAuth/PKCE.hs +++ b/share-auth/src/Share/OAuth/PKCE.hs @@ -4,15 +4,15 @@ -- Currently only supports the S256 method. module Share.OAuth.PKCE (generatePkce, verifyPkce) where -import Control.Monad.Except import Crypto.Hash qualified as Crypto import Data.ByteArray.Encoding qualified as BE import Data.Text.Encoding qualified as Text import Share.OAuth.Types import Share.Utils.SecureTokens (newSecureToken) +import UnliftIO (MonadIO) -- | Generate a PKCE verifier and challenge using the S256 method. -generatePkce :: MonadIO m => m (PKCEVerifier, PKCEChallenge, PKCEChallengeMethod) +generatePkce :: (MonadIO m) => m (PKCEVerifier, PKCEChallenge, PKCEChallengeMethod) generatePkce = do verifier <- newSecureToken let digest = Crypto.hashWith Crypto.SHA256 $ Text.encodeUtf8 verifier diff --git a/share-auth/src/Share/OAuth/ServiceProvider.hs b/share-auth/src/Share/OAuth/ServiceProvider.hs index 6321abe..94ab684 100644 --- a/share-auth/src/Share/OAuth/ServiceProvider.hs +++ b/share-auth/src/Share/OAuth/ServiceProvider.hs @@ -20,6 +20,7 @@ module Share.OAuth.ServiceProvider where import Control.Monad.Except +import Control.Monad.Trans (MonadTrans (..)) import Crypto.JWT (JWTError) import Data.Aeson (ToJSON (toJSON)) import Data.Aeson qualified as Aeson @@ -27,6 +28,7 @@ import Data.Function ((&)) import Data.Maybe (fromMaybe) import Data.Text (Text) import Database.Redis qualified as Redis +import Servant import Share.JWT (JWTParam (..)) import Share.JWT qualified as JWT import Share.OAuth.API @@ -40,7 +42,6 @@ import Share.OAuth.Types import Share.Utils.IDs import Share.Utils.Servant.Cookies qualified as Cookies import Share.Utils.URI (URIParam, setPathAndQueryParams, unpackURI) -import Servant import UnliftIO import Web.Cookie (SetCookie (..)) @@ -188,7 +189,7 @@ type LocationHeader = Headers '[Header "Location" String] NoContent -- | Log out the user by telling the browser to clear the session cookies. -- Note that this doesn't invalidate the session itself, it just removes its cookie from the current browser. -logoutEndpoint :: Redis.MonadRedis m => URI -> Cookies.CookieSettings -> Text -> ServerT LogoutEndpoint m +logoutEndpoint :: (Redis.MonadRedis m) => URI -> Cookies.CookieSettings -> Text -> ServerT LogoutEndpoint m logoutEndpoint afterLogoutURI cookieSettings sessionCookieKey = do pure . clearSession $ redirectTo afterLogoutURI where @@ -284,11 +285,11 @@ redirectReceiverEndpoint IdentityProviderConfig {exchangeCodeForToken} servicePr Just pSession -> pure $ pSession -- Clear the pending session - clearPendingSessionCookie :: AddHeader "Set-Cookie" SetCookie orig new => orig -> new + clearPendingSessionCookie :: (AddHeader "Set-Cookie" SetCookie orig new) => orig -> new clearPendingSessionCookie = addHeader @"Set-Cookie" (Cookies.clearCookie cookieSettings pendingSessionCookieKey) - clearSessionCookie :: AddHeader "Set-Cookie" SetCookie orig new => orig -> new + clearSessionCookie :: (AddHeader "Set-Cookie" SetCookie orig new) => orig -> new clearSessionCookie = addHeader @"Set-Cookie" (Cookies.clearCookie cookieSettings sessionCookieKey) -- | Decodes an Access Token into a session and verifies the following: diff --git a/share-auth/src/Share/OAuth/Session.hs b/share-auth/src/Share/OAuth/Session.hs index 02141bd..50eea4a 100644 --- a/share-auth/src/Share/OAuth/Session.hs +++ b/share-auth/src/Share/OAuth/Session.hs @@ -42,17 +42,17 @@ import Data.Text (Text) import Data.Text qualified as Text import Data.Text.Encoding qualified as Text import Data.Time (NominalDiffTime, UTCTime, addUTCTime, getCurrentTime, nominalDay) -import Share.JWT qualified as JWT -import Share.OAuth.Types -import Share.Utils.Binary -import Share.Utils.IDs qualified as IDs -import Share.Utils.Servant.Cookies qualified as Cookies import GHC.Generics (Generic) import Network.HTTP.Types qualified as Network import Network.URI import Network.Wai qualified as Wai import Servant import Servant.Server.Experimental.Auth qualified as ServantAuth +import Share.JWT qualified +import Share.OAuth.Types +import Share.Utils.Binary +import Share.Utils.IDs qualified as IDs +import Share.Utils.Servant.Cookies qualified as Cookies import Web.Cookie (parseCookies) -- | Requires a valid session cookie to be present in the request and provides it as an @@ -98,7 +98,7 @@ checkOptionalAuthenticatedSession :: Text -> SessionCheck -> Cookies.CookieSettings {- Not actually used yet, but will probably need it soon so this makes it future-compatible -} -> - JWT.JWTSettings -> + Share.JWT.JWTSettings -> ServantAuth.AuthHandler Wai.Request (Maybe Session) checkOptionalAuthenticatedSession sessionCookieName sessCheck _cookieSettings jwtSettings = ServantAuth.mkAuthHandler authHandler where @@ -117,23 +117,23 @@ checkOptionalAuthenticatedSession sessionCookieName sessCheck _cookieSettings jw (mbearer, rest) = BS.splitAt (BS.length bearer) authHdr guard (mbearer == bearer) pure rest - signedJWT <- MaybeT . pure . eitherToMaybe $ JWT.textToSignedJWT (Text.decodeUtf8 tokenBytes) - MaybeT . liftIO . fmap eitherToMaybe $ JWT.verifyJWT jwtSettings signedJWT + signedJWT <- MaybeT . pure . eitherToMaybe $ Share.JWT.textToSignedJWT (Text.decodeUtf8 tokenBytes) + MaybeT . liftIO . fmap eitherToMaybe $ Share.JWT.verifyJWT jwtSettings signedJWT cookieSession :: Wai.Request -> MaybeT Handler Session cookieSession req = do jwtCookieBytes <- MaybeT . pure $ do cookies' <- lookup Network.hCookie $ Wai.requestHeaders req let cookies = parseCookies cookies' lookup (Text.encodeUtf8 sessionCookieName) cookies - signedJWT <- MaybeT . pure . eitherToMaybe $ JWT.textToSignedJWT (Text.decodeUtf8 jwtCookieBytes) - MaybeT . liftIO . fmap eitherToMaybe $ JWT.verifyJWT jwtSettings signedJWT + signedJWT <- MaybeT . pure . eitherToMaybe $ Share.JWT.textToSignedJWT (Text.decodeUtf8 jwtCookieBytes) + MaybeT . liftIO . fmap eitherToMaybe $ Share.JWT.verifyJWT jwtSettings signedJWT eitherToMaybe = \case Left _ -> Nothing Right a -> Just a -- | Make an auth handler using an additional session check function. -checkRequiredAuthenticatedSession :: Text -> SessionCheck -> Cookies.CookieSettings -> JWT.JWTSettings -> ServantAuth.AuthHandler Wai.Request (Session) +checkRequiredAuthenticatedSession :: Text -> SessionCheck -> Cookies.CookieSettings -> Share.JWT.JWTSettings -> ServantAuth.AuthHandler Wai.Request (Session) checkRequiredAuthenticatedSession sessionCookieName sessCheck cookieSettings jwtSettings = ServantAuth.mkAuthHandler $ \req -> do ServantAuth.unAuthHandler (checkOptionalAuthenticatedSession sessionCookieName sessCheck cookieSettings jwtSettings) req >>= \case @@ -154,7 +154,7 @@ type AuthCheckCtx = -- level authCheckCtx :: Cookies.CookieSettings -> - JWT.JWTSettings -> + Share.JWT.JWTSettings -> Text -> Servant.Context AuthCheckCtx authCheckCtx cookieSettings jwtSettings sessionCookieName = @@ -173,7 +173,7 @@ authCheckCtx cookieSettings jwtSettings sessionCookieName = addAuthCheckCtx :: Cookies.CookieSettings -> - JWT.JWTSettings -> + Share.JWT.JWTSettings -> Text -> Servant.Context (appCtx :: [Type]) -> Servant.Context (AuthCheckCtx .++ appCtx) @@ -220,7 +220,7 @@ data Session = Session deriving stock (Show) deriving (Binary) via JSONBinary Session -instance JWT.ToJWT Session where +instance Share.JWT.ToJWT Session where encodeJWT (Session (SessionId sessionId) userID created expiry issuer aud) = JWT.emptyClaimsSet & JWT.claimSub ?~ (JWT.string # IDs.toText userID) @@ -230,7 +230,7 @@ instance JWT.ToJWT Session where & JWT.claimIss ?~ (JWT.uri # issuer) & JWT.claimAud ?~ JWT.Audience (review JWT.uri <$> Set.toList aud) -instance JWT.FromJWT Session where +instance Share.JWT.FromJWT Session where decodeJWT claims = do sessionUserId <- maybeToEither "Missing sub claim" (claims ^? JWT.claimSub . _Just . JWT.string) >>= IDs.fromText sessionId <- @@ -247,12 +247,12 @@ instance JWT.FromJWT Session where maybeToEither e = maybe (Left e) Right instance ToJSON Session where - toJSON s = toJSON $ JWT.encodeJWT s + toJSON s = toJSON $ Share.JWT.encodeJWT s instance FromJSON Session where parseJSON v = do claims <- parseJSON v - either (fail . Text.unpack) pure $ JWT.decodeJWT claims + either (fail . Text.unpack) pure $ Share.JWT.decodeJWT claims data PendingSession = PendingSession { pendingId :: PendingSessionId, @@ -283,7 +283,7 @@ sessionTTL :: NominalDiffTime sessionTTL = (30 * nominalDay) -createSession :: MonadIO m => URI -> Set URI -> UserId -> m Session +createSession :: (MonadIO m) => URI -> Set URI -> UserId -> m Session createSession sessionIssuer sessionAudience sessionUserId = do sessionId <- randomIO sessionCreated <- liftIO getCurrentTime diff --git a/src/Share/App.hs b/src/Share/App.hs index 9e12f59..47e113c 100644 --- a/src/Share/App.hs +++ b/src/Share/App.hs @@ -2,10 +2,8 @@ module Share.App where -import Control.Monad.Except import Control.Monad.Random.Strict import Control.Monad.Reader -import Crypto.JWT qualified as JWT import Crypto.Random.Types qualified as Cryptonite import Data.Set qualified as Set import Database.Redis qualified as R diff --git a/src/Share/Backend.hs b/src/Share/Backend.hs index 6aaacdc..24a5320 100644 --- a/src/Share/Backend.hs +++ b/src/Share/Backend.hs @@ -76,7 +76,7 @@ import Unison.Server.Types import Unison.ShortHash qualified as SH import Unison.Symbol (Symbol) import Unison.Syntax.DeclPrinter qualified as DeclPrinter -import Unison.Syntax.HashQualified' qualified as HQ' (toText) +import Unison.Syntax.HashQualifiedPrime qualified as HQ' (toText) import Unison.Term qualified as Term import Unison.Term qualified as V1 import Unison.Term qualified as V1Term diff --git a/src/Share/Prelude.hs b/src/Share/Prelude.hs index a1a0616..01e7a70 100644 --- a/src/Share/Prelude.hs +++ b/src/Share/Prelude.hs @@ -122,9 +122,6 @@ guardMaybe (Just a) = pure a guardMaybeM :: (Monad m, Alternative m) => m (Maybe b) -> m b guardMaybeM m = m >>= guardMaybe -hoistMaybe :: (Monad m) => Maybe a -> MaybeT m a -hoistMaybe = MaybeT . pure - -- | Like 'fold' but for Alternative. altSum :: (Alternative f, Foldable t) => t (f a) -> f a altSum = foldl' (<|>) empty @@ -198,7 +195,7 @@ wundefined :: (HasCallStack) => a wundefined = undefined -- | Map both sides of a bifunctor. -bothMap :: Bifunctor f => (a -> b) -> f a a -> f b b +bothMap :: (Bifunctor f) => (a -> b) -> f a a -> f b b bothMap f = bimap f f -- | Partition a list into two lists, based on a function that returns either a Left or a Right. diff --git a/src/Share/Web/Authentication/JWT.hs b/src/Share/Web/Authentication/JWT.hs index 9027cfa..dbb0dd2 100644 --- a/src/Share/Web/Authentication/JWT.hs +++ b/src/Share/Web/Authentication/JWT.hs @@ -1,4 +1,5 @@ {-# LANGUAGE RecordWildCards #-} +{-# OPTIONS_GHC -Wno-deprecations #-} module Share.Web.Authentication.JWT where @@ -16,6 +17,7 @@ import Share.App import Share.Env qualified as Env import Share.IDs (JTI (..), SessionId (..), UserId (..)) import Share.IDs qualified as IDs +import Share.JWT qualified import Share.JWT qualified as JWT import Share.Prelude import Share.Web.App @@ -74,10 +76,10 @@ shareStandardClaims aud sub ttl (SessionId sessionIdUUID) = do let exp = addUTCTime ttl iat pure (StandardClaims {..}) -signJWT :: JWT.ToJWT a => a -> WebApp SignedJWT +signJWT :: (JWT.ToJWT a) => a -> WebApp SignedJWT signJWT claims = do jSettings <- asks Env.jwtSettings - JWT.signJWT jSettings claims >>= \case + Share.JWT.signJWT jSettings claims >>= \case Left err -> respondError (InternalServerError "jwt:signing-error" err) Right a -> pure a @@ -91,7 +93,7 @@ signJWT claims = do verifyJWT :: forall claims reqCtx. (JWT.FromJWT claims, Typeable claims) => SignedJWT -> (claims -> Maybe AuthenticationErr) -> AppM reqCtx (Either AuthenticationErr claims) verifyJWT signedJWT checks = do jwtS <- asks Env.jwtSettings - Either.mapLeft JWTErr <$> JWT.verifyJWT @claims jwtS signedJWT <&> \case + Either.mapLeft JWTErr <$> Share.JWT.verifyJWT @claims jwtS signedJWT <&> \case Left err -> Left err Right a -> case checks a of Nothing -> Right a diff --git a/src/Unison/PrettyPrintEnvDecl/Postgres.hs b/src/Unison/PrettyPrintEnvDecl/Postgres.hs index a07e608..7e384e2 100644 --- a/src/Unison/PrettyPrintEnvDecl/Postgres.hs +++ b/src/Unison/PrettyPrintEnvDecl/Postgres.hs @@ -10,7 +10,7 @@ import Share.Postgres.NameLookups.Types (NamesPerspective) import Share.Postgres.NameLookups.Types qualified as NameLookups import Share.Postgres.Refs.Types import Share.Prelude -import Unison.HashQualified' qualified as HQ' +import Unison.HashQualifiedPrime qualified as HQ' import Unison.LabeledDependency (LabeledDependency) import Unison.Name (Name) import Unison.PrettyPrintEnv qualified as PPE diff --git a/src/Unison/Server/NameSearch/Postgres.hs b/src/Unison/Server/NameSearch/Postgres.hs index 735335b..39bfe7f 100644 --- a/src/Unison/Server/NameSearch/Postgres.hs +++ b/src/Unison/Server/NameSearch/Postgres.hs @@ -13,7 +13,7 @@ import Share.Postgres.NameLookups.Ops as NLOps import Share.Postgres.NameLookups.Types import Share.Prelude import Unison.Codebase.Path qualified as Path -import Unison.HashQualified' qualified as HQ' +import Unison.HashQualifiedPrime qualified as HQ' import Unison.Name (Name) import Unison.Name qualified as Name import Unison.NameSegment.Internal (NameSegment (..)) diff --git a/src/Unison/Server/Share/Definitions.hs b/src/Unison/Server/Share/Definitions.hs index e3f1be5..0b963af 100644 --- a/src/Unison/Server/Share/Definitions.hs +++ b/src/Unison/Server/Share/Definitions.hs @@ -33,7 +33,7 @@ import Unison.DataDeclaration qualified as DD import Unison.DataDeclaration.Dependencies qualified as DD import Unison.Debug qualified as Debug import Unison.HashQualified qualified as HQ -import Unison.HashQualified' qualified as HQ' +import Unison.HashQualifiedPrime qualified as HQ' import Unison.LabeledDependency qualified as LD import Unison.Name (Name) import Unison.Parser.Ann (Ann) diff --git a/src/Unison/Server/Share/Docs.hs b/src/Unison/Server/Share/Docs.hs index aabf1e7..d69bafe 100644 --- a/src/Unison/Server/Share/Docs.hs +++ b/src/Unison/Server/Share/Docs.hs @@ -7,7 +7,7 @@ import Share.Codebase qualified as Codebase import Share.Postgres qualified as PG import Share.Prelude import Share.Web.Errors (SomeServerError) -import Unison.HashQualified' qualified as HQ' +import Unison.HashQualifiedPrime qualified as HQ' import Unison.Name (Name) import Unison.NameSegment.Internal (NameSegment (..)) import Unison.NamesWithHistory (SearchType (ExactName)) diff --git a/stack.yaml b/stack.yaml index fae3c09..4a51a48 100644 --- a/stack.yaml +++ b/stack.yaml @@ -1,4 +1,4 @@ -resolver: lts-20.26 +resolver: lts-22.26 packages: - . @@ -39,15 +39,15 @@ packages: extra-deps: # wrong version in snapshot - resource-pool-0.3.1.0@sha256:dbaadfcc3c1be5391336e2016b28bb2d0c534f245ba9f5af5ed1d5125afc8c1a,1280 -- fuzzyfind-3.0.1@sha256:78f89c1d79adf0a15fa2e57c693d42b4765ccfbbe380d0c9d7da6bff9f124f85,1823 +- fuzzyfind-3.0.2@sha256:0fcd64eb1016fe0d0232abc26b2b80b32d676707ff41d155a28df8a9572603d4,1921 - guid-0.1.0@sha256:a7c975be473f6f142d5cc1b39bc807a99043d20b1bb0873fdfe7a3ce84d2faf1,1078 - lock-file-0.7.0.0@sha256:3ad84b5e454145e1d928063b56abb96db24a99a21b493989520e58fa0ab37b00,4484 -- monad-validate-1.2.0.1@sha256:5a100da896f11ca4b7c123da85decbedeb46c37054a097f258ac911e715cb68d,2587 +- monad-validate-1.3.0.0@sha256:eb6ddd5c9cf72ff0563cba604fa00291376e96138fdb4932d00ff3a99d66706e,2605 - raven-haskell-0.1.4.1@sha256:0d27e37968327faba577558a2ee4465ebfd3b6929b09cf4881dfa62a6873c85a,1393 -- recover-rtti-0.4.2@sha256:c179a303921126d8d782264e14f386c96e54a270df74be002e4c4ec3c8c7aebd,4529 - strings-1.1@sha256:0285dec4c8ab262359342b3e5ef1eb567074669461b9b38404f1cb870c881c5c,1617 -- hasql-interpolate-0.2.1.0@sha256:1cf2a01e83d155fabc6ae3e686c75dfe174cbc3addbe7c8ec55fe17368a3458c,3103 +- hasql-interpolate-0.2.2.0@sha256:e6dcd161bd7147915f5f837b2dfc6f1710d6f0ce47341944ea1925194b8ed1fd,3206 - network-udp-0.0.0@sha256:408d2d4fa1a25e49e95752ee124cca641993404bb133ae10fb81daef22d876ae,1075 +- recover-rtti-0.5.0@sha256:7d598b0c89dac9e170b488a7a50b322fcae06342fbd2da18cb8a7f93a0b44e68,4913 ghc-options: # All packages diff --git a/stack.yaml.lock b/stack.yaml.lock index 4c1009a..85ab95b 100644 --- a/stack.yaml.lock +++ b/stack.yaml.lock @@ -12,12 +12,12 @@ packages: original: hackage: resource-pool-0.3.1.0@sha256:dbaadfcc3c1be5391336e2016b28bb2d0c534f245ba9f5af5ed1d5125afc8c1a,1280 - completed: - hackage: fuzzyfind-3.0.1@sha256:78f89c1d79adf0a15fa2e57c693d42b4765ccfbbe380d0c9d7da6bff9f124f85,1823 + hackage: fuzzyfind-3.0.2@sha256:0fcd64eb1016fe0d0232abc26b2b80b32d676707ff41d155a28df8a9572603d4,1921 pantry-tree: - sha256: 46f001ec2725d3172161c993bc8fbcf0514e3ba736f868fe2c2655e1ff49dad1 + sha256: 5bb9d39dbc4a619cf9b65409dde0d58dd488c7abab030f71ac83ba849595ee05 size: 542 original: - hackage: fuzzyfind-3.0.1@sha256:78f89c1d79adf0a15fa2e57c693d42b4765ccfbbe380d0c9d7da6bff9f124f85,1823 + hackage: fuzzyfind-3.0.2@sha256:0fcd64eb1016fe0d0232abc26b2b80b32d676707ff41d155a28df8a9572603d4,1921 - completed: hackage: guid-0.1.0@sha256:a7c975be473f6f142d5cc1b39bc807a99043d20b1bb0873fdfe7a3ce84d2faf1,1078 pantry-tree: @@ -33,12 +33,12 @@ packages: original: hackage: lock-file-0.7.0.0@sha256:3ad84b5e454145e1d928063b56abb96db24a99a21b493989520e58fa0ab37b00,4484 - completed: - hackage: monad-validate-1.2.0.1@sha256:5a100da896f11ca4b7c123da85decbedeb46c37054a097f258ac911e715cb68d,2587 + hackage: monad-validate-1.3.0.0@sha256:eb6ddd5c9cf72ff0563cba604fa00291376e96138fdb4932d00ff3a99d66706e,2605 pantry-tree: - sha256: 034ee4de9765e38b763f5d73b236cc112205728e680cefbfe12d2882accc3264 + sha256: 0b2a3a57be48fcc739708b214fca202f1e95b1cd773dd3bb9589d3007cf8cf5e size: 611 original: - hackage: monad-validate-1.2.0.1@sha256:5a100da896f11ca4b7c123da85decbedeb46c37054a097f258ac911e715cb68d,2587 + hackage: monad-validate-1.3.0.0@sha256:eb6ddd5c9cf72ff0563cba604fa00291376e96138fdb4932d00ff3a99d66706e,2605 - completed: hackage: raven-haskell-0.1.4.1@sha256:0d27e37968327faba577558a2ee4465ebfd3b6929b09cf4881dfa62a6873c85a,1393 pantry-tree: @@ -46,13 +46,6 @@ packages: size: 632 original: hackage: raven-haskell-0.1.4.1@sha256:0d27e37968327faba577558a2ee4465ebfd3b6929b09cf4881dfa62a6873c85a,1393 -- completed: - hackage: recover-rtti-0.4.2@sha256:c179a303921126d8d782264e14f386c96e54a270df74be002e4c4ec3c8c7aebd,4529 - pantry-tree: - sha256: ad6f24481ebd25a1456d5dfaf08d48d95394ce83eb82a267e01d87d34f13bb83 - size: 2488 - original: - hackage: recover-rtti-0.4.2@sha256:c179a303921126d8d782264e14f386c96e54a270df74be002e4c4ec3c8c7aebd,4529 - completed: hackage: strings-1.1@sha256:0285dec4c8ab262359342b3e5ef1eb567074669461b9b38404f1cb870c881c5c,1617 pantry-tree: @@ -61,12 +54,12 @@ packages: original: hackage: strings-1.1@sha256:0285dec4c8ab262359342b3e5ef1eb567074669461b9b38404f1cb870c881c5c,1617 - completed: - hackage: hasql-interpolate-0.2.1.0@sha256:1cf2a01e83d155fabc6ae3e686c75dfe174cbc3addbe7c8ec55fe17368a3458c,3103 + hackage: hasql-interpolate-0.2.2.0@sha256:e6dcd161bd7147915f5f837b2dfc6f1710d6f0ce47341944ea1925194b8ed1fd,3206 pantry-tree: - sha256: 00de19fbc18c5fe3bd55f30775cd6b9dab855d82cc8d1c01930978986f71fdfa + sha256: e826a06d038ef9e2f1fdbaec5c0e3fb1baca63dbb463498fbf1e2d7540545c67 size: 1276 original: - hackage: hasql-interpolate-0.2.1.0@sha256:1cf2a01e83d155fabc6ae3e686c75dfe174cbc3addbe7c8ec55fe17368a3458c,3103 + hackage: hasql-interpolate-0.2.2.0@sha256:e6dcd161bd7147915f5f837b2dfc6f1710d6f0ce47341944ea1925194b8ed1fd,3206 - completed: hackage: network-udp-0.0.0@sha256:408d2d4fa1a25e49e95752ee124cca641993404bb133ae10fb81daef22d876ae,1075 pantry-tree: @@ -74,9 +67,16 @@ packages: size: 284 original: hackage: network-udp-0.0.0@sha256:408d2d4fa1a25e49e95752ee124cca641993404bb133ae10fb81daef22d876ae,1075 +- completed: + hackage: recover-rtti-0.5.0@sha256:7d598b0c89dac9e170b488a7a50b322fcae06342fbd2da18cb8a7f93a0b44e68,4913 + pantry-tree: + sha256: 94ceb6ec0bf54a8f8baf6f9627ffb891de15836a0e505921a7a3b857e714125d + size: 2489 + original: + hackage: recover-rtti-0.5.0@sha256:7d598b0c89dac9e170b488a7a50b322fcae06342fbd2da18cb8a7f93a0b44e68,4913 snapshots: - completed: - sha256: 5a59b2a405b3aba3c00188453be172b85893cab8ebc352b1ef58b0eae5d248a2 - size: 650475 - url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/20/26.yaml - original: lts-20.26 + sha256: 8e7996960d864443a66eb4105338bbdd6830377b9f6f99cd5527ef73c10c01e7 + size: 719128 + url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/22/26.yaml + original: lts-22.26 From e81e9cba1e9a60aff52f27b515969852d7822ca0 Mon Sep 17 00:00:00 2001 From: Chris Penner Date: Mon, 15 Jul 2024 15:47:03 -0700 Subject: [PATCH 3/6] Remove upload-to-loose-code endpoints --- src/Share/Web/UCM/Sync/Impl.hs | 313 +-------------------------------- 1 file changed, 4 insertions(+), 309 deletions(-) diff --git a/src/Share/Web/UCM/Sync/Impl.hs b/src/Share/Web/UCM/Sync/Impl.hs index 457b230..ec77451 100644 --- a/src/Share/Web/UCM/Sync/Impl.hs +++ b/src/Share/Web/UCM/Sync/Impl.hs @@ -72,7 +72,7 @@ import Unison.Share.API.Hash qualified as Hash import Unison.Sync.API qualified as Sync import Unison.Sync.Common (causalHashToHash32, hash32ToCausalHash) import Unison.Sync.EntityValidation qualified as Sync -import Unison.Sync.Types (DownloadEntitiesError (..), DownloadEntitiesRequest (..), DownloadEntitiesResponse (..), FastForwardPathError, FastForwardPathRequest, FastForwardPathResponse, GetCausalHashByPathRequest (..), GetCausalHashByPathResponse (..), NeedDependencies (..), RepoInfo (..), UpdatePathRequest (..), UpdatePathResponse, UploadEntitiesError (..), UploadEntitiesRequest (..), UploadEntitiesResponse (..), pathCodebasePath, pathRepoInfo) +import Unison.Sync.Types (DownloadEntitiesError (..), DownloadEntitiesRequest (..), DownloadEntitiesResponse (..), GetCausalHashByPathRequest (..), GetCausalHashByPathResponse (..), NeedDependencies (..), RepoInfo (..), UpdatePathRequest (..), UpdatePathResponse, UploadEntitiesError (..), UploadEntitiesRequest (..), UploadEntitiesResponse (..), pathCodebasePath, pathRepoInfo) import Unison.Sync.Types qualified as Share import Unison.Sync.Types qualified as Sync import UnliftIO (MonadUnliftIO (withRunInIO)) @@ -84,21 +84,6 @@ data RepoInfoKind | RepoInfoProjectRelease ProjectReleaseShortHand deriving stock (Show) -data UnexpectedHashMismatch = UnexpectedHashMismatch - { providedHash :: ComponentHash, - actualHash :: ComponentHash - } - deriving stock (Show) - -instance ToServerError UnexpectedHashMismatch where - toServerError UnexpectedHashMismatch {providedHash, actualHash} = - ( ErrorID "hash-validation:unexpected-hash-mismatch", - err400 {errBody = LT.encodeUtf8 . LT.fromStrict $ "Unexpected hash mismatch. provided: " <> tShow providedHash <> " actual: " <> tShow actualHash} - ) - -instance Loggable UnexpectedHashMismatch where - toLog = withSeverity UserFault . showLog - -- | Parse a `RepoInfo` into the correct codebase view, e.g. -- -- >>> repoInfoKind (RepoInfo "@unison") @@ -136,12 +121,12 @@ repoInfoKind (RepoInfo repoInfo) = server :: Maybe Session -> ServerT Sync.API WebApp server (Just Session {sessionUserId}) = getCausalHashByPathEndpoint (Just sessionUserId) - :<|> fastForwardPathEndpoint sessionUserId - :<|> updatePathEndpoint sessionUserId :<|> downloadEntitiesEndpoint (Just sessionUserId) :<|> uploadEntitiesEndpoint sessionUserId server _ = - getCausalHashByPathEndpoint Nothing :<|> err :<|> err :<|> downloadEntitiesEndpoint Nothing :<|> err + getCausalHashByPathEndpoint Nothing + :<|> downloadEntitiesEndpoint Nothing + :<|> err where err :: a -> WebApp b err _ = respondError AuthN.UnauthenticatedError @@ -170,268 +155,6 @@ getCausalHashByPathEndpoint callerUserId (GetCausalHashByPathRequest sharePath) hashJwt <- lift $ HashJWT.signHashForUser callerUserId (causalHashToHash32 (Causal.causalHash causalAtPath)) pure (GetCausalHashByPathSuccess $ Just hashJwt) -fastForwardPathEndpoint :: UserId -> FastForwardPathRequest -> WebApp FastForwardPathResponse -fastForwardPathEndpoint callerUserId Share.FastForwardPathRequest {expectedHash, hashes, path = sharePath} = do - signJWTForUser <- withRunInIO \runInIO -> do - let sign :: Maybe UserId -> Hash32 -> CodebaseM FastForwardPathError Hash.HashJWT - sign mayUser hash = liftIO . runInIO $ HashJWT.signHashForUser mayUser hash - pure sign - result <- - either Share.FastForwardPathFailure id <$> runExceptT do - let repoInfo = pathRepoInfo sharePath - addRequestTag "repo-info" (unRepoInfo repoInfo) - IDs.PrefixedID userHandle <- lift . parseParam @(IDs.PrefixedID "@" UserHandle) "path" $ unRepoInfo repoInfo - codebaseOwner@User {user_id = codebaseOwnerUserId} <- lift (PG.runTransaction $ PGQ.userByHandle userHandle) `whenNothingM` throwError Share.FastForwardPathError'UserNotFound - let codebaseLoc = Codebase.codebaseLocationForUserCodebase codebaseOwnerUserId - codebase <- - lift (AuthZ.checkWriteUserCodebase callerUserId codebaseOwner authPath) >>= \case - Left {} -> throwError (Share.FastForwardPathError'NoWritePermission sharePath) - Right authZReceipt -> pure $ Codebase.codebaseEnv authZReceipt codebaseLoc - ExceptT $ Codebase.tryRunCodebaseTransaction codebase (doFastForward signJWTForUser) - pure result - where - localPath :: [Text] - localPath = pathCodebasePath sharePath - authPath :: Path.Path - authPath = Path.fromList (UNameSegment.NameSegment <$> localPath) - needShareCausalHash :: Hash32 -> ValidateT (NESet Hash32) (CodebaseM e) CausalId - needShareCausalHash = needCausalHash . hash32ToCausalHash - doFastForward :: - (Maybe UserId -> Hash32 -> CodebaseM FastForwardPathError Hash.HashJWT) -> - CodebaseM FastForwardPathError FastForwardPathResponse - doFastForward signJWTForUser = do - (existingRootCausalId, _hash) <- LCQ.loadLooseCodeRoot `whenNothingM` (throwError Share.FastForwardPathError'NoHistory) - -- check for missing hashes - (Validate.runValidateT ((,) <$> needShareCausalHash expectedHash <*> traverse needShareCausalHash hashes)) >>= \case - Left missingDependencies -> - (pure (Share.FastForwardPathFailure $ Share.FastForwardPathError'MissingDependencies Share.NeedDependencies {missingDependencies})) - Right (expectedCausalId, causalIds) -> do - -- all good - (verifyCausalParentage (expectedCausalId : NEList.toList causalIds)) >>= \case - Left (parentId, childId) -> do - parent <- causalHashToHash32 <$> CausalQ.expectCausalHashesByIdsOf id parentId - child <- causalHashToHash32 <$> CausalQ.expectCausalHashesByIdsOf id childId - pure . Share.FastForwardPathFailure $ Share.FastForwardPathError'InvalidParentage Share.InvalidParentage {parent, child} - Right () -> do - tryRebuildPath existingRootCausalId localPath (History expectedCausalId) (NEList.last causalIds) >>= \case - TryRebuildPathHashMismatch Prehistory -> pure . Share.FastForwardPathFailure $ Share.FastForwardPathError'NoHistory - TryRebuildPathHashMismatch (History (causalHashToHash32 -> actualHash)) -> - (Share.FastForwardPathFailure . Share.FastForwardPathError'NotFastForward <$> signJWTForUser (Just callerUserId) actualHash) - TryRebuildPathSuccess newRootCausalId -> do - let description = Just $ "Fast Forward at " <> Text.intercalate "." localPath - Codebase.setLooseCodeRoot callerUserId description newRootCausalId - pure Share.FastForwardPathSuccess - --- | parents come in to the left of children -verifyCausalParentage :: [CausalId] -> Codebase.CodebaseM e (Either (CausalId, CausalId) ()) -verifyCausalParentage = - runExceptT . traverse_ go . pairs - where - go :: (CausalId, CausalId) -> ExceptT (CausalId, CausalId) (Codebase.CodebaseM e) () - go pair@(ancestor, child) = - ExceptT do - success <- - PG.queryExpect1Col - [PG.sql| - SELECT EXISTS ( - SELECT FROM causal_ancestors - WHERE ancestor_id = #{ancestor} - AND causal_id = #{child} - ) - |] - pure if success then Right () else Left pair - - -- pairs [1,2,3] = [(1,2),(2,3)] - pairs :: [CausalId] -> [(CausalId, CausalId)] - pairs = \case - x : xs@(y : _) -> (x, y) : pairs xs - _ -> [] - -updatePathEndpoint :: UserId -> UpdatePathRequest -> WebApp UpdatePathResponse -updatePathEndpoint callerUserId (UpdatePathRequest {path = sharePath, expectedHash, newHash}) = - either id id <$> runExceptT do - let repoInfo = Share.pathRepoInfo sharePath - localPath = pathCodebasePath sharePath - authPath = Path.fromList (UNameSegment.NameSegment <$> localPath) - addRequestTag "repo-info" (unRepoInfo repoInfo) - IDs.PrefixedID userHandle <- lift . parseParam @(IDs.PrefixedID "@" UserHandle) "path" $ unRepoInfo repoInfo - codebaseOwner@User {user_id = codebaseOwnerUserId} <- lift (PG.runTransaction $ PGQ.userByHandle userHandle) `whenNothingM` throwError (Share.UpdatePathFailure $ Share.UpdatePathError'UserNotFound) - let codebaseLoc = Codebase.codebaseLocationForUserCodebase codebaseOwnerUserId - response <- - lift $ - AuthZ.checkWriteUserCodebase callerUserId codebaseOwner authPath >>= \case - Left {} -> pure (Share.UpdatePathFailure $ Share.UpdatePathError'NoWritePermission sharePath) - Right authZReceipt -> do - let codebase = Codebase.codebaseEnv authZReceipt codebaseLoc - action <- Codebase.runCodebaseTransaction codebase $ do - (existingRootCausalId, _) <- LCQ.expectLooseCodeRoot - let expectedCausalHash = hash32ToCausalHash <$> expectedHash - convertOrElaborate (maybeToHistory expectedCausalHash) (hash32ToCausalHash newHash) >>= \case - Left missing -> pure . pure $ (Share.UpdatePathFailure $ Share.UpdatePathError'MissingDependencies (Share.NeedDependencies missing)) - Right (expectedHistoryId, newHashId) -> do - tryRebuildPath existingRootCausalId localPath expectedHistoryId newHashId >>= \case - TryRebuildPathHashMismatch actualHash -> - pure . pure $ - Share.UpdatePathFailure $ - Share.UpdatePathError'HashMismatch - Share.HashMismatch - { path = sharePath, - expectedHash = expectedHash, - actualHash = causalHashToHash32 <$> historyToMaybe actualHash - } - TryRebuildPathSuccess newRootCausalId -> do - pure $ do - let description = Just $ "Update Path at " <> Text.intercalate "." localPath - -- Within a transaction, check if the root causal hash has changed while we were calculating the new one. - -- If not, commit the change in Postgres, if yes, fail and tell the user that - -- there's new code to pull. - result <- Codebase.runCodebaseTransaction codebase $ do - (preUpdateCHId, _) <- LCQ.expectLooseCodeRoot - if preUpdateCHId == existingRootCausalId - then do - Codebase.setLooseCodeRoot callerUserId description newRootCausalId - pure $ Right () - else Left <$> CausalQ.expectCausalHashesByIdsOf id preUpdateCHId - case result of - Right () -> do - pure Share.UpdatePathSuccess - Left actualHash -> - pure - . Share.UpdatePathFailure - $ Share.UpdatePathError'HashMismatch - Share.HashMismatch - { path = sharePath, - expectedHash = expectedHash, - actualHash = Just (causalHashToHash32 actualHash) - } - action - pure response - where - convertOrElaborate :: - History CausalHash -> - CausalHash -> - Codebase.CodebaseM e (Either (NESet Hash32) (History CausalId, CausalId)) - convertOrElaborate expectedHistory newCausalHash = Validate.runValidateT do - (,) <$> traverse needCausalHash expectedHistory <*> needCausalHash newCausalHash - -needCausalHash :: CausalHash -> ValidateT (NESet Hash32) (Codebase.CodebaseM e) CausalId -needCausalHash h = - lift (CausalQ.loadCausalIdByHash h) >>= \case - Nothing -> do - lift (SyncQ.elaborateHashes (NESet.singleton (causalHashToHash32 h))) >>= \case - (Just neededHashes, _) -> Validate.refute neededHashes - (Nothing, _) -> do - error "impossible: elaborateHashes returned an empty set, but we knew it should at least return `newCausalHash`" - -- Flushing may have made the hash available, so try one more time. - Just newCausalHashId -> pure newCausalHashId - --- FIXME document this -tryRebuildPath :: (HasCallStack) => CausalId -> [NameSegment] -> History CausalId -> CausalId -> Codebase.CodebaseM e TryRebuildPathResult -tryRebuildPath startRootCausalId path expectedHistoryAtPathId newCausalId = do - (rebuilds, creates, actualHistoryAtPathId) <- excavate startRootCausalId path - if actualHistoryAtPathId /= expectedHistoryAtPathId - then TryRebuildPathHashMismatch <$> CausalQ.expectCausalHashesByIdsOf traversed actualHistoryAtPathId - else do - -- share invariant: we have branch objects for all causals - namespaceHashId <- CausalQ.expectNamespaceIdForCausal newCausalId - createdHashes <- create creates (namespaceHashId, newCausalId) - (_newRootBranchObjectId, newRootCausalId) <- rebuild createdHashes rebuilds - pure $ TryRebuildPathSuccess newRootCausalId - -data TryRebuildPathResult - = TryRebuildPathHashMismatch (History CausalHash) - | -- The new root causal hash - TryRebuildPathSuccess CausalId - --- | create the branches for paths that didn't exist, and save them to the codebase -create :: [Create] -> (BranchHashId, CausalId) -> CodebaseM e (BranchHashId, CausalId) -create cs (ch, bh) = do - foldrM createNamespace (ch, bh) cs - --- | Create and save a new namespace with a single child pointing at the provided causal. -createNamespace :: Create -> (BranchHashId, CausalId) -> CodebaseM e (BranchHashId, CausalId) -createNamespace (Create ns) branchIds = do - saveNewCausalBranch - ((BranchFull.emptyBranch :: PgNamespace) & field @"children" .~ Map.singleton ns branchIds) - Set.empty - --- | rebuild the contents of this stack using the supplied Causal/Branch pair. --- --- E.g. rebuild branchId [Rebuild chId branch "b", Rebuild chId2 branch2 "a"] will --- set "a.b" = branchId and will rehash and save the "a" child to contain it. -rebuild :: (BranchHashId, CausalId) -> [Rebuild] -> CodebaseM e (BranchHashId, CausalId) -rebuild hashes = \case - [] -> pure hashes - Rebuild oldChId oldBranch ns : rest -> do - newBranchIds <- do - let newBranch = - oldBranch & field @"children" %~ Map.insert ns hashes - saveNewCausalBranch newBranch (Set.singleton oldChId) - rebuild newBranchIds rest - -saveNewCausalBranch :: PgNamespace -> Set CausalId -> CodebaseM e (BranchHashId, CausalId) -saveNewCausalBranch branch ancestorIds = do - (branchHashId, _branchHash) <- CausalQ.savePgNamespace Nothing branch - (causalId, _causalHash) <- CausalQ.saveCausal Nothing branchHashId ancestorIds - pure (branchHashId, causalId) - -type NameSegment = Text - -type NameSegmentId = TextId - --- Information that's needed to rebuild a branch (because we are adding or updating a child). -data Rebuild = Rebuild - { -- The branch's causal id and the branch itself. - causalId :: CausalId, - branch :: PgNamespace, - -- The name of the child that's being added or updated. - name :: NameSegmentId - } - deriving stock (Show) - --- Information that's needed to build a new branch with a single child. -newtype Create = Create NameSegmentId - deriving stock (Show) - --- FIXME document this --- include in docs this factoid: rebuilds in reverse order, creates in forward order --- --- mention invariant that (length rebuilds + length creates = length path) --- also mention this: --- --- when check-and-setting path foo.bar.baz.qux, --- --- if exists, 0 rebuild 4 create --- if . exists, 1 rebuild 3 create --- if .foo exists, 2 rebuild 2 create --- if .foo.bar exists, 3 rebuild 1 create --- if .foo.bar.baz exists, 4 rebuild 0 create -excavate :: (HasCallStack) => CausalId -> [NameSegment] -> CodebaseM e ([Rebuild], [Create], History CausalId) -excavate rootCausalHashId = \path -> do - pathIds <- lift $ Defn.ensureTextIds path - loop [] (History rootCausalHashId) pathIds - where - -- First argument: the rebuilds we've accumulated so far. (Loop doesn't inspect them, just cons-es). - -- Second argument: the causal at the current point in the path - -- Third argument: the remaining/unvisited segments of the path - -- - -- For example, if we are "excavating" path ["foo", "bar", "baz"], we might end up with arguments - -- - -- Arg 1: [ rebuild of ".", rebuild of ".foo" ] - -- Arg 2: The causal of ".foo.bar" - -- Arg 3: The remaining path ["baz"] - loop :: (HasCallStack) => [Rebuild] -> History CausalId -> [NameSegmentId] -> CodebaseM e ([Rebuild], [Create], History CausalId) - loop rebuilds history remainingPath = case history of - Prehistory -> pure (rebuilds, Create <$> remainingPath, Prehistory) - History cId -> case remainingPath of - [] -> do - pure (rebuilds, [], History cId) - nsId : rest -> do - namespace@BranchFull.Branch {children} <- CausalQ.expectPgCausalNamespace cId >>= value - let rebuilds' = Rebuild cId namespace nsId : rebuilds - let childChId = maybeToHistory (snd <$> Map.lookup nsId children) - loop rebuilds' childChId rest - downloadEntitiesEndpoint :: Maybe UserId -> DownloadEntitiesRequest -> WebApp DownloadEntitiesResponse downloadEntitiesEndpoint mayUserId DownloadEntitiesRequest {repoInfo, hashes = hashJWTs} = either id id <$> runExceptT do @@ -707,34 +430,6 @@ validateEntity checkIfComponentHashMismatchIsAllowed checkIfCausalHashMismatchIs pure (Just err) Nothing -> pure Nothing ------------------------------------------------------------------------------------------------------------------------- --- History type --- --- There are a couple places where Maybes were nested, and some of them are semantically representing a causal history, --- or lack thereof, hence this type. --- --- Hopefully it makes code easier to read and reason about, especially in the presence of multiple layers of Maybe, but --- if not ("wait, what's a History?"), it could be deleted and replaced with Maybe again. - --- | A @History a@ represents either the absence of any history, or a single @a@ that encapsulates its own history. --- --- For example, a @History CausalHash@ can represent the history of a particular name in a namespace: either nothing's --- ever had that name before, so there's no history ('Prehistory'), or there is some causal there ('History'). -data History a - = Prehistory - | History a - deriving stock (Eq, Foldable, Functor, Show, Traversable) - -maybeToHistory :: Maybe a -> History a -maybeToHistory = \case - Nothing -> Prehistory - Just x -> History x - -historyToMaybe :: History a -> Maybe a -historyToMaybe = \case - Prehistory -> Nothing - History x -> Just x - -- | Get the actual codebase path from a Sync path, since the sync path has the user as the -- first segment. looseCodeCodebasePath :: Sync.Path -> Path.Path From 5be10ef781acfe9cf3cff9beed992ce3c70d5a9b Mon Sep 17 00:00:00 2001 From: Chris Penner Date: Tue, 16 Jul 2024 10:10:35 -0700 Subject: [PATCH 4/6] Update unison submodule --- unison | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/unison b/unison index 7019595..605e062 160000 --- a/unison +++ b/unison @@ -1 +1 @@ -Subproject commit 7019595b7ba9fffea3dcb295a72fdbf0a1c147ca +Subproject commit 605e062bcfc3118ee83ca35c7d86a4036adea22f From 79277266b97386178b798b729d3a097e6e5b556b Mon Sep 17 00:00:00 2001 From: Chris Penner Date: Tue, 16 Jul 2024 10:10:51 -0700 Subject: [PATCH 5/6] Update to new lts --- app/Env.hs | 9 ++++++++- src/Share/Backend.hs | 1 - src/Share/Postgres/Contributions/Queries.hs | 1 - src/Share/Postgres/Tickets/Queries.hs | 1 - src/Share/Web/Authentication/AccessToken.hs | 8 ++++---- src/Share/Web/UCM/Sync/Impl.hs | 17 ++--------------- src/Unison/Server/Share/Definitions.hs | 1 - src/Unison/Server/Share/FuzzyFind.hs | 1 - src/Unison/Server/Share/NamespaceDetails.hs | 1 - src/Unison/Server/Share/NamespaceListing.hs | 9 ++++----- src/Unison/Server/Share/RenderDoc.hs | 1 - 11 files changed, 18 insertions(+), 32 deletions(-) diff --git a/app/Env.hs b/app/Env.hs index 6cf8c90..67bca31 100644 --- a/app/Env.hs +++ b/app/Env.hs @@ -32,6 +32,7 @@ import System.Log.Raven qualified as Sentry import System.Log.Raven.Transport.HttpConduit qualified as Sentry import System.Log.Raven.Types qualified as Sentry import Unison.Runtime.Interface as RT +import Data.Time.Clock qualified as Time withEnv :: (Env () -> IO a) -> IO a withEnv action = do @@ -90,8 +91,14 @@ withEnv action = do let cookieSettings = Cookies.defaultCookieSettings Deployment.onLocal (Just (realToFrac cookieSessionTTL)) let sessionCookieKey = tShow Deployment.deployment <> "-share-session" redisConnection <- Redis.checkedConnect redisConfig + -- Set some very conservative defaults + let pgConnectionAcquisitionTimeout = Time.secondsToDiffTime 60 -- 1 minute + -- Helps prevent leaking connections if they somehow get forgotten about. + let pgConnectionMaxIdleTime = Time.secondsToDiffTime (60 * 5) -- 5 minutes + -- Limiting max lifetime helps cycle connections which may have accumulated memory cruft. + let pgConnectionMaxLifetime = Time.secondsToDiffTime (60 * 60) -- 1 hour pgConnectionPool <- - Pool.acquire postgresConnMax Nothing (Text.encodeUtf8 postgresConfig) + Pool.acquire postgresConnMax pgConnectionAcquisitionTimeout pgConnectionMaxLifetime pgConnectionMaxIdleTime (Text.encodeUtf8 postgresConfig) timeCache <- FL.newTimeCache FL.simpleTimeFormat -- E.g. 05/Sep/2023:13:23:56 -0700 sandboxedRuntime <- RT.startRuntime True RT.Persistent "share" let requestCtx = () diff --git a/src/Share/Backend.hs b/src/Share/Backend.hs index 24a5320..86d9712 100644 --- a/src/Share/Backend.hs +++ b/src/Share/Backend.hs @@ -35,7 +35,6 @@ module Share.Backend where import Control.Lens hiding ((??)) -import Control.Monad.Except import Data.List qualified as List import Data.Map qualified as Map import Share.Codebase (CodebaseM) diff --git a/src/Share/Postgres/Contributions/Queries.hs b/src/Share/Postgres/Contributions/Queries.hs index 16e6a07..618c678 100644 --- a/src/Share/Postgres/Contributions/Queries.hs +++ b/src/Share/Postgres/Contributions/Queries.hs @@ -20,7 +20,6 @@ module Share.Postgres.Contributions.Queries where import Control.Lens -import Control.Monad.Except import Data.List qualified as List import Data.Map qualified as Map import Data.Set qualified as Set diff --git a/src/Share/Postgres/Tickets/Queries.hs b/src/Share/Postgres/Tickets/Queries.hs index c5dd08c..6f960fe 100644 --- a/src/Share/Postgres/Tickets/Queries.hs +++ b/src/Share/Postgres/Tickets/Queries.hs @@ -18,7 +18,6 @@ module Share.Postgres.Tickets.Queries where import Control.Lens -import Control.Monad.Except import Data.List qualified as List import Data.Time (UTCTime) import Safe (lastMay) diff --git a/src/Share/Web/Authentication/AccessToken.hs b/src/Share/Web/Authentication/AccessToken.hs index 9702360..c465dd0 100644 --- a/src/Share/Web/Authentication/AccessToken.hs +++ b/src/Share/Web/Authentication/AccessToken.hs @@ -5,7 +5,7 @@ module Share.Web.Authentication.AccessToken where import Control.Lens hiding ((.=)) -import Crypto.JWT +import Crypto.JWT qualified as Crypto.JWT import Data.Aeson qualified as Aeson import Data.Map qualified as Map import Data.Set qualified as Set @@ -22,7 +22,7 @@ import Share.Postgres.Ops qualified as PGO import Share.Prelude import Share.User import Share.Web.App -import Share.Web.Authentication.JWT (verifyJWT) +import Share.Web.Authentication.JWT qualified as Auth.JWT import Share.Web.Authentication.JWT qualified as AuthJWT import Share.Web.Authentication.JWT qualified as JWT import Share.Web.Authentication.Types @@ -46,7 +46,7 @@ instance ToJWT AccessTokenClaims where JWT.encodeStandardClaims standardClaims (Map.fromList [("scope", Aeson.toJSON scope)]) instance FromJWT AccessTokenClaims where - decodeJWT :: ClaimsSet -> Either Text AccessTokenClaims + decodeJWT :: Crypto.JWT.ClaimsSet -> Either Text AccessTokenClaims decodeJWT claims = do (standardClaims, extra) <- JWT.decodeStandardClaims claims scope <- fromMaybe (Left "Invalid scope") (extra ^? ix "scope" . to (resultEither . Aeson.fromJSON)) @@ -59,7 +59,7 @@ instance FromJWT AccessTokenClaims where -- | A version of verifyAccessToken which returns an Either rather than throwing an exception. verifyAccessToken' :: Scopes -> AccessToken -> AppM reqCtx (Either AuthenticationErr AccessTokenClaims) verifyAccessToken' (Scopes requiredScopes) (AccessToken (JWTParam signed)) = do - verifyJWT signed extraClaimsChecks + Auth.JWT.verifyJWT signed extraClaimsChecks where extraClaimsChecks (AccessTokenClaims {scope = Scopes tokenScopes}) = let missingScopes = Set.difference requiredScopes tokenScopes diff --git a/src/Share/Web/UCM/Sync/Impl.hs b/src/Share/Web/UCM/Sync/Impl.hs index ec77451..2bd7131 100644 --- a/src/Share/Web/UCM/Sync/Impl.hs +++ b/src/Share/Web/UCM/Sync/Impl.hs @@ -14,21 +14,13 @@ where import Control.Lens import Control.Monad.Except (ExceptT (ExceptT), runExceptT) -import Control.Monad.Validate (ValidateT) -import Control.Monad.Validate qualified as Validate import Data.Foldable qualified as Foldable -import Data.Generics.Product import Data.List.NonEmpty qualified as NEL -import Data.List.NonEmpty qualified as NEList import Data.Map.NonEmpty (NEMap) import Data.Map.NonEmpty qualified as NEMap -import Data.Map.Strict qualified as Map import Data.Set qualified as Set import Data.Set.NonEmpty (NESet) import Data.Set.NonEmpty qualified as NESet -import Data.Text qualified as Text -import Data.Text.Lazy qualified as LT -import Data.Text.Lazy.Encoding qualified as LT import Servant import Share.App import Share.Codebase (CodebaseM) @@ -40,11 +32,8 @@ import Share.IDs qualified as IDs import Share.OAuth.Session (Session (..)) import Share.Postgres qualified as PG import Share.Postgres.Causal.Queries qualified as CausalQ -import Share.Postgres.Causal.Types -import Share.Postgres.Definitions.Queries qualified as Defn import Share.Postgres.Hashes.Queries qualified as HashQ import Share.Postgres.IDs -import Share.Postgres.LooseCode.Queries qualified as LCQ import Share.Postgres.Queries qualified as PGQ import Share.Postgres.Sync.Queries (entityLocations) import Share.Postgres.Sync.Queries qualified as SyncQ @@ -61,7 +50,6 @@ import Share.Web.Errors import Share.Web.UCM.Sync.HashJWT qualified as HashJWT import Share.Web.UCM.Sync.Types (EntityBunch (..), EntityKind (..), entityKind) import U.Codebase.Causal qualified as Causal -import U.Codebase.Sqlite.Branch.Full qualified as BranchFull import U.Codebase.Sqlite.Orphans () import Unison.Codebase.Path qualified as Path import Unison.Hash32 (Hash32) @@ -70,12 +58,11 @@ import Unison.NameSegment.Internal qualified as UNameSegment import Unison.Share.API.Hash (HashJWTClaims (..)) import Unison.Share.API.Hash qualified as Hash import Unison.Sync.API qualified as Sync -import Unison.Sync.Common (causalHashToHash32, hash32ToCausalHash) +import Unison.Sync.Common (causalHashToHash32) import Unison.Sync.EntityValidation qualified as Sync -import Unison.Sync.Types (DownloadEntitiesError (..), DownloadEntitiesRequest (..), DownloadEntitiesResponse (..), GetCausalHashByPathRequest (..), GetCausalHashByPathResponse (..), NeedDependencies (..), RepoInfo (..), UpdatePathRequest (..), UpdatePathResponse, UploadEntitiesError (..), UploadEntitiesRequest (..), UploadEntitiesResponse (..), pathCodebasePath, pathRepoInfo) +import Unison.Sync.Types (DownloadEntitiesError (..), DownloadEntitiesRequest (..), DownloadEntitiesResponse (..), GetCausalHashByPathRequest (..), GetCausalHashByPathResponse (..), NeedDependencies (..), RepoInfo (..), UploadEntitiesError (..), UploadEntitiesRequest (..), UploadEntitiesResponse (..)) import Unison.Sync.Types qualified as Share import Unison.Sync.Types qualified as Sync -import UnliftIO (MonadUnliftIO (withRunInIO)) import UnliftIO qualified data RepoInfoKind diff --git a/src/Unison/Server/Share/Definitions.hs b/src/Unison/Server/Share/Definitions.hs index 0b963af..ac289f5 100644 --- a/src/Unison/Server/Share/Definitions.hs +++ b/src/Unison/Server/Share/Definitions.hs @@ -11,7 +11,6 @@ module Unison.Server.Share.Definitions where import Control.Lens hiding ((??)) -import Control.Monad.Except import Data.Bifoldable (bifoldMap) import Data.Either (partitionEithers) import Data.List qualified as List diff --git a/src/Unison/Server/Share/FuzzyFind.hs b/src/Unison/Server/Share/FuzzyFind.hs index fe57b6d..12b739f 100644 --- a/src/Unison/Server/Share/FuzzyFind.hs +++ b/src/Unison/Server/Share/FuzzyFind.hs @@ -11,7 +11,6 @@ module Unison.Server.Share.FuzzyFind where import Control.Lens -import Control.Monad.Except import Data.Aeson import Data.Aeson qualified as Aeson import Data.Char qualified as Char diff --git a/src/Unison/Server/Share/NamespaceDetails.hs b/src/Unison/Server/Share/NamespaceDetails.hs index 3e29416..406bf19 100644 --- a/src/Unison/Server/Share/NamespaceDetails.hs +++ b/src/Unison/Server/Share/NamespaceDetails.hs @@ -1,6 +1,5 @@ module Unison.Server.Share.NamespaceDetails (namespaceDetails) where -import Control.Monad.Except import Data.Set qualified as Set import Share.Codebase qualified as Codebase import Share.Codebase.Types (CodebaseM, CodebaseRuntime) diff --git a/src/Unison/Server/Share/NamespaceListing.hs b/src/Unison/Server/Share/NamespaceListing.hs index a112cdc..e0465e1 100644 --- a/src/Unison/Server/Share/NamespaceListing.hs +++ b/src/Unison/Server/Share/NamespaceListing.hs @@ -5,17 +5,16 @@ module Unison.Server.Share.NamespaceListing (serve, NamespaceListingAPI, NamespaceListing (..), NamespaceObject (..), NamedNamespace (..), NamedPatch (..), KindExpression (..)) where -import Control.Monad.Except import Data.Aeson +import Servant + ( QueryParam, + (:>), + ) import Share.Backend qualified as Backend import Share.Codebase (CodebaseM) import Share.Codebase qualified as Codebase import Share.Postgres.IDs (CausalId) import Share.Prelude -import Servant - ( QueryParam, - (:>), - ) import U.Codebase.Branch (NamespaceStats (..)) import U.Codebase.Causal qualified as V2Causal import U.Codebase.HashTags (CausalHash (..)) diff --git a/src/Unison/Server/Share/RenderDoc.hs b/src/Unison/Server/Share/RenderDoc.hs index ffcf0ea..b94fafe 100644 --- a/src/Unison/Server/Share/RenderDoc.hs +++ b/src/Unison/Server/Share/RenderDoc.hs @@ -10,7 +10,6 @@ -- | Helper for rendering docs within a given namespace module Unison.Server.Share.RenderDoc where -import Control.Monad.Except import Data.Set qualified as Set import Share.Backend qualified as Backend import Share.Codebase.Types (CodebaseM, CodebaseRuntime) From d7e7601084e47c2e908a9b7ff20efa5940f67194 Mon Sep 17 00:00:00 2001 From: Chris Penner Date: Tue, 16 Jul 2024 10:39:21 -0700 Subject: [PATCH 6/6] Bump stack version in CI --- .github/workflows/ci.yaml | 2 ++ 1 file changed, 2 insertions(+) diff --git a/.github/workflows/ci.yaml b/.github/workflows/ci.yaml index 853d80f..4462190 100644 --- a/.github/workflows/ci.yaml +++ b/.github/workflows/ci.yaml @@ -71,6 +71,8 @@ jobs: - name: install stack uses: unisonweb/actions/stack/install@main + with: + stack-version: 2.15.5 - name: build run: |