Merge pull request #11 from unisoncomputing/cp/lts-upgrade

Upgrade unison, and the LTS

.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: |

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 = ()

package.yaml

@@ -41,7 +41,6 @@ dependencies:
 - bytes
 - case-insensitive
 - clock
-- connection
 - containers
 - cookie
 - cryptonite

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

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

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)

share-auth/src/Share/OAuth/IdentityProvider/Share.hs

@@ -13,22 +13,22 @@ 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
 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

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"

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

share-auth/src/Share/OAuth/ServiceProvider.hs

@@ -20,13 +20,15 @@ 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
 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: