diff --git a/hie.yaml b/hie.yaml deleted file mode 100644 index b9a338f6..00000000 --- a/hie.yaml +++ /dev/null @@ -1,97 +0,0 @@ -cradle: - stack: - - path: "./src" - component: "share-api:lib" - - - path: "./app/Main.hs" - component: "share-api:exe:share-api" - - - path: "./app/Env.hs" - component: "share-api:exe:share-api" - - - path: "./share-auth/src" - component: "share-auth:lib" - - - path: "./share-auth/src" - component: "share-auth:lib" - - - path: "./share-utils/src" - component: "share-utils:lib" - - - path: "unison/codebase2/codebase/./" - component: "unison-codebase:lib" - - - path: "unison/codebase2/codebase-sqlite/./" - component: "unison-codebase-sqlite:lib" - - - path: "unison/codebase2/codebase-sync/./" - component: "unison-codebase-sync:lib" - - - path: "unison/codebase2/core/./" - component: "unison-core:lib" - - - path: "unison/codebase2/util/src" - component: "unison-util:lib" - - - path: "unison/codebase2/util/bench/Main.hs" - component: "unison-util:bench:bench" - - - path: "unison/codebase2/util-serialization/./" - component: "unison-util-serialization:lib" - - - path: "unison/codebase2/util-term/./" - component: "unison-util-term:lib" - - - path: "unison/lib/unison-prelude/src" - component: "unison-prelude:lib" - - - path: "unison/lib/unison-pretty-printer/src" - component: "unison-pretty-printer:lib" - - - path: "unison/lib/unison-pretty-printer/prettyprintdemo/Main.hs" - component: "unison-pretty-printer:exe:prettyprintdemo" - - - path: "unison/lib/unison-pretty-printer/tests" - component: "unison-pretty-printer:test:pretty-printer-tests" - - - path: "unison/lib/unison-sqlite/src" - component: "unison-sqlite:lib" - - - path: "unison/lib/unison-util-base32hex/src" - component: "unison-util-base32hex:lib" - - - path: "unison/lib/unison-util-base32hex-orphans-aeson/src" - component: "unison-util-base32hex-orphans-aeson:lib" - - - path: "unison/lib/unison-util-base32hex-orphans-sqlite/src" - component: "unison-util-base32hex-orphans-sqlite:lib" - - - path: "unison/lib/unison-util-relation/src" - component: "unison-util-relation:lib" - - - path: "unison/lib/unison-util-relation/test" - component: "unison-util-relation:test:util-relation-tests" - - - path: "unison/lib/unison-util-relation/benchmarks/relation/Main.hs" - component: "unison-util-relation:bench:relation" - - - path: "unison/parser-typechecker/src" - component: "unison-parser-typechecker:lib" - - - path: "unison/parser-typechecker/tests" - component: "unison-parser-typechecker:test:parser-typechecker-tests" - - - path: "unison/unison-core/src" - component: "unison-core1:lib" - - - path: "unison/unison-share-api/src" - component: "unison-share-api:lib" - - - path: "unison/yaks/easytest/src" - component: "easytest:lib" - - - path: "unison/yaks/easytest/tests/Suite.hs" - component: "easytest:exe:runtests" - - - path: "unison/yaks/easytest/tests" - component: "easytest:test:tests" diff --git a/package.yaml b/package.yaml index 20310511..f1b5caf2 100644 --- a/package.yaml +++ b/package.yaml @@ -110,6 +110,7 @@ dependencies: - servant - servant-auth - servant-client +- servant-client-core - servant-server - servant-conduit - serialise diff --git a/share-api.cabal b/share-api.cabal index f85663cf..099034bb 100644 --- a/share-api.cabal +++ b/share-api.cabal @@ -187,6 +187,7 @@ library Share.Web.Share.Tickets.Impl Share.Web.Share.Tickets.Types Share.Web.Share.Types + Share.Web.Share.Users.API Share.Web.Support.API Share.Web.Support.Impl Share.Web.Support.Types @@ -310,6 +311,7 @@ library , servant , servant-auth , servant-client + , servant-client-core , servant-conduit , servant-server , share-auth @@ -466,6 +468,7 @@ executable share-api , servant , servant-auth , servant-client + , servant-client-core , servant-conduit , servant-server , share-api diff --git a/share-auth/src/Share/OAuth/Session.hs b/share-auth/src/Share/OAuth/Session.hs index 5853cb94..06a281b2 100644 --- a/share-auth/src/Share/OAuth/Session.hs +++ b/share-auth/src/Share/OAuth/Session.hs @@ -29,6 +29,7 @@ where import Control.Applicative import Control.Monad.Random import Control.Monad.Trans.Maybe (MaybeT (..)) +import Crypto.JWT qualified as JWT import Data.Aeson import Data.Aeson qualified as Aeson import Data.Binary @@ -46,6 +47,7 @@ import Network.HTTP.Types qualified as Network import Network.URI import Network.Wai qualified as Wai import Servant +import Servant.Client.Core.Auth qualified as ServantAuth import Servant.Server.Experimental.Auth qualified as ServantAuth import Share.JWT import Share.OAuth.Types @@ -63,6 +65,8 @@ type AuthenticatedSession = Servant.AuthProtect "require-session" type instance ServantAuth.AuthServerData (Servant.AuthProtect "require-session") = Session +type instance ServantAuth.AuthClientData (Servant.AuthProtect "require-session") = JWT.SignedJWT + -- | Requires a valid session cookie to be present in the request, -- provides the authenticated user's user-id as an argument to the handler -- @@ -71,6 +75,8 @@ type AuthenticatedUserId = Servant.AuthProtect "require-user-id" type instance ServantAuth.AuthServerData (AuthProtect "require-user-id") = UserId +type instance ServantAuth.AuthClientData (AuthProtect "require-user-id") = JWT.SignedJWT + -- | Used for endpoints with optional auth. -- Provides 'Just' the session if a valid session cookie is present in the request, -- otherwise provides 'Nothing'. @@ -80,6 +86,8 @@ type MaybeAuthenticatedSession = Servant.AuthProtect "maybe-session" type instance ServantAuth.AuthServerData (AuthProtect "maybe-session") = Maybe Session +type instance ServantAuth.AuthClientData (AuthProtect "maybe-session") = Maybe JWT.SignedJWT + -- | Used for endpoints with optional auth. -- Provides 'Just' the user ID if a valid session cookie is present in the request, -- otherwise provides 'Nothing'. @@ -87,6 +95,8 @@ type MaybeAuthenticatedUserId = Servant.AuthProtect "maybe-user-id" type instance ServantAuth.AuthServerData (AuthProtect "maybe-user-id") = Maybe UserId +type instance ServantAuth.AuthClientData (AuthProtect "maybe-user-id") = Maybe JWT.SignedJWT + -- | An additional check to perform on a session. Returns True if valid, False otherwise. type SessionCheck = (Session -> Handler Bool) diff --git a/share-auth/src/Share/OAuth/Types.hs b/share-auth/src/Share/OAuth/Types.hs index 507825ba..9118f27f 100644 --- a/share-auth/src/Share/OAuth/Types.hs +++ b/share-auth/src/Share/OAuth/Types.hs @@ -42,15 +42,15 @@ import Data.Text (Text) import Data.Text qualified as Text import Data.Time (NominalDiffTime) import Data.UUID (UUID) +import GHC.TypeLits (Symbol, symbolVal) +import Hasql.Interpolate qualified as Hasql +import Servant import Share.JWT.Types import Share.OAuth.Scopes import Share.Utils.Binary (JSONBinary (..)) import Share.Utils.IDs import Share.Utils.Show (Censored (..)) import Share.Utils.URI (URIParam) -import GHC.TypeLits (Symbol, symbolVal) -import Hasql.Interpolate qualified as Hasql -import Servant import Web.FormUrlEncoded (FromForm (..), ToForm (..)) import Web.FormUrlEncoded qualified as Form @@ -117,10 +117,17 @@ newtype PKCEVerifier = PKCEVerifier Text deriving (Show) via Text data ResponseType = ResponseTypeCode + deriving stock (Show, Eq, Ord) instance ToJSON ResponseType where toJSON ResponseTypeCode = Aeson.String "code" +instance FromJSON ResponseType where + parseJSON = Aeson.withText "ResponseType" $ \txt -> do + case Text.toLower txt of + "code" -> pure ResponseTypeCode + _ -> fail $ "Unsupported response_type: " <> Text.unpack txt + instance ToHttpApiData ResponseType where toQueryParam = \case ResponseTypeCode -> "code" diff --git a/share-client/LICENSE b/share-client/LICENSE new file mode 100644 index 00000000..2b315a66 --- /dev/null +++ b/share-client/LICENSE @@ -0,0 +1,19 @@ +Copyright (c) 2024, Unison Computing, public benefit corp and contributors + +Permission is hereby granted, free of charge, to any person obtaining a copy +of this software and associated documentation files (the "Software"), to deal +in the Software without restriction, including without limitation the rights +to use, copy, modify, merge, publish, distribute, sublicense, and/or sell +copies of the Software, and to permit persons to whom the Software is +furnished to do so, subject to the following conditions: + +The above copyright notice and this permission notice shall be included in +all copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, +OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN +THE SOFTWARE. diff --git a/share-client/README.md b/share-client/README.md new file mode 100644 index 00000000..5c54d4e7 --- /dev/null +++ b/share-client/README.md @@ -0,0 +1 @@ +# share-client diff --git a/share-client/Setup.hs b/share-client/Setup.hs new file mode 100644 index 00000000..e8ef27db --- /dev/null +++ b/share-client/Setup.hs @@ -0,0 +1,3 @@ +import Distribution.Simple + +main = defaultMain diff --git a/share-client/package.yaml b/share-client/package.yaml new file mode 100644 index 00000000..f2be46d6 --- /dev/null +++ b/share-client/package.yaml @@ -0,0 +1,73 @@ +name: share-client +version: 0.1.0.0 +github: "unisoncomputing/share-api" +author: "Unison Computing" +maintainer: "Unison Computing" +copyright: "2024 Unison Computing" + +extra-source-files: +- README.md + +# Metadata used when publishing your package +# synopsis: Short description of your package +# category: Web + +# To avoid duplicated efforts in documentation and dealing with the +# complications of embedding Haddock markup inside cabal files, it is +# common to point users to the README.md file. +description: Please see the README on GitHub at + +ghc-options: +- -Wall +- -Werror +- -Wno-name-shadowing +- -Wno-type-defaults +- -Wno-missing-pattern-synonym-signatures +- -fprint-expanded-synonyms +- -fwrite-ide-info +- -O2 +- -funbox-strict-fields + +default-extensions: + - ApplicativeDo + - BangPatterns + - BlockArguments + - DeriveFunctor + - DeriveGeneric + - DeriveFoldable + - DeriveTraversable + - DerivingStrategies + - DerivingVia + - DoAndIfThenElse + - FlexibleContexts + - FlexibleInstances + - GeneralizedNewtypeDeriving + - InstanceSigs + - LambdaCase + - MultiParamTypeClasses + - NamedFieldPuns + - OverloadedStrings + - PatternSynonyms + - RankNTypes + - ScopedTypeVariables + - TupleSections + - TypeApplications + - ViewPatterns + - QuasiQuotes + - BlockArguments + - QuasiQuotes + - ImportQualifiedPost + +dependencies: +- base >= 4.7 && < 5 +- jose +- servant +- servant-client +- servant-client-core +- share-auth +- share-api +- text +- wai + +library: + source-dirs: src diff --git a/share-client/share-client.cabal b/share-client/share-client.cabal new file mode 100644 index 00000000..e64ee3b2 --- /dev/null +++ b/share-client/share-client.cabal @@ -0,0 +1,74 @@ +cabal-version: 1.12 + +-- This file has been generated from package.yaml by hpack version 0.37.0. +-- +-- see: https://github.com/sol/hpack + +name: share-client +version: 0.1.0.0 +description: Please see the README on GitHub at +homepage: https://github.com/unisoncomputing/share-api#readme +bug-reports: https://github.com/unisoncomputing/share-api/issues +author: Unison Computing +maintainer: Unison Computing +copyright: 2024 Unison Computing +license: MIT +license-file: LICENSE +build-type: Simple +extra-source-files: + README.md + +source-repository head + type: git + location: https://github.com/unisoncomputing/share-api + +library + exposed-modules: + Share.Client.Orgs + Share.Client.Users + Share.Client.Utils + other-modules: + Paths_share_client + hs-source-dirs: + src + default-extensions: + ApplicativeDo + BangPatterns + BlockArguments + DeriveFunctor + DeriveGeneric + DeriveFoldable + DeriveTraversable + DerivingStrategies + DerivingVia + DoAndIfThenElse + FlexibleContexts + FlexibleInstances + GeneralizedNewtypeDeriving + InstanceSigs + LambdaCase + MultiParamTypeClasses + NamedFieldPuns + OverloadedStrings + PatternSynonyms + RankNTypes + ScopedTypeVariables + TupleSections + TypeApplications + ViewPatterns + QuasiQuotes + BlockArguments + QuasiQuotes + ImportQualifiedPost + ghc-options: -Wall -Werror -Wno-name-shadowing -Wno-type-defaults -Wno-missing-pattern-synonym-signatures -fprint-expanded-synonyms -fwrite-ide-info -O2 -funbox-strict-fields + build-depends: + base >=4.7 && <5 + , jose + , servant + , servant-client + , servant-client-core + , share-api + , share-auth + , text + , wai + default-language: Haskell2010 diff --git a/share-client/src/Share/Client/Orgs.hs b/share-client/src/Share/Client/Orgs.hs new file mode 100644 index 00000000..5020d369 --- /dev/null +++ b/share-client/src/Share/Client/Orgs.hs @@ -0,0 +1,73 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DisambiguateRecordFields #-} +{-# LANGUAGE TypeOperators #-} + +module Share.Client.Orgs + ( createOrg, + addOrgRoles, + listOrgRoles, + removeOrgRoles, + listOrgMembers, + addOrgMembers, + removeOrgMembers, + + -- * Types + module OrgsAPI, + module Share.Web.Authorization.Types, + module Share.IDs, + ) +where + +import Crypto.JWT qualified as JWT +import Data.Proxy (Proxy (..)) +import Servant.API +import Servant.Client +import Servant.Client.Core +import Share.Client.Utils (jwtToAuthenticatedRequest) +import Share.IDs (UserHandle) +import Share.OAuth.Session (AuthenticatedUserId) +import Share.Web.API (OrgsAPI) +import Share.Web.Authorization.Types +import Share.Web.Authorization.Types qualified as OrgsAPI +import Share.Web.Share.DisplayInfo.Types +import Share.Web.Share.Orgs.API qualified as OrgsAPI +import Share.Web.Share.Orgs.Types + +orgsClient :: Client ClientM OrgsAPI +orgsClient = client (Proxy :: Proxy OrgsAPI) + +resourceRoutes :: UserHandle -> Client ClientM (NamedRoutes OrgsAPI.ResourceRoutes) +orgRolesRoutes :: UserHandle -> Client ClientM (NamedRoutes OrgsAPI.OrgRolesRoutes) +orgRolesRoutes = OrgsAPI.orgRoles <$> resourceRoutes + +orgMembersRoutes :: UserHandle -> Client ClientM (NamedRoutes OrgsAPI.OrgMembersRoutes) +orgMembersRoutes = OrgsAPI.orgMembers <$> resourceRoutes + +listOrgRoles :: JWT.SignedJWT -> UserHandle -> ClientM ListRolesResponse +listOrgRoles jwt userHandle = OrgsAPI.listOrgRoles (orgRolesRoutes userHandle) (jwtToAuthenticatedRequest jwt) + +removeOrgRoles :: JWT.SignedJWT -> UserHandle -> OrgsAPI.RemoveRolesRequest -> ClientM ListRolesResponse +removeOrgRoles jwt userHandle removeRolesReq = + OrgsAPI.removeOrgRoles (orgRolesRoutes userHandle) (jwtToAuthenticatedRequest jwt) removeRolesReq + +listOrgMembers :: JWT.SignedJWT -> UserHandle -> ClientM OrgMembersListResponse +listOrgMembers jwt userHandle = OrgsAPI.listOrgMembers (orgMembersRoutes userHandle) (jwtToAuthenticatedRequest jwt) + +addOrgMembers :: JWT.SignedJWT -> UserHandle -> OrgMembersAddRequest -> ClientM OrgMembersListResponse +addOrgMembers jwt userHandle addMembersReq = + OrgsAPI.addOrgMembers (orgMembersRoutes userHandle) (jwtToAuthenticatedRequest jwt) addMembersReq + +removeOrgMembers :: JWT.SignedJWT -> UserHandle -> OrgMembersRemoveRequest -> ClientM OrgMembersListResponse +removeOrgMembers jwt userHandle removeMembersReq = + OrgsAPI.removeOrgMembers (orgMembersRoutes userHandle) (jwtToAuthenticatedRequest jwt) removeMembersReq + +addOrgRoles :: JWT.SignedJWT -> UserHandle -> OrgsAPI.AddRolesRequest -> ClientM ListRolesResponse +addOrgRoles jwt userHandle addRolesReq = + OrgsAPI.addOrgRoles (orgRolesRoutes userHandle) (jwtToAuthenticatedRequest jwt) addRolesReq + +createOrg :: JWT.SignedJWT -> CreateOrgRequest -> ClientM OrgDisplayInfo +createOrg jwt createOrgReq = + createOrg' (jwtToAuthenticatedRequest jwt) createOrgReq + +createOrg' :: AuthenticatedRequest AuthenticatedUserId -> CreateOrgRequest -> ClientM OrgDisplayInfo +(createOrg' :<|> resourceRoutes) = orgsClient diff --git a/share-client/src/Share/Client/Users.hs b/share-client/src/Share/Client/Users.hs new file mode 100644 index 00000000..96e9927c --- /dev/null +++ b/share-client/src/Share/Client/Users.hs @@ -0,0 +1,35 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DisambiguateRecordFields #-} +{-# LANGUAGE TypeOperators #-} + +module Share.Client.Users + ( getUserProfile, + + -- * Types + module Share.Web.Share.Types, + module Share.IDs, + ) +where + +import Crypto.JWT qualified as JWT +import Data.Proxy (Proxy (..)) +import Servant.API +import Servant.Client +import Share.Client.Utils (maybeJwtToAuthenticatedRequest) +import Share.IDs (UserHandle) +import Share.Web.API (UsersAPI) +import Share.Web.Share.Types + +usersClient :: Client ClientM UsersAPI +usersClient = client (Proxy :: Proxy UsersAPI) + +getUserProfile :: Maybe JWT.SignedJWT -> UserHandle -> ClientM DescribeUserProfile +getUserProfile = \jwt handle -> + let ( _ :<|> userProfileEndpoint + :<|> _ + :<|> _ + :<|> _ + :<|> _ + :<|> _ + ) = usersClient (maybeJwtToAuthenticatedRequest jwt) handle + in userProfileEndpoint diff --git a/share-client/src/Share/Client/Utils.hs b/share-client/src/Share/Client/Utils.hs new file mode 100644 index 00000000..5ddc9c04 --- /dev/null +++ b/share-client/src/Share/Client/Utils.hs @@ -0,0 +1,27 @@ +{-# LANGUAGE TypeOperators #-} + +module Share.Client.Utils (jwtToAuthenticatedRequest, maybeJwtToAuthenticatedRequest) where + +import Crypto.JWT qualified as JWT +import Data.Foldable +import Data.Function ((&)) +import Data.List qualified as List +import Servant.Client.Core +import Servant.Client.Core qualified as Client +import Share.JWT qualified as ShareJWT + +jwtToAuthenticatedRequest :: (AuthClientData a ~ JWT.SignedJWT) => JWT.SignedJWT -> AuthenticatedRequest a +jwtToAuthenticatedRequest jwt = + mkAuthenticatedRequest jwt addJWTHeader + +maybeJwtToAuthenticatedRequest :: (AuthClientData a ~ Maybe JWT.SignedJWT) => Maybe JWT.SignedJWT -> AuthenticatedRequest a +maybeJwtToAuthenticatedRequest mayJWT = + mkAuthenticatedRequest mayJWT (maybe id addJWTHeader) + +addJWTHeader :: JWT.SignedJWT -> Request -> Request +addJWTHeader jwt req = + case List.lookup "Authorization" (toList $ Client.requestHeaders req) of + Nothing -> + req + & Client.addHeader "Authorization" ("Bearer " <> ShareJWT.signedJWTToText jwt) + Just _ -> req diff --git a/share-utils/src/Share/Utils/API.hs b/share-utils/src/Share/Utils/API.hs index 076a7df8..ec3ebd3d 100644 --- a/share-utils/src/Share/Utils/API.hs +++ b/share-utils/src/Share/Utils/API.hs @@ -10,6 +10,7 @@ module Share.Utils.API fromNullableUpdate, applySetUpdate, parseNullableUpdate, + nullableUpdateToJSON, emptySetUpdate, Cursor (..), Paged (..), @@ -86,6 +87,12 @@ parseNullableUpdate obj key = Just Aeson.Null -> pure Nullify Just v -> UpdateTo <$> parseJSON v +nullableUpdateToJSON :: (ToJSON a) => NullableUpdate a -> Maybe Value +nullableUpdateToJSON = \case + Unchanged -> Nothing + Nullify -> Just Aeson.Null + UpdateTo a -> Just (toJSON a) + -- | Perform a nullable update to an existing value and return the result. -- -- >>> fromNullableUpdate (Just 1) Unchanged @@ -132,11 +139,20 @@ data SetUpdate a -- | Type for specifying whether a value should be added or removed from a set. data AddOrRemove = Add | Remove - deriving (Show) + deriving (Show, Eq, Ord) emptySetUpdate :: SetUpdate a emptySetUpdate = SetUpdate Map.empty +instance forall a. (ToJSON a, Ord a, Typeable a) => ToJSON (SetUpdate a) where + toJSON = \case + SetUpdate updates -> + object + [ "add" .= Map.keys (Map.filter (== Add) updates), + "remove" .= Map.keys (Map.filter (== Remove) updates) + ] + SetReplacement new -> object ["replaceWith" .= Set.toList new] + instance forall a. (FromJSON a, Ord a, Typeable a) => FromJSON (SetUpdate a) where parseJSON = Aeson.withObject ("(SetUpdate" <> show (typeRep (Proxy @a)) <> ")") $ \obj -> do parseReplacement obj <|> parseAddOrRemove obj @@ -238,6 +254,13 @@ instance (ToJSON a, ToJSON cursor) => ToJSON (Paged cursor a) where "nextCursor" .= nextCursor ] +instance (FromJSON a, FromJSON cursor) => FromJSON (Paged cursor a) where + parseJSON = withObject "Paged" $ \obj -> do + items <- obj .: "items" + prevCursor <- obj .:? "prevCursor" + nextCursor <- obj .:? "nextCursor" + pure $ Paged items prevCursor nextCursor + guardPaged :: Bool -> Bool -> Paged cursor a -> Paged cursor a guardPaged hasPrev hasNext paged@(Paged {prevCursor, nextCursor}) = paged diff --git a/share-utils/src/Share/Utils/Aeson.hs b/share-utils/src/Share/Utils/Aeson.hs index 3083b166..705c3668 100644 --- a/share-utils/src/Share/Utils/Aeson.hs +++ b/share-utils/src/Share/Utils/Aeson.hs @@ -26,6 +26,9 @@ instance (Typeable a, ToJSON a) => ToJSON (MaybeEncoded a) where toEncoding (IsEncoded txt) = Aeson.toEncoding (PreEncoded @a txt) toEncoding (NotEncoded a) = Aeson.toEncoding a +instance (Aeson.FromJSON a) => Aeson.FromJSON (MaybeEncoded a) where + parseJSON v = NotEncoded <$> Aeson.parseJSON v + newtype PreEncoded a = PreEncoded BL.ByteString deriving stock (Show, Eq, Ord) @@ -38,3 +41,8 @@ instance (Typeable a) => ToJSON (PreEncoded a) where toEncoding :: (HasCallStack) => PreEncoded a -> Aeson.Encoding toEncoding (PreEncoded txt) = Encoding.unsafeToEncoding . Builder.fromLazyByteString $ txt + +instance (Aeson.FromJSON a) => Aeson.FromJSON (PreEncoded a) where + parseJSON v = do + -- TODO: This is a bit silly. + pure . PreEncoded $ Aeson.encode v diff --git a/share-utils/src/Share/Utils/Servant/Cookies.hs b/share-utils/src/Share/Utils/Servant/Cookies.hs index cd77d38c..564340a2 100644 --- a/share-utils/src/Share/Utils/Servant/Cookies.hs +++ b/share-utils/src/Share/Utils/Servant/Cookies.hs @@ -18,6 +18,7 @@ module Share.Utils.Servant.Cookies ) where +import Data.Binary.Builder qualified as Builder import Data.ByteString qualified as BS import Data.Function ((&)) import Data.Map (Map) @@ -70,6 +71,14 @@ instance (KnownSymbol s, FromHttpApiData a) => FromHttpApiData (CookieVal s a) w Just valTxt -> CookieVal . Just <$> parseQueryParam valTxt ) +instance (KnownSymbol s, ToHttpApiData a) => ToHttpApiData (CookieVal s a) where + toQueryParam (CookieVal Nothing) = "" + toQueryParam (CookieVal (Just a)) = + Text.pack (symbolVal (Proxy @s)) <> "=" <> toQueryParam a + toHeader (CookieVal Nothing) = "" + toHeader (CookieVal (Just a)) = + toHeader $ CookieMap $ Map.singleton (Text.pack $ symbolVal (Proxy @s)) (toQueryParam a) + type Cookies = Header "Cookie" CookieMap -- | This type is used by 'Cookies' and 'CookieVal' as a way to deserialize the Cookie header @@ -80,6 +89,15 @@ instance FromHttpApiData CookieMap where parseQueryParam _ = error "CookieMap used outside of Header field" parseHeader bs = Right . CookieMap . Map.fromList $ Cookie.parseCookiesText bs +instance ToHttpApiData CookieMap where + toQueryParam _ = error "CookieMap used outside of Header field" + + toHeader (CookieMap m) = + Map.toList m + & Cookie.renderCookiesText + & Builder.toLazyByteString + & BS.toStrict + -- | The @SameSite@ attribute of cookies determines whether cookies will be sent -- on cross-origin requests. -- diff --git a/src/Share/BackgroundJobs/Search/DefinitionSync/Types.hs b/src/Share/BackgroundJobs/Search/DefinitionSync/Types.hs index 87bb0aa5..4ec3749e 100644 --- a/src/Share/BackgroundJobs/Search/DefinitionSync/Types.hs +++ b/src/Share/BackgroundJobs/Search/DefinitionSync/Types.hs @@ -87,6 +87,12 @@ instance ToHttpApiData TermOrTypeTag where instance ToJSON TermOrTypeTag where toJSON = String . toQueryParam +instance FromJSON TermOrTypeTag where + parseJSON = withText "TermOrTypeTag" $ \txt -> + case parseQueryParam txt of + Left err -> fail $ Text.unpack err + Right tag -> pure tag + instance Hasql.EncodeValue TermOrTypeTag where encodeValue = Encoders.enum diff --git a/src/Share/BackgroundJobs/Webhooks/Worker.hs b/src/Share/BackgroundJobs/Webhooks/Worker.hs index 2316b65e..fea66b16 100644 --- a/src/Share/BackgroundJobs/Webhooks/Worker.hs +++ b/src/Share/BackgroundJobs/Webhooks/Worker.hs @@ -176,13 +176,12 @@ instance ToJSON (WebhookEventPayload ()) where ] instance FromJSON (WebhookEventPayload ()) where - parseJSON = Aeson.withObject "WebhookEventPayload" $ \o -> - WebhookEventPayload - <$> o Aeson..: "eventId" - <*> o Aeson..: "occurredAt" - <*> o Aeson..: "topic" - <*> o Aeson..: "data" - <*> pure () + parseJSON = Aeson.withObject "WebhookEventPayload" $ \o -> do + eventId <- o Aeson..: "eventId" + occurredAt <- o Aeson..: "occurredAt" + topic <- o Aeson..: "topic" + data_ <- o Aeson..: "data" + pure WebhookEventPayload {eventId, occurredAt, topic, data_, jwt = ()} tryWebhook :: NotificationEvent NotificationEventId UnifiedDisplayInfo UTCTime HydratedEvent -> diff --git a/src/Share/Contribution.hs b/src/Share/Contribution.hs index 27df62f1..af7f18b9 100644 --- a/src/Share/Contribution.hs +++ b/src/Share/Contribution.hs @@ -6,7 +6,7 @@ import Data.Aeson qualified as Aeson import Data.Time (UTCTime) import Hasql.Decoders qualified as Hasql import Hasql.Interpolate qualified as Hasql -import Servant (FromHttpApiData (..)) +import Servant (FromHttpApiData (..), ToHttpApiData (..)) import Share.IDs import Share.Postgres qualified as PG import Share.Postgres.IDs (CausalId) @@ -59,6 +59,13 @@ instance FromHttpApiData ContributionStatus where "merged" -> Right Merged _ -> Left "Invalid contribution status" +instance ToHttpApiData ContributionStatus where + toQueryParam = \case + Draft -> "draft" + InReview -> "in_review" + Closed -> "closed" + Merged -> "merged" + instance Hasql.DecodeValue ContributionStatus where decodeValue = do Hasql.decodeValue @Text & Hasql.refine \case diff --git a/src/Share/Notifications/API.hs b/src/Share/Notifications/API.hs index 92c5d210..bb1d5da9 100644 --- a/src/Share/Notifications/API.hs +++ b/src/Share/Notifications/API.hs @@ -124,6 +124,11 @@ instance ToJSON GetSubscriptionsResponse where toJSON GetSubscriptionsResponse {subscriptions} = object ["subscriptions" .= subscriptions] +instance FromJSON GetSubscriptionsResponse where + parseJSON = withObject "GetSubscriptionsResponse" $ \o -> do + subscriptions <- o .: "subscriptions" + pure GetSubscriptionsResponse {subscriptions} + type CreateSubscriptionEndpoint = AuthenticatedUserId :> ReqBody '[JSON] CreateSubscriptionRequest @@ -137,6 +142,15 @@ data CreateSubscriptionRequest subscriptionFilter :: Maybe SubscriptionFilter } +instance ToJSON CreateSubscriptionRequest where + toJSON CreateSubscriptionRequest {subscriptionScope, subscriptionTopics, subscriptionTopicGroups, subscriptionFilter} = + object + [ "scope" .= subscriptionScope, + "topics" .= subscriptionTopics, + "topicGroups" .= subscriptionTopicGroups, + "filter" .= subscriptionFilter + ] + instance FromJSON CreateSubscriptionRequest where parseJSON = withObject "CreateSubscriptionRequest" $ \o -> do subscriptionScope <- o .: "scope" @@ -154,6 +168,11 @@ instance ToJSON CreateSubscriptionResponse where toJSON CreateSubscriptionResponse {subscription} = object ["subscription" .= subscription] +instance FromJSON CreateSubscriptionResponse where + parseJSON = withObject "CreateSubscriptionResponse" $ \o -> do + subscription <- o .: "subscription" + pure CreateSubscriptionResponse {subscription} + type DeleteSubscriptionEndpoint = AuthenticatedUserId :> Capture "subscription_id" NotificationSubscriptionId @@ -172,6 +191,14 @@ data UpdateSubscriptionRequest subscriptionFilter :: Maybe SubscriptionFilter } +instance ToJSON UpdateSubscriptionRequest where + toJSON UpdateSubscriptionRequest {subscriptionTopics, subscriptionTopicGroups, subscriptionFilter} = + object + [ "topics" .= subscriptionTopics, + "topicGroups" .= subscriptionTopicGroups, + "filter" .= subscriptionFilter + ] + instance FromJSON UpdateSubscriptionRequest where parseJSON = withObject "UpdateSubscriptionRequest" $ \o -> do subscriptionTopics <- o .:? "topics" @@ -192,6 +219,11 @@ instance ToJSON GetDeliveryMethodsResponse where toJSON GetDeliveryMethodsResponse {deliveryMethods} = object ["deliveryMethods" .= deliveryMethods] +instance FromJSON GetDeliveryMethodsResponse where + parseJSON = withObject "GetDeliveryMethodsResponse" $ \o -> do + deliveryMethods <- o .: "deliveryMethods" + pure GetDeliveryMethodsResponse {deliveryMethods} + newtype StatusFilter = StatusFilter { getStatusFilter :: NESet NotificationStatus } @@ -204,6 +236,17 @@ instance FromHttpApiData StatusFilter where Nothing -> Left "Empty status filter" Just statuses -> Right $ StatusFilter $ NESet.fromList statuses +instance ToHttpApiData StatusFilter where + toQueryParam (StatusFilter statuses) = + toList statuses + <&> toQueryParam + & Text.intercalate "," + +instance ToJSON StatusFilter where + toJSON (StatusFilter statuses) = + toList statuses + & toJSON + instance FromJSON StatusFilter where parseJSON = Aeson.withArray "StatusFilter" $ \arr -> (traverse . traverse) parseJSON (NEL.nonEmpty $ toList arr) >>= \case @@ -230,6 +273,13 @@ data UpdateHubEntriesRequest notificationIds :: NESet NotificationHubEntryId } +instance ToJSON UpdateHubEntriesRequest where + toJSON UpdateHubEntriesRequest {notificationStatus, notificationIds} = + object + [ "status" .= notificationStatus, + "notificationIds" .= notificationIds + ] + instance FromJSON UpdateHubEntriesRequest where parseJSON = withObject "UpdateHubEntriesRequest" $ \o -> do notificationStatus <- o .: "status" @@ -246,6 +296,10 @@ data CreateEmailDeliveryMethodRequest { email :: Email } +instance ToJSON CreateEmailDeliveryMethodRequest where + toJSON CreateEmailDeliveryMethodRequest {email} = + object ["email" .= email] + instance FromJSON CreateEmailDeliveryMethodRequest where parseJSON = withObject "CreateEmailDeliveryMethodRequest" $ \o -> do email <- o .: "email" @@ -260,6 +314,11 @@ instance ToJSON CreateEmailDeliveryMethodResponse where toJSON CreateEmailDeliveryMethodResponse {emailDeliveryMethodId} = object ["emailDeliveryMethodId" .= emailDeliveryMethodId] +instance FromJSON CreateEmailDeliveryMethodResponse where + parseJSON = withObject "CreateEmailDeliveryMethodResponse" $ \o -> do + emailDeliveryMethodId <- o .: "emailDeliveryMethodId" + pure CreateEmailDeliveryMethodResponse {emailDeliveryMethodId} + type DeleteEmailDeliveryMethodEndpoint = AuthenticatedUserId :> Capture "emailDeliveryMethodId" NotificationEmailDeliveryMethodId @@ -276,6 +335,10 @@ data UpdateEmailDeliveryMethodRequest { email :: Email } +instance ToJSON UpdateEmailDeliveryMethodRequest where + toJSON UpdateEmailDeliveryMethodRequest {email} = + object ["email" .= email] + instance FromJSON UpdateEmailDeliveryMethodRequest where parseJSON = withObject "UpdateEmailDeliveryMethodRequest" $ \o -> do email <- o .: "email" @@ -292,6 +355,10 @@ data CreateWebhookRequest name :: Text } +instance ToJSON CreateWebhookRequest where + toJSON CreateWebhookRequest {url, name} = + object ["url" .= url, "name" .= name] + instance FromJSON CreateWebhookRequest where parseJSON = withObject "CreateWebhookRequest" $ \o -> do url <- o .: "url" @@ -307,6 +374,11 @@ instance ToJSON CreateWebhookResponse where toJSON CreateWebhookResponse {webhookId} = object ["webhookId" .= webhookId] +instance FromJSON CreateWebhookResponse where + parseJSON = withObject "CreateWebhookResponse" $ \o -> do + webhookId <- o .: "webhookId" + pure CreateWebhookResponse {webhookId} + type DeleteWebhookEndpoint = AuthenticatedUserId :> Capture "webhookId" NotificationWebhookId @@ -323,6 +395,10 @@ data UpdateWebhookRequest { url :: URIParam } +instance ToJSON UpdateWebhookRequest where + toJSON UpdateWebhookRequest {url} = + object ["url" .= url] + instance FromJSON UpdateWebhookRequest where parseJSON = withObject "UpdateWebhookRequest" $ \o -> do url <- o .: "url" @@ -344,6 +420,10 @@ data AddSubscriptionDeliveryMethodsRequest } deriving stock (Show, Eq, Ord) +instance ToJSON AddSubscriptionDeliveryMethodsRequest where + toJSON AddSubscriptionDeliveryMethodsRequest {deliveryMethods} = + object ["deliveryMethods" .= deliveryMethods] + instance FromJSON AddSubscriptionDeliveryMethodsRequest where parseJSON = withObject "AddSubscriptionDeliveryMethodsRequest" $ \o -> do deliveryMethods <- o .: "deliveryMethods" @@ -355,6 +435,10 @@ data RemoveSubscriptionDeliveryMethodsRequest } deriving stock (Show, Eq, Ord) +instance ToJSON RemoveSubscriptionDeliveryMethodsRequest where + toJSON RemoveSubscriptionDeliveryMethodsRequest {deliveryMethods} = + object ["deliveryMethods" .= deliveryMethods] + instance FromJSON RemoveSubscriptionDeliveryMethodsRequest where parseJSON = withObject "RemoveSubscriptionDeliveryMethodsRequest" $ \o -> do deliveryMethods <- o .: "deliveryMethods" diff --git a/src/Share/Notifications/Types.hs b/src/Share/Notifications/Types.hs index dc947ea0..3b365998 100644 --- a/src/Share/Notifications/Types.hs +++ b/src/Share/Notifications/Types.hs @@ -42,7 +42,7 @@ module Share.Notifications.Types where import Control.Lens hiding ((.=)) -import Data.Aeson (FromJSON, ToJSON (..), (.:), (.=)) +import Data.Aeson (FromJSON, ToJSON (..), (.:), (.:?), (.=)) import Data.Aeson qualified as Aeson import Data.Set qualified as Set import Data.Text qualified as Text @@ -51,7 +51,7 @@ import Hasql.Decoders qualified as HasqlDecoders import Hasql.Encoders qualified as HasqlEncoders import Hasql.Interpolate qualified as Hasql import Network.URI (URI) -import Servant (FromHttpApiData (..)) +import Servant (FromHttpApiData (..), ToHttpApiData (..)) import Share.Contribution (ContributionStatus) import Share.IDs import Share.Postgres qualified as PG @@ -153,6 +153,12 @@ instance FromHttpApiData NotificationStatus where "archived" -> Right Archived s -> Left $ "Invalid notification status: " <> s +instance ToHttpApiData NotificationStatus where + toQueryParam = \case + Unread -> "unread" + Read -> "read" + Archived -> "archived" + instance Aeson.ToJSON NotificationStatus where toJSON = \case Unread -> "unread" @@ -446,15 +452,26 @@ eventUserInfo_ f NotificationEvent {eventActor, eventScope, ..} = do pure $ NotificationEvent {eventActor = eventActor', eventScope = eventScope', ..} instance (Aeson.ToJSON eventPayload, Aeson.ToJSON userInfo) => Aeson.ToJSON (NotificationEvent NotificationEventId userInfo UTCTime eventPayload) where - toJSON NotificationEvent {eventId, eventOccurredAt, eventData, eventScope, eventActor} = + toJSON NotificationEvent {eventId, eventOccurredAt, eventData, eventScope, eventActor, eventResourceId} = Aeson.object [ "id" Aeson..= eventId, "occurredAt" Aeson..= eventOccurredAt, "data" Aeson..= eventData, "scope" Aeson..= eventScope, - "actor" Aeson..= eventActor + "actor" Aeson..= eventActor, + "resourceId" Aeson..= eventResourceId ] +instance (Aeson.FromJSON eventPayload, Aeson.FromJSON userInfo) => Aeson.FromJSON (NotificationEvent NotificationEventId userInfo UTCTime eventPayload) where + parseJSON = Aeson.withObject "NotificationEvent" \o -> do + eventId <- o .: "id" + eventOccurredAt <- o .: "occurredAt" + eventData <- o .: "data" + eventScope <- o .: "scope" + eventActor <- o .: "actor" + eventResourceId <- o .: "resourceId" + pure NotificationEvent {eventId, eventOccurredAt, eventData, eventScope, eventActor, eventResourceId} + instance Hasql.DecodeRow (NotificationEvent NotificationEventId UserId UTCTime NotificationEventData) where decodeRow = do eventId <- PG.decodeField @@ -488,6 +505,12 @@ instance Aeson.ToJSON NotificationEmailDeliveryConfig where "email" Aeson..= emailDeliveryEmail ] +instance Aeson.FromJSON NotificationEmailDeliveryConfig where + parseJSON = Aeson.withObject "NotificationEmailDeliveryConfig" \o -> do + emailDeliveryId <- o .: "id" + emailDeliveryEmail <- o .: "email" + pure NotificationEmailConfig {emailDeliveryId, emailDeliveryEmail} + data NotificationWebhookConfig = NotificationWebhookConfig { webhookDeliveryId :: NotificationWebhookId, webhookDeliveryUrl :: URI @@ -507,11 +530,22 @@ instance Aeson.ToJSON NotificationWebhookConfig where "url" Aeson..= show webhookDeliveryUrl ] +instance Aeson.FromJSON NotificationWebhookConfig where + parseJSON = Aeson.withObject "NotificationWebhookConfig" \o -> do + webhookDeliveryId <- o .: "id" + URIParam webhookDeliveryUrl <- o .: "url" + pure NotificationWebhookConfig {webhookDeliveryId, webhookDeliveryUrl} + data DeliveryMethodId = EmailDeliveryMethodId NotificationEmailDeliveryMethodId | WebhookDeliveryMethodId NotificationWebhookId deriving stock (Show, Eq, Ord) +instance Aeson.ToJSON DeliveryMethodId where + toJSON = \case + EmailDeliveryMethodId eid -> Aeson.object ["kind" .= ("email" :: Text), "id" .= eid] + WebhookDeliveryMethodId wid -> Aeson.object ["kind" .= ("webhook" :: Text), "id" .= wid] + instance Aeson.FromJSON DeliveryMethodId where parseJSON = Aeson.withObject "DeliveryMethodId" $ \o -> do deliveryMethodKind <- o .: "kind" @@ -530,6 +564,14 @@ instance Aeson.ToJSON NotificationDeliveryMethod where EmailDeliveryMethod config -> Aeson.object ["kind" .= ("email" :: Text), "config" .= config] WebhookDeliveryMethod config -> Aeson.object ["kind" .= ("webhook" :: Text), "config" .= config] +instance Aeson.FromJSON NotificationDeliveryMethod where + parseJSON = Aeson.withObject "NotificationDeliveryMethod" $ \o -> do + deliveryMethodKind <- o .: "kind" + case deliveryMethodKind of + "email" -> EmailDeliveryMethod <$> o .: "config" + "webhook" -> WebhookDeliveryMethod <$> o .: "config" + _ -> fail $ "Unknown delivery method kind: " <> Text.unpack deliveryMethodKind + data NotificationSubscription id = NotificationSubscription { subscriptionId :: id, subscriptionScope :: UserId, @@ -557,6 +599,15 @@ instance Aeson.ToJSON (NotificationSubscription NotificationSubscriptionId) wher "filter" Aeson..= subscriptionFilter ] +instance Aeson.FromJSON (NotificationSubscription NotificationSubscriptionId) where + parseJSON = Aeson.withObject "NotificationSubscription" \o -> do + subscriptionId <- o .: "id" + subscriptionScope <- o .: "scope" + subscriptionTopics <- o .: "topics" + subscriptionTopicGroups <- o .: "topicGroups" + subscriptionFilter <- o .:? "filter" + pure NotificationSubscription {subscriptionId, subscriptionScope, subscriptionTopics, subscriptionTopicGroups, subscriptionFilter} + data NotificationHubEntry userInfo eventPayload = NotificationHubEntry { hubEntryId :: NotificationHubEntryId, hubEntryEvent :: NotificationEvent NotificationEventId userInfo UTCTime eventPayload, @@ -574,6 +625,14 @@ instance (Aeson.ToJSON eventPayload, Aeson.ToJSON userInfo) => Aeson.ToJSON (Not "createdAt" Aeson..= hubEntryCreatedAt ] +instance (Aeson.FromJSON eventPayload, Aeson.FromJSON userInfo) => Aeson.FromJSON (NotificationHubEntry userInfo eventPayload) where + parseJSON = Aeson.withObject "NotificationHubEntry" \o -> do + hubEntryId <- o .: "id" + hubEntryEvent <- o .: "event" + hubEntryStatus <- o .: "status" + hubEntryCreatedAt <- o .: "createdAt" + pure NotificationHubEntry {hubEntryId, hubEntryEvent, hubEntryStatus, hubEntryCreatedAt} + instance Hasql.DecodeRow (NotificationHubEntry UserId NotificationEventData) where decodeRow = do hubEntryId <- PG.decodeField diff --git a/src/Share/Ticket.hs b/src/Share/Ticket.hs index 2a38b726..bb845357 100644 --- a/src/Share/Ticket.hs +++ b/src/Share/Ticket.hs @@ -7,7 +7,7 @@ import Data.Time (UTCTime) import Hasql.Decoders qualified as Decoders import Hasql.Encoders qualified as Encoders import Hasql.Interpolate qualified as Hasql -import Servant (FromHttpApiData (..)) +import Servant (FromHttpApiData (..), ToHttpApiData (..)) import Share.IDs import Share.Postgres qualified as PG import Share.Prelude @@ -44,6 +44,11 @@ instance FromHttpApiData TicketStatus where "closed" -> Right Closed _ -> Left "Invalid ticket status" +instance ToHttpApiData TicketStatus where + toQueryParam = \case + Open -> "open" + Closed -> "closed" + instance Hasql.DecodeValue TicketStatus where decodeValue = do Decoders.enum diff --git a/src/Share/Utils/Caching.hs b/src/Share/Utils/Caching.hs index eef64a20..85142381 100644 --- a/src/Share/Utils/Caching.hs +++ b/src/Share/Utils/Caching.hs @@ -36,6 +36,11 @@ instance MimeRender JSON (Cached JSON a) where mimeRender _proxy = \case Cached bs -> BL.fromStrict bs +-- | This 'Cached' primitive is a bit weird, we may wish to revisit it. +instance {-# OVERLAPPING #-} MimeUnrender JSON (Cached JSON a) where + mimeUnrender _proxy bs = do + pure $ Cached $ BS.toStrict bs + instance (FromJSON a, ToJSON a) => ToJSON (Cached JSON a) where toJSON (Cached bs) = toJSON $ Aeson.decode @a $ BL.fromStrict bs diff --git a/src/Share/Utils/Servant.hs b/src/Share/Utils/Servant.hs index 6c2d146f..560f0dd9 100644 --- a/src/Share/Utils/Servant.hs +++ b/src/Share/Utils/Servant.hs @@ -23,6 +23,7 @@ import Data.Text qualified as Text import Data.Time (NominalDiffTime) import GHC.TypeLits (KnownSymbol, Nat, Symbol) import Servant +import Servant.Client.Core import Share.Prelude import Share.Utils.Logging import Share.Web.App (WebApp) @@ -40,7 +41,7 @@ type RequiredQueryParam = QueryParam' '[Required, Strict] type RequiredHeader = Header' '[Required, Strict] redirectTo :: URI -> LocationHeader -redirectTo uri = addHeader (show uri) NoContent +redirectTo uri = Servant.addHeader (show uri) NoContent data Timeout = Timeout NominalDiffTime @@ -92,3 +93,16 @@ instance (HasServer api ctx, KnownSymbol sym, FromHttpApiData a, HasContextEntry route _ ctx d = route (Proxy :: Proxy ((Capture sym a :> api) :<|> api)) ctx $ fmap f d where f may = may . Just :<|> may Nothing + +instance (HasClient m api, ToHttpApiData a) => HasClient m (OptionalCapture sym a :> api) where + type Client m (OptionalCapture sym a :> api) = Maybe a -> Client m api + + clientWithRoute pm _ req ma = + case ma of + Nothing -> + clientWithRoute pm (Proxy :: Proxy api) req + Just capture -> + let req' = (req {requestPath = requestPath req <> "/" <> toEncodedUrlPiece capture}) + in clientWithRoute pm (Proxy :: Proxy api) req' + + hoistClientMonad pm _ nt = fmap (hoistClientMonad pm (Proxy :: Proxy api) nt) diff --git a/src/Share/Web/API.hs b/src/Share/Web/API.hs index dfdde698..b2f94dae 100644 --- a/src/Share/Web/API.hs +++ b/src/Share/Web/API.hs @@ -13,18 +13,24 @@ import Share.Web.Local.API qualified as Local import Share.Web.Share.API qualified as Share import Share.Web.Share.Orgs.API qualified as Orgs import Share.Web.Share.Projects.API qualified as Projects +import Share.Web.Share.Users.API qualified as Users import Share.Web.Support.API qualified as Support import Share.Web.Types import Share.Web.UCM.SyncV2.API qualified as SyncV2 import Unison.Share.API.Projects qualified as UCMProjects import Unison.Sync.API qualified as Unison.Sync +-- Some APIs are pulled out separately to make building clients easier. +type OrgsAPI = ("orgs" :> Orgs.API) + +type UsersAPI = ("users" :> Users.API) + type API = OAuth.ServiceProviderAPI :<|> OAuth.IdentityProviderAPI :<|> ("codebases" :> Share.UserPublicCodebaseAPI) - :<|> ("users" :> Share.UserAPI) - :<|> ("orgs" :> Orgs.API) + :<|> UsersAPI + :<|> OrgsAPI :<|> ("search" :> Share.OmniSearchEndpoint) :<|> ("search-names" :> Share.SearchDefinitionNamesEndpoint) :<|> ("search-definitions" :> Share.SearchDefinitionsEndpoint) diff --git a/src/Share/Web/Authorization/Types.hs b/src/Share/Web/Authorization/Types.hs index da87f059..0b5fe3fd 100644 --- a/src/Share/Web/Authorization/Types.hs +++ b/src/Share/Web/Authorization/Types.hs @@ -105,12 +105,6 @@ instance ToJSON ResolvedAuthSubject where OrgSubject id -> object ["kind" .= ("org" :: Text), "id" .= id] TeamSubject id -> object ["kind" .= ("team" :: Text), "id" .= id] -instance ToJSON DisplayAuthSubject where - toJSON = \case - UserSubject user -> object ["kind" .= ("user" :: Text), "data" .= user] - OrgSubject org -> object ["kind" .= ("org" :: Text), "data" .= org] - TeamSubject team -> object ["kind" .= ("team" :: Text), "data" .= team] - instance FromJSON ResolvedAuthSubject where parseJSON = withObject "ResolvedAuthSubject" $ \o -> do kind <- o Aeson..: "kind" @@ -120,6 +114,21 @@ instance FromJSON ResolvedAuthSubject where "team" -> TeamSubject <$> o Aeson..: "id" _ -> fail "Invalid ResolvedAuthSubject" +instance ToJSON DisplayAuthSubject where + toJSON = \case + UserSubject user -> object ["kind" .= ("user" :: Text), "data" .= user] + OrgSubject org -> object ["kind" .= ("org" :: Text), "data" .= org] + TeamSubject team -> object ["kind" .= ("team" :: Text), "data" .= team] + +instance FromJSON DisplayAuthSubject where + parseJSON = withObject "DisplayAuthSubject" $ \o -> do + kind <- o Aeson..: "kind" + case (kind :: Text) of + "user" -> UserSubject <$> o Aeson..: "data" + "org" -> OrgSubject <$> o Aeson..: "data" + "team" -> TeamSubject <$> o Aeson..: "data" + _ -> fail "Invalid DisplayAuthSubject" + -- Decoder for (subject.kind, id :: UUID) instance Hasql.DecodeRow ResolvedAuthSubject where decodeRow = do @@ -351,7 +360,7 @@ instance (FromJSON user) => FromJSON (RoleAssignment user) where -- | A type for mixing in permissions info on a response for a resource. newtype PermissionsInfo = PermissionsInfo (Set RolePermission) deriving (Show) - deriving (ToJSON) via (AtKey "permissions" (Set RolePermission)) + deriving (ToJSON, FromJSON) via (AtKey "permissions" (Set RolePermission)) data ProjectMaintainerPermissions = ProjectMaintainerPermissions { canView :: Bool, @@ -390,6 +399,12 @@ instance ToJSON ListRolesResponse where "active" .= active ] +instance FromJSON ListRolesResponse where + parseJSON = Aeson.withObject "ListRolesResponse" $ \o -> do + roleAssignments <- o Aeson..: "role_assignments" + active <- o Aeson..: "active" + pure ListRolesResponse {roleAssignments, active} + data AddRolesResponse = AddRolesResponse { roleAssignments :: [RoleAssignment DisplayAuthSubject] } @@ -400,6 +415,11 @@ instance ToJSON AddRolesResponse where [ "role_assignments" Aeson..= roleAssignments ] +instance FromJSON AddRolesResponse where + parseJSON = Aeson.withObject "AddRolesResponse" $ \o -> do + roleAssignments <- o Aeson..: "role_assignments" + pure AddRolesResponse {roleAssignments} + data RemoveRolesResponse = RemoveRolesResponse { roleAssignments :: [RoleAssignment DisplayAuthSubject] } @@ -410,11 +430,22 @@ instance ToJSON RemoveRolesResponse where [ "role_assignments" Aeson..= roleAssignments ] +instance FromJSON RemoveRolesResponse where + parseJSON = Aeson.withObject "RemoveRolesResponse" $ \o -> do + roleAssignments <- o Aeson..: "role_assignments" + pure RemoveRolesResponse {roleAssignments} + data AddRolesRequest = AddRolesRequest { roleAssignments :: [RoleAssignment ResolvedAuthSubject] } deriving (Show) +instance ToJSON AddRolesRequest where + toJSON AddRolesRequest {..} = + object + [ "role_assignments" .= roleAssignments + ] + instance FromJSON AddRolesRequest where parseJSON = Aeson.withObject "AddRolesRequest" $ \o -> do roleAssignments <- o Aeson..: "role_assignments" @@ -425,6 +456,12 @@ data RemoveRolesRequest = RemoveRolesRequest } deriving (Show) +instance ToJSON RemoveRolesRequest where + toJSON RemoveRolesRequest {..} = + object + [ "role_assignments" .= roleAssignments + ] + instance FromJSON RemoveRolesRequest where parseJSON = Aeson.withObject "RemoveRolesRequest" $ \o -> do roleAssignments <- o Aeson..: "role_assignments" @@ -443,6 +480,12 @@ data ProjectNotificationSubscriptionRequest } deriving (Show, Eq) +instance ToJSON ProjectNotificationSubscriptionRequest where + toJSON ProjectNotificationSubscriptionRequest {..} = + object + [ "isSubscribed" .= isSubscribed + ] + instance FromJSON ProjectNotificationSubscriptionRequest where parseJSON = Aeson.withObject "ProjectNotificationSubscriptionRequest" $ \o -> do isSubscribed <- o Aeson..: "isSubscribed" @@ -459,3 +502,8 @@ instance ToJSON ProjectNotificationSubscriptionResponse where object [ "subscriptionId" .= subscriptionId ] + +instance FromJSON ProjectNotificationSubscriptionResponse where + parseJSON = Aeson.withObject "ProjectNotificationSubscriptionResponse" $ \o -> do + subscriptionId <- o Aeson..: "subscriptionId" + pure ProjectNotificationSubscriptionResponse {subscriptionId} diff --git a/src/Share/Web/Share/API.hs b/src/Share/Web/Share/API.hs index 50656076..70b890ee 100644 --- a/src/Share/Web/Share/API.hs +++ b/src/Share/Web/Share/API.hs @@ -5,46 +5,14 @@ module Share.Web.Share.API where import Servant import Share.IDs -import Share.Notifications.API qualified as Notifications -import Share.OAuth.Session (AuthenticatedSession, AuthenticatedUserId, MaybeAuthenticatedSession, MaybeAuthenticatedUserId) +import Share.OAuth.Session (AuthenticatedSession, MaybeAuthenticatedSession, MaybeAuthenticatedUserId) import Share.Prelude import Share.Utils.API -import Share.Utils.Caching import Share.Utils.IDs qualified as IDs import Share.Utils.Servant -import Share.Web.Share.Branches.API (UserBranchesAPI) import Share.Web.Share.CodeBrowsing.API (CodeBrowseAPI) -import Share.Web.Share.Contributions.API (ContributionsByUserAPI) -import Share.Web.Share.Projects.API (ProjectsAPI) import Share.Web.Share.Types -type UserAPI = - MaybeAuthenticatedSession - :> Capture "user_handle" UserHandle - :> UserResourceAPI - -type UserResourceAPI = - ("readme" :> UserReadmeEndpoint) - :<|> UserProfileEndpoint - :<|> UpdateUserEndpoint - :<|> ("projects" :> ProjectsAPI) - :<|> ("branches" :> UserBranchesAPI) - :<|> ("contributions" :> ContributionsByUserAPI) - :<|> ("notifications" :> Notifications.API) - --- | PATCH /users/:user_handle --- Update the user's profile -type UpdateUserEndpoint = - AuthenticatedUserId - :> ReqBody '[JSON] UpdateUserRequest - :> Patch '[JSON] DescribeUserProfile - --- | GET /users/:user_handle -type UserProfileEndpoint = Get '[JSON] DescribeUserProfile - --- | GET /users/:user_handle/readme -type UserReadmeEndpoint = Get '[JSON] (Cached JSON ReadmeResponse) - -- | GET /search?query=hoj&limit=9 -- -- Search users by a prefix of their name or handle. diff --git a/src/Share/Web/Share/Branches/Types.hs b/src/Share/Web/Share/Branches/Types.hs index 41072f39..bd70a576 100644 --- a/src/Share/Web/Share/Branches/Types.hs +++ b/src/Share/Web/Share/Branches/Types.hs @@ -8,7 +8,7 @@ module Share.Web.Share.Branches.Types where import Data.Aeson import Data.Time (UTCTime) import Servant (FromHttpApiData) -import Servant.API (FromHttpApiData (..)) +import Servant.API (FromHttpApiData (..), ToHttpApiData (..)) import Share.Branch (Branch (..)) import Share.IDs import Share.IDs qualified as IDs @@ -48,6 +48,16 @@ instance ToJSON ShareBranch where "contributions" .= contributions ] +instance FromJSON ShareBranch where + parseJSON = withObject "ShareBranch" $ \o -> + ShareBranch + <$> o .: "branchRef" + <*> o .: "createdAt" + <*> o .: "updatedAt" + <*> o .: "causalHash" + <*> o .: "project" + <*> o .: "contributions" + -- | Allows filtering the branches list for contributor or core branches. data BranchKindFilter = AllBranchKinds @@ -60,3 +70,8 @@ instance FromHttpApiData BranchKindFilter where parseQueryParam "core" = Right OnlyCoreBranches parseQueryParam "contributor" = Right OnlyContributorBranches parseQueryParam _ = Left "Invalid branch kind filter, must be one of: ['all', 'core', contributor']" + +instance ToHttpApiData BranchKindFilter where + toQueryParam AllBranchKinds = "all" + toQueryParam OnlyCoreBranches = "core" + toQueryParam OnlyContributorBranches = "contributor" diff --git a/src/Share/Web/Share/Comments.hs b/src/Share/Web/Share/Comments.hs index 4c19cc87..a37f28b2 100644 --- a/src/Share/Web/Share/Comments.hs +++ b/src/Share/Web/Share/Comments.hs @@ -63,7 +63,7 @@ commentEventTimestamp = \case CommentEvent Comment {timestamp} -> timestamp DeletedCommentEvent DeletedComment {timestamp} -> timestamp -instance Aeson.ToJSON user => Aeson.ToJSON (CommentEvent user) where +instance (Aeson.ToJSON user) => Aeson.ToJSON (CommentEvent user) where toJSON = \case CommentEvent Comment {..} -> @@ -83,3 +83,21 @@ instance Aeson.ToJSON user => Aeson.ToJSON (CommentEvent user) where "timestamp" Aeson..= timestamp, "deletedAt" Aeson..= deletedAt ] + +instance (Aeson.FromJSON user) => Aeson.FromJSON (CommentEvent user) where + parseJSON = + Aeson.withObject "CommentEvent" $ \o -> do + mayDeleted <- o Aeson..: "deletedAt" + case mayDeleted of + Just (deletedAt :: UTCTime) -> do + commentId <- o Aeson..: "id" + timestamp <- o Aeson..: "timestamp" + pure $ DeletedCommentEvent DeletedComment {..} + Nothing -> do + commentId <- o Aeson..: "id" + actor <- o Aeson..: "actor" + timestamp <- o Aeson..: "timestamp" + editedAt <- o Aeson..:? "editedAt" + content <- o Aeson..: "content" + revision <- o Aeson..: "revision" + pure $ CommentEvent Comment {..} diff --git a/src/Share/Web/Share/Comments/Types.hs b/src/Share/Web/Share/Comments/Types.hs index d6b431ce..363a6a8c 100644 --- a/src/Share/Web/Share/Comments/Types.hs +++ b/src/Share/Web/Share/Comments/Types.hs @@ -16,6 +16,12 @@ data CreateCommentRequest = CreateCommentRequest } deriving (Show) +instance ToJSON CreateCommentRequest where + toJSON CreateCommentRequest {..} = + object + [ "content" .= content + ] + instance FromJSON CreateCommentRequest where parseJSON = withObject "CreateCommentRequest" \o -> do content <- o .: "content" @@ -30,6 +36,13 @@ data UpdateCommentRequest = UpdateCommentRequest } deriving (Show) +instance ToJSON UpdateCommentRequest where + toJSON UpdateCommentRequest {..} = + object + [ "content" .= content, + "expectedRevision" .= expectedRevision + ] + instance FromJSON UpdateCommentRequest where parseJSON = withObject "UpdateCommentRequest" \o -> do content <- o .: "content" @@ -45,3 +58,11 @@ instance ToJSON UpdateCommentResponse where toJSON = \case UpdateCommentSuccess event -> object ["kind" .= ("success" :: Text), "comment" .= event] UpdateCommentConflict event -> object ["kind" .= ("conflict" :: Text), "comment" .= event] + +instance FromJSON UpdateCommentResponse where + parseJSON = withObject "UpdateCommentResponse" \o -> do + kind :: Text <- o .: "kind" + case kind of + "success" -> UpdateCommentSuccess <$> o .: "comment" + "conflict" -> UpdateCommentConflict <$> o .: "comment" + _ -> fail $ "Unknown kind: " <> show kind diff --git a/src/Share/Web/Share/Contributions/Types.hs b/src/Share/Web/Share/Contributions/Types.hs index 5cc4be9c..df0ef2f4 100644 --- a/src/Share/Web/Share/Contributions/Types.hs +++ b/src/Share/Web/Share/Contributions/Types.hs @@ -16,7 +16,7 @@ import Share.IDs import Share.IDs qualified as IDs import Share.Postgres qualified as PG import Share.Prelude -import Share.Utils.API (NullableUpdate, parseNullableUpdate) +import Share.Utils.API (NullableUpdate, nullableUpdateToJSON, parseNullableUpdate) import Share.Utils.Logging qualified as Logging import Share.Web.Errors qualified as Err import Share.Web.Share.Comments (CommentEvent (..), commentEventTimestamp) @@ -84,6 +84,22 @@ instance ToJSON (ShareContribution UserDisplayInfo) where "numComments" .= numComments ] +instance FromJSON (ShareContribution UserDisplayInfo) where + parseJSON = withObject "ShareContribution" \o -> do + contributionId <- o .: "id" + projectShortHand <- o .: "projectRef" + number <- o .: "number" + title <- o .: "title" + description <- o .:? "description" + status <- o .: "status" + sourceBranchShortHand <- o .: "sourceBranchRef" + targetBranchShortHand <- o .: "targetBranchRef" + createdAt <- o .: "createdAt" + updatedAt <- o .: "updatedAt" + author <- o .:? "author" + numComments <- o .: "numComments" + pure ShareContribution {..} + -- | Allows filtering the branches list for contributor or core branches. data ContributionKindFilter = AllContributionKinds @@ -92,10 +108,17 @@ data ContributionKindFilter deriving stock (Eq, Show) instance FromHttpApiData ContributionKindFilter where - parseQueryParam "all" = Right AllContributionKinds - parseQueryParam "core" = Right OnlyCoreContributions - parseQueryParam "contributor" = Right OnlyContributorContributions - parseQueryParam _ = Left "Invalid contribution kind filter, must be one of: ['all', 'core', contributor']" + parseQueryParam = \case + "all" -> Right AllContributionKinds + "core" -> Right OnlyCoreContributions + "contributor" -> Right OnlyContributorContributions + _ -> Left "Invalid contribution kind filter, must be one of: ['all', 'core', contributor']" + +instance ToHttpApiData ContributionKindFilter where + toQueryParam = \case + AllContributionKinds -> "all" + OnlyCoreContributions -> "core" + OnlyContributorContributions -> "contributor" data StatusChangeEvent user = StatusChangeEvent { oldStatus :: Maybe ContributionStatus, @@ -135,6 +158,18 @@ instance (ToJSON user) => ToJSON (ContributionTimelineEvent user) where ] ContributionTimelineComment commentEvent -> toJSON commentEvent +instance (FromJSON user) => FromJSON (ContributionTimelineEvent user) where + parseJSON = withObject "ContributionTimelineEvent" \o -> do + kind <- o .:? "kind" + case kind of + (Just ("statusChange" :: Text)) -> do + newStatus <- o .: "newStatus" + oldStatus <- o .:? "oldStatus" + actor <- o .: "actor" + timestamp <- o .: "timestamp" + pure $ ContributionTimelineStatusChange StatusChangeEvent {..} + _ -> ContributionTimelineComment <$> parseJSON (Object o) + data CreateContributionRequest = CreateContributionRequest { title :: Text, description :: Maybe Text, @@ -144,6 +179,16 @@ data CreateContributionRequest = CreateContributionRequest } deriving (Show) +instance ToJSON CreateContributionRequest where + toJSON CreateContributionRequest {..} = + object + [ "title" .= title, + "description" .= description, + "status" .= status, + "sourceBranchRef" .= sourceBranchShortHand, + "targetBranchRef" .= targetBranchShortHand + ] + instance FromJSON CreateContributionRequest where parseJSON = withObject "CreateContributionRequest" \o -> do title <- o .: "title" @@ -162,6 +207,16 @@ data UpdateContributionRequest = UpdateContributionRequest } deriving (Show) +instance ToJSON UpdateContributionRequest where + toJSON UpdateContributionRequest {..} = + object + [ "title" .= title, + "description" .= nullableUpdateToJSON description, + "status" .= status, + "sourceBranchRef" .= sourceBranchSH, + "targetBranchRef" .= targetBranchSH + ] + instance FromJSON UpdateContributionRequest where parseJSON = withObject "UpdateContributionRequest" \o -> do title <- o .:? "title" @@ -196,6 +251,23 @@ instance ToJSON CheckMergeContributionResponse where CantMerge msg -> object ["kind" .= ("cant_merge" :: Text), "reason" .= msg] ] +instance FromJSON CheckMergeContributionResponse where + parseJSON = withObject "CheckMergeContributionResponse" \o -> do + mergeability <- o .: "mergeability" + case mergeability of + Object obj -> do + kind <- obj .: "kind" + case kind of + ("fast_forward" :: Text) -> pure CheckMergeContributionResponse {mergeability = CanFastForward} + "merge" -> pure CheckMergeContributionResponse {mergeability = CanMerge} + "conflicted" -> pure CheckMergeContributionResponse {mergeability = Conflicted} + "already_merged" -> pure CheckMergeContributionResponse {mergeability = AlreadyMerged} + "cant_merge" -> do + reason <- obj .: "reason" + pure $ CheckMergeContributionResponse {mergeability = CantMerge reason} + _ -> fail $ "Invalid mergeability kind: " <> Text.unpack kind + _ -> fail "Expected an object for check merge contribution response" + data MergeResult = MergeSuccess | SourceBranchUpdated @@ -209,6 +281,12 @@ data MergeContributionRequest = MergeContributionRequest } deriving (Show) +instance ToJSON MergeContributionRequest where + toJSON MergeContributionRequest {..} = + object + [ "contributionStateToken" .= toQueryParam contributionStateToken + ] + instance FromJSON MergeContributionRequest where parseJSON = withObject "MergeContributionRequest" \o -> do contributionStateToken <- o .: "contributionStateToken" @@ -232,6 +310,23 @@ instance ToJSON MergeContributionResponse where MergeFailed msg -> object ["kind" .= ("failed" :: Text), "reason" .= msg] ] +instance FromJSON MergeContributionResponse where + parseJSON = withObject "MergeContributionResponse" \o -> do + result <- o .: "result" + case result of + Object obj -> do + kind <- obj .: "kind" + case kind of + ("success" :: Text) -> pure MergeContributionResponse {result = MergeSuccess} + "source_branch_updated" -> pure MergeContributionResponse {result = SourceBranchUpdated} + "target_branch_updated" -> pure MergeContributionResponse {result = TargetBranchUpdated} + "conflicted" -> pure MergeContributionResponse {result = MergeConflicted} + "failed" -> do + reason <- obj .: "reason" + pure $ MergeContributionResponse {result = MergeFailed reason} + _ -> fail $ "Invalid merge result kind: " <> Text.unpack kind + _ -> fail "Expected an object for merge contribution response" + -- | Token used to ensure that the state of a contribution hasn't changed between -- rendering the page and the user taking a given action. -- diff --git a/src/Share/Web/Share/Diffs/Types.hs b/src/Share/Web/Share/Diffs/Types.hs index 47c36507..b3df3e60 100644 --- a/src/Share/Web/Share/Diffs/Types.hs +++ b/src/Share/Web/Share/Diffs/Types.hs @@ -10,12 +10,13 @@ import Share.Prelude import Share.Utils.Aeson (PreEncoded) import Unison.Server.Types ( DisplayObjectDiff (..), - TermDefinition, + TermDefinition (termDefinition), TermDefinitionDiff (..), TermTag, TypeDefinition, TypeDefinitionDiff (..), TypeTag, + typeDefinition, ) import Unison.ShortHash (ShortHash) @@ -38,8 +39,8 @@ data ShareNamespaceDiffResponse = ShareNamespaceDiffResponse instance ToJSON ShareNamespaceDiffResponse where toJSON (ShareNamespaceDiffResponse {diff, project, oldRef, newRef, oldRefHash, newRefHash}) = object $ - diffPairs ++ - [ "project" .= toJSON project, + diffPairs + ++ [ "project" .= toJSON project, "oldRef" .= oldRef, "oldRefHash" .= oldRefHash, "newRef" .= newRef, @@ -50,8 +51,8 @@ instance ToJSON ShareNamespaceDiffResponse where diffPairs = case diff of ShareNamespaceDiffStatus'Done diff -> - [ "diff" .= toJSON diff - , "tag" .= ("done" :: Text) + [ "diff" .= toJSON diff, + "tag" .= ("done" :: Text) ] ShareNamespaceDiffStatus'StillComputing -> [ "tag" .= ("computing" :: Text) @@ -89,6 +90,22 @@ instance ToJSON ShareTermDiffResponse where "newTerm" .= newTerm ] +instance FromJSON ShareTermDiffResponse where + parseJSON = withObject "ShareTermDiffResponse" $ \o -> do + project <- o .: "project" + oldBranch <- o .: "oldBranchRef" + newBranch <- o .: "newBranchRef" + oldTerm <- o .: "oldTerm" + newTerm <- o .: "newTerm" + diffKind <- o .: "diffKind" + diff <- case (diffKind :: Text) of + "diff" -> do + diffValue <- o .: "diff" + pure $ DisplayObjectDiff diffValue + "mismatched" -> pure $ MismatchedDisplayObjects (termDefinition oldTerm) (termDefinition newTerm) + t -> fail $ "Invalid ShareTermDiffResponse diffKind: " <> show t + pure ShareTermDiffResponse {project, oldBranch, newBranch, oldTerm, newTerm, diff} + data ShareTypeDiffResponse = ShareTypeDiffResponse { project :: ProjectShortHand, oldBranch :: BranchOrReleaseShortHand, @@ -120,3 +137,19 @@ instance ToJSON ShareTypeDiffResponse where "oldType" .= oldType, "newType" .= newType ] + +instance FromJSON ShareTypeDiffResponse where + parseJSON = withObject "ShareTypeDiffResponse" $ \o -> do + project <- o .: "project" + oldBranch <- o .: "oldBranchRef" + newBranch <- o .: "newBranchRef" + oldType <- o .: "oldType" + newType <- o .: "newType" + diffKind <- o .: "diffKind" + diff <- case (diffKind :: Text) of + "diff" -> do + diffValue <- o .: "diff" + pure $ DisplayObjectDiff diffValue + "mismatched" -> pure $ MismatchedDisplayObjects (typeDefinition oldType) (typeDefinition newType) + t -> fail $ "Invalid ShareTypeDiffResponse diffKind: " <> show t + pure ShareTypeDiffResponse {project, oldBranch, newBranch, oldType, newType, diff} diff --git a/src/Share/Web/Share/DisplayInfo/Types.hs b/src/Share/Web/Share/DisplayInfo/Types.hs index c7c074fe..a58a05fe 100644 --- a/src/Share/Web/Share/DisplayInfo/Types.hs +++ b/src/Share/Web/Share/DisplayInfo/Types.hs @@ -129,6 +129,13 @@ instance ToJSON OrgDisplayInfo where "isCommercial" Aeson..= isCommercial ] +instance FromJSON OrgDisplayInfo where + parseJSON = Aeson.withObject "OrgDisplayInfo" $ \o -> do + user <- o Aeson..: "user" + orgId <- o Aeson..: "orgId" + isCommercial <- o Aeson..: "isCommercial" + pure OrgDisplayInfo {user, orgId, isCommercial} + data TeamDisplayInfo = TeamDisplayInfo { teamId :: TeamId, name :: Text, @@ -143,3 +150,11 @@ instance ToJSON TeamDisplayInfo where "name" Aeson..= name, "avatarUrl" Aeson..= (URIParam <$> avatarUrl) ] + +instance FromJSON TeamDisplayInfo where + parseJSON = + Aeson.withObject "TeamDisplayInfo" $ \o -> do + teamId <- o Aeson..: "teamId" + name <- o Aeson..: "name" + avatarUrl <- fmap unpackURI <$> o Aeson..:? "avatarUrl" + pure TeamDisplayInfo {teamId, name, avatarUrl} diff --git a/src/Share/Web/Share/Impl.hs b/src/Share/Web/Share/Impl.hs index e1ba3518..a0ec4667 100644 --- a/src/Share/Web/Share/Impl.hs +++ b/src/Share/Web/Share/Impl.hs @@ -58,6 +58,7 @@ import Share.Web.Share.DisplayInfo.Queries qualified as DisplayInfoQ import Share.Web.Share.DisplayInfo.Types (OrgDisplayInfo (..), UserLike (..)) import Share.Web.Share.Projects.Impl qualified as Projects import Share.Web.Share.Types +import Share.Web.Share.Users.API qualified as Users import Unison.Codebase.Path qualified as Path import Unison.HashQualified qualified as HQ import Unison.Name (Name) @@ -98,9 +99,9 @@ userCodebaseServer session handle = addRequestTag "codebase-handle" (IDs.toText handle) m -userServer :: ServerT Share.UserAPI WebApp +userServer :: ServerT Users.API WebApp userServer session handle = - hoistServerWithContext (Proxy @Share.UserResourceAPI) ctxType addTags $ + hoistServerWithContext (Proxy @Users.UserResourceAPI) ctxType addTags $ ( getUserReadmeEndpoint session handle :<|> getUserProfileEndpoint mayCallerId handle :<|> updateUserEndpoint handle diff --git a/src/Share/Web/Share/Orgs/API.hs b/src/Share/Web/Share/Orgs/API.hs index 7d33829b..6d718cea 100644 --- a/src/Share/Web/Share/Orgs/API.hs +++ b/src/Share/Web/Share/Orgs/API.hs @@ -24,24 +24,24 @@ type API = data ResourceRoutes mode = ResourceRoutes - { roles :: mode :- "roles" :> NamedRoutes OrgRolesRoutes, - members :: mode :- "members" :> NamedRoutes OrgMembersRoutes + { orgRoles :: mode :- "roles" :> NamedRoutes OrgRolesRoutes, + orgMembers :: mode :- "members" :> NamedRoutes OrgMembersRoutes } deriving stock (Generic) data OrgRolesRoutes mode = OrgRolesRoutes - { list :: mode :- OrgRolesListEndpoint, - add :: mode :- OrgRolesAddEndpoint, - remove :: mode :- OrgRolesRemoveEndpoint + { listOrgRoles :: mode :- OrgRolesListEndpoint, + addOrgRoles :: mode :- OrgRolesAddEndpoint, + removeOrgRoles :: mode :- OrgRolesRemoveEndpoint } deriving stock (Generic) data OrgMembersRoutes mode = OrgMembersRoutes - { list :: mode :- OrgMembersListEndpoint, - add :: mode :- OrgMembersAddEndpoint, - remove :: mode :- OrgMembersRemoveEndpoint + { listOrgMembers :: mode :- OrgMembersListEndpoint, + addOrgMembers :: mode :- OrgMembersAddEndpoint, + removeOrgMembers :: mode :- OrgMembersRemoveEndpoint } deriving stock (Generic) diff --git a/src/Share/Web/Share/Orgs/Impl.hs b/src/Share/Web/Share/Orgs/Impl.hs index 7f603f46..6a5e99aa 100644 --- a/src/Share/Web/Share/Orgs/Impl.hs +++ b/src/Share/Web/Share/Orgs/Impl.hs @@ -53,8 +53,8 @@ server :: ServerT API.API WebApp server = let orgResourceServer orgHandle = API.ResourceRoutes - { API.roles = rolesServer orgHandle, - API.members = membersServer orgHandle + { API.orgRoles = rolesServer orgHandle, + API.orgMembers = membersServer orgHandle } in orgCreateEndpoint :<|> orgResourceServer @@ -68,17 +68,17 @@ orgCreateEndpoint callerUserId (CreateOrgRequest {name, handle, avatarUrl, email rolesServer :: UserHandle -> API.OrgRolesRoutes (AsServerT WebApp) rolesServer orgHandle = API.OrgRolesRoutes - { API.list = listRolesEndpoint orgHandle, - API.add = addRolesEndpoint orgHandle, - API.remove = removeRolesEndpoint orgHandle + { API.listOrgRoles = listRolesEndpoint orgHandle, + API.addOrgRoles = addRolesEndpoint orgHandle, + API.removeOrgRoles = removeRolesEndpoint orgHandle } membersServer :: UserHandle -> API.OrgMembersRoutes (AsServerT WebApp) membersServer orgHandle = API.OrgMembersRoutes - { API.list = listMembersEndpoint orgHandle, - API.add = addMembersEndpoint orgHandle, - API.remove = removeMembersEndpoint orgHandle + { API.listOrgMembers = listMembersEndpoint orgHandle, + API.addOrgMembers = addMembersEndpoint orgHandle, + API.removeOrgMembers = removeMembersEndpoint orgHandle } orgIdByHandle :: UserHandle -> WebApp OrgId diff --git a/src/Share/Web/Share/Orgs/Types.hs b/src/Share/Web/Share/Orgs/Types.hs index 3953f3a7..6e2a1707 100644 --- a/src/Share/Web/Share/Orgs/Types.hs +++ b/src/Share/Web/Share/Orgs/Types.hs @@ -35,6 +35,17 @@ data CreateOrgRequest = CreateOrgRequest } deriving (Show, Eq) +instance ToJSON CreateOrgRequest where + toJSON CreateOrgRequest {..} = + object + [ "name" .= name, + "handle" .= handle, + "avatarUrl" .= avatarUrl, + "owner" .= owner, + "email" .= email, + "isCommercial" .= isCommercial + ] + instance FromJSON CreateOrgRequest where parseJSON = withObject "CreateOrgRequest" $ \o -> do name <- o .: "name" @@ -50,6 +61,12 @@ data OrgMembersAddRequest = OrgMembersAddRequest } deriving (Show, Eq) +instance ToJSON OrgMembersAddRequest where + toJSON OrgMembersAddRequest {..} = + object + [ "members" .= members + ] + instance FromJSON OrgMembersAddRequest where parseJSON = withObject "OrgMembersAddRequest" $ \o -> do members <- o .: "members" @@ -66,11 +83,22 @@ instance ToJSON OrgMembersListResponse where [ "members" .= members ] +instance FromJSON OrgMembersListResponse where + parseJSON = withObject "OrgMembersListResponse" $ \o -> do + members <- o .: "members" + pure OrgMembersListResponse {..} + data OrgMembersRemoveRequest = OrgMembersRemoveRequest { members :: [UserHandle] } deriving (Show, Eq) +instance ToJSON OrgMembersRemoveRequest where + toJSON OrgMembersRemoveRequest {..} = + object + [ "members" .= members + ] + instance FromJSON OrgMembersRemoveRequest where parseJSON = withObject "OrgMembersRemoveRequest" $ \o -> do members <- o .: "members" diff --git a/src/Share/Web/Share/Projects/Types.hs b/src/Share/Web/Share/Projects/Types.hs index a1e4a53e..8b8ce284 100644 --- a/src/Share/Web/Share/Projects/Types.hs +++ b/src/Share/Web/Share/Projects/Types.hs @@ -82,6 +82,20 @@ instance ToJSON ProjectOwner where "type" .= ("user" :: Text) ] +instance FromJSON ProjectOwner where + parseJSON = Aeson.withObject "ProjectOwner" $ \o -> do + typ <- o .: "type" + case typ of + ("organization" :: Text) -> do + ownerHandle <- o .: "handle" + ownerName <- o .:? "name" + pure $ OrganizationOwner {..} + ("user" :: Text) -> do + ownerHandle <- o .: "handle" + ownerName <- o .:? "name" + pure $ UserOwner {..} + _ -> fail $ "Unknown ProjectOwner type: " <> show typ + data FavData = FavData { numFavs :: Int64, isFaved :: Bool @@ -101,6 +115,12 @@ instance ToJSON FavData where "isFaved" .= isFaved ] +instance FromJSON FavData where + parseJSON = Aeson.withObject "FavData" $ \o -> do + numFavs <- o .: "numFavs" + isFaved <- o .: "isFaved" + pure FavData {..} + data APIProjectBranchAndReleaseDetails = APIProjectBranchAndReleaseDetails { defaultBranch :: Maybe BranchName, latestRelease :: Maybe ReleaseVersion @@ -114,6 +134,12 @@ instance ToJSON APIProjectBranchAndReleaseDetails where "latestRelease" .= latestRelease ] +instance FromJSON APIProjectBranchAndReleaseDetails where + parseJSON = Aeson.withObject "APIProjectBranchAndReleaseDetails" $ \o -> do + defaultBranch <- o .:? "defaultBranch" + latestRelease <- o .:? "latestRelease" + pure APIProjectBranchAndReleaseDetails {..} + data APIProject = APIProject { owner :: ProjectOwner, slug :: ProjectSlug, @@ -137,12 +163,31 @@ instance ToJSON APIProject where "updatedAt" .= updatedAt ] +instance FromJSON APIProject where + parseJSON = Aeson.withObject "APIProject" $ \o -> do + owner <- o .: "owner" + slug <- o .: "slug" + summary <- o .:? "summary" + visibility <- o .: "visibility" + tags <- o .:? "tags" .!= Set.empty + createdAt <- o .: "createdAt" + updatedAt <- o .: "updatedAt" + pure APIProject {..} + data CreateProjectRequest = CreateProjectRequest { summary :: Maybe Text, visibility :: ProjectVisibility, tags :: Set ProjectTag } +instance Aeson.ToJSON CreateProjectRequest where + toJSON CreateProjectRequest {..} = + object + [ "summary" .= summary, + "visibility" .= visibility, + "tags" .= tags + ] + instance Aeson.FromJSON CreateProjectRequest where parseJSON = Aeson.withObject "CreateProjectRequest" $ \o -> do summary <- o .:? "summary" @@ -155,6 +200,9 @@ data CreateProjectResponse = CreateProjectResponse instance Aeson.ToJSON CreateProjectResponse where toJSON CreateProjectResponse = Aeson.object [] +instance Aeson.FromJSON CreateProjectResponse where + parseJSON _ = pure CreateProjectResponse + -- | A list of daily downloads for a project, limited to the last 28 days (4 weeks) -- Listed from [most recent -> least recent] newtype DownloadStats = DownloadStats [Int64] @@ -163,6 +211,11 @@ newtype DownloadStats = DownloadStats [Int64] instance Aeson.ToJSON DownloadStats where toJSON (DownloadStats stats) = toJSON stats +instance Aeson.FromJSON DownloadStats where + parseJSON arr = do + stats <- parseJSON arr + pure $ DownloadStats stats + data ReleaseDownloadStats = ReleaseDownloadStats { releaseDownloads :: DownloadStats } @@ -174,6 +227,11 @@ instance Aeson.ToJSON ReleaseDownloadStats where [ "releaseDownloads" .= releaseDownloads ] +instance Aeson.FromJSON ReleaseDownloadStats where + parseJSON = Aeson.withObject "ReleaseDownloadStats" $ \o -> do + releaseDownloads <- o .: "releaseDownloads" + pure ReleaseDownloadStats {..} + data ContributionStats = ContributionStats { inReview :: Int, draft :: Int, @@ -191,6 +249,14 @@ instance Aeson.ToJSON ContributionStats where "numMergedContributions" .= merged ] +instance Aeson.FromJSON ContributionStats where + parseJSON = Aeson.withObject "ContributionStats" $ \o -> do + inReview <- o .: "numActiveContributions" + draft <- o .: "numDraftContributions" + closed <- o .: "numClosedContributions" + merged <- o .: "numMergedContributions" + pure ContributionStats {..} + instance PG.DecodeRow ContributionStats where decodeRow = do inReview <- fromIntegral @Int64 <$> PG.decodeField @@ -212,6 +278,12 @@ instance Aeson.ToJSON TicketStats where "numClosedTickets" .= numClosedTickets ] +instance Aeson.FromJSON TicketStats where + parseJSON = Aeson.withObject "TicketStats" $ \o -> do + numOpenTickets <- o .: "numOpenTickets" + numClosedTickets <- o .: "numClosedTickets" + pure TicketStats {..} + instance PG.DecodeRow TicketStats where decodeRow = do numOpenTickets <- fromIntegral @Int64 <$> PG.decodeField @@ -222,13 +294,13 @@ newtype IsPremiumProject = IsPremiumProject { isPremiumProject :: Bool } deriving (Show) - deriving (ToJSON) via (AtKey "isPremiumProject" Bool) + deriving (ToJSON, FromJSON) via (AtKey "isPremiumProject" Bool) newtype IsSubscribed = IsSubscribed { isSubscribed :: Bool } deriving (Show) - deriving (ToJSON) via (AtKey "isSubscribed" Bool) + deriving (ToJSON, FromJSON) via (AtKey "isSubscribed" Bool) type GetProjectResponse = APIProject @@ -248,12 +320,23 @@ data ListProjectsResponse = ListProjectsResponse instance Aeson.ToJSON ListProjectsResponse where toJSON (ListProjectsResponse projects) = toJSON projects +instance Aeson.FromJSON ListProjectsResponse where + parseJSON v = ListProjectsResponse <$> Aeson.parseJSON v + data UpdateProjectRequest = UpdateProjectRequest { summary :: NullableUpdate Text, visibility :: Maybe ProjectVisibility, tags :: SetUpdate ProjectTag } +instance Aeson.ToJSON UpdateProjectRequest where + toJSON UpdateProjectRequest {..} = + object + [ "summary" .= nullableUpdateToJSON summary, + "visibility" .= visibility, + "tags" .= tags + ] + instance Aeson.FromJSON UpdateProjectRequest where parseJSON = Aeson.withObject "UpdateProjectRequest" $ \obj -> do summary <- parseNullableUpdate obj "summary" @@ -271,6 +354,12 @@ data FavProjectRequest = FavProjectRequest } deriving (Show) +instance Aeson.ToJSON FavProjectRequest where + toJSON FavProjectRequest {..} = + Aeson.object + [ "isFaved" .= isFaved + ] + instance Aeson.FromJSON FavProjectRequest where parseJSON = Aeson.withObject "FavProjectRequest" $ \o -> FavProjectRequest <$> o Aeson..: "isFaved" diff --git a/src/Share/Web/Share/Releases/Types.hs b/src/Share/Web/Share/Releases/Types.hs index 304b4f72..912745d2 100644 --- a/src/Share/Web/Share/Releases/Types.hs +++ b/src/Share/Web/Share/Releases/Types.hs @@ -8,11 +8,11 @@ module Share.Web.Share.Releases.Types where import Data.Aeson import Data.Time (UTCTime) +import Servant (FromHttpApiData (..), ToHttpApiData (..)) import Share.IDs import Share.Postgres.IDs import Share.Prelude import Share.Release -import Servant (FromHttpApiData (..)) data ReleaseStatusFilter = OnlyPublished @@ -27,6 +27,12 @@ instance FromHttpApiData ReleaseStatusFilter where "any" -> Right AllReleases _ -> Left "Invalid release status filter" +instance ToHttpApiData ReleaseStatusFilter where + toQueryParam = \case + OnlyPublished -> "published" + OnlyDeprecated -> "deprecated" + AllReleases -> "any" + data APIReleaseStatus = APIPublishedRelease UTCTime (Maybe (PrefixedID "@" UserHandle)) | APIDeprecatedRelease UTCTime (Maybe (PrefixedID "@" UserHandle)) @@ -47,6 +53,14 @@ instance ToJSON APIReleaseStatus where "deprecatedBy" .= deprecatedBy ] +instance FromJSON APIReleaseStatus where + parseJSON = withObject "APIReleaseStatus" $ \o -> do + status :: Text <- o .: "status" + case status of + "published" -> APIPublishedRelease <$> o .: "publishedAt" <*> o .:? "publishedBy" + "deprecated" -> APIDeprecatedRelease <$> o .: "deprecatedAt" <*> o .:? "deprecatedBy" + _ -> fail $ "Invalid release status: " <> show status + -- | The api format for a release. data APIRelease = APIRelease { version :: ReleaseVersion, @@ -73,6 +87,18 @@ instance ToJSON APIRelease where "status" .= status ] +instance FromJSON APIRelease where + parseJSON = withObject "APIRelease" $ \o -> + APIRelease + <$> o .: "version" + <*> o .: "causalHashUnsquashed" + <*> o .: "causalHashSquashed" + <*> o .: "projectRef" + <*> o .: "createdAt" + <*> o .: "createdBy" + <*> o .: "updatedAt" + <*> o .: "status" + releaseToAPIRelease :: ProjectShortHand -> Release CausalHash UserHandle -> APIRelease releaseToAPIRelease projectSH Release {..} = APIRelease @@ -96,6 +122,11 @@ data StatusUpdate | MakeDeprecated deriving stock (Eq, Show) +instance ToJSON StatusUpdate where + toJSON = \case + MakePublished -> String "published" + MakeDeprecated -> String "deprecated" + instance FromJSON StatusUpdate where parseJSON = withText "StatusUpdate" $ \case "published" -> pure MakePublished @@ -106,6 +137,12 @@ data UpdateReleaseRequest = UpdateReleaseRequest { status :: Maybe StatusUpdate } +instance ToJSON UpdateReleaseRequest where + toJSON UpdateReleaseRequest {..} = + object + [ "status" .= status + ] + instance FromJSON UpdateReleaseRequest where parseJSON = withObject "UpdateReleaseRequest" $ \obj -> do status <- obj .:? "status" @@ -116,6 +153,15 @@ data CreateReleaseRequest = CreateReleaseRequest releaseVersion :: ReleaseVersion } +instance ToJSON CreateReleaseRequest where + toJSON CreateReleaseRequest {..} = + object + [ "causalHash" .= causalHash, + "major" .= major releaseVersion, + "minor" .= minor releaseVersion, + "patch" .= patch releaseVersion + ] + instance FromJSON CreateReleaseRequest where parseJSON = withObject "CreateReleaseRequest" $ \obj -> CreateReleaseRequest diff --git a/src/Share/Web/Share/Tickets/Types.hs b/src/Share/Web/Share/Tickets/Types.hs index c33880d0..d57fff2e 100644 --- a/src/Share/Web/Share/Tickets/Types.hs +++ b/src/Share/Web/Share/Tickets/Types.hs @@ -12,7 +12,7 @@ import Share.IDs import Share.Postgres qualified as PG import Share.Prelude import Share.Ticket (TicketStatus) -import Share.Utils.API (NullableUpdate, parseNullableUpdate) +import Share.Utils.API (NullableUpdate, nullableUpdateToJSON, parseNullableUpdate) import Share.Web.Share.Comments import Share.Web.Share.DisplayInfo.Types (UserDisplayInfo (..)) @@ -62,6 +62,20 @@ instance ToJSON (ShareTicket UserDisplayInfo) where "numComments" .= numComments ] +instance FromJSON (ShareTicket UserDisplayInfo) where + parseJSON = withObject "ShareTicket" \o -> do + ticketId <- o .: "id" + projectShortHand <- o .: "projectRef" + number <- o .: "number" + title <- o .: "title" + description <- o .:? "description" + status <- o .: "status" + createdAt <- o .: "createdAt" + updatedAt <- o .: "updatedAt" + author <- o .:? "author" + numComments <- o .: "numComments" + pure ShareTicket {..} + data StatusChangeEvent user = StatusChangeEvent { oldStatus :: Maybe TicketStatus, newStatus :: TicketStatus, @@ -100,12 +114,32 @@ instance (ToJSON user) => ToJSON (TicketTimelineEvent user) where ] TicketTimelineComment commentEvent -> toJSON commentEvent +instance (FromJSON user) => FromJSON (TicketTimelineEvent user) where + parseJSON = withObject "TicketTimelineEvent" \o -> do + kind <- o .: "kind" + case (kind :: Text) of + "statusChange" -> do + newStatus <- o .: "newStatus" + oldStatus <- o .:? "oldStatus" + actor <- o .: "actor" + timestamp <- o .: "timestamp" + pure $ TicketTimelineStatusChange StatusChangeEvent {..} + "comment" -> TicketTimelineComment <$> parseJSON (Object o) + _ -> fail $ "Unknown ticket timeline event kind: " <> show kind + data CreateTicketRequest = CreateTicketRequest { title :: Text, description :: Maybe Text } deriving (Show) +instance ToJSON CreateTicketRequest where + toJSON CreateTicketRequest {..} = + object + [ "title" .= title, + "description" .= description + ] + instance FromJSON CreateTicketRequest where parseJSON = withObject "CreateContributionRequest" \o -> do title <- o .: "title" @@ -119,6 +153,14 @@ data UpdateTicketRequest = UpdateTicketRequest } deriving (Show) +instance ToJSON UpdateTicketRequest where + toJSON UpdateTicketRequest {..} = + object + [ "title" .= title, + "description" .= nullableUpdateToJSON description, + "status" .= status + ] + instance FromJSON UpdateTicketRequest where parseJSON = withObject "UpdateTicketRequest" \o -> do title <- o .:? "title" diff --git a/src/Share/Web/Share/Types.hs b/src/Share/Web/Share/Types.hs index 13e518c9..a83b3e76 100644 --- a/src/Share/Web/Share/Types.hs +++ b/src/Share/Web/Share/Types.hs @@ -4,7 +4,7 @@ module Share.Web.Share.Types where -import Data.Aeson (KeyValue ((.=)), ToJSON (..)) +import Data.Aeson (FromJSON, KeyValue ((.=)), ToJSON (..), (.:), (.:?)) import Data.Aeson qualified as Aeson import Data.List.NonEmpty qualified as NEL import Data.Set qualified as Set @@ -17,7 +17,7 @@ import Share.IDs import Share.Postgres qualified as PG import Share.Prelude import Share.Project (ProjectVisibility) -import Share.Utils.API (NullableUpdate, parseNullableUpdate) +import Share.Utils.API (NullableUpdate, nullableUpdateToJSON, parseNullableUpdate) import Share.Utils.URI import Share.Web.Authorization.Types (RolePermission) import Share.Web.Share.DisplayInfo.Types (OrgDisplayInfo (..), UnifiedDisplayInfo, UserDisplayInfo (..), UserLike (..)) @@ -36,6 +36,18 @@ data UpdateUserRequest = UpdateUserRequest } deriving (Show) +instance Aeson.ToJSON UpdateUserRequest where + toJSON UpdateUserRequest {..} = + Aeson.object + [ "name" .= nullableUpdateToJSON name, + "avatarUrl" .= nullableUpdateToJSON avatarUrl, + "bio" .= nullableUpdateToJSON bio, + "website" .= nullableUpdateToJSON website, + "location" .= nullableUpdateToJSON location, + "twitterHandle" .= nullableUpdateToJSON twitterHandle, + "pronouns" .= nullableUpdateToJSON pronouns + ] + instance Aeson.FromJSON UpdateUserRequest where parseJSON = Aeson.withObject "UpdateUserRequest" $ \o -> do name <- parseNullableUpdate o "name" @@ -55,6 +67,12 @@ instance ToJSON UserKind where UserKind -> "user" OrgKind -> "org" +instance FromJSON UserKind where + parseJSON = Aeson.withText "UserKind" $ \case + "user" -> pure UserKind + "org" -> pure OrgKind + t -> fail $ "Invalid UserKind: " <> Text.unpack t + data DescribeUserProfile = DescribeUserProfile { bio :: Maybe Text, website :: Maybe Text, @@ -99,6 +117,39 @@ instance ToJSON DescribeUserProfile where "orgId" .= orgId ] +instance FromJSON DescribeUserProfile where + parseJSON = Aeson.withObject "DescribeUserProfile" $ \o -> do + kind <- o .: "kind" + case (kind :: Text) of + "user" -> do + handle <- o .: "handle" + name <- o .:? "name" + avatarUrl <- fmap unpackURI <$> o .:? "avatarUrl" + userId <- o .: "userId" + bio <- o .:? "bio" + website <- o .:? "website" + location <- o .:? "location" + twitterHandle <- o .:? "twitterHandle" + pronouns <- o .:? "pronouns" + permissions <- o .: "permissions" + pure $ DescribeUserProfile {bio, website, location, twitterHandle, pronouns, permissions, displayInfo = UnifiedUser (UserDisplayInfo {handle, name, avatarUrl, userId})} + "org" -> do + userInfo <- o .: "user" + handle <- userInfo Aeson..: "handle" + name <- userInfo Aeson..:? "name" + avatarUrl <- fmap unpackURI <$> userInfo Aeson..:? "avatarUrl" + userId <- userInfo Aeson..: "userId" + let user = UserDisplayInfo {handle, name, avatarUrl, userId} + orgId <- o .: "orgId" + isCommercial <- o .: "isCommercial" + bio <- userInfo Aeson..:? "bio" + website <- userInfo Aeson..:? "website" + twitterHandle <- userInfo Aeson..:? "twitterHandle" + pronouns <- userInfo Aeson..:? "pronouns" + permissions <- o .: "permissions" + pure $ DescribeUserProfile {bio, website, location = Nothing, twitterHandle, pronouns, permissions, displayInfo = UnifiedOrg (OrgDisplayInfo {user, orgId, isCommercial})} + _ -> fail $ "Unknown kind for DescribeUserProfile: " <> show kind + data ReadmeResponse = ReadmeResponse { readMe :: Maybe Doc, markdownReadMe :: Maybe Text @@ -112,6 +163,12 @@ instance ToJSON ReadmeResponse where "markdownReadMe" .= markdownReadMe ] +instance FromJSON ReadmeResponse where + parseJSON = Aeson.withObject "ReadmeResponse" $ \o -> do + readMe <- o Aeson..: "readMe" + markdownReadMe <- o Aeson..: "markdownReadMe" + pure ReadmeResponse {readMe, markdownReadMe} + -- | A reponse for rendering docs. data DocResponse = DocResponse { doc :: Maybe Doc @@ -124,6 +181,11 @@ instance ToJSON DocResponse where [ "doc" .= doc ] +instance FromJSON DocResponse where + parseJSON = Aeson.withObject "DocResponse" $ \o -> do + doc <- o Aeson..: "doc" + pure DocResponse {doc} + data SearchResult = SearchResultUserLike UnifiedDisplayInfo | -- | shorthand summary visibility @@ -163,6 +225,32 @@ instance ToJSON SearchResult where "visibility" .= visibility ] +instance FromJSON SearchResult where + parseJSON = Aeson.withObject "SearchResult" $ \o -> do + tag <- o Aeson..: "tag" + case (tag :: Text) of + "user" -> do + handle <- o Aeson..: "handle" + name <- o Aeson..:? "name" + avatarUrl <- o Aeson..:? "avatarUrl" + userId <- o Aeson..: "userId" + pure $ SearchResultUserLike $ UnifiedUser $ UserDisplayInfo {handle, name, avatarUrl, userId} + "org" -> do + orgId <- o Aeson..: "orgId" + isCommercial <- o Aeson..: "isCommercial" + user <- o Aeson..: "user" + handle <- user Aeson..: "handle" + name <- user Aeson..:? "name" + avatarUrl <- user Aeson..:? "avatarUrl" + userId <- user Aeson..: "userId" + pure $ SearchResultUserLike $ UnifiedOrg $ OrgDisplayInfo {user = UserDisplayInfo {handle, name, avatarUrl, userId}, orgId, isCommercial} + "project" -> do + projectRef <- o Aeson..: "projectRef" + summary <- o Aeson..:? "summary" + visibility <- o Aeson..: "visibility" + pure $ SearchResultProject projectRef summary visibility + t -> fail $ "Invalid SearchResult tag: " <> Text.unpack t + -- | Cloud/Unison Subscription plan tier data PlanTier = Free | Starter | Pro deriving (Show, Eq, Ord) @@ -173,6 +261,13 @@ instance ToJSON PlanTier where Starter -> "Starter" Pro -> "Pro" +instance FromJSON PlanTier where + parseJSON = Aeson.withText "PlanTier" $ \case + "Free" -> pure Free + "Starter" -> pure Starter + "Pro" -> pure Pro + t -> fail $ "Invalid PlanTier: " <> Text.unpack t + instance PG.DecodeValue PlanTier where decodeValue = PG.decodeValue @Text @@ -228,6 +323,55 @@ instance ToJSON UserAccountInfo where "hasUnreadNotifications" .= hasUnreadNotifications ] +instance FromJSON UserAccountInfo where + parseJSON = Aeson.withObject "UserAccountInfo" $ \o -> do + kind <- o Aeson..: "kind" + case (kind :: Text) of + "user" -> do + handle <- o Aeson..: "handle" + name <- o Aeson..:? "name" + avatarUrl <- o Aeson..:? "avatarUrl" + userId <- o Aeson..: "userId" + isSuperadmin <- o Aeson..: "isSuperadmin" + organizationMemberships <- o Aeson..: "organizationMemberships" + completedTours <- o Aeson..: "completedTours" + primaryEmail <- o Aeson..:? "primaryEmail" + planTier <- o Aeson..: "planTier" + hasUnreadNotifications <- o Aeson..: "hasUnreadNotifications" + pure $ + UserAccountInfo + { primaryEmail, + completedTours, + organizationMemberships, + isSuperadmin, + planTier, + displayInfo = UnifiedUser $ UserDisplayInfo {handle, name, avatarUrl, userId}, + hasUnreadNotifications + } + "org" -> do + userInfo <- o Aeson..: "user" + handle <- userInfo Aeson..: "handle" + name <- userInfo Aeson..:? "name" + avatarUrl <- userInfo Aeson..:? "avatarUrl" + userId <- userInfo Aeson..: "userId" + let user = UserDisplayInfo {handle, name, avatarUrl, userId} + orgId <- o Aeson..: "orgId" + isCommercial <- o Aeson..: "isCommercial" + organizationMemberships <- o Aeson..: "organizationMemberships" + planTier <- o Aeson..: "planTier" + hasUnreadNotifications <- o Aeson..: "hasUnreadNotifications" + pure $ + UserAccountInfo + { primaryEmail = Nothing, + completedTours = [], + organizationMemberships, + isSuperadmin = False, + planTier, + displayInfo = UnifiedOrg $ OrgDisplayInfo {orgId, isCommercial, user}, + hasUnreadNotifications + } + t -> fail $ "Invalid UserAccountInfo kind: " <> Text.unpack t + type PathSegment = Text data DefinitionNameSearchResult = DefinitionNameSearchResult @@ -242,6 +386,12 @@ instance ToJSON DefinitionNameSearchResult where "tag" .= tag ] +instance FromJSON DefinitionNameSearchResult where + parseJSON = Aeson.withObject "DefinitionNameSearchResult" $ \o -> do + token <- o Aeson..: "token" + tag <- o Aeson..: "tag" + pure DefinitionNameSearchResult {token, tag} + newtype DefinitionSearchResults = DefinitionSearchResults { results :: [DefinitionSearchResult] } @@ -252,6 +402,11 @@ instance ToJSON DefinitionSearchResults where [ "results" .= results ] +instance FromJSON DefinitionSearchResults where + parseJSON = Aeson.withObject "DefinitionSearchResults" $ \o -> do + results <- o Aeson..: "results" + pure DefinitionSearchResults {results} + data DefinitionSearchResult = DefinitionSearchResult { fqn :: Name, summary :: DefSync.TermOrTypeSummary, @@ -289,6 +444,35 @@ instance ToJSON DefinitionSearchResult where ] ) +instance FromJSON DefinitionSearchResult where + parseJSON = Aeson.withObject "DefinitionSearchResult" $ \o -> do + fqn <- o Aeson..: "fqn" + project <- o Aeson..: "projectRef" + branchRef <- o Aeson..: "branchRef" + kind <- o Aeson..: "kind" + definition <- o Aeson..: "definition" + summary <- case kind of + Aeson.String "term" -> do + definitionObj <- case definition of + Aeson.Object obj -> pure obj + _ -> fail "Expected object for term definition" + displayName <- definitionObj Aeson..: "displayName" + hash <- definitionObj Aeson..: "hash" + summaryText <- definitionObj Aeson..: "summary" + tag <- definitionObj Aeson..: "tag" + pure $ DefSync.ToTTermSummary $ TermSummary {displayName, hash, summary = summaryText, tag} + Aeson.String "type" -> do + definitionObj <- case definition of + Aeson.Object obj -> pure obj + _ -> fail "Expected object for type definition" + displayName <- definitionObj Aeson..: "displayName" + hash <- definitionObj Aeson..: "hash" + summaryText <- definitionObj Aeson..: "summary" + tag <- definitionObj Aeson..: "tag" + pure $ DefSync.ToTTypeSummary $ TypeSummary {displayName, hash, summary = summaryText, tag} + _ -> fail "Invalid definition kind" + pure DefinitionSearchResult {fqn, summary, project, branchRef} + data SearchKind = SearchKindProjects | SearchKindUsers @@ -314,10 +498,23 @@ instance FromHttpApiData SearchKinds where Nothing -> do Left $ "Invalid search kinds: " <> q +instance ToHttpApiData SearchKinds where + toQueryParam (SearchKinds kinds) = + kinds + & toList + <&> toQueryParam + & Text.intercalate "," + instance FromHttpApiData SearchKind where - parseQueryParam "projects" = Right SearchKindProjects - parseQueryParam "users" = Right SearchKindUsers - parseQueryParam _ = Left "Invalid search kind" + parseQueryParam = \case + "projects" -> Right SearchKindProjects + "users" -> Right SearchKindUsers + _ -> Left "Invalid search kind" + +instance ToHttpApiData SearchKind where + toQueryParam = \case + SearchKindProjects -> "projects" + SearchKindUsers -> "users" data UserSearchKind = UserSearchKindDefault @@ -325,9 +522,15 @@ data UserSearchKind UserSearchKindHandlePrefix instance FromHttpApiData UserSearchKind where - parseQueryParam "default" = Right UserSearchKindDefault - parseQueryParam "handle-prefix" = Right UserSearchKindHandlePrefix - parseQueryParam _ = Left "Invalid user search kind" + parseQueryParam = \case + "default" -> Right UserSearchKindDefault + "handle-prefix" -> Right UserSearchKindHandlePrefix + _ -> Left "Invalid user search kind" + +instance ToHttpApiData UserSearchKind where + toQueryParam = \case + UserSearchKindDefault -> "default" + UserSearchKindHandlePrefix -> "handle-prefix" data ProjectSearchKind = ProjectSearchKindWebSearch @@ -336,7 +539,14 @@ data ProjectSearchKind ProjectSearchKindSlugInfix instance FromHttpApiData ProjectSearchKind where - parseQueryParam "web-search" = Right ProjectSearchKindWebSearch - parseQueryParam "slug-prefix" = Right ProjectSearchKindSlugPrefix - parseQueryParam "slug-infix" = Right ProjectSearchKindSlugInfix - parseQueryParam _ = Left "Invalid project search kind" + parseQueryParam = \case + "web-search" -> Right ProjectSearchKindWebSearch + "slug-prefix" -> Right ProjectSearchKindSlugPrefix + "slug-infix" -> Right ProjectSearchKindSlugInfix + _ -> Left "Invalid project search kind" + +instance ToHttpApiData ProjectSearchKind where + toQueryParam = \case + ProjectSearchKindWebSearch -> "web-search" + ProjectSearchKindSlugPrefix -> "slug-prefix" + ProjectSearchKindSlugInfix -> "slug-infix" diff --git a/src/Share/Web/Share/Users/API.hs b/src/Share/Web/Share/Users/API.hs new file mode 100644 index 00000000..312555d6 --- /dev/null +++ b/src/Share/Web/Share/Users/API.hs @@ -0,0 +1,45 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TypeOperators #-} + +module Share.Web.Share.Users.API + ( API, + UserResourceAPI, + ) +where + +import Servant +import Share.IDs +import Share.Notifications.API qualified as Notifications +import Share.OAuth.Session (AuthenticatedUserId, MaybeAuthenticatedSession) +import Share.Utils.Caching +import Share.Web.Share.Branches.API (UserBranchesAPI) +import Share.Web.Share.Contributions.API (ContributionsByUserAPI) +import Share.Web.Share.Projects.API (ProjectsAPI) +import Share.Web.Share.Types + +type API = + MaybeAuthenticatedSession + :> Capture "user_handle" UserHandle + :> UserResourceAPI + +type UserResourceAPI = + ("readme" :> UserReadmeEndpoint) + :<|> UserProfileEndpoint + :<|> UpdateUserEndpoint + :<|> ("projects" :> ProjectsAPI) + :<|> ("branches" :> UserBranchesAPI) + :<|> ("contributions" :> ContributionsByUserAPI) + :<|> ("notifications" :> Notifications.API) + +-- | PATCH /users/:user_handle +-- Update the user's profile +type UpdateUserEndpoint = + AuthenticatedUserId + :> ReqBody '[JSON] UpdateUserRequest + :> Patch '[JSON] DescribeUserProfile + +-- | GET /users/:user_handle +type UserProfileEndpoint = Get '[JSON] DescribeUserProfile + +-- | GET /users/:user_handle/readme +type UserReadmeEndpoint = Get '[JSON] (Cached JSON ReadmeResponse) diff --git a/src/Share/Web/Types.hs b/src/Share/Web/Types.hs index 9b656d38..c32a6095 100644 --- a/src/Share/Web/Types.hs +++ b/src/Share/Web/Types.hs @@ -2,7 +2,7 @@ module Share.Web.Types (DiscoveryDocument (..), UserInfo (..)) where -import Data.Aeson (ToJSON (..), (.=)) +import Data.Aeson (FromJSON (..), ToJSON (..), (.=)) import Data.Aeson qualified as Aeson import Share.IDs import Share.OAuth.Types (ResponseType) @@ -32,6 +32,16 @@ instance ToJSON DiscoveryDocument where "response_types_supported" .= responseTypesSupported ] +instance FromJSON DiscoveryDocument where + parseJSON = Aeson.withObject "DiscoveryDocument" $ \o -> do + issuer <- o Aeson..: "issuer" + authorizationE <- o Aeson..: "authorization_endpoint" + tokenE <- o Aeson..: "token_endpoint" + userInfoE <- o Aeson..: "userinfo_endpoint" + jwksURI <- o Aeson..: "jwks_uri" + responseTypesSupported <- o Aeson..: "response_types_supported" + pure DiscoveryDocument {issuer, authorizationE, tokenE, userInfoE, jwksURI, responseTypesSupported} + -- | This response is compliant with the claims specified here: https://openid.net/specs/openid-connect-core-1_0.html#StandardClaims -- -- It's permitted to add additional claims, but any standard claims must be formatted @@ -57,3 +67,13 @@ instance ToJSON UserInfo where "email" .= email, "handle" .= handle ] + +instance FromJSON UserInfo where + parseJSON = Aeson.withObject "UserInfo" $ \o -> do + sub <- o Aeson..: "sub" + name <- o Aeson..: "name" + picture <- o Aeson..: "picture" + profile <- o Aeson..: "profile" + email <- o Aeson..: "email" + handle <- o Aeson..: "handle" + pure UserInfo {sub, name, picture, profile, email, handle} diff --git a/src/Unison/Server/Share/FuzzyFind.hs b/src/Unison/Server/Share/FuzzyFind.hs index 6b854bb2..10ab8c02 100644 --- a/src/Unison/Server/Share/FuzzyFind.hs +++ b/src/Unison/Server/Share/FuzzyFind.hs @@ -88,6 +88,13 @@ instance ToJSON FoundType where "namedType" Aeson..= namedType ] +instance FromJSON FoundType where + parseJSON = withObject "FoundType" $ \o -> do + bestFoundTypeName <- o .: "bestFoundTypeName" + typeDef <- o .: "typeDef" + namedType <- o .: "namedType" + pure FoundType {bestFoundTypeName, typeDef, namedType} + instance ToJSON FoundTerm where toJSON (FoundTerm {bestFoundTermName, namedTerm}) = object @@ -95,6 +102,12 @@ instance ToJSON FoundTerm where "namedTerm" Aeson..= namedTerm ] +instance FromJSON FoundTerm where + parseJSON = withObject "FoundTerm" $ \o -> do + bestFoundTermName <- o .: "bestFoundTermName" + namedTerm <- o .: "namedTerm" + pure FoundTerm {bestFoundTermName, namedTerm} + data FoundResult = FoundTermResult FoundTerm | FoundTypeResult FoundType @@ -105,6 +118,14 @@ instance ToJSON FoundResult where FoundTermResult ft -> object ["tag" Aeson..= String "FoundTermResult", "contents" Aeson..= ft] FoundTypeResult ft -> object ["tag" Aeson..= String "FoundTypeResult", "contents" Aeson..= ft] +instance FromJSON FoundResult where + parseJSON = withObject "FoundResult" $ \o -> do + tag :: Text <- o .: "tag" + case tag of + "FoundTermResult" -> FoundTermResult <$> o .: "contents" + "FoundTypeResult" -> FoundTypeResult <$> o .: "contents" + _ -> fail $ "Unknown FoundResult tag: " <> show tag + serveFuzzyFind :: forall m. (QueryM m) => @@ -251,14 +272,33 @@ instance ToJSON Alignment where toJSON (Alignment {score, result}) = object ["score" Aeson..= score, "result" Aeson..= result] +instance FromJSON Alignment where + parseJSON = withObject "Alignment" $ \o -> do + score <- o .: "score" + result <- o .: "result" + pure Alignment {score, result} + instance ToJSON MatchResult where toJSON (MatchResult {segments}) = object ["segments" Aeson..= toJSON segments] +instance FromJSON MatchResult where + parseJSON = withObject "MatchResult" $ \o -> do + segments <- o .: "segments" + pure MatchResult {segments} + instance ToJSON MatchSegment where toJSON = \case Gap s -> object ["tag" Aeson..= String "Gap", "contents" Aeson..= s] Match s -> object ["tag" Aeson..= String "Match", "contents" Aeson..= s] +instance FromJSON MatchSegment where + parseJSON = withObject "MatchSegment" $ \o -> do + tag :: Text <- o .: "tag" + case tag of + "Gap" -> Gap <$> o .: "contents" + "Match" -> Match <$> o .: "contents" + _ -> fail $ "Unknown MatchSegment tag: " <> show tag + -- After finding a search results with fuzzy find we do some post processing to -- refine the result: -- * Sort: diff --git a/stack.yaml b/stack.yaml index 6130c9d9..dfd3d48e 100644 --- a/stack.yaml +++ b/stack.yaml @@ -5,6 +5,7 @@ packages: - share-auth - share-auth/example - share-utils +- share-client - unison/codebase2/codebase - unison/codebase2/codebase-sqlite - unison/codebase2/codebase-sqlite-hashing-v2 diff --git a/transcripts/share-apis/notifications/list-notifications-read-transcripts.json b/transcripts/share-apis/notifications/list-notifications-read-transcripts.json index 34917006..ad33a97e 100644 --- a/transcripts/share-apis/notifications/list-notifications-read-transcripts.json +++ b/transcripts/share-apis/notifications/list-notifications-read-transcripts.json @@ -36,6 +36,7 @@ }, "id": "EVENT-", "occurredAt": "", + "resourceId": "RES-", "scope": { "info": { "avatarUrl": null, diff --git a/transcripts/share-apis/notifications/list-notifications-test-paging.json b/transcripts/share-apis/notifications/list-notifications-test-paging.json index 1aad3a4f..ca9938cd 100644 --- a/transcripts/share-apis/notifications/list-notifications-test-paging.json +++ b/transcripts/share-apis/notifications/list-notifications-test-paging.json @@ -53,6 +53,7 @@ }, "id": "EVENT-", "occurredAt": "", + "resourceId": "RES-", "scope": { "info": { "avatarUrl": null, diff --git a/transcripts/share-apis/notifications/list-notifications-test.json b/transcripts/share-apis/notifications/list-notifications-test.json index c240e3af..3f5d159a 100644 --- a/transcripts/share-apis/notifications/list-notifications-test.json +++ b/transcripts/share-apis/notifications/list-notifications-test.json @@ -53,6 +53,7 @@ }, "id": "EVENT-", "occurredAt": "", + "resourceId": "RES-", "scope": { "info": { "avatarUrl": null, @@ -107,6 +108,7 @@ }, "id": "EVENT-", "occurredAt": "", + "resourceId": "RES-", "scope": { "info": { "avatarUrl": null, @@ -187,6 +189,7 @@ }, "id": "EVENT-", "occurredAt": "", + "resourceId": "RES-", "scope": { "info": { "avatarUrl": null, @@ -256,6 +259,7 @@ }, "id": "EVENT-", "occurredAt": "", + "resourceId": "RES-", "scope": { "info": { "avatarUrl": null, diff --git a/transcripts/share-apis/notifications/list-notifications-transcripts.json b/transcripts/share-apis/notifications/list-notifications-transcripts.json index c8ed1feb..f94e8cf8 100644 --- a/transcripts/share-apis/notifications/list-notifications-transcripts.json +++ b/transcripts/share-apis/notifications/list-notifications-transcripts.json @@ -36,6 +36,7 @@ }, "id": "EVENT-", "occurredAt": "", + "resourceId": "RES-", "scope": { "info": { "avatarUrl": null, @@ -109,6 +110,7 @@ }, "id": "EVENT-", "occurredAt": "", + "resourceId": "RES-", "scope": { "info": { "avatarUrl": null, @@ -154,6 +156,7 @@ }, "id": "EVENT-", "occurredAt": "", + "resourceId": "RES-", "scope": { "info": { "avatarUrl": null, diff --git a/transcripts/share-apis/notifications/list-notifications-unread-test.json b/transcripts/share-apis/notifications/list-notifications-unread-test.json index 6ee65027..11149940 100644 --- a/transcripts/share-apis/notifications/list-notifications-unread-test.json +++ b/transcripts/share-apis/notifications/list-notifications-unread-test.json @@ -42,6 +42,7 @@ }, "id": "EVENT-", "occurredAt": "", + "resourceId": "RES-", "scope": { "info": { "avatarUrl": null, @@ -122,6 +123,7 @@ }, "id": "EVENT-", "occurredAt": "", + "resourceId": "RES-", "scope": { "info": { "avatarUrl": null, @@ -191,6 +193,7 @@ }, "id": "EVENT-", "occurredAt": "", + "resourceId": "RES-", "scope": { "info": { "avatarUrl": null, diff --git a/unison b/unison index 3ecad945..abe58eb3 160000 --- a/unison +++ b/unison @@ -1 +1 @@ -Subproject commit 3ecad945acf0dfdd8adf1b9486d74143063358db +Subproject commit abe58eb349bfba2a39e576e335af9b18dcc3a5b2