diff --git a/.linting/duplicate-ids-whitelist.txt b/.linting/duplicate-ids-whitelist.txt deleted file mode 100644 index 54192d56961..00000000000 --- a/.linting/duplicate-ids-whitelist.txt +++ /dev/null @@ -1,658 +0,0 @@ -<| 2 -A 2 -AWSOpts 3 -Access 3 -AccessToken 3 -Activated 2 -ActivationEmail 2 -ActivationEmailTemplate 2 -Active 2 -AddBot 2 -Amazon 3 -AppT 2 -Asset 2 -Auth 2 -Bot 2 -Brig 3 -Buckets 2 -Cannon 5 -CargoHold 2 -CassandraSettings 4 -Client 2 -ClientDataError 2 -ClientEvent 2 -ClientId 2 -Clients 2 -Clock 2 -Code 2 -Command 2 -CompletePasswordReset 2 -Config 3 -ConnectionEvent 2 -ConvCreate 2 -ConvDelete 2 -ConvEvent 2 -Conversation 2 -Counter 2 -Create 2 -Credentials 3 -DeleteService 2 -DeleteUser 2 -Deleted 2 -DeliveryFailure 2 -EdMemberUpdate 2 -EmailUpdate 2 -EndpointDisabled 2 -Env 19 -Error 6 -ErrorResponse 2 -Event 5 -EventData 2 -EventType 4 -Failure 2 -Galley 3 -Gauge 2 -GeneralError 3 -Gundeck 3 -Handler 2 -HighPriority 2 -IndexError 2 -IntegrationConfig 4 -JSON 6 -Key 2 -Label 2 -LoginFailed 2 -LowPriority 2 -MatchFailure 3 -MemberJoin 2 -MemberLeave 2 -MemberUpdate 2 -Message 3 -MessageId 2 -MessageResponse 2 -MigratorSettings 2 -Name 2 -NewOtrMessage 2 -NewTeamMember 2 -Notification 2 -Octet 2 -Opts 10 -P 2 -ParseError 4 -Password 2 -PasswordChange 2 -PasswordReset 3 -PasswordResetEmail 2 -PasswordResetEmailTemplate 2 -Path 2 -PayloadTooLarge 2 -Priority 2 -PropertyEvent 2 -Provider 2 -Push 2 -Queue 2 -QueueUrl 2 -Recipient 2 -ResponseLBS 3 -ResultPage 2 -S 3 -Scope 2 -Section 2 -Server 2 -Service 2 -ServiceConfigFile 3 -Settings 5 -Suspended 2 -TTL 3 -TestSetup 3 -TestSignature 5 -Timeout 2 -Token 2 -Transport 2 -Type 2 -U 2 -User 2 -UserEvent 2 -UserId 2 -Writetime 2 -_applog 4 -_awsEnv 4 -_awsQueueName 2 -_cHosts 3 -_cKeyspace 4 -_cPort 4 -_clock 2 -_cstate 2 -_eventQueue 2 -_extGetManager 2 -_httpManager 2 -_key 2 -_logger 3 -_manager 3 -_metrics 2 -_monitor 3 -_optAws 2 -_optCassandra 2 -_optDiscoUrl 2 -_optGundeck 2 -_optLogLevel 3 -_optLogNetStrings 3 -_optSettings 3 -_options 3 -_pushNativePriority 2 -_pushTransient 2 -_queue 2 -_recipientClients 2 -_reqId 3 -_requestId 2 -_setCasBrig 2 -_setHttpPoolSize 2 -_settings 3 -_time 2 -_user 2 -_userId 3 -accept 2 -access 2 -accessDenied 2 -accessToken 4 -acmName 2 -acmTo 2 -activate 6 -activateKey 3 -activationEmail 2 -activationEmailBodyHtml 2 -activationEmailBodyText 2 -activationEmailSender 2 -activationEmailSenderName 2 -activationEmailSubject 2 -activationEmailUpdate 2 -activationEmailUrl 2 -add 4 -addBot 4 -addBotMember 2 -addClient 5 -addMembers 4 -addService 3 -addTeamMember 5 -addTeamMemberInternal 2 -appName 2 -assert 2 -assertQueue 2 -assertTrue 2 -assetSize 2 -autoConnect 2 -await 2 -awsEnv 2 -beginPasswordReset 3 -bindUser 2 -blockConv 2 -body 2 -brig 7 -buckets 2 -bulkPush 2 -bytes 2 -call 5 -canBeDeleted 2 -canRetry 3 -cannon 5 -cannon2 2 -cargohold 4 -cassandra 2 -cassandraSettingsParser 4 -changeAccountStatus 2 -changeEmail 2 -changeHandle 3 -changeLocale 3 -changePassword 3 -changePhone 2 -changeTeamStatus 2 -check 4 -checkHandles 4 -claimPrekey 2 -clearProperties 3 -cliOptsParser 2 -client 3 -clientClass 2 -clientError 3 -clientId 3 -clientType 2 -clients 3 -close 2 -closeEnv 2 -code 3 -codeDelete 2 -codeInsert 2 -codeKey 2 -codeScope 2 -codeSelect 3 -codeTTL 2 -codeValue 2 -compile 2 -completePasswordReset 5 -connect 2 -connectUsers 3 -connection 3 -connectionUpdate 2 -contains 3 -conversation 3 -conversationCode 2 -conversations 2 -cookie 2 -cookieList 2 -cookieType 2 -cpNewPassword 2 -cpOldPassword 2 -cpwrCode 2 -cpwrPassword 2 -create 4 -createConnectConversation 2 -createConnection 2 -createConv 2 -createEnv 3 -createManagedConv 2 -createOne2OneConversation 2 -createRandomPhoneUser 2 -createResumable 2 -createSelfConversation 2 -createTeam 4 -createTeamConv 2 -createTeamMember 2 -createUser 7 -createUserWithTeam 2 -createUser_ 2 -decode 3 -decodeBase64 2 -decodeBody 5 -decodeBody' 3 -defCookieLabel 2 -defPassword 3 -delete 6 -deleteAccount 3 -deleteAll 2 -deleteBot 2 -deleteClient 3 -deleteCode 2 -deleteEndpoint 2 -deleteInvitation 2 -deleteKey 2 -deleteMessage 2 -deletePrefix 2 -deleteProperty 4 -deleteScimToken 2 -deleteService 4 -deleteTeam 6 -deleteTeamConv 2 -deleteTeamMember 2 -deleteToken 4 -deleteUser 7 -deleteUserNoVerify 2 -deliver 2 -destroyEnv 2 -dict 2 -discoUrl 2 -docs 3 -download 2 -downloadAsset 2 -ec2InternalHostname 2 -ec2Region 2 -empty 5 -enqueue 4 -ensureReAuthorised 2 -env 2 -euEmail 2 -event 3 -eventType 3 -exec 2 -execute 4 -fetchMessage 2 -field 3 -fieldParsers 2 -fromBody 3 -galley 5 -gcmPriority 2 -genAlphaNum 2 -genRecipient 2 -generate 2 -get 2 -getActivationCode 4 -getAsset 2 -getClient 2 -getClients 2 -getConnection 3 -getContactList 2 -getConv 3 -getConversation 2 -getCookie 2 -getInvitation 2 -getInvitationCode 2 -getManager 2 -getPrekey 2 -getProperty 2 -getProviderProfile 2 -getResumable 2 -getRichInfo 2 -getSelf 2 -getSelfProfile 3 -getService 2 -getServiceProfile 2 -getTeam 4 -getTeamMember 4 -getTeamMembers 4 -getTeams 2 -getTime 2 -getUser 6 -getUsers 2 -gundeck 3 -handlers 2 -head 2 -header 3 -host 4 -ifNothing 3 -index 2 -initCassandra 3 -initHttpManager 4 -insert 5 -insertAccount 2 -insertCode 2 -insertKey 2 -insertPrefix 2 -insertService 2 -insertUser 2 -invalidCode 2 -invalidRange 2 -invalidUser 2 -isConvDeleted 2 -isMember 3 -isSearchable 2 -isTeamOwner 2 -journalEvent 3 -json 2 -key 2 -keyDelete 3 -keyInsert 3 -keySelect 3 -label 2 -labels 2 -list 2 -listAll 2 -listConnections 3 -listCookies 4 -listServiceProfiles 2 -listServices 2 -listTokens 2 -listUsers 2 -listen 4 -location 4 -logError 2 -logNetStrings 2 -login 6 -logout 2 -lookup 3 -lookupAccount 2 -lookupActivationCode 2 -lookupClients 3 -lookupCode 3 -lookupConnections 2 -lookupCookie 2 -lookupKey 2 -lookupLoginCode 2 -lookupPassword 2 -lookupPasswordResetCode 2 -lookupReqId 4 -lookupService 2 -mFailure 2 -main 41 -manager 4 -match 2 -maxAttempts 3 -member 3 -memberEvent 2 -memberUpdate 3 -members 3 -message 2 -method 2 -migration 72 -mkActivationKey 2 -mkAddress 2 -mkBot 2 -mkEndpoint 2 -mkEnv 11 -mkKey 3 -mkPasswordResetKey 2 -monitor 2 -monitoring 4 -msgFrom 2 -msgText 2 -msgTo 2 -name 2 -new 2 -newAccessToken 2 -newAccount 2 -newBotToken 2 -newClient 3 -newClientId 2 -newEnv 4 -newOtrMessage 2 -newPush 2 -newTeam 3 -newTeamMember 2 -nginz 2 -noOtherOwner 2 -notConnected 2 -notFound 2 -now 2 -octet 3 -onError 2 -onEvent 3 -onboarding 2 -optInfo 2 -options 4 -opts 2 -optsParser 2 -otrRecipients 2 -parse 2 -parseDeleteMessage 2 -parseEventData 2 -parseOptions 3 -parseOpts 2 -parseResponse 3 -parser 2 -passwordResetEmail 2 -passwordResetEmailBodyHtml 2 -passwordResetEmailBodyText 2 -passwordResetEmailSender 2 -passwordResetEmailSenderName 2 -passwordResetEmailSubject 2 -passwordResetEmailUrl 2 -path 3 -paths 2 -ping 2 -port 2 -postBotMessage 2 -postOtrMessage 3 -postProtoOtrBroadcast 2 -postProtoOtrMessage 2 -postUser 2 -provider 2 -pubClient 2 -publish 2 -purgeQueue 2 -push 6 -push1 2 -pushToken 2 -put 2 -putConnection 2 -pwrCode 2 -pwrTo 2 -quoted 2 -randomBytes 3 -randomConnId 2 -randomEmail 3 -randomPhone 2 -randomUser 4 -randomUser' 2 -rangeChecked 2 -reAuthUser 2 -readBody 2 -readFile 2 -receive 2 -recipient 2 -refreshIndex 2 -register 2 -registerUser 3 -reindex 2 -remove 2 -removeBot 3 -removeClient 2 -removeEmail 2 -removeMember 4 -removePhone 2 -removeUser 3 -render 2 -renderActivationMail 2 -renderActivationUrl 2 -renderPwResetMail 2 -renderPwResetUrl 2 -renderText 2 -renewToken 2 -reqId 2 -reqIdMsg 3 -requestId 2 -resultHasMore 2 -retryWhileN 4 -revokeIdentity 2 -rmClient 6 -rmUser 2 -routes 5 -rtcConfiguration 2 -rtcIceServer 2 -run 4 -runAppResourceT 2 -runAppT 2 -runCannon 2 -runCommand 4 -runGundeck 2 -runHandler 2 -runServer 4 -runTests 4 -schemaVersion 5 -search 2 -secret 2 -selectClients 2 -selfConv 2 -send 3 -sendActivationCode 3 -sendActivationMail 2 -sendCall 2 -sendCatch 3 -sendLoginCode 4 -sendMail 3 -sendMessage 3 -sendMessages 2 -sendPasswordResetMail 2 -serialise 2 -serialiseOkProp 2 -serverHost 2 -serverPort 2 -setProperty 3 -setStatus 2 -settingsParser 3 -signature 2 -signedURL 2 -singleton 2 -sitemap 6 -sockSv 2 -sockSvTiny 2 -sockSvTinyNetstr 2 -someLastPrekeys 2 -spec 13 -ssoLogin 4 -start 2 -status 2 -suspendTeam 2 -svTiny 2 -svTinyNetstr 2 -svlogd 2 -tagged 2 -tdStatus 2 -team 3 -teamConversation 2 -teamDelete 2 -teamMember 2 -terminate 2 -test 7 -testCreateTeam 2 -testCreateUser 2 -testDeleteTeam 2 -tests 34 -timeout 2 -tiny 2 -tinyNetstr 2 -toCode 2 -toJson 3 -toText 3 -token 2 -tokenResponse 2 -tooManyMembers 2 -tooManyTeamMembers 2 -tryMatch 2 -ttl 2 -unAmazon 3 -unblockConv 2 -unsuspendTeam 2 -unwrap 2 -updateAccountPassword 2 -updateAccountProfile 2 -updateClient 5 -updateClientLabel 2 -updateConnection 4 -updateConversation 2 -updateConversationAccess 3 -updateConversationMessageTimer 2 -updateConversationReceiptMode 2 -updateEndpoint 3 -updateManagedBy 2 -updateMember 2 -updatePermissions 2 -updatePhone 2 -updateRichInfo 2 -updateSSOId 2 -updateSearchableStatus 2 -updateService 3 -updateServiceConn 3 -updateServiceTags 2 -updateServiceWhitelist 2 -updateTeam 2 -updateTeamMember 2 -updateTeamStatus 3 -updateUser 4 -upload 2 -url 3 -urlPort 2 -user 4 -userClients 2 -userId 3 -userName 2 -userUpdate 2 -validate 2 -values 2 -verify 3 -verifyDeleteUser 2 -version 2 -wait 2 -whitelistService 2 -wsAssertMemberJoin 2 -wsAssertMemberLeave 2 -x1 3 -x3 6 -zAuthAccess 2 -zConn 5 -zUser 6 -zauth 3 -BrigR 2 -CannonR 2 -TestM 2 -_tsBrig 2 -_tsCannon 2 -_tsManager 2 -runTestM 2 diff --git a/CHANGELOG.md b/CHANGELOG.md index 4ce9c74b4f4..944d3af9c61 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,36 @@ +# 2019-04-09 #710 + +## API changes + +- Do not allow provisioning saml users if SCIM is configured (#706) + +## Documentation changes + +- Docs for user deletion via SCIM. (#691) +- Docs for jump-to-definition with Emacs (#693) +- Add missing config options in demo (#694) +- Move the connections doc, add haddocks (#695) + +## Bug fixes + +- Fix templating in outgoing SMSs. (#696) +- Saml implicit user creation no longer chokes on odd but legal names. (#702) +- Fix: user deletion via scim (#698) + +## Internal changes + +- Remove redundant cassandra write in renewCookie (#676) +- Add Prometheus middleware for wire-services (#672) +- Improve logging of spar errors (#654) +- Upgrade cql-io-1.1.0 (#697) +- Switch metrics-core to be backed by Prometheus (#704) +- Refactorings: + - #665, #687, #685, #686 + +## Changes (potentially) requiring action for self-hosters + +- Switch proxy to use YAML-only config (#684) + # 2019-03-25 #674 ## API changes diff --git a/build/alpine/Dockerfile.builder b/build/alpine/Dockerfile.builder index f0b03bf2aa2..e5e9dafc7c5 100644 --- a/build/alpine/Dockerfile.builder +++ b/build/alpine/Dockerfile.builder @@ -14,8 +14,11 @@ WORKDIR / # # Finally, we build docs for haskell-src-exts without hyperlinking enabled # to avoid a Haddock segfault. See https://github.com/haskell/haddock/issues/928 +# +# Note: git, ncurses, sed are added here for historical reasons; since +# roughly 2019-03-28, they are included in prebuilder as well. -RUN apk add --no-cache git ncurses && \ +RUN apk add --no-cache git ncurses sed && \ git clone -b develop https://github.com/wireapp/wire-server.git && \ cd /wire-server && \ stack update && \ diff --git a/build/alpine/Dockerfile.prebuilder b/build/alpine/Dockerfile.prebuilder index 8c895457cfe..71a6e51d979 100644 --- a/build/alpine/Dockerfile.prebuilder +++ b/build/alpine/Dockerfile.prebuilder @@ -33,10 +33,23 @@ RUN apk add --no-cache \ llvm-libunwind-dev \ bash \ xz \ - libxml2-dev + libxml2-dev \ + git \ + ncurses \ + sed # get static version of Haskell Stack and use system ghc by default ARG STACK_ALPINE_VERSION=1.9.1 RUN curl -sSfL https://github.com/commercialhaskell/stack/releases/download/v${STACK_ALPINE_VERSION}/stack-${STACK_ALPINE_VERSION}-linux-x86_64-static.tar.gz \ | tar --wildcards -C /usr/local/bin --strip-components=1 -xzvf - '*/stack' && chmod 755 /usr/local/bin/stack && \ stack config set system-ghc --global true + +# upgrade stack to current master (2019-03-28). this fixes an issue +# with building internal libraries as used in cql-io-1.1.0. +# details: https://github.com/commercialhaskell/stack/pull/4596 +RUN git clone https://github.com/commercialhaskell/stack && \ + cd stack && \ + git checkout f0b66a1ab60fb5be85f6cb60491915bf53d3cd3c && \ + sed -i -e 's/lts-12.20/lts-12.14/' snapshot-lts-12.yaml && \ + stack install --system-ghc --stack-yaml=stack-lts-12.yaml --system-ghc && \ + cp /root/.local/bin/stack /usr/local/bin/stack diff --git a/deploy/services-demo/conf/brig.demo.yaml b/deploy/services-demo/conf/brig.demo.yaml index 17e3f1a1030..e0596a1508c 100644 --- a/deploy/services-demo/conf/brig.demo.yaml +++ b/deploy/services-demo/conf/brig.demo.yaml @@ -43,7 +43,17 @@ emailSMS: templateDir: resources/templates emailSender: backend-demo@mail.wiredemo.example.com smsSender: "" - + templateBranding: + brand: Wire + brandUrl: https://wire.com + brandLabelUrl: wire.com # This is the text in the label for the above URL + brandLogoUrl: https://wire.com/p/img/email/logo-email-black.png + brandService: Wire Service Provider + copyright: © WIRE SWISS GmbH + misuse: misuse@wire.com + legal: https://wire.com/legal/ + forgot: https://wire.com/forgot/ + support: https://support.wire.com/ user: activationUrl: http://127.0.0.1:8080/activate?key=${key}&code=${code} smsActivationUrl: http://127.0.0.1:8080/v/${code} diff --git a/deploy/services-demo/conf/proxy.demo.yaml b/deploy/services-demo/conf/proxy.demo.yaml index e9b1e196eaf..7ed80906ac0 100644 --- a/deploy/services-demo/conf/proxy.demo.yaml +++ b/deploy/services-demo/conf/proxy.demo.yaml @@ -4,3 +4,6 @@ port: 8087 httpPoolSize: 1000 maxConns: 5000 secretsConfig: resources/proxy.config + +logLevel: Info +logNetStrings: false diff --git a/deploy/services-demo/demo.sh b/deploy/services-demo/demo.sh index 6479fb49f59..46c6936dd14 100755 --- a/deploy/services-demo/demo.sh +++ b/deploy/services-demo/demo.sh @@ -99,8 +99,6 @@ blueish=4 function run_haskell_service() { service=$1 colour=$2 - # TODO can be removed once all services have been switched to YAML configs - [ $# -gt 2 ] && export LOG_LEVEL=$3 (cd ${SCRIPT_DIR} && ${DIR}/../dist/${service} -c ${SCRIPT_DIR}/conf/${service}.demo.yaml || kill_all) \ | sed -e "s/^/$(tput setaf ${colour})[${service}] /" -e "s/$/$(tput sgr0)/" & } @@ -145,7 +143,7 @@ if [ "$docker_deployment" = "false" ]; then run_haskell_service gundeck ${blue} run_haskell_service cannon ${orange} run_haskell_service cargohold ${purpleish} - run_haskell_service proxy ${redish} Info + run_haskell_service proxy ${redish} run_haskell_service spar ${orange} run_nginz ${blueish} else diff --git a/docs/README.md b/docs/README.md index 7d9999a29a1..1f489461a0b 100644 --- a/docs/README.md +++ b/docs/README.md @@ -2,12 +2,13 @@ # Reference documentation -What you need to know as a user of the Wire backend: concepts, features, and API. +What you need to know as a user of the Wire backend: concepts, features, and API. We strive to keep these up to date. ## Users We support the following functionality related to users and user profiles: +* [Connections between users](reference/user/connection.md) `{#RefConnection}` * [Rich info](reference/user/rich-info.md) `{#RefRichInfo}` * TODO @@ -23,7 +24,10 @@ We have support for provisioning users via SCIM ([RFC 7664][], [RFC 7643][]). It # Developer documentation -What you need to know as a Wire backend developer. All of these documents can and should be referenced in the code. +Internal documentation detailing what you need to know as a Wire backend developer. All of these documents can and should be referenced in the code. + +If you're not a member of the Wire backend team, you might still find these documents useful, but keep in mind that they are a work in progress. * [Development setup](developer/dependencies.md) `{#DevDeps}` +* [Editor setup](developer/editor-setup.md) `{#DevEditor}` * TODO diff --git a/docs/developer/dependencies.md b/docs/developer/dependencies.md index 23cb5b2762d..512a007b621 100644 --- a/docs/developer/dependencies.md +++ b/docs/developer/dependencies.md @@ -51,6 +51,12 @@ extra-lib-dirs: - /usr/local/opt/icu4c/lib ``` +_Note_: if you're getting `fatal error: 'libxml/parser.h' file not found` and you're on macOS Mojave, try doing: + +```bash +sudo installer -pkg /Library/Developer/CommandLineTools/Packages/macOS_SDK_headers_for_macOS_10.14.pkg -target / +``` + ## Haskell Stack When you're done, ensure `stack --version` is >= 1.6.5 diff --git a/docs/developer/editor-setup.md b/docs/developer/editor-setup.md new file mode 100644 index 00000000000..3c07c05f2ec --- /dev/null +++ b/docs/developer/editor-setup.md @@ -0,0 +1,50 @@ +# Editor setup {#DevEditor} + +This page provides tips for setting up editors to work with the Wire codebase. + +## Emacs {#DevEmacs} + +### Jump-to-definition {#DevEmacsJump} + +Jump-to-definition is possible with [hasktags][]. First you need to install it and make sure it's on your PATH (if you don't want hasktags to be on your PATH, do `M-x customize-variable haskell-hasktags-path`): + +[hasktags]: https://hackage.haskell.org/package/hasktags + +```bash +stack install hasktags # or cabal install hasktags +``` + +To generate tags, do `M-x haskell-mode-generate-tags`. You can also add a Git hook to regenerate tags on checkout: + +```bash +echo "hasktags -e -x ." > .git/hooks/post-checkout +chmod +x .git/hooks/post-checkout +``` + +To jump to an identifier, press `M-.`. You can also do `C-u M-x xref-find-definitions` to get interactive search through identifiers. Press `M-,` to return to where you were before the jump. + +Jump-to-definition is case-insensitive by default, which is probably not what you want. To change that, do `M-x customize-variable tags-case-fold-search`. + +By default hasktags only generates tags for the current package. The Wire backend is composed of many packages, and it's useful to be able to jump to any identifier in wire-server. One way to do it is to setup Emacs to check if there's a Projectile project that the current directory belongs to, and if so, override the "current package" default. + +Install the [projectile][] package for Emacs and do `M-x projectile-add-known-project `. Then add the following snippet to your `init.el`: + +[projectile]: https://www.projectile.mx/en/latest/installation/ + +``` +(require 'haskell) +(require 'projectile) + +;; When inside a project, even if there is a cabal file in the current +;; folder, use the project folder to generate tags. This is useful for +;; projects with several services or subprojects. +(defadvice haskell-cabal--find-tags-dir (around project-tags act) + (setq ad-return-value + (if (projectile-project-root) + (projectile-project-root) + ad-do-it))) +``` + +## Vim {#DevVim} + +TODO. diff --git a/docs/reference/provisioning/scim-via-curl.md b/docs/reference/provisioning/scim-via-curl.md index ed0de6280e1..7e28794a326 100644 --- a/docs/reference/provisioning/scim-via-curl.md +++ b/docs/reference/provisioning/scim-via-curl.md @@ -169,7 +169,11 @@ curl -X PUT \ ### delete user -**Not implemented yet.** +``` +curl -X DELETE \ + --header "Authorization: Bearer $SCIM_TOKEN" \ + $WIRE_BACKEND/scim/v2/Users/$STORED_USER_ID +``` ### groups diff --git a/services/brig/doc/connections.png b/docs/reference/user/connection-transitions.png similarity index 100% rename from services/brig/doc/connections.png rename to docs/reference/user/connection-transitions.png diff --git a/services/brig/doc/connections.xml b/docs/reference/user/connection-transitions.xml similarity index 100% rename from services/brig/doc/connections.xml rename to docs/reference/user/connection-transitions.xml diff --git a/services/brig/doc/connections.md b/docs/reference/user/connection.md similarity index 75% rename from services/brig/doc/connections.md rename to docs/reference/user/connection.md index a7286386ccd..92598089772 100644 --- a/services/brig/doc/connections.md +++ b/docs/reference/user/connection.md @@ -1,7 +1,4 @@ - -## User Connections - -### Concepts +# Connection {#RefConnection} Connections between users are a means for giving users some control over their privacy and a degree of spam protection. Connections control whether a user can: @@ -25,52 +22,51 @@ group conversations where the blocked user is a member. In the implementation, a connection is a directed edge from one user to another that is attributed with a relation state and potentially other meta information. -### Connection States +## Connection states {#RefConnectionStates} The following are the existing states that connections can be in and their meaning. -#### Sent +### Sent {#RefConnectionSent} The creator of a new connection (i.e. the sender of the connection request) ends up in this state. From the point of view of the creator, it indicates that a connection request has been sent but not accepted (it might be blocked or ignored). -#### Pending +### Pending {#RefConnectionPending} The recipient of a connection request automatically ends up in this state. From his point of view, the state indicates that the connection is pending and awaiting further action (i.e. through accepting, ignoring or blocking it). -#### Blocked +### Blocked {#RefConnectionBlocked} When a connection is in this state it indicates that the user does not want to be bothered by the other user, e.g. by receiving messages, calls or being added to conversations. -#### Ignored +### Ignored {#RefConnectionIgnored} -This is a temporary state for the recipient of a connection request. It indicates -that the recipient neither wanted to accept nor block the connection (yet). In this state -the sender can continue to send further connection attempts. +The recipient of a connection request may decide to explicitly "ignore" the request +In this state the sender can continue to send further connection attempts. The +recipient can change their mind and accept the request later. -#### Cancelled +### Cancelled {#RefConnectionCancelled} This is a state that the sender can change to if the connection has not yet been accepted. The state will also change for the recipient, unless blocked. -#### Accepted +### Accepted {#RefConnectionAccepted} A connection in this state is fully accepted by a user. The user thus allows the user at the other end of the connection to add him to conversations, view his full profile information, etc. - -### Transitions +## Transitions between connection states {#RefConnectionTransitions} The following diagram depicts the transitions between connection states. -![Connection State Transitions](connections.png) +![Connection State Transitions](connection-transitions.png) -In order to edit this diagram, open the [connections.xml](connections.xml) +In order to edit this diagram, open [connection-transitions.xml](connection-transitions.xml) with [draw.io](https://www.draw.io/). diff --git a/libs/api-bot/src/Network/Wire/Bot/Monad.hs b/libs/api-bot/src/Network/Wire/Bot/Monad.hs index c9182614ad8..be022e0ab9d 100644 --- a/libs/api-bot/src/Network/Wire/Bot/Monad.hs +++ b/libs/api-bot/src/Network/Wire/Bot/Monad.hs @@ -778,9 +778,10 @@ timed p ma = do start <- liftIO getCurrentTime a <- ma stop <- liftIO getCurrentTime - let d = round . (* 1000) $ stop `diffUTCTime` start + let durationInMillis = realToFrac . (* 1000) $ stop `diffUTCTime` start m <- getMetrics - liftIO $ Metrics.bucketsIncr 30 12 d p m + let timeHisto = Metrics.deprecatedRequestDurationHistogram p + liftIO $ Metrics.histoSubmit durationInMillis timeHisto m return a incrAssertTotal :: MonadBotNet m => m () @@ -806,10 +807,10 @@ decrBotsAlive = getMetrics >>= liftIO . Metrics.gaugeDecr Metrics.botsAlive -- Note: Separate TVars to avoid contention. data BotMetrics = BotMetrics - { botEventsRcvd :: TVar (HashMap Metrics.Path Word) - , botEventsAckd :: TVar (HashMap Metrics.Path Word) - , botEventsIgnd :: TVar (HashMap Metrics.Path Word) - , botEventsMssd :: TVar (HashMap Metrics.Path Word) + { botEventsRcvd :: TVar (HashMap Metrics.Path Double) + , botEventsAckd :: TVar (HashMap Metrics.Path Double) + , botEventsIgnd :: TVar (HashMap Metrics.Path Double) + , botEventsMssd :: TVar (HashMap Metrics.Path Double) } newBotMetrics :: IO BotMetrics diff --git a/libs/api-bot/src/Network/Wire/Bot/Report.hs b/libs/api-bot/src/Network/Wire/Bot/Report.hs index 1235d638f97..295fbf9a8e3 100644 --- a/libs/api-bot/src/Network/Wire/Bot/Report.hs +++ b/libs/api-bot/src/Network/Wire/Bot/Report.hs @@ -29,7 +29,6 @@ module Network.Wire.Bot.Report import Imports import Data.Metrics -import Data.Metrics.Buckets import Data.Time.Clock import Network.Wire.Client.API.Push (EventType (..), eventTypeText) import Network.Wire.Bot.Metrics @@ -60,24 +59,21 @@ createReport t m (SectionS (Endo f)) = do Counter _ p -> do v <- counterValue =<< counterGet p m return $! Data (HashMap.insert p v cs) ls bs gs - Label _ p -> do - v <- labelValue =<< labelGet p m - return $! Data cs (HashMap.insert p v ls) bs gs Gauge _ p -> do v <- gaugeValue =<< gaugeGet p m return $! Data cs ls bs (HashMap.insert p v gs) - Buckets _ p -> do - v <- snapshot =<< bucketsGet 0 0 p m + Histogram _ p hi -> do + v <- histoGet hi m >>= histoValue return $! Data cs ls (HashMap.insert p v bs) gs ------------------------------------------------------------------------------- -- * Access Report Data data Data = Data - { _counters :: HashMap Path Word - , _labels :: HashMap Path Text - , _buckets :: HashMap Path (HashMap Int Word) - , _gauges :: HashMap Path Int + { _counters :: HashMap Path Double + , _labels :: HashMap Path Text + , _histograms :: HashMap Path (Map Bucket Int) + , _gauges :: HashMap Path Double } deriving (Eq) instance Semigroup Data where @@ -87,17 +83,17 @@ instance Semigroup Data where instance Monoid Data where mempty = Data mempty mempty mempty mempty -reportCounter :: Report -> Path -> Word +reportCounter :: Report -> Path -> Double reportCounter r p = fromMaybe 0 $ HashMap.lookup p (_counters (_data r)) reportLabel :: Report -> Path -> Text reportLabel r p = fromMaybe "" $ HashMap.lookup p (_labels (_data r)) -reportGauge :: Report -> Path -> Int +reportGauge :: Report -> Path -> Double reportGauge r p = fromMaybe 0 $ HashMap.lookup p (_gauges (_data r)) -reportBucket :: Report -> Path -> HashMap Int Word -reportBucket r p = fromMaybe mempty $ HashMap.lookup p (_buckets (_data r)) +reportBucket :: Report -> Path -> Map Bucket Int +reportBucket r p = fromMaybe mempty $ HashMap.lookup p (_histograms (_data r)) ------------------------------------------------------------------------------- -- * Structure Reports @@ -110,10 +106,9 @@ data Section = Section } deriving (Eq) data Metric - = Counter !Text !Path - | Gauge !Text !Path - | Buckets !Text !Path - | Label !Text !Path + = Counter !Text !Path + | Gauge !Text !Path + | Histogram !Text !Path !HistogramInfo deriving (Eq) section :: Text -> [Metric] -> SectionS diff --git a/libs/api-bot/src/Network/Wire/Bot/Report/Text.hs b/libs/api-bot/src/Network/Wire/Bot/Report/Text.hs index 1864abcbc73..eb860302b52 100644 --- a/libs/api-bot/src/Network/Wire/Bot/Report/Text.hs +++ b/libs/api-bot/src/Network/Wire/Bot/Report/Text.hs @@ -12,7 +12,7 @@ import Data.Text.Lazy.Builder.Int import Network.Wire.Bot.Report hiding (section) import System.Console.ANSI -import qualified Data.HashMap.Strict as HashMap +import qualified Data.Map.Strict as Map import qualified Data.Text.Lazy as Lazy import qualified Data.Text.Lazy.IO as Text @@ -37,14 +37,13 @@ formatReport pretty r = toLazyText $ <> foldMap metric (sectionMetrics s) <> "\n" - metric (Counter l p) = single l $ decimal (reportCounter r p) - metric (Label l p) = single l $ fromText (reportLabel r p) - metric (Gauge l p) = single l $ decimal (reportGauge r p) - metric (Buckets l p) = multi l $ sort $ HashMap.toList (reportBucket r p) + metric (Counter l p) = single l . fromString . show $ (reportCounter r p) + metric (Gauge l p) = single l . fromString . show $ (reportGauge r p) + metric (Histogram l p _) = multi l $ sort $ Map.toList (reportBucket r p) single k v = "\t" <> fromText k <> ": " <> value v <> "\n" multi k v = "\t" <> subsection k <> "\n" <> foldMap pair v - pair (b,n) = "\t" <> decimal b <> ": " <> value (decimal n) <> "\n" + pair (b,n) = "\t" <> fromString (show b) <> ": " <> value (decimal n) <> "\n" subsection k = pp underline <> fromText k <> pp clear diff --git a/libs/brig-types/src/Brig/Types/Connection.hs b/libs/brig-types/src/Brig/Types/Connection.hs index d493f248d2a..340995782ee 100644 --- a/libs/brig-types/src/Brig/Types/Connection.hs +++ b/libs/brig-types/src/Brig/Types/Connection.hs @@ -4,6 +4,9 @@ {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE RecordWildCards #-} +-- | Relations between users. +-- +-- See {#RefConnection}. module Brig.Types.Connection ( module Brig.Types.Connection , module C @@ -20,10 +23,16 @@ import Data.Json.Util import Data.Range import Data.Text as Text +-- | Initial message sent along with a connection request. 1-256 characters. +-- +-- /Note 2019-03-28:/ some clients send it, but we have hidden it anyway in the UI since it +-- works as a nice source of spam. TODO deprecate and remove. newtype Message = Message { messageText :: Text } deriving (Eq, Ord, Show, ToJSON) --- | Look at @services\/brig\/doc@ for descriptions of these states. +-- | Possible relations between two users. +-- +-- See {#RefConnectionStates} for detailed descriptions of these states. data Relation = Accepted | Blocked @@ -33,30 +42,41 @@ data Relation | Cancelled deriving (Eq, Ord, Show) +-- | Exact state of the connection between two users, stored in Brig database (see +-- 'Brig.Data.Connection.lookupConnections'). +-- +-- Connection states have a direction -- e.g. if A sends a connection request to B, we'll +-- create connections (A, B, Sent) and (B, A, Pending). data UserConnection = UserConnection { ucFrom :: !UserId , ucTo :: !UserId , ucStatus :: !Relation - , ucLastUpdate :: !UTCTimeMillis + , ucLastUpdate :: !UTCTimeMillis -- ^ When 'ucStatus' was last changed , ucMessage :: !(Maybe Message) , ucConvId :: !(Maybe ConvId) } deriving (Eq, Show) +-- | Payload type for a connection request from one user to another. data ConnectionRequest = ConnectionRequest - { crUser :: !UserId - , crName :: !Text -- ^ Conversation name - , crMessage :: !Message + { crUser :: !UserId -- ^ Connection recipient + , crName :: !Text -- ^ Name of the conversation to be created + , crMessage :: !Message -- ^ Initial message } deriving (Eq, Show) +-- | Payload type for "please change the status of this connection". data ConnectionUpdate = ConnectionUpdate { cuStatus :: !Relation } deriving (Eq, Show) +-- | Response type for endpoints returning lists of connections. data UserConnectionList = UserConnectionList { clConnections :: [UserConnection] - , clHasMore :: !Bool + , clHasMore :: !Bool -- ^ Pagination flag ("we have more results") } deriving (Eq, Show) +-- | Response type for endpoints returning lists of users with a specific connection state. +-- E.g. 'getContactList' returns a 'UserIds' containing the list of connections in an +-- 'Accepted' state. data UserIds = UserIds { cUsers :: [UserId] } @@ -66,7 +86,8 @@ data ConnectionsStatusRequest = ConnectionsStatusRequest , csrTo :: ![UserId] } deriving (Eq, Show) --- * JSON Instances: +---------------------------------------------------------------------------- +-- JSON instances instance FromJSON Message where parseJSON x = Message . fromRange <$> (parseJSON x :: Parser (Range 1 256 Text)) diff --git a/libs/cassandra-util/src/Cassandra.hs b/libs/cassandra-util/src/Cassandra.hs index 81c609a71a0..77416f19da2 100644 --- a/libs/cassandra-util/src/Cassandra.hs +++ b/libs/cassandra-util/src/Cassandra.hs @@ -1,4 +1,64 @@ +-- | The top import of our Cassandra utility library. Essentially, a "everyone who needs cassandra needs this" import. module Cassandra (module C) where -import Cassandra.CQL as C -import Cassandra.Exec as C +-- pull in our extended wrapper of Database.CQL.Protocol +import Cassandra.CQL as C ( + Keyspace(Keyspace), + Tagged(Tagged), + TimeUuid(TimeUuid), + Blob(Blob), + Ascii(Ascii), + Set(Set), + QueryString(QueryString), + QueryParams(QueryParams), + Consistency(One, Quorum, All), + BatchType(BatchLogged, BatchUnLogged), + Value(CqlInt, CqlBlob, CqlText, CqlUdt, CqlBigInt, CqlList, CqlAscii, CqlDouble, CqlBoolean), + ColumnType(IntColumn, BlobColumn, TextColumn, BigIntColumn, UdtColumn, TimestampColumn, ListColumn, AsciiColumn, DoubleColumn, MaybeColumn, UuidColumn, BooleanColumn), + Version(V3), + R, + W, + S, + Cql, + unKeyspace, + ctype, + toCql, + fromCql, + fromAscii, + fromSet, + fromBlob, + fromTimeUuid, + retag, + untag) + +-- pull in our extended wrapper of Database.CQL.IO. +import Cassandra.Exec as C ( + MonadClient, + ClientState, + Client, + Page, + PrepQuery, + BatchM, + query, + retry, + query1, + batch, + emptyPage, + hasMore, + nextPage, + localState, + liftClient, + paginateC, + result, + setConsistency, + setType, + addPrepQuery, + runClient, + params, + paramsP, + paginate, + shutdown, + init, + write, + x5, + x1) diff --git a/libs/cassandra-util/src/Cassandra/CQL.hs b/libs/cassandra-util/src/Cassandra/CQL.hs index 91719743ff4..2a90b639ba4 100644 --- a/libs/cassandra-util/src/Cassandra/CQL.hs +++ b/libs/cassandra-util/src/Cassandra/CQL.hs @@ -1,36 +1,32 @@ +-- | This module just exports components from cassandra's Database.CQL.Protocol. + module Cassandra.CQL (module C) where -import Database.CQL.Protocol as C - ( Cql (..) - , Error (..) - , Value (..) - , Ascii (..) - , Blob (..) - , Counter (..) - , TimeUuid (..) - , Set (..) - , Map (..) - , Keyspace (..) - , Table (..) - , PagingState - , QueryId - , ColumnType (..) - , CompressionAlgorithm (..) - , Consistency (..) - , Tuple - , TupleType - , Record (..) - , recordInstance - , QueryString (..) - , QueryParams (..) - , SchemaChange - , BatchQuery (..) - , BatchType (..) - , Batch (..) - , Version (..) - , Tagged (..) - , retag - , R - , W - , S - ) +import Database.CQL.Protocol as C ( + Keyspace(Keyspace), + Tagged(Tagged), + TimeUuid(TimeUuid), + Blob(Blob), + Ascii(Ascii), + Set(Set), + QueryString(QueryString), + QueryParams(QueryParams), + Consistency(One, Quorum, All), + BatchType(BatchLogged, BatchUnLogged), + Value(CqlInt, CqlBlob, CqlText, CqlUdt, CqlBigInt, CqlList, CqlAscii, CqlDouble, CqlBoolean), + ColumnType(IntColumn, BlobColumn, TextColumn, BigIntColumn, UdtColumn, TimestampColumn, ListColumn, AsciiColumn, DoubleColumn, MaybeColumn, UuidColumn, BooleanColumn), + Version(V3), + R, + W, + S, + Cql, + unKeyspace, + ctype, + toCql, + fromCql, + fromAscii, + fromSet, + fromBlob, + fromTimeUuid, + retag, + untag) diff --git a/libs/cassandra-util/src/Cassandra/Exec.hs b/libs/cassandra-util/src/Cassandra/Exec.hs index fad09bd1fb1..8b121ea1750 100644 --- a/libs/cassandra-util/src/Cassandra/Exec.hs +++ b/libs/cassandra-util/src/Cassandra/Exec.hs @@ -1,58 +1,29 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ScopedTypeVariables #-} -module Cassandra.Exec - ( Client - , MonadClient (..) - , ClientState - , CassandraError (..) - , syncCassandra - , runClient - , Database.CQL.IO.init - , shutdown - - , Page (hasMore, result, nextPage) - , emptyPage +-- | This module exports components from Cassandra's Database.CQL.IO, adding a few functions we find useful, that are built on top of it. - , params +module Cassandra.Exec + ( params , paramsP , x5 , x1 - - , query - , query1 - , write - , schema - , paginate + , syncCassandra , paginateC - - -- * Prepared Queries - , PrepQuery - , prepared - , queryString - - -- * Batch - , BatchM - , addQuery - , addPrepQuery - , setType - , setConsistency - , setSerialConsistency - , batch - - -- * Retry Settings - , RetrySettings - , adjustConsistency - , adjustSendTimeout - , adjustResponseTimeout - , retry + , module C ) where -import Imports -import Cassandra.CQL +import Imports hiding (init) +import Cassandra.CQL (R, Consistency) import Control.Monad.Catch import Data.Conduit -import Database.CQL.IO + +-- Things we just import and re-export. +import Database.CQL.IO as C (MonadClient, Client, ClientState, BatchM, PrepQuery, Page(hasMore, result, nextPage), adjustResponseTimeout, adjustSendTimeout, adjustConsistency, batch, setSerialConsistency, setConsistency, setType, addPrepQuery, addQuery, queryString, prepared, schema, write, query1, query, emptyPage, shutdown, runClient, retry, localState, liftClient, paginate, init) +-- We only use these locally. +import Database.CQL.IO (RetrySettings, RunQ, eagerRetrySettings, defRetrySettings) + +import Database.CQL.Protocol (QueryParams(QueryParams), Error, Tuple) params :: Tuple a => Consistency -> a -> QueryParams a params c p = QueryParams c False p Nothing Nothing Nothing Nothing diff --git a/libs/cassandra-util/src/Cassandra/Schema.hs b/libs/cassandra-util/src/Cassandra/Schema.hs index ed0b0f2ec8f..71bd721e422 100644 --- a/libs/cassandra-util/src/Cassandra/Schema.hs +++ b/libs/cassandra-util/src/Cassandra/Schema.hs @@ -3,6 +3,8 @@ {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} +-- Additional functionality on top of our cassandra library. Used by brig, brig's schema definitions, Spar, Spar's schema definitions, Galley, Galley's schema definitions, Gundeck, and Gundeck's schema definitions. + module Cassandra.Schema ( Migration (..) , MigrationOpts (..) @@ -18,9 +20,10 @@ module Cassandra.Schema , schema' ) where -import Imports hiding (intercalate, fromString, log, All) -import Cassandra -import Cassandra.Settings +import Imports hiding (intercalate, fromString, log, All, init) +import Cassandra (Keyspace(Keyspace), Version(V3), PrepQuery, Client, Consistency(One, All), R, W, S, QueryString(QueryString), QueryParams(QueryParams), write, query, query1, retry, params, x1, x5, runClient) +import Cassandra.Settings (initialContactsPlain, Policy, defSettings, setLogger, setPolicy, setPoolStripes, setMaxConnections, setPortNumber, setContacts, setProtocolVersion, setResponseTimeout, setSendTimeout, setConnectTimeout) +import qualified Cassandra as CQL (init) import Control.Monad.Catch import Control.Retry import Data.Aeson @@ -30,8 +33,8 @@ import Data.Text.Lazy (fromStrict) import Data.Text.Lazy.Builder (fromText, fromString, toLazyText) import Data.Time.Clock import Data.UUID (UUID) -import Database.CQL.IO -import Database.CQL.Protocol (Request (..), Query (..)) +import Database.CQL.IO (Policy(Policy, setup, onEvent, select, acceptable, hostCount, display, current), schema, HostResponse, getResult, request) +import Database.CQL.Protocol (Request(RqQuery), Query(Query)) import Options.Applicative hiding (info) import qualified Database.CQL.IO.Tinylog as CT @@ -132,7 +135,7 @@ useKeyspace (Keyspace k) = void . getResult =<< qry migrateSchema :: Log.Logger -> MigrationOpts -> [Migration] -> IO () migrateSchema l o ms = do hosts <- initialContactsPlain $ pack (migHost o) - p <- Database.CQL.IO.init $ + p <- CQL.init $ setLogger (CT.mkLogger l) . setContacts (NonEmpty.head hosts) (NonEmpty.tail hosts) . setPortNumber (fromIntegral $ migPort o) diff --git a/libs/cassandra-util/src/Cassandra/Settings.hs b/libs/cassandra-util/src/Cassandra/Settings.hs index 1827bef6f41..c6276996161 100644 --- a/libs/cassandra-util/src/Cassandra/Settings.hs +++ b/libs/cassandra-util/src/Cassandra/Settings.hs @@ -1,37 +1,18 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ViewPatterns #-} +-- | This module exports types and functions from Database.CQL.IO, while adding a few wire specific functions. module Cassandra.Settings - ( Settings - , defSettings - , setProtocolVersion - , setCompression - , setContacts - , addContact - , setKeyspace - , setPortNumber - , setIdleTimeout - , setMaxConnections - , setMaxStreams - , setPoolStripes - , setConnectTimeout - , setSendTimeout - , setMaxTimeouts - , setPrepareStrategy - , setResponseTimeout - , setRetrySettings - , setPolicy - , setLogger - , mkLogger - , initialContactsDisco - , initialContactsPlain - ) where + ( module C + , initialContactsDisco + , initialContactsPlain + ) where import Imports import Control.Lens import Data.Aeson.Lens -import Database.CQL.IO hiding (values) -import Database.CQL.IO.Tinylog (mkLogger) +import Database.CQL.IO as C (Settings, Policy, setLogger, setPolicy, setRetrySettings, setResponseTimeout, setPrepareStrategy, setMaxTimeouts, setSendTimeout, setConnectTimeout, setPoolStripes, setMaxStreams, setMaxConnections, setIdleTimeout, setPortNumber, setKeyspace, addContact, setContacts, setCompression, setProtocolVersion, defSettings) +import Database.CQL.IO.Tinylog as C (mkLogger) import Data.List.NonEmpty (NonEmpty (..)) import Data.Text (pack, stripSuffix, unpack) import Network.Wreq diff --git a/libs/cassandra-util/src/Cassandra/Util.hs b/libs/cassandra-util/src/Cassandra/Util.hs index ee47ee24c0e..7089bea8da0 100644 --- a/libs/cassandra-util/src/Cassandra/Util.hs +++ b/libs/cassandra-util/src/Cassandra/Util.hs @@ -1,8 +1,8 @@ -module Cassandra.Util where +module Cassandra.Util (writeTimeToUTC, defInitCassandra, Writetime) where import Imports hiding (init) -import Cassandra -import Cassandra.Settings +import Cassandra (ClientState, Keyspace(Keyspace), init) +import Cassandra.Settings (setLogger, setPortNumber, setContacts, setKeyspace, defSettings) import Data.Text (unpack) import Data.Time (UTCTime) import Data.Time.Clock.POSIX(posixSecondsToUTCTime) diff --git a/libs/extended/src/System/Logger/Extended.hs b/libs/extended/src/System/Logger/Extended.hs index 5d251a25fb9..5447e1d6bfb 100644 --- a/libs/extended/src/System/Logger/Extended.hs +++ b/libs/extended/src/System/Logger/Extended.hs @@ -2,7 +2,8 @@ {-# LANGUAGE DerivingStrategies #-} -- | Tinylog convenience things. module System.Logger.Extended - ( mkLogger + ( module Log + , mkLogger , mkLogger' , LoggerT(..) , runWithLogger @@ -12,7 +13,7 @@ import Imports import Control.Monad.Catch import Database.CQL.IO -import qualified System.Logger as Log +import System.Logger as Log import qualified System.Logger.Class as LC mkLogger :: Log.Level -> Bool -> IO Log.Logger @@ -37,7 +38,7 @@ mkLogger' = Log.new -- may need it elsewhere in the future and here it's easier to find. newtype LoggerT m a = LoggerT {runLoggerT :: ReaderT Log.Logger m a} deriving newtype - (Functor + ( Functor , Applicative , Monad , MonadIO diff --git a/libs/galley-types/package.yaml b/libs/galley-types/package.yaml index db3cc8a8ccf..62a77627bef 100644 --- a/libs/galley-types/package.yaml +++ b/libs/galley-types/package.yaml @@ -50,7 +50,7 @@ library: - condition: flag(cql) cpp-options: -DWITH_CQL dependencies: - - cql >=3.0 + - cassandra-util tests: galley-types-tests: main: Main.hs diff --git a/libs/galley-types/src/Galley/Types/Teams.hs b/libs/galley-types/src/Galley/Types/Teams.hs index 352191e90c2..74510d850a7 100644 --- a/libs/galley-types/src/Galley/Types/Teams.hs +++ b/libs/galley-types/src/Galley/Types/Teams.hs @@ -128,7 +128,7 @@ import qualified Data.HashMap.Strict as HashMap import qualified Data.Set as Set #ifdef WITH_CQL import qualified Control.Error.Util as Err -import qualified Database.CQL.Protocol as Cql +import qualified Cassandra as Cql #endif data Event = Event diff --git a/libs/metrics-core/bench/Main.hs b/libs/metrics-core/bench/Main.hs deleted file mode 100644 index 25ff62de00c..00000000000 --- a/libs/metrics-core/bench/Main.hs +++ /dev/null @@ -1,68 +0,0 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE OverloadedStrings #-} - -module Main where - -import Imports -import Control.Concurrent.Async -import Control.Exception (assert) -import Criterion.Main -import Data.Metrics - -import qualified Data.HashMap.Strict as HashMap -import qualified Data.Metrics.Buckets as Buckets - -main :: IO () -main = do - m <- metrics - defaultMain - [ bgroup "Counter" - [ bench "add" $ whnfIO $ - counterAdd 1 (path "add") m - , bench "value" $ whnfIO $ do - c <- counterGet (path "value") m - counterValue c - , bench "contention" $ whnfIO $ do - c <- counterGet (path "contention") m - v <- counterValue c - _ <- mapConcurrently (\n -> - loop contentionIters (counterAdd n (path "contention") m) - ) [1..contentionConc] - v' <- counterValue c - assert (v' == v + contentionSum) (return v') - ] - , bgroup "Gauge" - [ bench "set" $ whnfIO $ - gaugeSet 1 (path "set") m - , bench "add" $ whnfIO $ - gaugeAdd 1 (path "add") m - , bench "value" $ whnfIO $ do - g <- gaugeGet (path "value") m - gaugeValue g - ] - , bgroup "Buckets" - [ bench "incr" $ whnfIO $ - bucketsIncr 1 1 1 (path "incr") m - , bench "contention" $ whnfIO $ do - b <- bucketsGet 1 1 (path "contention") m - v <- Buckets.snapshot b - _ <- mapConcurrently (\n -> - loop contentionIters (bucketsIncr 1 1 n (path "contention") m) - ) [1..contentionConc] - v' <- Buckets.snapshot b - assert (HashMap.insertWith (+) 1 (contentionIters * contentionConc) v == v') (return v') - ] - ] - -loop :: Word -> IO () -> IO () -loop 0 _ = return () -loop !i io = io >> loop (i - 1) io - -contentionIters :: Word -contentionIters = 10000 - -contentionConc :: Word -contentionConc = 100 - -contentionSum :: Word -contentionSum = sum [i * contentionIters | i <- [1..contentionConc]] diff --git a/libs/metrics-core/package.yaml b/libs/metrics-core/package.yaml index a9165afbf95..3be1c68754b 100644 --- a/libs/metrics-core/package.yaml +++ b/libs/metrics-core/package.yaml @@ -12,29 +12,14 @@ dependencies: - imports library: source-dirs: src - exposed-modules: - - Data.Metrics - - Data.Metrics.Buckets dependencies: - aeson >=0.6 - atomic-primops >=0.8 - base >=4.9 + - containers - hashable >=1.2 + - prometheus-client - unordered-containers >=0.2 - text >=0.11 - transformers >=0.3 - vector >=0.10 -benchmarks: - metrics-core-bench: - main: Main.hs - source-dirs: bench - ghc-options: - - -rtsopts - - -threaded - - -fno-ignore-asserts - dependencies: - - base - - async - - criterion - - metrics-core - - unordered-containers diff --git a/libs/metrics-core/src/Data/Metrics.hs b/libs/metrics-core/src/Data/Metrics.hs index 1cea2fc1605..ba1d8d33d9b 100644 --- a/libs/metrics-core/src/Data/Metrics.hs +++ b/libs/metrics-core/src/Data/Metrics.hs @@ -2,24 +2,22 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} module Data.Metrics - ( Path + ( + -- * Types + Path , Metrics + , Histogram , Counter , Gauge - , Label - , Buckets - - , path - , metrics + -- * Counters , counterGet - , counterGet' , counterAdd , counterIncr , counterValue + -- * Gauges , gaugeGet - , gaugeGet' , gaugeAdd , gaugeSub , gaugeIncr @@ -27,189 +25,259 @@ module Data.Metrics , gaugeSet , gaugeValue - , labelGet - , labelGet' - , labelSet - , labelValue + -- * Histograms + -- ** Types + , HistogramInfo + , Buckets + , Bucket + + -- ** Describing Histograms + , linearHistogram + , customHistogram + , deprecatedRequestDurationHistogram - , bucketsGet - , bucketsGet' - , bucketsIncr + -- ** Manipulating Histograms + , histoGet + , histoSubmit + , histoValue + , histoTimeAction + -- * Helper functions + , path + , metrics , render ) where import Imports hiding (lookup, union) import Data.Aeson -import Data.Atomics.Counter (AtomicCounter) import Data.Hashable -import Data.Metrics.Buckets (Buckets) -import qualified Data.Atomics.Counter as Atomic import qualified Data.Text as T -import qualified Data.HashMap.Strict as Map -import qualified Data.Metrics.Buckets as Buckets +import qualified Data.HashMap.Strict as HM +import qualified Data.Map.Strict as M import qualified Data.Metrics.GC as GC - -newtype Path = Path { _path :: Text } deriving (Eq, Hashable, Semigroup, Monoid) - +import qualified Prometheus as P + +-- | Internal Counter type +newtype Counter = Counter P.Counter +-- | Internal Gauge type +newtype Gauge = Gauge P.Gauge +-- | Internal Histogram type +newtype Histogram = Histogram P.Histogram + +-- | Represents a descriptive metric path or name. +-- +-- NOTE: Until all metrics are fully migrated to Prometheus this should be a valid +-- name according to collectd; e.g. @net.resources./teams/invitations/info@ +-- All names are converted into valid prometheus names when needed via 'toInfo' +newtype Path = + Path + { _path :: Text + } + deriving (Eq, Show, Hashable, Semigroup, Monoid) + +-- | Create a path path :: Text -> Path path = Path -newtype Counter = Counter AtomicCounter -newtype Gauge = Gauge AtomicCounter -newtype Label = Label (IORef Text) - -data Metrics = Metrics - { counters :: IORef (HashMap Path Counter) - , gauges :: IORef (HashMap Path Gauge) - , labels :: IORef (HashMap Path Label) - , buckets :: IORef (HashMap Path Buckets) - } +-- | Opaque storage of metrics +data Metrics = + Metrics + { counters :: IORef (HashMap Path Counter) + , gauges :: IORef (HashMap Path Gauge) + , histograms :: IORef (HashMap Path Histogram) + } +-- Initialize an empty set of metrics metrics :: MonadIO m => m Metrics metrics = liftIO $ Metrics - <$> newIORef Map.empty - <*> newIORef Map.empty - <*> newIORef Map.empty - <*> newIORef Map.empty + <$> newIORef HM.empty + <*> newIORef HM.empty + <*> newIORef HM.empty + +-- | Converts a CollectD style 'path' to a Metric name usable by prometheus +-- This is to provide back compatibility with the previous collect-d metric names +-- which often had paths and dot-separated names. +-- +-- Currently just replaces all "/" and "." with "_" and lowercases the result +toInfo :: Path -> P.Info +toInfo (Path p) = P.Info (p & T.replace "." "_" + & T.replace "/" "_" + & T.toLower) + "description not provided" + + +-- | Checks whether a given key exists in a mutable hashmap (i.e. one inside an IORef) +-- If it exists it is returned, if it does not then one is initialized using the provided +-- initializer, then stored, then returned. +getOrCreate :: (MonadIO m, Eq k, Hashable k) => IORef (HashMap k v) -> k -> IO v -> m v +getOrCreate mapRef key initializer = liftIO $ do + hMap <- readIORef mapRef + maybe initialize return (HM.lookup key hMap) + where + initialize = do + val <- initializer + atomicModifyIORef' mapRef $ \m -> (HM.insert key val m, val) ----------------------------------------------------------------------------- -- Counter specifics +-- | Create a counter for a 'Path' +newCounter :: Path -> IO Counter +newCounter p = Counter <$> P.register (P.counter $ toInfo p) + +-- | Access the counter for a given 'Path' counterGet :: MonadIO m => Path -> Metrics -> m Counter -counterGet t m = liftIO $ do - cs <- readIORef (counters m) - maybe make return (Map.lookup t cs) - where - make = do - c <- Counter <$> Atomic.newCounter 0 - atomicModifyIORef' (counters m) $ \cs -> (Map.insert t c cs, c) - -counterGet' :: MonadIO m => Path -> Metrics -> m Counter -counterGet' t m = liftIO $ do - c <- Counter <$> Atomic.newCounter 0 - atomicModifyIORef' (counters m) $ \cs -> - case Map.lookup t cs of - Nothing -> (Map.insert t c cs, c) - Just c' -> (cs , c') - -counterAdd :: MonadIO m => Word -> Path -> Metrics -> m () +counterGet p m = getOrCreate (counters m) p (newCounter p) + +-- | Add the given amount to the counter at 'Path' +counterAdd :: MonadIO m => Double -> Path -> Metrics -> m () counterAdd x p m = liftIO $ do Counter c <- counterGet p m - Atomic.incrCounter_ (fromIntegral x) c + void $ P.addCounter c x +-- | Add 1 to the counter at 'Path' counterIncr :: MonadIO m => Path -> Metrics -> m () counterIncr = counterAdd 1 -counterValue :: MonadIO m => Counter -> m Word -counterValue (Counter c) = liftIO $ fromIntegral <$> Atomic.readCounter c +-- | Get the current value of the Counter +counterValue :: MonadIO m => Counter -> m Double +counterValue (Counter c) = P.getCounter c ----------------------------------------------------------------------------- -- Gauge specifics +-- | Create a gauge for a 'Path' +newGauge :: Path -> IO Gauge +newGauge p = Gauge <$> P.register (P.gauge $ toInfo p) + +-- | Access the gauge for a given 'Path' gaugeGet :: MonadIO m => Path -> Metrics -> m Gauge -gaugeGet t m = liftIO $ do - gs <- readIORef (gauges m) - maybe make return (Map.lookup t gs) - where - make = do - g <- Gauge <$> Atomic.newCounter 0 - atomicModifyIORef' (gauges m) $ \gs -> (Map.insert t g gs, g) - -gaugeGet' :: MonadIO m => Path -> Metrics -> m Gauge -gaugeGet' t m = liftIO $ do - g <- Gauge <$> Atomic.newCounter 0 - atomicModifyIORef' (gauges m) $ \gs -> - case Map.lookup t gs of - Nothing -> (Map.insert t g gs, g) - Just g' -> (gs , g') - -gaugeSet :: MonadIO m => Int -> Path -> Metrics -> m () +gaugeGet p m = getOrCreate (gauges m) p (newGauge p) + +-- | Set the 'Gauge' at 'Path' to the given value +gaugeSet :: MonadIO m => Double -> Path -> Metrics -> m () gaugeSet x p m = liftIO $ do Gauge g <- gaugeGet p m - -- To play it safe, we want a full memory barrier, which 'writeCounter' - -- does not provide, so we use a CAS loop instead. This is not worse - -- than e.g. a CAS loop inherent to a comparable 'atomicModifyIORef'. - casLoop g =<< Atomic.readCounterForCAS g - where - casLoop g v = do - (ok, v') <- Atomic.casCounter g v x - unless ok (casLoop g v') + P.setGauge g x -gaugeAdd :: MonadIO m => Int -> Path -> Metrics -> m () +-- | Add the given amount to the gauge at 'Path' +gaugeAdd :: MonadIO m => Double -> Path -> Metrics -> m () gaugeAdd x p m = liftIO $ do Gauge g <- gaugeGet p m - Atomic.incrCounter_ x g + P.addGauge g x +-- | Add 1 to the gauge at 'Path' gaugeIncr :: MonadIO m => Path -> Metrics -> m () gaugeIncr = gaugeAdd 1 +-- | Subtract 1 from the gauge at 'Path' gaugeDecr :: MonadIO m => Path -> Metrics -> m () gaugeDecr = gaugeAdd (-1) -gaugeSub :: MonadIO m => Int -> Path -> Metrics -> m () +-- | Subtract the given amount from the gauge at 'Path' +gaugeSub :: MonadIO m => Double -> Path -> Metrics -> m () gaugeSub x = gaugeAdd (-x) -gaugeValue :: MonadIO m => Gauge -> m Int -gaugeValue (Gauge g) = liftIO $ Atomic.readCounter g +-- | Get the current value of the Gauge +gaugeValue :: MonadIO m => Gauge -> m Double +gaugeValue (Gauge g) = liftIO $ P.getGauge g ----------------------------------------------------------------------------- --- Label specifics - -labelGet :: MonadIO m => Path -> Metrics -> m Label -labelGet t m = liftIO $ do - ls <- readIORef (labels m) - maybe make return (Map.lookup t ls) - where - make = do - l <- Label <$> newIORef T.empty - atomicModifyIORef' (labels m) $ \ls -> (Map.insert t l ls, l) - -labelGet' :: MonadIO m => Path -> Metrics -> m Label -labelGet' t m = liftIO $ do - l <- Label <$> newIORef T.empty - atomicModifyIORef' (labels m) $ \ls -> - case Map.lookup t ls of - Nothing -> (Map.insert t l ls, l) - Just l' -> (ls , l') - -labelSet :: MonadIO m => Text -> Path -> Metrics -> m () -labelSet x p m = liftIO $ do - Label l <- labelGet p m - atomicModifyIORef' l $ const (x, ()) - -labelValue :: MonadIO m => Label -> m Text -labelValue (Label l) = liftIO $ readIORef l - ------------------------------------------------------------------------------ --- Buckets specifics - -bucketsGet :: MonadIO m => Int -> Int -> Path -> Metrics -> m Buckets -bucketsGet k n t m = liftIO $ do - bs <- readIORef (buckets m) - maybe make return (Map.lookup t bs) +-- Histogram specifics + +-- | *DEPRECATED* +-- These are the exact histogram bucket markers which the old *custom* metrics-core +-- library used. Some wire-internal grafana graphs are still built around these exact number +-- e.g. (for wire employees only) see galley's POST duration graph: +-- https://staging-ie-grafana.zinfra.io/dashboard/db/galley +-- +-- This is annoying and very fragile, prometheus has a better way of handling this, but +-- until we've converted all of the dashboards over to use prometheus rather than collect-d +-- we're stuck with these exact bucket counts. +-- +-- Once we use prometheus metrics (e.g. there are no graphs in grafana which depend on metrics +-- prefixed with @collectd@) then you can delete this middleware entirely since the prometheus +-- middleware records request durations already. In fact it much of the `metrics-wai` package +-- can likely be deleted at that point. +deprecatedRequestDurationHistogram :: Path -> HistogramInfo +deprecatedRequestDurationHistogram pth = customHistogram pth requestDurationBuckets + where + requestDurationBuckets = [0, 30, 42, 60, 85, 120, 170, 240, 339, 480, 679, 960, 1358] + +-- | A marker of a bucketing point +type Bucket = Double +-- | Description of discrete buckets which histogram samples will be allocated into +type Buckets = [Bucket] +-- | Describes a histogram metric +data HistogramInfo = + HistogramInfo + { hiPath :: Path + , hiBuckets :: Buckets + } deriving (Eq, Show) + +type RangeStart = Double +type RangeEnd = Double +type BucketWidth = Double + +-- | Creates a 'HistogramInfo' which has evenly sized buckets of the given 'BucketWidth' +-- between 'RangeStart' and 'RangeEnd' +linearHistogram :: Path -> RangeStart -> RangeEnd -> BucketWidth -> HistogramInfo +linearHistogram pth start end width = + HistogramInfo + { hiPath = pth + , hiBuckets = buckets + } where - make = do - b <- Buckets.create k n - atomicModifyIORef' (buckets m) $ \bs -> (Map.insert t b bs, b) - -bucketsGet' :: MonadIO m => Int -> Int -> Path -> Metrics -> m Buckets -bucketsGet' k n t m = liftIO $ do - b <- Buckets.create k n - atomicModifyIORef' (buckets m) $ \bs -> - case Map.lookup t bs of - Nothing -> (Map.insert t b bs, b) - Just b' -> (bs , b') - -bucketsIncr :: MonadIO m => Int -> Int -> Word -> Path -> Metrics -> m () -bucketsIncr k n x p m = liftIO $ do - b <- bucketsGet k n p m - Buckets.incr b x + -- | How many buckets exist between start and end of the given width + -- We round up because more precision is better than less + count :: Int + count = ceiling $ (end - start) / width + buckets :: Buckets + buckets = P.linearBuckets start width count + +-- | Construct a histogram using a given list of buckets. +-- It's recommended that you use 'linearHistogram' instead when possible. +customHistogram :: Path -> Buckets -> HistogramInfo +customHistogram pth buckets = HistogramInfo{hiPath=pth, hiBuckets=buckets} + +-- | Create a histo for a 'HistogramInfo' +newHisto :: HistogramInfo -> IO Histogram +newHisto HistogramInfo {hiPath, hiBuckets} = + Histogram <$> P.register (P.histogram (toInfo hiPath) hiBuckets) + +-- | Access the histogram for a given 'HistogramInfo' +histoGet :: MonadIO m + => HistogramInfo + -> Metrics + -> m Histogram +histoGet hi@HistogramInfo{hiPath} m = getOrCreate (histograms m) hiPath (newHisto hi) + +-- | Get the current distribution of a Histogram +histoValue :: MonadIO m => Histogram -> m (M.Map Bucket Int) +histoValue (Histogram histo) = liftIO $ P.getHistogram histo + +-- | Report an individual value to be bucketed in the histogram +histoSubmit :: MonadIO m => Double -> HistogramInfo -> Metrics -> m () +histoSubmit val hi m = liftIO $ do + Histogram h <- histoGet hi m + P.observe h val + +-- | Execute and time the provided monadic action and submit it as an entry +-- to the provided Histogram metric. +-- +-- NOTE: If the action throws an exception it will NOT be reported. +-- This is particularly relevant for web handlers which signal their response +-- with an exception. +histoTimeAction :: (P.MonadMonitor m, MonadIO m) => HistogramInfo -> Metrics -> m a -> m a +histoTimeAction hi m act = do + Histogram h <- histoGet hi m + P.observeDuration h act ----------------------------------------------------------------------------- -- JSON rendering +-- | This is used to serialize metrics into a JSON value for collectd class Jsonable a where toJson :: a -> IO Value @@ -219,24 +287,25 @@ instance Jsonable Counter where instance Jsonable Gauge where toJson g = toJSON <$> gaugeValue g -instance Jsonable Label where - toJson l = toJSON <$> labelValue l - -instance Jsonable Buckets where - toJson = Buckets.toJson +instance Jsonable Histogram where + -- Note that we round the keys into integers here for back-compatibility because + -- some metrics are constructed using the keys of this map (as integers) and having Double + -- keys would break the dashboards. This will no longer matter once all dashboards using + -- collectd have been migrated to use prometheus-backed metrics instead. + toJson h = toJSON . M.mapKeys (round @Double @Integer) <$> histoValue h +-- | Render metrics into a JSON value render :: MonadIO m => Metrics -> m Value render m = liftIO $ do c <- snapshot =<< readIORef (counters m) g <- snapshot =<< readIORef (gauges m) - l <- snapshot =<< readIORef (labels m) - b <- snapshot =<< readIORef (buckets m) - h <- GC.toJson - let result = c `union` g `union` l `union` b - return $ maybe result (union result) h + b <- snapshot =<< readIORef (histograms m) + gc <- GC.toJson + let result = c `union` g `union` b + return $ maybe result (union result) gc where snapshot :: Jsonable a => HashMap Path a -> IO Value - snapshot = fmap object . mapM (\(k, v) -> (_path k .=) <$> toJson v) . Map.toList + snapshot = fmap object . mapM (\(k, v) -> (_path k .=) <$> toJson v) . HM.toList union :: Value -> Value -> Value union (Object a) (Object b) = Object $ a `merge` b @@ -244,18 +313,19 @@ render m = liftIO $ do union Null b = b union a _ = a +-- | Merge two 'Object's together merge :: Object -> Object -> Object merge a = expand (expand mempty a) where expand :: Object -> Object -> Object - expand = Map.foldrWithKey (\k v obj -> insert obj (T.splitOn "." k) v) + expand = HM.foldrWithKey (\k v obj -> insert obj (T.splitOn "." k) v) insert :: Object -> [Text] -> Value -> Object - insert obj [t] v = Map.insert t v obj - insert obj (t:tt) v = Map.insert t (Object $ insert (subtree t obj) tt v) obj + insert obj [t] v = HM.insert t v obj + insert obj (t:tt) v = HM.insert t (Object $ insert (subtree t obj) tt v) obj insert obj [] _ = obj subtree :: Text -> Object -> Object - subtree t o = case Map.lookup t o of + subtree t o = case HM.lookup t o of Just (Object x) -> x _ -> mempty diff --git a/libs/metrics-core/src/Data/Metrics/Buckets.hs b/libs/metrics-core/src/Data/Metrics/Buckets.hs deleted file mode 100644 index 43dcc910f6f..00000000000 --- a/libs/metrics-core/src/Data/Metrics/Buckets.hs +++ /dev/null @@ -1,59 +0,0 @@ -module Data.Metrics.Buckets - ( Buckets - , start - , create - , index - , incr - , snapshot - , toJson - ) where - -import Imports -import Data.Aeson -import Data.Atomics.Counter (AtomicCounter) -import Data.Text (pack) -import Data.Vector (Vector, (!)) - -import qualified Data.Atomics.Counter as Atomic -import qualified Data.HashMap.Strict as Map -import qualified Data.Vector as Vec - -data Buckets = Buckets - { start :: Int - , labels :: [Int] - , zero :: AtomicCounter - , buckets :: Vector AtomicCounter - } - -create :: Int -> Int -> IO Buckets -create b n = do - let ll = take n . nub $ zipWith ($) (repeat (gen . fromIntegral)) [0::Int ..] - Buckets b (reverse ll) <$> Atomic.newCounter 0 <*> Vec.replicateM n (Atomic.newCounter 0) - where - gen :: Double -> Int - gen i = round $ fromIntegral b * (2.0 ** (i / 2.0)) - -index :: Buckets -> Word -> Int -index b i = truncate $ - logBase (2.0 :: Double) (fromIntegral i / fromIntegral (start b)) * 2.0 - -incr :: Buckets -> Word -> IO () -incr b n = case index b n of - i | i < 0 -> - Atomic.incrCounter_ 1 (zero b) - | i >= Vec.length (buckets b) -> - Atomic.incrCounter_ 1 (Vec.last (buckets b)) - | otherwise -> - Atomic.incrCounter_ 1 (buckets b ! i) - -snapshot :: Buckets -> IO (HashMap Int Word) -snapshot b = do - z <- fromIntegral <$> Atomic.readCounter (zero b) - n <- Vec.foldM' (\acc r -> (:acc) . fromIntegral <$> Atomic.readCounter r) [] (buckets b) - return $ Map.fromList ((0, z) : zip (labels b) n) - -toJson :: Buckets -> IO Value -toJson b = object - . map (\(k, v) -> pack (show k) .= toJSON v) - . Map.toList - <$> snapshot b diff --git a/libs/metrics-wai/src/Data/Metrics/Middleware.hs b/libs/metrics-wai/src/Data/Metrics/Middleware.hs index dda16c37e57..127d16b8a7d 100644 --- a/libs/metrics-wai/src/Data/Metrics/Middleware.hs +++ b/libs/metrics-wai/src/Data/Metrics/Middleware.hs @@ -22,7 +22,6 @@ import qualified Data.Text as T import qualified Data.Text.Encoding as T import qualified Network.Wai.Route.Tree as Tree - withPathTemplate :: Paths -> (PathTemplate -> Middleware) -> Middleware withPathTemplate t f app r k = f (fromMaybe def tmp) app r k where @@ -31,13 +30,15 @@ withPathTemplate t f app r k = f (fromMaybe def tmp) app r k . T.decodeUtf8 <$> treeLookup t (Tree.segments $ rawPathInfo r) -duration :: Int -> Int -> Metrics -> PathTemplate -> Middleware -duration start len m (PathTemplate t) f rq k = do +duration :: Metrics -> PathTemplate -> Middleware +duration m (PathTemplate t) f rq k = do st <- getTime Monotonic rs <- f rq k ed <- getTime Monotonic let p = mkPath [t, methodName rq, "time"] - bucketsIncr start len (timeSpecAsMilliSecs $ ed `diffTimeSpec` st) p m + let timeElapsed = timeSpecAsMilliSecs $ ed `diffTimeSpec` st + let requestDurationHisto = deprecatedRequestDurationHistogram p + histoSubmit timeElapsed requestDurationHisto m return rs -- Count Requests and their status code. @@ -72,5 +73,5 @@ methodName :: Request -> Text methodName = T.decodeUtf8 . requestMethod {-# INLINE methodName #-} -timeSpecAsMilliSecs :: TimeSpec -> Word +timeSpecAsMilliSecs :: TimeSpec -> Double timeSpecAsMilliSecs t = fromIntegral (sec t * 1000 + nsec t `div` 1000000) diff --git a/libs/metrics-wai/src/Data/Metrics/Middleware/Prometheus.hs b/libs/metrics-wai/src/Data/Metrics/Middleware/Prometheus.hs index 85af747620a..9b0e07f79f5 100644 --- a/libs/metrics-wai/src/Data/Metrics/Middleware/Prometheus.hs +++ b/libs/metrics-wai/src/Data/Metrics/Middleware/Prometheus.hs @@ -7,6 +7,7 @@ import qualified Network.Wai.Middleware.Prometheus as Promth import qualified Data.Text.Encoding as T import Data.Metrics.WaiRoute (treeToPaths) +import Data.Metrics.Types (Paths) import Data.Metrics.Types (treeLookup) -- | Adds a prometheus metrics endpoint at @/i/metrics@ @@ -14,8 +15,9 @@ import Data.Metrics.Types (treeLookup) -- (e.g. removing params from calls) waiPrometheusMiddleware :: Monad m => Routes a m b -> Wai.Middleware waiPrometheusMiddleware routes = - Promth.prometheus conf . Promth.instrumentHandlerValue (normalizeWaiRequestRoute routes) + Promth.prometheus conf . Promth.instrumentHandlerValue (normalizeWaiRequestRoute paths) where + paths = treeToPaths $ prepare routes conf = Promth.def { Promth.prometheusEndPoint = ["i", "metrics"] -- We provide our own instrumentation so we can normalize routes @@ -25,11 +27,11 @@ waiPrometheusMiddleware routes = -- | Compute a normalized route for a given request. -- Normalized routes have route parameters replaced with their identifier -- e.g. @/user/1234@ might become @/user/userid@ -normalizeWaiRequestRoute :: Monad m => Routes a m b -> Wai.Request -> Text -normalizeWaiRequestRoute routes req = pathInfo +normalizeWaiRequestRoute :: Paths -> Wai.Request -> Text +normalizeWaiRequestRoute paths req = pathInfo where mPathInfo :: Maybe ByteString - mPathInfo = treeLookup (treeToPaths $ prepare routes) (T.encodeUtf8 <$> Wai.pathInfo req) + mPathInfo = treeLookup paths (T.encodeUtf8 <$> Wai.pathInfo req) -- Use the normalized path info if available; otherwise dump the raw path info for -- debugging purposes diff --git a/libs/types-common/package.yaml b/libs/types-common/package.yaml index 74a3ebe9d57..aed6860f5cb 100644 --- a/libs/types-common/package.yaml +++ b/libs/types-common/package.yaml @@ -73,7 +73,7 @@ library: - condition: flag(cql) cpp-options: -DWITH_CQL dependencies: - - cql >=3.0 + - cassandra-util - condition: flag(protobuf) cpp-options: -DWITH_PROTOBUF dependencies: diff --git a/libs/types-common/src/Data/Code.hs b/libs/types-common/src/Data/Code.hs index e90ef77fc85..d7cd8fbf500 100644 --- a/libs/types-common/src/Data/Code.hs +++ b/libs/types-common/src/Data/Code.hs @@ -19,7 +19,7 @@ import Data.Json.Util import Data.Text.Ascii import Data.Time.Clock #ifdef WITH_CQL -import Database.CQL.Protocol hiding (unpack, Value) +import Cassandra hiding (Value) #endif -- | A scoped identifier for a 'Value' with an associated 'Timeout'. diff --git a/libs/types-common/src/Data/Id.hs b/libs/types-common/src/Data/Id.hs index 97bdd08a4d6..d24905c165e 100644 --- a/libs/types-common/src/Data/Id.hs +++ b/libs/types-common/src/Data/Id.hs @@ -23,7 +23,7 @@ import Data.Text.Lazy.Builder.Int import Data.UUID import Data.UUID.V4 #ifdef WITH_CQL -import Database.CQL.Protocol hiding (S) +import Cassandra hiding (S) #endif #ifdef WITH_ARBITRARY import Test.QuickCheck diff --git a/libs/types-common/src/Data/Json/Util.hs b/libs/types-common/src/Data/Json/Util.hs index 224914cae09..cc46fd7171f 100644 --- a/libs/types-common/src/Data/Json/Util.hs +++ b/libs/types-common/src/Data/Json/Util.hs @@ -17,7 +17,7 @@ module Data.Json.Util import Imports import Control.Lens ((%~), coerced) #ifdef WITH_CQL -import qualified Database.CQL.Protocol as CQL +import qualified Cassandra as CQL #endif import Data.Aeson import Data.Aeson.Types diff --git a/libs/types-common/src/Data/List1.hs b/libs/types-common/src/Data/List1.hs index 032516606fd..d80068362a4 100644 --- a/libs/types-common/src/Data/List1.hs +++ b/libs/types-common/src/Data/List1.hs @@ -9,7 +9,7 @@ import Imports import Data.List.NonEmpty (NonEmpty) import Data.Aeson #ifdef WITH_CQL -import Database.CQL.Protocol +import Cassandra #endif import qualified Data.List.NonEmpty as N diff --git a/libs/types-common/src/Data/Misc.hs b/libs/types-common/src/Data/Misc.hs index 1c8036306c3..e5dfc006fa2 100644 --- a/libs/types-common/src/Data/Misc.hs +++ b/libs/types-common/src/Data/Misc.hs @@ -49,7 +49,7 @@ import Data.Range import Data.Text.Encoding (decodeUtf8, encodeUtf8) #ifdef WITH_CQL import Data.ByteString.Lazy (toStrict) -import Database.CQL.Protocol hiding (unpack) +import Cassandra #endif #ifdef WITH_ARBITRARY import Test.QuickCheck (Arbitrary(..)) diff --git a/libs/types-common/src/Data/Range.hs b/libs/types-common/src/Data/Range.hs index 052d9cf93f8..03ec96a2b2a 100644 --- a/libs/types-common/src/Data/Range.hs +++ b/libs/types-common/src/Data/Range.hs @@ -44,7 +44,7 @@ import Data.Singletons.Prelude.Ord import Data.Singletons.TypeLits import Data.Text.Ascii (AsciiText) #ifdef WITH_CQL -import Database.CQL.Protocol hiding (Set, Map) +import Cassandra hiding (Set) #endif import Numeric.Natural #ifdef WITH_ARBITRARY diff --git a/libs/types-common/src/Data/Text/Ascii.hs b/libs/types-common/src/Data/Text/Ascii.hs index 11bd0d8a986..156b436b3c3 100644 --- a/libs/types-common/src/Data/Text/Ascii.hs +++ b/libs/types-common/src/Data/Text/Ascii.hs @@ -59,7 +59,7 @@ import Data.ByteString.Conversion import Data.Hashable (Hashable) import Data.Text.Encoding (decodeLatin1, decodeUtf8') #ifdef WITH_CQL -import Database.CQL.Protocol hiding (Ascii, check) +import Cassandra hiding (Ascii) #endif #ifdef WITH_ARBITRARY import Test.QuickCheck diff --git a/libs/wai-utilities/package.yaml b/libs/wai-utilities/package.yaml index b2f7f51244e..82251da3832 100644 --- a/libs/wai-utilities/package.yaml +++ b/libs/wai-utilities/package.yaml @@ -1,4 +1,4 @@ -defaults: +defaults: local: ../../package-defaults.yaml name: wai-utilities version: '0.16.1' @@ -23,7 +23,10 @@ dependencies: - metrics-core >=0.1 - metrics-wai >=0.5.7 - pipes >=4.1 +- prometheus-client - streaming-commons >=0.1 +- string-conversions +- stm - swagger >=0.1 - text >=0.11 - transformers >=0.3 diff --git a/libs/wai-utilities/src/Network/Wai/Utilities/Request.hs b/libs/wai-utilities/src/Network/Wai/Utilities/Request.hs index 1b2e6c40e0c..269708f3e45 100644 --- a/libs/wai-utilities/src/Network/Wai/Utilities/Request.hs +++ b/libs/wai-utilities/src/Network/Wai/Utilities/Request.hs @@ -1,6 +1,8 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE CPP #-} +{-# OPTIONS -Wno-orphans #-} -- for "instance HasRequest Request" :( + module Network.Wai.Utilities.Request where import Imports @@ -9,6 +11,9 @@ import Control.Monad.Catch (MonadThrow, throwM) import Data.Aeson import Network.HTTP.Types.Status (status400) import Network.Wai +import Network.Wai.Predicate +import Network.Wai.Predicate.Request +import Network.Wai.Utilities.ZAuth ((.&>)) import Pipes import qualified Data.ByteString as B @@ -17,24 +22,45 @@ import qualified Data.Text.Lazy as Text import qualified Pipes.Prelude as P import qualified Network.Wai.Utilities.Error as Wai -readBody :: MonadIO m => Request -> m Lazy.ByteString +readBody :: (MonadIO m, HasRequest r) => r -> m LByteString readBody r = liftIO $ Lazy.fromChunks <$> P.toListM chunks where chunks = do - b <- lift $ requestBody r + b <- lift $ requestBody (getRequest r) unless (B.null b) $ do yield b chunks parseBody :: (MonadIO m, FromJSON a) - => Request + => JsonRequest a -> ExceptT LText m a parseBody r = readBody r >>= hoistEither . fmapL Text.pack . eitherDecode' -parseBody' :: (FromJSON a, MonadIO m, MonadThrow m) => Request -> m a +parseBody' :: (FromJSON a, MonadIO m, MonadThrow m) => JsonRequest a -> m a parseBody' r = either thrw pure =<< runExceptT (parseBody r) where thrw msg = throwM $ Wai.Error status400 "bad-request" msg -lookupRequestId :: Request -> Maybe ByteString -lookupRequestId = lookup "Request-Id" . requestHeaders +lookupRequestId :: HasRequest r => r -> Maybe ByteString +lookupRequestId = lookup "Request-Id" . requestHeaders . getRequest + +---------------------------------------------------------------------------- +-- Typed JSON 'Request' + +newtype JsonRequest body = JsonRequest { fromJsonRequest :: Request } + +jsonRequest + :: forall body r. (HasRequest r, HasHeaders r) + => Predicate r Error (JsonRequest body) +jsonRequest = + contentType "application" "json" + .&> (return . JsonRequest . getRequest) + +---------------------------------------------------------------------------- +-- Instances + +instance HasRequest (JsonRequest a) where + getRequest = fromJsonRequest + +instance HasRequest Request where + getRequest = id diff --git a/libs/wai-utilities/src/Network/Wai/Utilities/Server.hs b/libs/wai-utilities/src/Network/Wai/Utilities/Server.hs index 8825c930d42..b36e405191b 100644 --- a/libs/wai-utilities/src/Network/Wai/Utilities/Server.hs +++ b/libs/wai-utilities/src/Network/Wai/Utilities/Server.hs @@ -13,6 +13,8 @@ module Network.Wai.Utilities.Server -- * Middlewares , measureRequests , catchErrors + , OnErrorMetrics + , heavyDebugLogging -- * Utilities , onError @@ -31,19 +33,21 @@ import Data.Aeson (encode) import Data.ByteString.Builder import Data.Metrics.Middleware import Data.Streaming.Zlib (ZlibException (..)) +import Data.String.Conversions (cs) import Data.Text.Encoding.Error (lenientDecode) import Network.HTTP.Types.Status import Network.Wai import Network.Wai.Handler.Warp import Network.Wai.Handler.Warp.Internal (TimeoutThread) import Network.Wai.Predicate hiding (Error, err, status) +import Network.Wai.Predicate.Request (HasRequest) import Network.Wai.Routing.Route (Routes, Tree, App, Continue) -import Network.Wai.Utilities.Error (Error (Error)) import Network.Wai.Utilities.Request (lookupRequestId) import Network.Wai.Utilities.Response import System.Logger.Class hiding (Settings, Error, format) import System.Posix.Signals (installHandler, sigINT, sigTERM) +import qualified Network.Wai.Utilities.Error as Wai import qualified Data.ByteString as BS import qualified Data.ByteString.Char8 as C import qualified Data.ByteString.Lazy as LBS @@ -51,6 +55,7 @@ import qualified Data.Text.Lazy.Encoding as LT import qualified Network.Wai.Predicate as P import qualified Network.Wai.Routing.Route as Route import qualified Network.Wai.Utilities.Error as Error +import qualified Prometheus as Prm import qualified System.Logger as Log import qualified System.Posix.Signals as Sig @@ -63,25 +68,21 @@ data Server = Server , serverLogger :: Logger , serverMetrics :: Metrics , serverTimeout :: Maybe Int - , serverOnException :: [Maybe Request -> Handler IO ()] - , serverOnExceptionResponse :: [Handler Identity Response] } defaultServer :: String -> Word16 -> Logger -> Metrics -> Server -defaultServer h p l m = Server h p l m Nothing [] [] +defaultServer h p l m = Server h p l m Nothing newSettings :: MonadIO m => Server -> m Settings -newSettings (Server h p l m t el er) = do +newSettings (Server h p l m t) = do -- (Atomically) initialise the standard metrics, to avoid races. - void $ gaugeGet' (path "net.connections") m - void $ counterGet' (path "net.errors") m + void $ gaugeGet (path "net.connections") m + void $ counterGet (path "net.errors") m return $ setHost (fromString h) . setPort (fromIntegral p) . setBeforeMainLoop logStart . setOnOpen (const $ connStart >> return True) . setOnClose (const connEnd) - . setOnException onException - . setOnExceptionResponse onExceptionResponse . setTimeout (fromMaybe 300 t) $ defaultSettings where @@ -91,25 +92,6 @@ newSettings (Server h p l m t el er) = do logStart = Log.info l . msg $ val "Listening on " +++ h +++ ':' +++ p - onException r e = for_ r flushRequestBody >> (runHandlers e $ - map ($ r) el ++ - [ Handler $ \(x :: Error) -> do - logError l r x - when (statusCode (Error.code x) >= 500) $ - counterIncr (path "net.errors") m - , Handler $ \(ZlibException (-3)) -> logIO l Info r $ - val "Invalid zlib compression in request body." - , Handler $ \(x :: SomeException) -> - if defaultShouldDisplayException x - then do - logIO l Log.Error r (show e) - counterIncr (path "net.errors") m - else logIO l Log.Trace r (show e) - ]) - - onExceptionResponse e = runIdentity . runHandlers e $ - er ++ map (fmap errorRs') errorHandlers - -- Run a WAI 'Application', initiating Warp's graceful shutdown -- on receiving either the INT or TERM signals. After closing -- the listen socket, Warp will be allowed to drain existing @@ -137,7 +119,7 @@ runSettingsWithShutdown s app secs = do compile :: Monad m => Routes a m b -> Tree (App m) compile routes = Route.prepare (Route.renderer predicateError >> routes) where - predicateError e = return (encode $ Error (P.status e) "client-error" (format e), [jsonContent]) + predicateError e = return (encode $ Wai.Error (P.status e) "client-error" (format e), [jsonContent]) -- [label] 'source' reason: message format e = @@ -167,13 +149,14 @@ compile routes = Route.prepare (Route.renderer predicateError >> routes) route :: (MonadCatch m, MonadIO m) => Tree (App m) -> Request -> Continue IO -> m ResponseReceived route rt rq k = Route.routeWith (Route.Config $ errorRs' noEndpoint) rt rq (liftIO . k) where - noEndpoint = Error status404 "no-endpoint" "The requested endpoint does not exist" + noEndpoint = Wai.Error status404 "no-endpoint" "The requested endpoint does not exist" {-# INLINEABLE route #-} -------------------------------------------------------------------------------- -- Middlewares --- | Create a middleware that tracks detailed request / response +-- | DEPRECATED; use 'waiPrometheusMiddleware' instead. +-- Create a middleware that tracks detailed request / response -- statistics, including timing information, for every path in the -- given routing tree. -- @@ -181,59 +164,135 @@ route rt rq k = Route.routeWith (Route.Config $ errorRs' noEndpoint) rt rq (lift -- should be combined with the 'catchErrors' middleware. measureRequests :: Metrics -> Paths -> Middleware measureRequests m rtree = withPathTemplate rtree $ \p -> - requestCounter m p . duration 30 12 m p + requestCounter m p . duration m p {-# INLINEABLE measureRequests #-} -- | Create a middleware that catches exceptions and turns -- them into appropriate 'Error' responses, thereby logging -- as well as counting server errors (i.e. exceptions that -- yield 5xx responses). -catchErrors :: Logger -> Metrics -> Middleware +-- +-- This does not log any 'Response' values with error status. +-- See 'catchErrors'. +catchErrors :: Logger -> OnErrorMetrics -> Middleware catchErrors l m app req k = app req k `catch` errorResponse where + errorResponse :: SomeException -> IO ResponseReceived errorResponse ex = do er <- runHandlers ex errorHandlers when (statusCode (Error.code er) >= 500) $ - logIO l Log.Error (Just req) (oneline <$> show ex) + logIO l Log.Error (Just req) (show ex) onError l m req k er - oneline c = if isSpace c then ' ' else c {-# INLINEABLE catchErrors #-} -- | Standard handlers for turning exceptions into appropriate -- 'Error' responses. -errorHandlers :: Applicative m => [Handler m Error] +errorHandlers :: Applicative m => [Handler m Wai.Error] errorHandlers = - [ Handler $ \(x :: Error) -> pure x - , Handler $ \(_ :: InvalidRequest) -> pure $ Error status400 "client-error" "Invalid Request" - , Handler $ \(_ :: TimeoutThread) -> pure $ Error status408 "client-error" "Request Timeout" - , Handler $ \(ZlibException (-3)) -> pure $ Error status400 "client-error" "Invalid request body compression" - , Handler $ \(_ :: SomeException) -> pure $ Error status500 "server-error" "Server Error" + [ Handler $ \(x :: Wai.Error) -> pure x + , Handler $ \(_ :: InvalidRequest) -> pure $ Wai.Error status400 "client-error" "Invalid Request" + , Handler $ \(_ :: TimeoutThread) -> pure $ Wai.Error status408 "client-error" "Request Timeout" + , Handler $ \(ZlibException (-3)) -> pure $ Wai.Error status400 "client-error" "Invalid request body compression" + , Handler $ \(_ :: SomeException) -> pure $ Wai.Error status500 "server-error" "Server Error" ] {-# INLINE errorHandlers #-} +-- | If the log level is less sensitive than 'Debug' just call the underlying app unchanged. +-- Otherwise, pull a copy of the request body before running it, and if response status is @>= +-- 400@, log the entire request, including the body. +-- +-- The request sanitizer is called on the 'Request' and its body before it is being logged, +-- giving you a chance to erase any confidential information. +-- +-- WARNINGS: +-- +-- * This may log confidential information if contained in the request. Use the sanitizer to +-- avoid that. +-- * This does not catch any exceptions in the underlying app, so consider calling +-- 'catchErrors' before this. +-- * Be careful with trying this in production: this puts a performance penalty on every +-- request (unless level is less sensitive than 'Debug'). +heavyDebugLogging + :: ((Request, LByteString) -> Maybe (Request, LByteString)) + -> Level -> Logger -> Middleware +heavyDebugLogging sanitizeReq lvl lgr app = \req cont -> do + (bdy, req') <- if lvl <= Debug -- or (`elem` [Trace, Debug]) + then cloneBody req + else pure ("body omitted because log level was less sensitive than Debug", req) + app req' $ \resp -> do + forM_ (sanitizeReq (req', bdy)) $ \(req'', bdy') -> + when (statusCode (responseStatus resp) >= 400) $ logBody req'' bdy' + cont resp + where + cloneBody :: Request -> IO (LByteString, Request) + cloneBody req = do + bdy <- lazyRequestBody req + requestBody' <- emitLByteString bdy + pure (bdy, req { requestBody = requestBody' }) + + logBody :: Request -> LByteString -> IO () + logBody req bdy = Log.debug lgr logMsg + where + logMsg = field "request" (fromMaybe "N/A" $ lookupRequestId req) + . field "request_details" (show req) + . field "request_body" bdy + . msg (val "full request details") + +-- | Compute a stream from a lazy bytestring suitable for putting into the 'Response'. This +-- can be used if we want to take a look at the body in a 'Middleware' *after* the request has +-- been processed and the stream flushed. +-- +-- This implementation returns the entire body in the first stream chunk. An alternative, +-- possibly faster implementation would be this: +-- +-- >>> emitLByteString lbs = do +-- >>> chunks <- TVar.newTVarIO (LBS.toChunks lbs) +-- >>> pure $ do +-- >>> nextChunk <- atomically $ do +-- >>> xs <- TVar.readTVar chunks +-- >>> case xs of +-- >>> [] -> pure Nothing +-- >>> (x:xs') -> TVar.writeTVar chunks xs' >> pure (Just x) +-- >>> pure $ fromMaybe "" nextChunk +emitLByteString :: LByteString -> IO (IO ByteString) +emitLByteString lbs = do + tvar <- newTVarIO (cs lbs) + -- | Emit the bytestring on the first read, then always return "" on subsequent reads + return . atomically $ swapTVar tvar mempty + -------------------------------------------------------------------------------- -- Utilities +-- | 'onError' and 'catchErrors' support both the metrics-core ('Right') and the prometheus +-- package introduced for spar ('Left'). +type OnErrorMetrics = [Either Prm.Counter Metrics] + -- | Send an 'Error' response. -onError :: MonadIO m => Logger -> Metrics -> Request -> Continue IO -> Error -> m ResponseReceived +onError + :: MonadIO m + => Logger -> OnErrorMetrics -> Request -> Continue IO -> Wai.Error + -> m ResponseReceived onError g m r k e = liftIO $ do logError g (Just r) e when (statusCode (Error.code e) >= 500) $ - counterIncr (path "net.errors") m + either Prm.incCounter (counterIncr (path "net.errors")) `mapM_` m flushRequestBody r k (errorRs' e) -- | Log an 'Error' response for debugging purposes. -logError :: MonadIO m => Logger -> Maybe Request -> Error -> m () -logError g r (Error c l m) = liftIO $ Log.debug g logMsg +-- +-- It would be nice to have access to the request body here, but that's already streamed away +-- by the handler in all likelyhood. See 'heavyDebugLogging'. +logError :: (MonadIO m, HasRequest r) => Logger -> Maybe r -> Wai.Error -> m () +logError g mr (Wai.Error c l m) = liftIO $ Log.debug g logMsg where logMsg = field "code" (statusCode c) . field "label" l - . field "request" (fromMaybe "N/A" (lookupRequestId =<< r)) + . field "request" (fromMaybe "N/A" (lookupRequestId =<< mr)) . msg (val "\"" +++ m +++ val "\"") -logIO :: ToBytes a => Logger -> Level -> Maybe Request -> a -> IO () +logIO :: (ToBytes msg, HasRequest r) => Logger -> Level -> Maybe r -> msg -> IO () logIO lg lv r a = let reqId = field "request" . fromMaybe "N/A" . lookupRequestId <$> r mesg = fromMaybe id reqId . msg a diff --git a/services/brig/package.yaml b/services/brig/package.yaml index aa87314a6d5..1846c22323e 100644 --- a/services/brig/package.yaml +++ b/services/brig/package.yaml @@ -28,6 +28,7 @@ dependencies: - lens-aeson >=1.0 - mtl >=2.1 - optparse-applicative >=0.11 +- prometheus-client - safe >=0.3 - text >=0.11 - transformers >=0.3 @@ -47,6 +48,7 @@ library: - Brig.Options - Brig.Provider.DB - Brig.RPC + - Brig.Run - Brig.User.Auth.Cookie.Limit - Brig.User.Search.Index - Brig.ZAuth diff --git a/services/brig/schema/src/Main.hs b/services/brig/schema/src/Main.hs index 80e589a0a7f..96625de04c7 100644 --- a/services/brig/schema/src/Main.hs +++ b/services/brig/schema/src/Main.hs @@ -5,7 +5,6 @@ import Cassandra.Schema import Control.Exception (finally) import Util.Options -import qualified System.Logger as Log import qualified System.Logger.Extended as Log import qualified V9 diff --git a/services/brig/src/Brig/API.hs b/services/brig/src/Brig/API.hs index 4bbd0385ddd..59dd26ced22 100644 --- a/services/brig/src/Brig/API.hs +++ b/services/brig/src/Brig/API.hs @@ -1,10 +1,9 @@ {-# LANGUAGE RecordWildCards #-} -module Brig.API (runServer) where +module Brig.API (sitemap) where import Imports hiding (head) import Brig.App -import Brig.AWS (sesQueue) import Brig.API.Error import Brig.API.Handler import Brig.API.Types @@ -17,54 +16,41 @@ import Brig.User.Email import Brig.User.Phone import Control.Error hiding (bool) import Control.Lens (view, (^.)) -import Control.Monad.Catch (finally) import Data.Aeson hiding (json) import Data.ByteString.Conversion import Data.Id import Data.Metrics.Middleware hiding (metrics) -import Data.Metrics.WaiRoute (treeToPaths) import Data.Misc (IpAddr (..)) import Data.Range -import Data.Text (unpack) import Data.Text.Encoding (decodeLatin1) import Data.Text.Lazy (pack) import Galley.Types (UserClients (..)) import Network.HTTP.Types.Status -import Network.Wai (Request, Response, responseLBS, lazyRequestBody) +import Network.Wai (Response, responseLBS, lazyRequestBody) import Network.Wai.Predicate hiding (setStatus, result) import Network.Wai.Routing import Network.Wai.Utilities -import Network.Wai.Utilities.Server import Network.Wai.Utilities.Swagger (document, mkSwaggerApi) -import Util.Options import qualified Data.Text.Ascii as Ascii import qualified Data.List1 as List1 -import qualified Control.Concurrent.Async as Async import qualified Brig.API.Client as API import qualified Brig.API.Connection as API import qualified Brig.API.Properties as API import qualified Brig.API.User as API import qualified Brig.Data.User as Data -import qualified Brig.Queue as Queue import qualified Brig.Team.Util as Team import qualified Brig.User.API.Auth as Auth import qualified Brig.User.API.Search as Search import qualified Brig.User.Auth.Cookie as Auth -import qualified Brig.AWS as AWS -import qualified Brig.AWS.SesNotification as SesNotification -import qualified Brig.InternalEvent.Process as Internal import qualified Brig.Types.Swagger as Doc import qualified Network.Wai.Utilities.Swagger as Doc import qualified Data.Swagger.Build.Api as Doc import qualified Galley.Types.Swagger as Doc import qualified Galley.Types.Teams as Team -import qualified Network.Wai.Middleware.Gzip as GZip -import qualified Network.Wai.Middleware.Gunzip as GZip import qualified Network.Wai.Utilities as Utilities import qualified Data.ByteString.Lazy as Lazy import qualified Data.Map.Strict as Map -import qualified Network.Wai.Utilities.Server as Server import qualified Data.Set as Set import qualified Data.Text as Text import qualified Brig.Provider.API as Provider @@ -73,31 +59,6 @@ import qualified Brig.Team.Email as Team import qualified Brig.TURN.API as TURN import qualified System.Logger.Class as Log -runServer :: Opts -> IO () -runServer o = do - e <- newEnv o - s <- Server.newSettings (server e) - emailListener <- for (e^.awsEnv.sesQueue) $ \q -> - Async.async $ - AWS.execute (e^.awsEnv) $ - AWS.listen q (runAppT e . SesNotification.onEvent) - internalEventListener <- Async.async $ - runAppT e $ Queue.listen (e^.internalEvents) Internal.onEvent - runSettingsWithShutdown s (pipeline e) 5 `finally` do - mapM_ Async.cancel emailListener - Async.cancel internalEventListener - closeEnv e - where - rtree = compile (sitemap o) - endpoint = brig o - server e = defaultServer (unpack $ endpoint^.epHost) (endpoint^.epPort) (e^.applog) (e^.metrics) - pipeline e = measureRequests (e^.metrics) (treeToPaths rtree) - . catchErrors (e^.applog) (e^.metrics) - . GZip.gunzip . GZip.gzip GZip.def - $ serve e - - serve e r k = runHandler e r (Server.route rtree r k) k - --------------------------------------------------------------------------- -- Sitemap @@ -114,20 +75,17 @@ sitemap o = do post "/i/users/:id/auto-connect" (continue autoConnect) $ accept "application" "json" - .&. contentType "application" "json" .&. capture "id" .&. opt (header "Z-Connection") - .&. request + .&. jsonRequest @UserSet post "/i/users" (continue createUserNoVerify) $ accept "application" "json" - .&. contentType "application" "json" - .&. request + .&. jsonRequest @NewUser put "/i/self/email" (continue changeSelfEmailNoSend) $ - contentType "application" "json" - .&. header "Z-User" - .&. request + header "Z-User" + .&. jsonRequest @EmailUpdate delete "/i/users/:id" (continue deleteUserNoVerify) $ capture "id" @@ -138,8 +96,7 @@ sitemap o = do post "/i/users/connections-status" (continue getConnectionsStatus) $ accept "application" "json" - .&. contentType "application" "json" - .&. request + .&. jsonRequest @ConnectionsStatusRequest .&. opt (query "filter") get "/i/users" (continue listActivatedAccounts) $ @@ -151,9 +108,8 @@ sitemap o = do .&. (param "email" ||| param "phone") put "/i/users/:id/status" (continue changeAccountStatus) $ - contentType "application" "json" - .&. capture "id" - .&. request + capture "id" + .&. jsonRequest @AccountStatusUpdate get "/i/users/:id/status" (continue getAccountStatus) $ accept "application" "json" @@ -193,8 +149,7 @@ sitemap o = do post "/i/users/phone-prefixes" (continue addPhonePrefix) $ accept "application" "json" - .&. contentType "application" "json" - .&. request + .&. jsonRequest @ExcludedPrefix -- is :uid not team owner, or there are other team owners? get "/i/users/:uid/can-be-deleted/:tid" (continue canBeDeleted) $ @@ -209,25 +164,21 @@ sitemap o = do put "/i/users/:uid/sso-id" (continue updateSSOId) $ capture "uid" .&. accept "application" "json" - .&. contentType "application" "json" - .&. request + .&. jsonRequest @UserSSOId put "/i/users/:uid/managed-by" (continue updateManagedBy) $ capture "uid" .&. accept "application" "json" - .&. contentType "application" "json" - .&. request + .&. jsonRequest @ManagedByUpdate put "/i/users/:uid/rich-info" (continue updateRichInfo) $ capture "uid" .&. accept "application" "json" - .&. contentType "application" "json" - .&. request + .&. jsonRequest @RichInfoUpdate post "/i/clients" (continue internalListClients) $ accept "application" "json" - .&. contentType "application" "json" - .&. request + .&. jsonRequest @UserSet -- /users ----------------------------------------------------------------- @@ -270,9 +221,8 @@ sitemap o = do post "/users/handles" (continue checkHandles) $ accept "application" "json" - .&. contentType "application" "json" .&. header "Z-User" - .&. request + .&. jsonRequest @CheckHandles document "POST" "checkUserHandles" $ do Doc.summary "Check availability of user handles" @@ -328,8 +278,7 @@ sitemap o = do --- post "/users/prekeys" (continue getMultiPrekeyBundles) $ - request - .&. contentType "application" "json" + jsonRequest @UserClients .&. accept "application" "json" document "POST" "getMultiPrekeyBundles" $ do @@ -432,10 +381,9 @@ sitemap o = do --- put "/self" (continue updateUser) $ - contentType "application" "json" - .&. header "Z-User" + header "Z-User" .&. header "Z-Connection" - .&. request + .&. jsonRequest @UserUpdate document "PUT" "updateSelf" $ do Doc.summary "Update your profile" @@ -457,10 +405,9 @@ sitemap o = do --- put "/self/email" (continue changeSelfEmail) $ - contentType "application" "json" - .&. header "Z-User" + header "Z-User" .&. header "Z-Connection" - .&. request + .&. jsonRequest @EmailUpdate document "PUT" "changeEmail" $ do Doc.summary "Change your email address" @@ -476,10 +423,9 @@ sitemap o = do --- put "/self/phone" (continue changePhone) $ - contentType "application" "json" - .&. header "Z-User" + header "Z-User" .&. header "Z-Connection" - .&. request + .&. jsonRequest @PhoneUpdate document "PUT" "changePhone" $ do Doc.summary "Change your phone number" @@ -501,9 +447,8 @@ sitemap o = do --- put "/self/password" (continue changePassword) $ - contentType "application" "json" - .&. header "Z-User" - .&. request + header "Z-User" + .&. jsonRequest @PasswordChange document "PUT" "changePassword" $ do Doc.summary "Change your password" @@ -516,10 +461,9 @@ sitemap o = do -- put "/self/locale" (continue changeLocale) $ - contentType "application" "json" - .&. header "Z-User" + header "Z-User" .&. header "Z-Connection" - .&. request + .&. jsonRequest @LocaleUpdate document "PUT" "changeLocale" $ do Doc.summary "Change your locale" @@ -530,10 +474,9 @@ sitemap o = do -- put "/self/handle" (continue changeHandle) $ - contentType "application" "json" - .&. header "Z-User" + header "Z-User" .&. header "Z-Connection" - .&. request + .&. jsonRequest @HandleUpdate document "PUT" "changeHandle" $ do Doc.summary "Change your handle" @@ -576,8 +519,7 @@ sitemap o = do delete "/self" (continue deleteUser) $ header "Z-User" - .&. request - .&. contentType "application" "json" + .&. jsonRequest @DeleteUser .&. accept "application" "json" document "DELETE" "deleteUser" $ do @@ -598,8 +540,7 @@ sitemap o = do --- post "/delete" (continue verifyDeleteUser) $ - request - .&. contentType "application" "json" + jsonRequest @VerifyDeleteUser .&. accept "application" "json" document "POST" "verifyDeleteUser" $ do @@ -613,10 +554,9 @@ sitemap o = do post "/connections" (continue createConnection) $ accept "application" "json" - .&. contentType "application" "json" .&. header "Z-User" .&. header "Z-Connection" - .&. request + .&. jsonRequest @ConnectionRequest document "POST" "createConnection" $ do Doc.summary "Create a connection to another user." @@ -655,11 +595,10 @@ sitemap o = do put "/connections/:id" (continue updateConnection) $ accept "application" "json" - .&. contentType "application" "json" .&. header "Z-User" .&. header "Z-Connection" .&. capture "id" - .&. request + .&. jsonRequest @ConnectionUpdate document "PUT" "updateConnection" $ do Doc.summary "Update a connection." @@ -692,12 +631,11 @@ sitemap o = do --- Clients post "/clients" (continue addClient) $ - request + jsonRequest @NewClient .&. header "Z-User" .&. header "Z-Connection" .&. opt (header "X-Forwarded-For") .&. accept "application" "json" - .&. contentType "application" "json" document "POST" "registerClient" $ do Doc.summary "Register a new client." @@ -712,11 +650,10 @@ sitemap o = do --- put "/clients/:client" (continue updateClient) $ - request + jsonRequest @UpdateClient .&. header "Z-User" .&. capture "client" .&. accept "application" "json" - .&. contentType "application" "json" document "PUT" "updateClient" $ do Doc.summary "Update a registered client." @@ -730,12 +667,11 @@ sitemap o = do --- delete "/clients/:client" (continue rmClient) $ - request + jsonRequest @RmClient .&. header "Z-User" .&. header "Z-Connection" .&. capture "client" .&. accept "application" "json" - .&. contentType "application" "json" document "DELETE" "deleteClient" $ do Doc.summary "Delete an existing client." @@ -790,8 +726,7 @@ sitemap o = do header "Z-User" .&. header "Z-Connection" .&. capture "key" - .&. request - .&. contentType "application" "json" + .&. jsonRequest @PropertyValue document "PUT" "setProperty" $ do Doc.summary "Set a user property." @@ -864,8 +799,7 @@ sitemap o = do post "/register" (continue createUser) $ accept "application" "json" - .&. contentType "application" "json" - .&. request + .&. jsonRequest @NewUserPublic document "POST" "register" $ do Doc.summary "Register a new user." @@ -906,8 +840,7 @@ sitemap o = do post "/activate" (continue activateKey) $ accept "application" "json" - .&. contentType "application" "json" - .&. request + .&. jsonRequest @Activate document "POST" "activate" $ do Doc.summary "Activate (i.e. confirm) an email address or phone number." @@ -923,8 +856,7 @@ sitemap o = do --- post "/activate/send" (continue sendActivationCode) $ - contentType "application" "json" - .&. request + jsonRequest @SendActivationCode document "POST" "sendActivationCode" $ do Doc.summary "Send (or resend) an email or phone activation code." @@ -941,8 +873,7 @@ sitemap o = do post "/password-reset" (continue beginPasswordReset) $ accept "application" "json" - .&. contentType "application" "json" - .&. request + .&. jsonRequest @NewPasswordReset document "POST" "beginPasswordReset" $ do Doc.summary "Initiate a password reset." @@ -956,8 +887,7 @@ sitemap o = do post "/password-reset/complete" (continue completePasswordReset) $ accept "application" "json" - .&. contentType "application" "json" - .&. request + .&. jsonRequest @CompletePasswordReset document "POST" "completePasswordReset" $ do Doc.summary "Complete a password reset." @@ -970,9 +900,8 @@ sitemap o = do post "/password-reset/:key" (continue deprecatedCompletePasswordReset) $ accept "application" "json" - .&. contentType "application" "json" .&. capture "key" - .&. request + .&. jsonRequest @PasswordReset document "POST" "deprecatedCompletePasswordReset" $ do Doc.deprecated @@ -983,9 +912,8 @@ sitemap o = do post "/onboarding/v3" (continue onboarding) $ accept "application" "json" - .&. contentType "application" "json" .&. header "Z-User" - .&. request + .&. jsonRequest @AddressBook document "POST" "onboardingV3" $ do Doc.summary "Upload contacts and invoke matching. Returns the list of Matches" @@ -1004,11 +932,11 @@ sitemap o = do --------------------------------------------------------------------------- -- Handlers -setProperty :: UserId ::: ConnId ::: PropertyKey ::: Request ::: JSON -> Handler Response -setProperty (u ::: c ::: k ::: req ::: _) = do +setProperty :: UserId ::: ConnId ::: PropertyKey ::: JsonRequest PropertyValue -> Handler Response +setProperty (u ::: c ::: k ::: req) = do unless (Text.compareLength (Ascii.toText (propertyKeyName k)) maxKeyLen <= EQ) $ throwStd propertyKeyTooLarge - lbs <- Lazy.take (maxValueLen + 1) <$> liftIO (lazyRequestBody req) + lbs <- Lazy.take (maxValueLen + 1) <$> liftIO (lazyRequestBody (fromJsonRequest req)) unless (Lazy.length lbs <= maxValueLen) $ throwStd propertyValueTooLarge val <- hoistEither $ fmapL (StdError . badRequest . pack) (eitherDecode lbs) @@ -1047,7 +975,7 @@ getPrekey (u ::: c ::: _) = do getPrekeyBundle :: UserId ::: JSON -> Handler Response getPrekeyBundle (u ::: _) = json <$> lift (API.claimPrekeyBundle u) -getMultiPrekeyBundles :: Request ::: JSON ::: JSON -> Handler Response +getMultiPrekeyBundles :: JsonRequest UserClients ::: JSON -> Handler Response getMultiPrekeyBundles (req ::: _) = do body <- parseJsonBody req maxSize <- fromIntegral . setMaxConvSize <$> view settings @@ -1055,7 +983,7 @@ getMultiPrekeyBundles (req ::: _) = do throwStd tooManyClients json <$> lift (API.claimMultiPrekeyBundles body) -addClient :: Request ::: UserId ::: ConnId ::: Maybe IpAddr ::: JSON ::: JSON -> Handler Response +addClient :: JsonRequest NewClient ::: UserId ::: ConnId ::: Maybe IpAddr ::: JSON -> Handler Response addClient (req ::: usr ::: con ::: ip ::: _) = do new <- parseJsonBody req clt <- API.addClient usr con (ipAddr <$> ip) new !>> clientError @@ -1063,13 +991,13 @@ addClient (req ::: usr ::: con ::: ip ::: _) = do . addHeader "Location" (toByteString' $ clientId clt) $ json clt -rmClient :: Request ::: UserId ::: ConnId ::: ClientId ::: JSON ::: JSON -> Handler Response +rmClient :: JsonRequest RmClient ::: UserId ::: ConnId ::: ClientId ::: JSON -> Handler Response rmClient (req ::: usr ::: con ::: clt ::: _) = do body <- parseJsonBody req API.rmClient usr con clt (rmPassword body) !>> clientError return empty -updateClient :: Request ::: UserId ::: ClientId ::: JSON ::: JSON -> Handler Response +updateClient :: JsonRequest UpdateClient ::: UserId ::: ClientId ::: JSON -> Handler Response updateClient (req ::: usr ::: clt ::: _) = do body <- parseJsonBody req API.updateClient usr clt body !>> clientError @@ -1078,8 +1006,8 @@ updateClient (req ::: usr ::: clt ::: _) = do listClients :: UserId ::: JSON -> Handler Response listClients (usr ::: _) = json <$> lift (API.lookupClients usr) -internalListClients :: JSON ::: JSON ::: Request -> Handler Response -internalListClients (_ ::: _ ::: req) = do +internalListClients :: JSON ::: JsonRequest UserSet -> Handler Response +internalListClients (_ ::: req) = do UserSet usrs <- parseJsonBody req ucs <- Map.fromList <$> lift (API.lookupUsersClientIds $ Set.toList usrs) return $ json (UserClients ucs) @@ -1117,8 +1045,8 @@ getRichInfo (self ::: user ::: _) = do listPrekeyIds :: UserId ::: ClientId ::: JSON -> Handler Response listPrekeyIds (usr ::: clt ::: _) = json <$> lift (API.lookupPrekeyIds usr clt) -autoConnect :: JSON ::: JSON ::: UserId ::: Maybe ConnId ::: Request -> Handler Response -autoConnect (_ ::: _ ::: uid ::: conn ::: req) = do +autoConnect :: JSON ::: UserId ::: Maybe ConnId ::: JsonRequest UserSet -> Handler Response +autoConnect (_ ::: uid ::: conn ::: req) = do UserSet to <- parseJsonBody req let num = Set.size to when (num < 1) $ @@ -1128,8 +1056,8 @@ autoConnect (_ ::: _ ::: uid ::: conn ::: req) = do conns <- API.autoConnect uid to conn !>> connError return $ json conns -createUser :: JSON ::: JSON ::: Request -> Handler Response -createUser (_ ::: _ ::: req) = do +createUser :: JSON ::: JsonRequest NewUserPublic -> Handler Response +createUser (_ ::: req) = do NewUserPublic new <- parseJsonBody req for_ (newUserEmail new) $ checkWhitelist . Left for_ (newUserPhone new) $ checkWhitelist . Right @@ -1167,8 +1095,8 @@ createUser (_ ::: _ ::: req) = do sendWelcomeEmail e (CreateUserTeam t n) (NewTeamMember _) l = Team.sendMemberWelcomeMail e t n l sendWelcomeEmail e (CreateUserTeam t n) (NewTeamMemberSSO _) l = Team.sendMemberWelcomeMail e t n l -createUserNoVerify :: JSON ::: JSON ::: Request -> Handler Response -createUserNoVerify (_ ::: _ ::: req) = do +createUserNoVerify :: JSON ::: JsonRequest NewUser -> Handler Response +createUserNoVerify (_ ::: req) = do (uData :: NewUser) <- parseJsonBody req result <- API.createUser uData !>> newUserError let acc = createdAccount result @@ -1190,8 +1118,8 @@ deleteUserNoVerify uid = do lift $ API.deleteUserNoVerify uid return $ setStatus status202 empty -changeSelfEmailNoSend :: JSON ::: UserId ::: Request -> Handler Response -changeSelfEmailNoSend (_ ::: u ::: req) = changeEmail u req False +changeSelfEmailNoSend :: UserId ::: JsonRequest EmailUpdate -> Handler Response +changeSelfEmailNoSend (u ::: req) = changeEmail u req False checkUserExists :: UserId ::: UserId -> Handler Response checkUserExists (self ::: uid) = do @@ -1257,14 +1185,14 @@ getPasswordResetCode (_ ::: emailOrPhone) = do where found (k, c) = json $ object [ "key" .= k, "code" .= c ] -updateUser :: JSON ::: UserId ::: ConnId ::: Request -> Handler Response -updateUser (_ ::: uid ::: conn ::: req) = do +updateUser :: UserId ::: ConnId ::: JsonRequest UserUpdate -> Handler Response +updateUser (uid ::: conn ::: req) = do uu <- parseJsonBody req lift $ API.updateUser uid conn uu return empty -changeAccountStatus :: JSON ::: UserId ::: Request -> Handler Response -changeAccountStatus (_ ::: usr ::: req) = do +changeAccountStatus :: UserId ::: JsonRequest AccountStatusUpdate -> Handler Response +changeAccountStatus (usr ::: req) = do status <- suStatus <$> parseJsonBody req API.changeAccountStatus (List1.singleton usr) status !>> accountStatusError return empty @@ -1276,8 +1204,8 @@ getAccountStatus (_ ::: usr) = do Just s -> json $ object ["status" .= s] Nothing -> setStatus status404 empty -changePhone :: JSON ::: UserId ::: ConnId ::: Request -> Handler Response -changePhone (_ ::: u ::: _ ::: req) = do +changePhone :: UserId ::: ConnId ::: JsonRequest PhoneUpdate -> Handler Response +changePhone (u ::: _ ::: req) = do phone <- puPhone <$> parseJsonBody req (adata, pn) <- API.changePhone u phone !>> changePhoneError loc <- lift $ API.lookupLocale u @@ -1300,14 +1228,14 @@ checkPasswordExists self = do exists <- lift $ isJust <$> API.lookupPassword self return $ if exists then empty else setStatus status404 empty -changePassword :: JSON ::: UserId ::: Request -> Handler Response -changePassword (_ ::: u ::: req) = do +changePassword :: UserId ::: JsonRequest PasswordChange -> Handler Response +changePassword (u ::: req) = do cp <- parseJsonBody req API.changePassword u cp !>> changePwError return empty -changeLocale :: JSON ::: UserId ::: ConnId ::: Request -> Handler Response -changeLocale (_ ::: u ::: conn ::: req) = do +changeLocale :: UserId ::: ConnId ::: JsonRequest LocaleUpdate -> Handler Response +changeLocale (u ::: conn ::: req) = do l <- parseJsonBody req lift $ API.changeLocale u conn l return empty @@ -1326,8 +1254,8 @@ checkHandle (_ ::: h) = do -- Handle is free and can be taken -> return $ setStatus status404 empty -checkHandles :: JSON ::: JSON ::: UserId ::: Request -> Handler Response -checkHandles (_ ::: _ ::: _ ::: req) = do +checkHandles :: JSON ::: UserId ::: JsonRequest CheckHandles -> Handler Response +checkHandles (_ ::: _ ::: req) = do CheckHandles hs num <- parseJsonBody req let handles = mapMaybe parseHandle (fromRange hs) free <- lift $ API.checkHandles handles (fromRange num) @@ -1340,18 +1268,18 @@ getHandleInfo (_ ::: _ ::: h) = do Just u -> json (UserHandleInfo u) Nothing -> setStatus status404 empty -changeHandle :: JSON ::: UserId ::: ConnId ::: Request -> Handler Response -changeHandle (_ ::: u ::: conn ::: req) = do +changeHandle :: UserId ::: ConnId ::: JsonRequest HandleUpdate -> Handler Response +changeHandle (u ::: conn ::: req) = do HandleUpdate h <- parseJsonBody req handle <- validateHandle h API.changeHandle u conn handle !>> changeHandleError return empty -activateKey :: JSON ::: JSON ::: Request -> Handler Response -activateKey (_ ::: _ ::: req) = parseJsonBody req >>= activate +activateKey :: JSON ::: JsonRequest Activate -> Handler Response +activateKey (_ ::: req) = parseJsonBody req >>= activate -beginPasswordReset :: JSON ::: JSON ::: Request -> Handler Response -beginPasswordReset (_ ::: _ ::: req) = do +beginPasswordReset :: JSON ::: JsonRequest NewPasswordReset -> Handler Response +beginPasswordReset (_ ::: req) = do NewPasswordReset target <- parseJsonBody req checkWhitelist target (u, pair) <- API.beginPasswordReset target !>> pwResetError @@ -1361,21 +1289,21 @@ beginPasswordReset (_ ::: _ ::: req) = do Right phone -> sendPasswordResetSms phone pair loc return $ setStatus status201 empty -completePasswordReset :: JSON ::: JSON ::: Request -> Handler Response -completePasswordReset (_ ::: _ ::: req) = do +completePasswordReset :: JSON ::: JsonRequest CompletePasswordReset -> Handler Response +completePasswordReset (_ ::: req) = do CompletePasswordReset{..} <- parseJsonBody req API.completePasswordReset cpwrIdent cpwrCode cpwrPassword !>> pwResetError return empty -sendActivationCode :: JSON ::: Request -> Handler Response -sendActivationCode (_ ::: req) = do +sendActivationCode :: JsonRequest SendActivationCode -> Handler Response +sendActivationCode req = do SendActivationCode{..} <- parseJsonBody req checkWhitelist saUserKey API.sendActivationCode saUserKey saLocale saCall !>> sendActCodeError return empty -changeSelfEmail :: JSON ::: UserId ::: ConnId ::: Request -> Handler Response -changeSelfEmail (_ ::: u ::: _ ::: req) = changeEmail u req True +changeSelfEmail :: UserId ::: ConnId ::: JsonRequest EmailUpdate -> Handler Response +changeSelfEmail (u ::: _ ::: req) = changeEmail u req True -- Deprecated and to be removed after new versions of brig and galley are -- deployed. Reason for deprecation: it returns N^2 things (which is not @@ -1389,25 +1317,25 @@ deprecatedGetConnectionsStatus (users ::: flt) = do filterByRelation l rel = filter ((==rel) . csStatus) l getConnectionsStatus - :: JSON ::: JSON ::: Request ::: Maybe Relation + :: JSON ::: JsonRequest ConnectionsStatusRequest ::: Maybe Relation -> Handler Response -getConnectionsStatus (_ ::: _ ::: req ::: flt) = do +getConnectionsStatus (_ ::: req ::: flt) = do ConnectionsStatusRequest{csrFrom, csrTo} <- parseJsonBody req r <- lift $ API.lookupConnectionStatus csrFrom csrTo return . json $ maybe r (filterByRelation r) flt where filterByRelation l rel = filter ((==rel) . csStatus) l -createConnection :: JSON ::: JSON ::: UserId ::: ConnId ::: Request -> Handler Response -createConnection (_ ::: _ ::: self ::: conn ::: req) = do +createConnection :: JSON ::: UserId ::: ConnId ::: JsonRequest ConnectionRequest -> Handler Response +createConnection (_ ::: self ::: conn ::: req) = do cr <- parseJsonBody req rs <- API.createConnection self cr conn !>> connError return $ case rs of ConnectionCreated c -> setStatus status201 $ json c ConnectionExists c -> json c -updateConnection :: JSON ::: JSON ::: UserId ::: ConnId ::: UserId ::: Request -> Handler Response -updateConnection (_ ::: _ ::: self ::: conn ::: other ::: req) = do +updateConnection :: JSON ::: UserId ::: ConnId ::: UserId ::: JsonRequest ConnectionUpdate -> Handler Response +updateConnection (_ ::: self ::: conn ::: other ::: req) = do newStatus <- cuStatus <$> parseJsonBody req mc <- API.updateConnection self other newStatus (Just conn) !>> connError return $ case mc of @@ -1460,8 +1388,8 @@ deleteFromPhonePrefix prefix = do void . lift $ API.phonePrefixDelete prefix return empty -addPhonePrefix :: JSON ::: JSON ::: Request -> Handler Response -addPhonePrefix (_ ::: _ ::: req) = do +addPhonePrefix :: JSON ::: JsonRequest ExcludedPrefix -> Handler Response +addPhonePrefix (_ ::: req) = do prefix :: ExcludedPrefix <- parseJsonBody req void . lift $ API.phonePrefixInsert prefix return empty @@ -1488,22 +1416,22 @@ isTeamOwner (uid ::: tid) = do Team.NoTeamOwnersAreLeft -> throwStd insufficientTeamPermissions return empty -updateSSOId :: UserId ::: JSON ::: JSON ::: Request -> Handler Response -updateSSOId (uid ::: _ ::: _ ::: req) = do +updateSSOId :: UserId ::: JSON ::: JsonRequest UserSSOId -> Handler Response +updateSSOId (uid ::: _ ::: req) = do ssoid :: UserSSOId <- parseJsonBody req success <- lift $ Data.updateSSOId uid ssoid if success then return empty else return . setStatus status404 $ plain "User does not exist or has no team." -updateManagedBy :: UserId ::: JSON ::: JSON ::: Request -> Handler Response -updateManagedBy (uid ::: _ ::: _ ::: req) = do +updateManagedBy :: UserId ::: JSON ::: JsonRequest ManagedByUpdate -> Handler Response +updateManagedBy (uid ::: _ ::: req) = do ManagedByUpdate managedBy <- parseJsonBody req lift $ Data.updateManagedBy uid managedBy return empty -updateRichInfo :: UserId ::: JSON ::: JSON ::: Request -> Handler Response -updateRichInfo (uid ::: _ ::: _ ::: req) = do +updateRichInfo :: UserId ::: JSON ::: JsonRequest RichInfoUpdate -> Handler Response +updateRichInfo (uid ::: _ ::: req) = do richInfo <- normalizeRichInfo . riuRichInfo <$> parseJsonBody req maxSize <- setRichInfoLimit <$> view settings when (richInfoSize richInfo > maxSize) $ throwStd tooLargeRichInfo @@ -1512,22 +1440,22 @@ updateRichInfo (uid ::: _ ::: _ ::: req) = do -- Intra.onUserEvent uid (Just conn) (richInfoUpdate uid ri) return empty -deleteUser :: UserId ::: Request ::: JSON ::: JSON -> Handler Response -deleteUser (u ::: r ::: _ ::: _) = do +deleteUser :: UserId ::: JsonRequest DeleteUser ::: JSON -> Handler Response +deleteUser (u ::: r ::: _) = do body <- parseJsonBody r res <- API.deleteUser u (deleteUserPassword body) !>> deleteUserError return $ case res of Nothing -> setStatus status200 empty Just ttl -> setStatus status202 (json (DeletionCodeTimeout ttl)) -verifyDeleteUser :: Request ::: JSON ::: JSON -> Handler Response +verifyDeleteUser :: JsonRequest VerifyDeleteUser ::: JSON -> Handler Response verifyDeleteUser (r ::: _) = do body <- parseJsonBody r API.verifyDeleteUser body !>> deleteUserError return (setStatus status200 empty) -onboarding :: JSON ::: JSON ::: UserId ::: Request -> Handler Response -onboarding (_ ::: _ ::: uid ::: r) = do +onboarding :: JSON ::: UserId ::: JsonRequest AddressBook -> Handler Response +onboarding (_ ::: uid ::: r) = do ab <- parseJsonBody r json <$> API.onboarding uid ab !>> connError @@ -1538,8 +1466,8 @@ getContactList (_ ::: uid) = do -- Deprecated -deprecatedCompletePasswordReset :: JSON ::: JSON ::: PasswordResetKey ::: Request -> Handler Response -deprecatedCompletePasswordReset (_ ::: _ ::: k ::: req) = do +deprecatedCompletePasswordReset :: JSON ::: PasswordResetKey ::: JsonRequest PasswordReset -> Handler Response +deprecatedCompletePasswordReset (_ ::: k ::: req) = do pwr <- parseJsonBody req API.completePasswordReset (PasswordResetIdentityKey k) (pwrCode pwr) (pwrPassword pwr) !>> pwResetError return empty @@ -1563,7 +1491,7 @@ activate (Activate tgt code dryrun) respond (Just ident) first = setStatus status200 $ json (ActivationResponse ident first) respond Nothing _ = setStatus status200 empty -changeEmail :: UserId -> Request -> Bool -> Handler Response +changeEmail :: UserId -> JsonRequest EmailUpdate -> Bool -> Handler Response changeEmail u req sendOutEmail = do email <- euEmail <$> parseJsonBody req API.changeEmail u email !>> changeEmailError >>= \case diff --git a/services/brig/src/Brig/API/Handler.hs b/services/brig/src/Brig/API/Handler.hs index 83d160e8ed5..46b0105bcf2 100644 --- a/services/brig/src/Brig/API/Handler.hs +++ b/services/brig/src/Brig/API/Handler.hs @@ -25,7 +25,7 @@ import Network.Wai.Predicate (Media) import Network.Wai (Request, ResponseReceived) import Network.Wai.Routing (Continue) import Network.Wai.Utilities.Error ((!>>)) -import Network.Wai.Utilities.Request (lookupRequestId, parseBody) +import Network.Wai.Utilities.Request (JsonRequest, lookupRequestId, parseBody) import Network.Wai.Utilities.Response (setStatus, json, addHeader) import System.Logger (Logger) @@ -76,7 +76,7 @@ type JSON = Media "application" "json" -- TODO: move to libs/wai-utilities? there is a parseJson' in "Network.Wai.Utilities.Request", -- but adjusting its signature to this here would require to move more code out of brig (at least -- badRequest and probably all the other errors). -parseJsonBody :: FromJSON a => Request -> Handler a +parseJsonBody :: FromJSON a => JsonRequest a -> Handler a parseJsonBody req = parseBody req !>> StdError . badRequest -- | If a whitelist is configured, consult it, otherwise a no-op. diff --git a/services/brig/src/Brig/API/User.hs b/services/brig/src/Brig/API/User.hs index 70cbf30747b..ab0d3eb09a4 100644 --- a/services/brig/src/Brig/API/User.hs +++ b/services/brig/src/Brig/API/User.hs @@ -757,7 +757,7 @@ deleteAccount account@(accountUser -> user) = do -- Free unique keys for_ (userEmail user) $ deleteKey . userEmailKey for_ (userPhone user) $ deleteKey . userPhoneKey - for_ (userHandle user) freeHandle + for_ (userHandle user) $ freeHandle user -- Wipe data Data.clearProperties uid tombstone <- mkTombstone diff --git a/services/brig/src/Brig/App.hs b/services/brig/src/Brig/App.hs index a23011c6aac..b422db401a4 100644 --- a/services/brig/src/Brig/App.hs +++ b/services/brig/src/Brig/App.hs @@ -57,7 +57,7 @@ import Brig.User.Search.Index (runIndexIO, IndexEnv (..), MonadIndexIO (..)) import Brig.User.Template import Brig.Types (Locale (..), TurnURI) import Brig.ZAuth (MonadZAuth (..), runZAuth) -import Cassandra (MonadClient (..), Keyspace (..), runClient) +import Cassandra (MonadClient, Keyspace(Keyspace), runClient) import Cassandra.Schema (versionCheck) import Control.AutoUpdate import Control.Error @@ -106,7 +106,6 @@ import qualified Ropes.Nexmo as Nexmo import qualified Ropes.Twilio as Twilio import qualified System.FilePath as Path import qualified System.FSNotify as FS -import qualified System.Logger as Log import qualified System.Logger.Class as LC import qualified System.Logger.Extended as Log diff --git a/services/brig/src/Brig/Provider/API.hs b/services/brig/src/Brig/Provider/API.hs index cbd59381e50..03907184483 100644 --- a/services/brig/src/Brig/Provider/API.hs +++ b/services/brig/src/Brig/Provider/API.hs @@ -34,16 +34,17 @@ import Data.Misc (Fingerprint (..), Rsa) import Data.Predicate import Data.Range import Galley.Types (Conversation (..), ConvType (..), ConvMembers (..), AccessRole (..)) -import Galley.Types (OtherMember (..)) +import Galley.Types (OtherMember (..), UserClients) import Galley.Types (Event, userClients) import Galley.Types.Bot (newServiceRef, serviceRefProvider, serviceRefId) import Data.Conduit ((.|), runConduit) import Network.HTTP.Types.Status -import Network.Wai (Request, Response) -import Network.Wai.Predicate (contentType, accept, request, query, def, opt) +import Network.Wai (Response) +import Network.Wai.Predicate (contentType, accept, query, def, opt) import Network.Wai.Routing import Network.Wai.Utilities.Error ((!>>)) import Network.Wai.Utilities.Response (json, empty, setStatus, addHeader) +import Network.Wai.Utilities.Request (jsonRequest, JsonRequest) import Network.Wai.Utilities.ZAuth import OpenSSL.Random (randBytes) @@ -81,9 +82,8 @@ routes = do -- Public API -------------------------------------------------------------- post "/provider/register" (continue newAccount) $ - contentType "application" "json" - .&> accept "application" "json" - .&> request + accept "application" "json" + .&> jsonRequest @NewProvider get "/provider/activate" (continue activateAccountKey) $ accept "application" "json" @@ -96,45 +96,38 @@ routes = do .&. query "code" post "/provider/login" (continue login) $ - contentType "application" "json" - .&> request + jsonRequest @ProviderLogin post "/provider/password-reset" (continue beginPasswordReset) $ accept "application" "json" - .&> contentType "application" "json" - .&> request + .&> jsonRequest @PasswordReset post "/provider/password-reset/complete" (continue completePasswordReset) $ accept "application" "json" - .&> contentType "application" "json" - .&> request + .&> jsonRequest @CompletePasswordReset -- Provider API ------------------------------------------------------------ delete "/provider" (continue deleteAccount) $ - contentType "application" "json" - .&> zauth ZAuthProvider + zauth ZAuthProvider .&> zauthProviderId - .&. request + .&. jsonRequest @DeleteProvider put "/provider" (continue updateAccountProfile) $ - contentType "application" "json" - .&> accept "application" "json" + accept "application" "json" .&> zauth ZAuthProvider .&> zauthProviderId - .&. request + .&. jsonRequest @UpdateProvider put "/provider/email" (continue updateAccountEmail) $ - contentType "application" "json" - .&> zauth ZAuthProvider + zauth ZAuthProvider .&> zauthProviderId - .&. request + .&. jsonRequest @EmailUpdate put "/provider/password" (continue updateAccountPassword) $ - contentType "application" "json" - .&> zauth ZAuthProvider + zauth ZAuthProvider .&> zauthProviderId - .&. request + .&. jsonRequest @PasswordChange get "/provider" (continue getAccount) $ accept "application" "json" @@ -143,10 +136,9 @@ routes = do post "/provider/services" (continue addService) $ accept "application" "json" - .&> contentType "application" "json" .&> zauth ZAuthProvider .&> zauthProviderId - .&. request + .&. jsonRequest @NewService get "/provider/services" (continue listServices) $ accept "application" "json" @@ -160,18 +152,16 @@ routes = do .&. capture "sid" put "/provider/services/:sid" (continue updateService) $ - contentType "application" "json" - .&> zauth ZAuthProvider + zauth ZAuthProvider .&> zauthProviderId .&. capture "sid" - .&. request + .&. jsonRequest @UpdateService put "/provider/services/:sid/connection" (continue updateServiceConn) $ - contentType "application" "json" - .&> zauth ZAuthProvider + zauth ZAuthProvider .&> zauthProviderId .&. capture "sid" - .&. request + .&. jsonRequest @UpdateServiceConn -- TODO -- post "/provider/services/:sid/token" (continue genServiceToken) $ @@ -179,11 +169,10 @@ routes = do -- .&. zauthProvider delete "/provider/services/:sid" (continue deleteService) $ - contentType "application" "json" - .&> zauth ZAuthProvider + zauth ZAuthProvider .&> zauthProviderId .&. capture "sid" - .&. request + .&. jsonRequest @DeleteService -- User API ---------------------------------------------------------------- @@ -228,16 +217,15 @@ routes = do .&> zauthUserId .&. zauthConnId .&. capture "tid" - .&. request + .&. jsonRequest @UpdateServiceWhitelist post "/conversations/:cnv/bots" (continue addBot) $ - contentType "application" "json" - .&> accept "application" "json" + accept "application" "json" .&> zauth ZAuthAccess .&> zauthUserId .&. zauthConnId .&. capture "cnv" - .&. request + .&. jsonRequest @AddBot delete "/conversations/:cnv/bots/:bot" (continue removeBot) $ zauth ZAuthAccess @@ -264,10 +252,9 @@ routes = do .&> zauthBotId post "/bot/client/prekeys" (continue botUpdatePrekeys) $ - contentType "application" "json" - .&> zauth ZAuthBot + zauth ZAuthBot .&> zauthBotId - .&. request + .&. jsonRequest @UpdateBotPrekeys get "/bot/client" (continue botGetClient) $ contentType "application" "json" @@ -276,9 +263,8 @@ routes = do post "/bot/users/prekeys" (continue botClaimUsersPrekeys) $ accept "application" "json" - .&> contentType "application" "json" .&> zauth ZAuthBot - .&> request + .&> jsonRequest @UserClients get "/bot/users" (continue botListUserProfiles) $ accept "application" "json" @@ -299,7 +285,7 @@ routes = do -------------------------------------------------------------------------------- -- Public API (Unauthenticated) -newAccount :: Request -> Handler Response +newAccount :: JsonRequest NewProvider -> Handler Response newAccount req = do new <- parseJsonBody req @@ -382,7 +368,7 @@ approveAccountKey (key ::: val) = do return empty _ -> throwStd invalidCode -login :: Request -> Handler Response +login :: JsonRequest ProviderLogin -> Handler Response login req = do l <- parseJsonBody req pid <- DB.lookupKey (mkEmailKey (providerLoginEmail l)) >>= maybeBadCredentials @@ -392,7 +378,7 @@ login req = do tok <- ZAuth.newProviderToken pid setProviderCookie tok empty -beginPasswordReset :: Request -> Handler Response +beginPasswordReset :: JsonRequest PasswordReset -> Handler Response beginPasswordReset req = do PasswordReset target <- parseJsonBody req pid <- DB.lookupKey (mkEmailKey target) >>= maybeBadCredentials @@ -410,7 +396,7 @@ beginPasswordReset req = do lift $ sendPasswordResetMail target (Code.codeKey code) (Code.codeValue code) return $ setStatus status201 empty -completePasswordReset :: Request -> Handler Response +completePasswordReset :: JsonRequest CompletePasswordReset -> Handler Response completePasswordReset req = do CompletePasswordReset key val pwd <- parseJsonBody req c <- Code.verify key Code.PasswordReset val >>= maybeInvalidCode @@ -431,7 +417,7 @@ getAccount pid = do Just p -> json p Nothing -> setStatus status404 empty -updateAccountProfile :: ProviderId ::: Request -> Handler Response +updateAccountProfile :: ProviderId ::: JsonRequest UpdateProvider -> Handler Response updateAccountProfile (pid ::: req) = do _ <- DB.lookupAccount pid >>= maybeInvalidProvider upd <- parseJsonBody req @@ -441,7 +427,7 @@ updateAccountProfile (pid ::: req) = do (updateProviderDescr upd) return empty -updateAccountEmail :: ProviderId ::: Request -> Handler Response +updateAccountEmail :: ProviderId ::: JsonRequest EmailUpdate -> Handler Response updateAccountEmail (pid ::: req) = do EmailUpdate new <- parseJsonBody req email <- case validateEmail new of @@ -461,7 +447,7 @@ updateAccountEmail (pid ::: req) = do lift $ sendActivationMail (Name "name") email (Code.codeKey code) (Code.codeValue code) True return $ setStatus status202 empty -updateAccountPassword :: ProviderId ::: Request -> Handler Response +updateAccountPassword :: ProviderId ::: JsonRequest PasswordChange -> Handler Response updateAccountPassword (pid ::: req) = do upd <- parseJsonBody req pass <- DB.lookupPassword pid >>= maybeBadCredentials @@ -470,7 +456,7 @@ updateAccountPassword (pid ::: req) = do DB.updateAccountPassword pid (cpNewPassword upd) return empty -addService :: ProviderId ::: Request -> Handler Response +addService :: ProviderId ::: JsonRequest NewService -> Handler Response addService (pid ::: req) = do new <- parseJsonBody req _ <- DB.lookupAccount pid >>= maybeInvalidProvider @@ -499,7 +485,7 @@ getService (pid ::: sid) = do s <- DB.lookupService pid sid >>= maybeServiceNotFound return (json s) -updateService :: ProviderId ::: ServiceId ::: Request -> Handler Response +updateService :: ProviderId ::: ServiceId ::: JsonRequest UpdateService -> Handler Response updateService (pid ::: sid ::: req) = do upd <- parseJsonBody req _ <- DB.lookupAccount pid >>= maybeInvalidProvider @@ -520,7 +506,7 @@ updateService (pid ::: sid ::: req) = do return empty -updateServiceConn :: ProviderId ::: ServiceId ::: Request -> Handler Response +updateServiceConn :: ProviderId ::: ServiceId ::: JsonRequest UpdateServiceConn -> Handler Response updateServiceConn (pid ::: sid ::: req) = do upd <- parseJsonBody req @@ -568,7 +554,7 @@ updateServiceConn (pid ::: sid ::: req) = do -- Since deleting a service can be costly, it just marks the service as -- disabled and then creates an event that will, when processed, actually -- delete the service. See 'finishDeleteService'. -deleteService :: ProviderId ::: ServiceId ::: Request -> Handler Response +deleteService :: ProviderId ::: ServiceId ::: JsonRequest DeleteService -> Handler Response deleteService (pid ::: sid ::: req) = do del <- parseJsonBody req pass <- DB.lookupPassword pid >>= maybeBadCredentials @@ -595,7 +581,7 @@ finishDeleteService pid sid = do where kick (bid, cid, _) = deleteBot (botUserId bid) Nothing bid cid -deleteAccount :: ProviderId ::: Request -> Handler Response +deleteAccount :: ProviderId ::: JsonRequest DeleteProvider -> Handler Response deleteAccount (pid ::: req) = do del <- parseJsonBody req prov <- DB.lookupAccount pid >>= maybeInvalidProvider @@ -665,7 +651,7 @@ getServiceTagList _ = return (json (ServiceTagList allTags)) where allTags = [(minBound :: ServiceTag) ..] -updateServiceWhitelist :: UserId ::: ConnId ::: TeamId ::: Request -> Handler Response +updateServiceWhitelist :: UserId ::: ConnId ::: TeamId ::: JsonRequest UpdateServiceWhitelist -> Handler Response updateServiceWhitelist (uid ::: con ::: tid ::: req) = do upd :: UpdateServiceWhitelist <- parseJsonBody req let pid = updateServiceWhitelistProvider upd @@ -694,7 +680,7 @@ updateServiceWhitelist (uid ::: con ::: tid ::: req) = do DB.deleteServiceWhitelist (Just tid) pid sid return (setStatus status200 empty) -addBot :: UserId ::: ConnId ::: ConvId ::: Request -> Handler Response +addBot :: UserId ::: ConnId ::: ConvId ::: JsonRequest AddBot -> Handler Response addBot (zuid ::: zcon ::: cid ::: req) = do add <- parseJsonBody req zusr <- lift (User.lookupUser zuid) >>= maybeInvalidUser @@ -810,7 +796,7 @@ botListPrekeys bot = do Nothing -> return $ json ([] :: [PrekeyId]) Just ci -> json <$> lift (User.lookupPrekeyIds (botUserId bot) ci) -botUpdatePrekeys :: BotId ::: Request -> Handler Response +botUpdatePrekeys :: BotId ::: JsonRequest UpdateBotPrekeys -> Handler Response botUpdatePrekeys (bot ::: req) = do upd <- parseJsonBody req clt <- lift $ listToMaybe <$> User.lookupClients (botUserId bot) @@ -821,7 +807,7 @@ botUpdatePrekeys (bot ::: req) = do User.updatePrekeys (botUserId bot) (clientId c) pks !>> clientDataError return empty -botClaimUsersPrekeys :: Request -> Handler Response +botClaimUsersPrekeys :: JsonRequest UserClients -> Handler Response botClaimUsersPrekeys req = do body <- parseJsonBody req maxSize <- fromIntegral . setMaxConvSize <$> view settings diff --git a/services/brig/src/Brig/Run.hs b/services/brig/src/Brig/Run.hs new file mode 100644 index 00000000000..b822632b0ae --- /dev/null +++ b/services/brig/src/Brig/Run.hs @@ -0,0 +1,51 @@ +module Brig.Run (run) where + +import Imports hiding (head) +import Brig.App +import Brig.API (sitemap) +import Brig.AWS (sesQueue) +import Brig.API.Handler +import Brig.Options hiding (internalEvents, sesQueue) +import Control.Monad.Catch (finally) +import Control.Lens ((^.)) +import Data.Metrics.WaiRoute (treeToPaths) +import Data.Text (unpack) +import Network.Wai.Utilities.Server +import Util.Options + +import qualified Brig.AWS as AWS +import qualified Brig.AWS.SesNotification as SesNotification +import qualified Brig.InternalEvent.Process as Internal +import qualified Brig.Queue as Queue +import qualified Control.Concurrent.Async as Async +import qualified Data.Metrics.Middleware.Prometheus as Metrics +import qualified Network.Wai as Wai +import qualified Network.Wai.Middleware.Gunzip as GZip +import qualified Network.Wai.Middleware.Gzip as GZip +import qualified Network.Wai.Utilities.Server as Server + + +run :: Opts -> IO () +run o = do + e <- newEnv o + s <- Server.newSettings (server e) + emailListener <- for (e^.awsEnv.sesQueue) $ \q -> + Async.async $ + AWS.execute (e^.awsEnv) $ + AWS.listen q (runAppT e . SesNotification.onEvent) + internalEventListener <- Async.async $ + runAppT e $ Queue.listen (e^.internalEvents) Internal.onEvent + runSettingsWithShutdown s (middleware e $ serve e) 5 `finally` do + mapM_ Async.cancel emailListener + Async.cancel internalEventListener + closeEnv e + where + rtree = compile (sitemap o) + endpoint = brig o + server e = defaultServer (unpack $ endpoint^.epHost) (endpoint^.epPort) (e^.applog) (e^.metrics) + middleware :: Env -> Wai.Middleware + middleware e = Metrics.waiPrometheusMiddleware (sitemap o) + . measureRequests (e^.metrics) (treeToPaths rtree) + . catchErrors (e^.applog) [Right $ e^.metrics] + . GZip.gunzip . GZip.gzip GZip.def + serve e r k = runHandler e r (Server.route rtree r k) k diff --git a/services/brig/src/Brig/Team/API.hs b/services/brig/src/Brig/Team/API.hs index 56c0240f38d..adb51db836c 100644 --- a/services/brig/src/Brig/Team/API.hs +++ b/services/brig/src/Brig/Team/API.hs @@ -19,7 +19,7 @@ import Data.ByteString.Conversion import Data.Id import Data.Range import Network.HTTP.Types.Status -import Network.Wai (Request, Response) +import Network.Wai (Response) import Network.Wai.Predicate hiding (setStatus, result, and) import Network.Wai.Routing hiding (head) import Network.Wai.Utilities hiding (message, code) @@ -44,7 +44,7 @@ routes = do accept "application" "json" .&. header "Z-User" .&. capture "tid" - .&. request + .&. jsonRequest @InvitationRequest document "POST" "sendTeamInvitation" $ do Doc.summary "Create and send a new team invitation." @@ -153,7 +153,7 @@ getInvitationCode (_ ::: t ::: r) = do where found c = json $ object [ "code" .= c ] -createInvitation :: JSON ::: UserId ::: TeamId ::: Request -> Handler Response +createInvitation :: JSON ::: UserId ::: TeamId ::: JsonRequest InvitationRequest -> Handler Response createInvitation (_ ::: uid ::: tid ::: req) = do body :: InvitationRequest <- parseJsonBody req idt <- maybe (throwStd noIdentity) return =<< lift (fetchUserIdentity uid) diff --git a/services/brig/src/Brig/Unique.hs b/services/brig/src/Brig/Unique.hs index 222d2ddb827..ed5670912e9 100644 --- a/services/brig/src/Brig/Unique.hs +++ b/services/brig/src/Brig/Unique.hs @@ -2,6 +2,7 @@ -- to contention, i.e. where strong guarantees on uniqueness are desired. module Brig.Unique ( withClaim + , deleteClaim , lookupClaims -- * Re-exports @@ -50,6 +51,21 @@ withClaim u v t io = do cql :: PrepQuery W (Int32, C.Set (Id a), Text) () cql = "UPDATE unique_claims USING TTL ? SET claims = claims + ? WHERE value = ?" +deleteClaim :: MonadClient m + => Id a -- ^ The 'Id' associated with the claim. + -> Text -- ^ The value on which to acquire the claim. + -> Timeout -- ^ The minimum timeout (i.e. duration) of the rest of the claim. (Each + -- claim can have more than one claimer (even though this is a feature we + -- never use), so removing a claim is an update operation on the database. + -- Therefore, we reset the TTL the same way we reset it in 'withClaim'.) + -> m () +deleteClaim u v t = do + let ttl = max minTtl (fromIntegral (t #> Second)) + retry x5 $ write cql $ params Quorum (ttl * 2, C.Set [u], v) + where + cql :: PrepQuery W (Int32, C.Set (Id a), Text) () + cql = "UPDATE unique_claims USING TTL ? SET claims = claims - ? WHERE value = ?" + -- | Lookup the current claims on a value. lookupClaims :: MonadClient m => Text -> m [Id a] lookupClaims v = fmap (maybe [] (fromSet . runIdentity)) $ diff --git a/services/brig/src/Brig/User/API/Auth.hs b/services/brig/src/Brig/User/API/Auth.hs index 1c39a20d937..338f742108b 100644 --- a/services/brig/src/Brig/User/API/Auth.hs +++ b/services/brig/src/Brig/User/API/Auth.hs @@ -4,18 +4,19 @@ import Imports import Brig.API.Error import Brig.API.Handler import Brig.Phone -import Brig.Types.Intra (reAuthPassword) +import Brig.Types.Intra (reAuthPassword, ReAuthUser) import Brig.Types.User.Auth import Data.ByteString.Conversion import Data.Id import Data.Predicate import Network.HTTP.Types.Status -import Network.Wai (Request, Response) +import Network.Wai (Response) import Network.Wai.Predicate import Network.Wai.Predicate.Request import Network.Wai.Routing import Network.Wai.Utilities.Error ((!>>)) import Network.Wai.Utilities.Response (json, empty) +import Network.Wai.Utilities.Request (jsonRequest, JsonRequest) import Network.Wai.Utilities.Swagger (document) import qualified Brig.API.User as User @@ -54,8 +55,7 @@ routes = do -- post "/login/send" (continue sendLoginCode) $ - contentType "application" "json" - .&. request + jsonRequest @SendLoginCode document "POST" "sendLoginCode" $ do Doc.summary "Send a login code to a verified phone number." @@ -73,10 +73,9 @@ routes = do -- post "/login" (continue login) $ - request + jsonRequest @Login .&. def False (query "persist") .&. accept "application" "json" - .&. contentType "application" "json" document "POST" "login" $ do Doc.summary "Authenticate a user to obtain a cookie and first access token." @@ -129,7 +128,8 @@ routes = do -- post "/cookies/remove" (continue rmCookies) $ - header "Z-User" .&. request .&. contentType "application" "json" + header "Z-User" + .&. jsonRequest @RemoveCookies document "POST" "rmCookies" $ do Doc.summary "Revoke stored cookies." @@ -139,24 +139,22 @@ routes = do -- Internal post "/i/sso-login" (continue ssoLogin) $ - request + jsonRequest @SsoLogin .&. def False (query "persist") .&. accept "application" "json" - .&. contentType "application" "json" get "/i/users/login-code" (continue getLoginCode) $ accept "application" "json" .&. param "phone" get "/i/users/:id/reauthenticate" (continue reAuthUser) $ - contentType "application" "json" - .&. capture "id" - .&. request + capture "id" + .&. jsonRequest @ReAuthUser -- Handlers -sendLoginCode :: JSON ::: Request -> Handler Response -sendLoginCode (_ ::: req) = do +sendLoginCode :: JsonRequest SendLoginCode -> Handler Response +sendLoginCode req = do SendLoginCode phone call force <- parseJsonBody req checkWhitelist (Right phone) c <- Auth.sendLoginCode phone call force !>> sendLoginCodeError @@ -167,20 +165,20 @@ getLoginCode (_ ::: phone) = do code <- lift $ Auth.lookupLoginCode phone maybe (throwStd loginCodeNotFound) (return . json) code -reAuthUser :: JSON ::: UserId ::: Request -> Handler Response -reAuthUser (_ ::: uid ::: req) = do +reAuthUser :: UserId ::: JsonRequest ReAuthUser -> Handler Response +reAuthUser (uid ::: req) = do body <- parseJsonBody req User.reauthenticate uid (reAuthPassword body) !>> reauthError return empty -login :: Request ::: Bool ::: JSON ::: JSON -> Handler Response +login :: JsonRequest Login ::: Bool ::: JSON -> Handler Response login (req ::: persist ::: _) = do l <- parseJsonBody req let typ = if persist then PersistentCookie else SessionCookie a <- Auth.login l typ !>> loginError tokenResponse a -ssoLogin :: Request ::: Bool ::: JSON ::: JSON -> Handler Response +ssoLogin :: JsonRequest SsoLogin ::: Bool ::: JSON -> Handler Response ssoLogin (req ::: persist ::: _) = do l <- parseJsonBody req let typ = if persist then PersistentCookie else SessionCookie @@ -200,8 +198,8 @@ listCookies (u ::: ll ::: _) = do cs <- lift $ Auth.listCookies u (maybe [] fromList ll) return . json $ CookieList cs -rmCookies :: UserId ::: Request ::: JSON -> Handler Response -rmCookies (uid ::: req ::: _) = do +rmCookies :: UserId ::: JsonRequest RemoveCookies -> Handler Response +rmCookies (uid ::: req) = do RemoveCookies pw lls ids <- parseJsonBody req Auth.revokeAccess uid pw ids lls !>> authError return empty diff --git a/services/brig/src/Brig/User/API/Search.hs b/services/brig/src/Brig/User/API/Search.hs index 420077b1ed6..359b4907b75 100644 --- a/services/brig/src/Brig/User/API/Search.hs +++ b/services/brig/src/Brig/User/API/Search.hs @@ -4,13 +4,15 @@ import Imports import Brig.API.Handler import Brig.User.Event import Brig.User.Search.Index +import Brig.Types.Search (SearchableStatus) import Data.Id import Data.Range import Data.Predicate import Network.HTTP.Types.Status -import Network.Wai (Request, Response) +import Network.Wai (Response) import Network.Wai.Predicate hiding (setStatus) import Network.Wai.Routing +import Network.Wai.Utilities.Request (jsonRequest, JsonRequest) import Network.Wai.Utilities.Response (json, empty, setStatus) import Network.Wai.Utilities.Swagger (document) @@ -51,9 +53,8 @@ routes = do -- put "/self/searchable" (continue setSearchable) $ - contentType "application" "json" - .&. header "Z-User" - .&. request + header "Z-User" + .&. jsonRequest @SearchableStatus document "PUT" "updateSearchableStatus" $ do Doc.summary "Opt in or out of being included in search results." @@ -82,8 +83,8 @@ search (_ ::: u ::: q ::: s) = json <$> lift (searchIndex u q s) isSearchable :: JSON ::: UserId -> Handler Response isSearchable (_ ::: u) = json <$> lift (checkIndex u) -setSearchable :: JSON ::: UserId ::: Request-> Handler Response -setSearchable (_ ::: u ::: r) = do +setSearchable :: UserId ::: JsonRequest SearchableStatus -> Handler Response +setSearchable (u ::: r) = do s <- parseJsonBody r lift $ DB.updateSearchableStatus u s lift $ Intra.onUserEvent u Nothing (searchableStatusUpdated u s) diff --git a/services/brig/src/Brig/User/Auth/Cookie.hs b/services/brig/src/Brig/User/Auth/Cookie.hs index 4d82e66f1c1..2f2d4f7dd5c 100644 --- a/services/brig/src/Brig/User/Auth/Cookie.hs +++ b/services/brig/src/Brig/User/Auth/Cookie.hs @@ -100,9 +100,8 @@ renewCookie :: Cookie ZAuth.UserToken -> AppIO (Cookie ZAuth.UserToken) renewCookie old = do let t = cookieValue old let u = ZAuth.userTokenOf t - new <- newCookie u (cookieType old) (cookieLabel old) -- Insert new cookie - DB.insertCookie u new Nothing + new <- newCookie u (cookieType old) (cookieLabel old) -- Link the old cookie to the new (successor), keeping it -- around only for another renewal period so as not to build -- an ever growing chain of superseded cookies. diff --git a/services/brig/src/Brig/User/Handle.hs b/services/brig/src/Brig/User/Handle.hs index 1decb16a01e..de07a1cf1dd 100644 --- a/services/brig/src/Brig/User/Handle.hs +++ b/services/brig/src/Brig/User/Handle.hs @@ -32,13 +32,16 @@ claimHandle u h = do -- Update profile User.updateHandle (userId u) h -- Free old handle (if it changed) - for_ (mfilter (/= h) (userHandle u)) - freeHandle + for_ (mfilter (/= h) (userHandle u)) $ + freeHandle u return (isJust claimed) -- | Free a 'Handle', making it available to be claimed again. -freeHandle :: Handle -> AppIO () -freeHandle h = retry x5 $ write handleDelete (params Quorum (Identity h)) +freeHandle :: User -> Handle -> AppIO () +freeHandle u h = do + retry x5 $ write handleDelete (params Quorum (Identity h)) + let key = "@" <> fromHandle h + deleteClaim (userId u) key (30 # Minute) -- | Lookup the current owner of a 'Handle'. lookupHandle :: Handle -> AppIO (Maybe UserId) diff --git a/services/brig/src/Brig/User/Phone.hs b/services/brig/src/Brig/User/Phone.hs index 748a7aa1e88..9fb019f9a79 100644 --- a/services/brig/src/Brig/User/Phone.hs +++ b/services/brig/src/Brig/User/Phone.hs @@ -27,9 +27,11 @@ import Imports import Brig.App import Brig.Phone import Brig.User.Template +import Brig.Template import Brig.Types.Activation import Brig.Types.User import Brig.Types.User.Auth (LoginCode (..)) +import Control.Lens (view) import Data.Range import Data.Text.Lazy (toStrict) @@ -40,33 +42,39 @@ import qualified Ropes.Nexmo as Nexmo sendActivationSms :: Phone -> ActivationPair -> Maybe Locale -> AppIO () sendActivationSms to (_, c) loc = do + branding <- view templateBranding (loc', tpl) <- userTemplates loc - sendSms loc' $ renderActivationSms (ActivationSms to c) (activationSms tpl) + sendSms loc' $ renderActivationSms (ActivationSms to c) (activationSms tpl) branding sendPasswordResetSms :: Phone -> PasswordResetPair -> Maybe Locale -> AppIO () sendPasswordResetSms to (_, c) loc = do + branding <- view templateBranding (loc', tpl) <- userTemplates loc - sendSms loc' $ renderPasswordResetSms (PasswordResetSms to c) (passwordResetSms tpl) + sendSms loc' $ renderPasswordResetSms (PasswordResetSms to c) (passwordResetSms tpl) branding sendLoginSms :: Phone -> LoginCode -> Maybe Locale -> AppIO () sendLoginSms to code loc = do + branding <- view templateBranding (loc', tpl) <- userTemplates loc - sendSms loc' $ renderLoginSms (LoginSms to code) (loginSms tpl) + sendSms loc' $ renderLoginSms (LoginSms to code) (loginSms tpl) branding sendDeletionSms :: Phone -> Code.Key -> Code.Value -> Locale -> AppIO () sendDeletionSms to key code loc = do + branding <- view templateBranding (loc', tpl) <- userTemplates (Just loc) - sendSms loc' $ renderDeletionSms (DeletionSms to key code) (deletionSms tpl) + sendSms loc' $ renderDeletionSms (DeletionSms to key code) (deletionSms tpl) branding sendActivationCall :: Phone -> ActivationPair -> Maybe Locale -> AppIO () sendActivationCall to (_, c) loc = do + branding <- view templateBranding (loc', tpl) <- userTemplates loc - sendCall $ renderActivationCall (ActivationCall to c) (activationCall tpl) loc' + sendCall $ renderActivationCall (ActivationCall to c) (activationCall tpl) loc' branding sendLoginCall :: Phone -> LoginCode -> Maybe Locale -> AppIO () sendLoginCall to c loc = do + branding <- view templateBranding (loc', tpl) <- userTemplates loc - sendCall $ renderLoginCall (LoginCall to c) (loginCall tpl) loc' + sendCall $ renderLoginCall (LoginCall to c) (loginCall tpl) loc' branding ------------------------------------------------------------------------------- -- Activation SMS @@ -76,9 +84,9 @@ data ActivationSms = ActivationSms , actSmsCode :: !ActivationCode } -renderActivationSms :: ActivationSms -> ActivationSmsTemplate -> SMSMessage -renderActivationSms ActivationSms{..} (ActivationSmsTemplate url t from) = - SMSMessage from (fromPhone actSmsTo) (toStrict $ renderText t replace) +renderActivationSms :: ActivationSms -> ActivationSmsTemplate -> TemplateBranding -> SMSMessage +renderActivationSms ActivationSms{..} (ActivationSmsTemplate url t from) branding = + SMSMessage from (fromPhone actSmsTo) (toStrict $ renderTextWithBranding t replace branding) where replace "code" = codeText replace "url" = renderSmsActivationUrl url codeText @@ -94,9 +102,9 @@ data PasswordResetSms = PasswordResetSms , pwrSmsCode :: !PasswordResetCode } -renderPasswordResetSms :: PasswordResetSms -> PasswordResetSmsTemplate -> SMSMessage -renderPasswordResetSms PasswordResetSms{..} (PasswordResetSmsTemplate t from) = - SMSMessage from (fromPhone pwrSmsTo) (toStrict $ renderText t replace) +renderPasswordResetSms :: PasswordResetSms -> PasswordResetSmsTemplate -> TemplateBranding -> SMSMessage +renderPasswordResetSms PasswordResetSms{..} (PasswordResetSmsTemplate t from) branding = + SMSMessage from (fromPhone pwrSmsTo) (toStrict $ renderTextWithBranding t replace branding) where replace "code" = Ascii.toText (fromPasswordResetCode pwrSmsCode) replace x = x @@ -109,9 +117,9 @@ data LoginSms = LoginSms , loginSmsCode :: !LoginCode } -renderLoginSms :: LoginSms -> LoginSmsTemplate -> SMSMessage -renderLoginSms LoginSms{..} (LoginSmsTemplate url t from) = - SMSMessage from (fromPhone loginSmsTo) (toStrict $ renderText t replace) +renderLoginSms :: LoginSms -> LoginSmsTemplate -> TemplateBranding -> SMSMessage +renderLoginSms LoginSms{..} (LoginSmsTemplate url t from) branding = + SMSMessage from (fromPhone loginSmsTo) (toStrict $ renderTextWithBranding t replace branding) where replace "code" = fromLoginCode loginSmsCode replace "url" = renderSmsActivationUrl url (fromLoginCode loginSmsCode) @@ -126,9 +134,9 @@ data DeletionSms = DeletionSms , delSmsCode :: !Code.Value } -renderDeletionSms :: DeletionSms -> DeletionSmsTemplate -> SMSMessage -renderDeletionSms DeletionSms{..} (DeletionSmsTemplate url txt from) = - SMSMessage from (fromPhone delSmsTo) (toStrict $ renderText txt replace1) +renderDeletionSms :: DeletionSms -> DeletionSmsTemplate -> TemplateBranding -> SMSMessage +renderDeletionSms DeletionSms{..} (DeletionSmsTemplate url txt from) branding = + SMSMessage from (fromPhone delSmsTo) (toStrict $ renderTextWithBranding txt replace1 branding) where replace1 "code" = Ascii.toText (fromRange (Code.asciiValue delSmsCode)) replace1 "url" = toStrict (renderText url replace2) @@ -146,11 +154,11 @@ data ActivationCall = ActivationCall , actCallCode :: !ActivationCode } -renderActivationCall :: ActivationCall -> ActivationCallTemplate -> Locale -> Nexmo.Call -renderActivationCall ActivationCall{..} (ActivationCallTemplate t) loc = +renderActivationCall :: ActivationCall -> ActivationCallTemplate -> Locale -> TemplateBranding -> Nexmo.Call +renderActivationCall ActivationCall{..} (ActivationCallTemplate t) loc branding = Nexmo.Call Nothing (fromPhone actCallTo) - (toStrict $ renderText t replace) + (toStrict $ renderTextWithBranding t replace branding) (Just . Text.toLower $ locToText loc) (Just 1) where @@ -165,11 +173,11 @@ data LoginCall = LoginCall , loginCallCode :: !LoginCode } -renderLoginCall :: LoginCall -> LoginCallTemplate -> Locale -> Nexmo.Call -renderLoginCall LoginCall{..} (LoginCallTemplate t) loc = +renderLoginCall :: LoginCall -> LoginCallTemplate -> Locale -> TemplateBranding -> Nexmo.Call +renderLoginCall LoginCall{..} (LoginCallTemplate t) loc branding = Nexmo.Call Nothing (fromPhone loginCallTo) - (toStrict $ renderText t replace) + (toStrict $ renderTextWithBranding t replace branding) (Just . Text.toLower $ locToText loc) (Just 1) where diff --git a/services/brig/src/Main.hs b/services/brig/src/Main.hs index 06b67e06837..240d13d7f80 100644 --- a/services/brig/src/Main.hs +++ b/services/brig/src/Main.hs @@ -1,7 +1,7 @@ module Main (main) where import Imports -import Brig.API +import Brig.Run (run) import OpenSSL (withOpenSSL) import Util.Options @@ -11,4 +11,4 @@ main = withOpenSSL $ do let desc = "Brig - User Service" defaultPath = "/etc/wire/brig/conf/brig.yaml" options <- getOptions desc Nothing defaultPath - runServer options + run options diff --git a/services/brig/test/integration/API/Metrics.hs b/services/brig/test/integration/API/Metrics.hs index ceed603298e..c281b5f32d5 100644 --- a/services/brig/test/integration/API/Metrics.hs +++ b/services/brig/test/integration/API/Metrics.hs @@ -9,6 +9,7 @@ module API.Metrics (tests) where import Imports import Bilge +import Bilge.Assert import Brig.Types.User import Control.Lens import Data.ByteString.Conversion @@ -24,11 +25,19 @@ import Util tests :: Manager -> Brig -> IO TestTree tests manager brig = do return $ testGroup "metrics" - [ testCase "work" . void $ runHttpT manager (testMetricsWaiRoute brig) + [ testCase "prometheus" . void $ runHttpT manager (testPrometheusMetrics brig) + , testCase "work" . void $ runHttpT manager (testMonitoringEndpoint brig) ] -testMetricsWaiRoute :: Brig -> Http () -testMetricsWaiRoute brig = do +testPrometheusMetrics :: Brig -> Http () +testPrometheusMetrics brig = do + get (brig . path "/i/metrics") !!! do + const 200 === statusCode + -- Should contain the request duration metric in its output + const (Just "TYPE http_request_duration_seconds histogram") =~= responseBody + +testMonitoringEndpoint :: Brig -> Http () +testMonitoringEndpoint brig = do let p1 = "/self" p2 uid = "/users/" <> uid <> "/clients" diff --git a/services/brig/test/integration/API/User/Account.hs b/services/brig/test/integration/API/User/Account.hs index 2421d8b6de5..38139052f1b 100644 --- a/services/brig/test/integration/API/User/Account.hs +++ b/services/brig/test/integration/API/User/Account.hs @@ -396,16 +396,17 @@ testCreateUserAnonExpiry :: Brig -> Http () testCreateUserAnonExpiry b = do u1 <- randomUser b alice <- randomUser b + now <- liftIO getCurrentTime bob <- createAnonUserExpiry (Just 2) "bob" b liftIO $ assertBool "expiry not set on regular creation" (not $ isJust $ userExpire alice) - ensureExpiry (fromUTCTimeMillis <$> userExpire bob) "bob/register" + ensureExpiry now (fromUTCTimeMillis <$> userExpire bob) "bob/register" resAlice <- getProfile (userId u1) (userId alice) resBob <- getProfile (userId u1) (userId bob) selfBob <- get (b . zUser (userId bob) . path "self") deleted selfBob)) liftIO $ assertBool "Regular user should not have any expiry" (null $ expire resAlice) - ensureExpiry (expire resBob) "bob/public" - ensureExpiry (expire selfBob) "bob/self" + ensureExpiry now (expire resBob) "bob/public" + ensureExpiry now (expire selfBob) "bob/self" awaitExpiry 5 (userId u1) (userId bob) resBob' <- getProfile (userId u1) (userId bob) liftIO $ assertBool "Bob must be in deleted state" (fromMaybe False $ deleted resBob') @@ -421,11 +422,10 @@ testCreateUserAnonExpiry b = do liftIO $ threadDelay 1000000 awaitExpiry (n-1) zusr uid - ensureExpiry :: Maybe UTCTime -> String -> Http () - ensureExpiry expiry s = case expiry of + ensureExpiry :: UTCTime -> Maybe UTCTime -> String -> Http () + ensureExpiry now expiry s = case expiry of Nothing -> liftIO $ assertFailure ("user must have an expiry" <> s) Just a -> do - now <- liftIO getCurrentTime let diff = diffUTCTime a now minExp = 1 :: Integer -- 1 second maxExp = 60 * 60 * 24 * 10 :: Integer -- 10 days diff --git a/services/brig/test/integration/API/User/Handles.hs b/services/brig/test/integration/API/User/Handles.hs index ba2e04ff208..c2074c8dcdd 100644 --- a/services/brig/test/integration/API/User/Handles.hs +++ b/services/brig/test/integration/API/User/Handles.hs @@ -85,15 +85,20 @@ testHandleUpdate brig cannon = do Search.assertCan'tFind brig uid2 uid hdl Search.assertCanFind brig uid2 uid hdl2 - -- Other users cannot immediately claim the old handle since the previous claim - -- is still active. + -- Other users can immediately claim the old handle (the claim of the old handle is + -- removed). put (brig . path "/self/handle" . contentJson . zUser uid2 . zConn "c" . body update) !!! do - const 409 === statusCode - const (Just "handle-exists") === fmap Error.label . decodeBody + const 200 === statusCode -- The old handle can be claimed again immediately by the user who previously -- owned it (since the claim is either still active but his own, or expired). - put (brig . path "/self/handle" . contentJson . zUser uid . zConn "c" . body update) !!! + -- make sure 'hdl' is not used by 'uid2' already. + hdl3 <- randomHandle + let update3 = RequestBodyLBS . encode $ HandleUpdate hdl3 + put (brig . path "/self/handle" . contentJson . zUser uid2 . zConn "c" . body update3) !!! do + const 200 === statusCode + -- now 'uid2' takes 'hld' back. + put (brig . path "/self/handle" . contentJson . zUser uid2 . zConn "c" . body update) !!! const 200 === statusCode testHandleRace :: Brig -> Http () diff --git a/services/brig/test/integration/Main.hs b/services/brig/test/integration/Main.hs index d72cd761e21..fe61a908183 100644 --- a/services/brig/test/integration/Main.hs +++ b/services/brig/test/integration/Main.hs @@ -2,7 +2,7 @@ module Main (main) where import Imports hiding (local) import Bilge hiding (header) -import Cassandra.Util +import Cassandra.Util (defInitCassandra) import Control.Lens import Data.Aeson import Data.ByteString.Conversion diff --git a/services/cannon/package.yaml b/services/cannon/package.yaml index 88d67653e5c..d4f503074f2 100644 --- a/services/cannon/package.yaml +++ b/services/cannon/package.yaml @@ -17,9 +17,10 @@ library: exposed-modules: - Cannon.API - Cannon.Dict + - Cannon.Options + - Cannon.Run - Cannon.Types - Cannon.WS - - Cannon.Options dependencies: - base >=4.6 && <5 - aeson >=0.11 @@ -40,6 +41,7 @@ library: - metrics-wai >=0.4 - mtl >=2.2 - mwc-random >=0.13 + - prometheus-client - retry >=0.7 - singletons >=2.0 - strict >=0.3.2 diff --git a/services/cannon/src/Cannon/API.hs b/services/cannon/src/Cannon/API.hs index fca9eae2523..15d007d8c22 100644 --- a/services/cannon/src/Cannon/API.hs +++ b/services/cannon/src/Cannon/API.hs @@ -1,20 +1,14 @@ -module Cannon.API (run) where +module Cannon.API (sitemap) where import Imports hiding (head) -import Bilge (newManager, defaultManagerSettings, ManagerSettings (..)) import Cannon.App import Cannon.Types -import Cannon.Options import Cannon.WS hiding (env) -import Control.Lens ((^.)) import Control.Monad.Catch import Data.Aeson (encode) import Data.Id (ClientId, UserId, ConnId) import Data.Metrics.Middleware -import Data.Metrics.WaiRoute (treeToPaths) import Data.Swagger.Build.Api hiding (def, Response) -import Data.Text (strip, pack) -import Data.Text.Encoding (encodeUtf8) import Network.HTTP.Types import Gundeck.Types import Gundeck.Types.BulkPush @@ -23,54 +17,15 @@ import Network.Wai.Predicate hiding (Error, (#)) import Network.Wai.Routing hiding (route, path) import Network.Wai.Utilities hiding (message) import Network.Wai.Utilities.Request (parseBody') -import Network.Wai.Utilities.Server import Network.Wai.Utilities.Swagger -import Network.Wai.Handler.Warp hiding (run) import Network.Wai.Handler.WebSockets import System.Logger (msg, val) -import System.Random.MWC (createSystemRandom) import qualified Cannon.Dict as D import qualified Data.ByteString.Lazy as L import qualified Data.Metrics.Middleware as Metrics -import qualified Network.Wai.Middleware.Gzip as Gzip import qualified Network.WebSockets as Ws -import qualified System.Logger as L -import qualified System.Logger.Extended as L import qualified System.Logger.Class as LC -import qualified System.IO.Strict as Strict - -run :: Opts -> IO () -run o = do - ext <- loadExternal - m <- metrics - g <- L.mkLogger (o ^. logLevel) (o ^. logNetStrings) - e <- mkEnv <$> pure m - <*> pure ext - <*> pure o - <*> pure g - <*> D.empty 128 - <*> newManager defaultManagerSettings { managerConnCount = 128 } - <*> createSystemRandom - <*> mkClock - s <- newSettings $ Server (o^.cannon.host) (o^.cannon.port) (applog e) m (Just idleTimeout) [] [] - let rtree = compile sitemap - measured = measureRequests m (treeToPaths rtree) - app r k = runCannon e (route rtree r k) r - start = measured . catchErrors g m $ Gzip.gzip Gzip.def app - runSettings s start `finally` L.close (applog e) - where - idleTimeout = fromIntegral $ maxPingInterval + 3 - - -- Each cannon instance advertises its own location (ip or dns name) to gundeck. - -- Either externalHost or externalHostFile must be set (externalHost takes precedence if both are defined) - loadExternal :: IO ByteString - loadExternal = do - let extFile = fromMaybe (error "One of externalHost or externalHostFile must be defined") (o^.cannon.externalHostFile) - fromMaybe (readExternal extFile) (return . encodeUtf8 <$> o^.cannon.externalHost) - - readExternal :: FilePath -> IO ByteString - readExternal f = encodeUtf8 . strip . pack <$> Strict.readFile f sitemap :: Routes ApiBuilder Cannon () @@ -100,7 +55,7 @@ sitemap = do post "/i/push/:user/:conn" (continue push) $ capture "user" .&. capture "conn" .&. request - post "/i/bulkpush" (continue bulkpush) + post "/i/bulkpush" (continue bulkpush) $ request head "/i/presences/:user/:conn" (continue checkPresence) $ @@ -117,7 +72,7 @@ monitoring :: Media "application" "json" -> Cannon Response monitoring = const $ do m <- monitor s <- D.size =<< clients - gaugeSet s (path "net.websocket.clients") m + gaugeSet (fromIntegral s) (path "net.websocket.clients") m json <$> Metrics.render m docs :: Media "application" "json" ::: Text -> Cannon Response @@ -134,7 +89,7 @@ push (user ::: conn ::: req) = -- | Parse the entire list of notifcations and targets, then call 'singlePush' on the each of them -- in order. bulkpush :: Request -> Cannon Response -bulkpush req = json <$> (parseBody' req >>= bulkpush') +bulkpush req = json <$> (parseBody' (JsonRequest req) >>= bulkpush') -- | The typed part of 'bulkpush'. bulkpush' :: BulkPushRequest -> Cannon BulkPushResponse diff --git a/services/cannon/src/Cannon/Run.hs b/services/cannon/src/Cannon/Run.hs new file mode 100644 index 00000000000..715a9af36d3 --- /dev/null +++ b/services/cannon/src/Cannon/Run.hs @@ -0,0 +1,62 @@ +module Cannon.Run (run) where + +import Imports hiding (head) +import Bilge (newManager, defaultManagerSettings, ManagerSettings (..)) +import Cannon.App (maxPingInterval) +import Cannon.API (sitemap) +import Cannon.Types (mkEnv, applog, runCannon) +import Cannon.Options +import Cannon.WS hiding (env) +import Control.Lens ((^.)) +import Control.Monad.Catch (finally) +import Data.Metrics.Middleware.Prometheus (waiPrometheusMiddleware) +import Data.Metrics.WaiRoute (treeToPaths) +import Data.Text (strip, pack) +import Data.Text.Encoding (encodeUtf8) +import Network.Wai.Utilities.Server +import Network.Wai.Handler.Warp hiding (run) +import System.Random.MWC (createSystemRandom) + +import qualified Cannon.Dict as D +import qualified Data.Metrics.Middleware as Middleware +import qualified Network.Wai as Wai +import qualified Network.Wai.Middleware.Gzip as Gzip +import qualified System.IO.Strict as Strict +import qualified System.Logger.Extended as L + +run :: Opts -> IO () +run o = do + ext <- loadExternal + m <- Middleware.metrics + g <- L.mkLogger (o ^. logLevel) (o ^. logNetStrings) + e <- mkEnv <$> pure m + <*> pure ext + <*> pure o + <*> pure g + <*> D.empty 128 + <*> newManager defaultManagerSettings { managerConnCount = 128 } + <*> createSystemRandom + <*> mkClock + s <- newSettings $ Server (o^.cannon.host) (o^.cannon.port) (applog e) m (Just idleTimeout) + let rtree = compile sitemap + measured = measureRequests m (treeToPaths rtree) + app r k = runCannon e (route rtree r k) r + middleware :: Wai.Middleware + middleware = waiPrometheusMiddleware sitemap + . measured + . catchErrors g [Right m] + . Gzip.gzip Gzip.def + start = middleware app + runSettings s start `finally` L.close (applog e) + where + idleTimeout = fromIntegral $ maxPingInterval + 3 + + -- Each cannon instance advertises its own location (ip or dns name) to gundeck. + -- Either externalHost or externalHostFile must be set (externalHost takes precedence if both are defined) + loadExternal :: IO ByteString + loadExternal = do + let extFile = fromMaybe (error "One of externalHost or externalHostFile must be defined") (o^.cannon.externalHostFile) + fromMaybe (readExternal extFile) (return . encodeUtf8 <$> o^.cannon.externalHost) + + readExternal :: FilePath -> IO ByteString + readExternal f = encodeUtf8 . strip . pack <$> Strict.readFile f diff --git a/services/cannon/src/Main.hs b/services/cannon/src/Main.hs index ed4700ce9a6..41841a91fcb 100644 --- a/services/cannon/src/Main.hs +++ b/services/cannon/src/Main.hs @@ -1,7 +1,7 @@ module Main (main) where import Imports -import Cannon.API +import Cannon.Run (run) import Util.Options main :: IO () diff --git a/services/cargohold/package.yaml b/services/cargohold/package.yaml index 001b28112ab..87d09820d60 100644 --- a/services/cargohold/package.yaml +++ b/services/cargohold/package.yaml @@ -26,6 +26,7 @@ dependencies: - http-types >=0.8 - mime >=0.4 - mtl >=2.1 +- prometheus-client - safe >=0.3 - text >=1.1 - transformers >=0.3 @@ -36,6 +37,7 @@ library: exposed-modules: - CargoHold.API - CargoHold.Options + - CargoHold.Run dependencies: - base >=4 && <5 - attoparsec >=0.12 diff --git a/services/cargohold/src/CargoHold/API.hs b/services/cargohold/src/CargoHold/API.hs index b17a5089405..a152c47a7a6 100644 --- a/services/cargohold/src/CargoHold/API.hs +++ b/services/cargohold/src/CargoHold/API.hs @@ -1,18 +1,15 @@ -module CargoHold.API (runServer) where +module CargoHold.API (sitemap) where import Imports hiding (head) import CargoHold.App import CargoHold.Options import Control.Error import Control.Lens (view, (^.)) -import Control.Monad.Catch (finally) import Data.Aeson (encode) import Data.ByteString.Conversion import Data.Id import Data.Metrics.Middleware hiding (metrics) -import Data.Metrics.WaiRoute (treeToPaths) import Data.Predicate -import Data.Text (unpack) import Data.Text.Encoding (decodeLatin1) import Network.HTTP.Types.Status import Network.Wai (Response, Request, responseLBS) @@ -20,11 +17,9 @@ import Network.Wai.Conduit (sourceRequestBody) import Network.Wai.Predicate hiding (Error, setStatus) import Network.Wai.Routing import Network.Wai.Utilities hiding (message) -import Network.Wai.Utilities.Server import Network.Wai.Utilities.Swagger (document, mkSwaggerApi) import Network.Wai.Utilities.ZAuth import URI.ByteString -import Util.Options import qualified CargoHold.API.V3 as V3 import qualified CargoHold.API.V3.Resumable as Resumable @@ -34,25 +29,8 @@ import qualified CargoHold.TUS as TUS import qualified CargoHold.Types.V3 as V3 import qualified CargoHold.Types.V3.Resumable as V3 import qualified Data.Swagger.Build.Api as Doc -import qualified Network.Wai.Middleware.Gzip as GZip -import qualified Network.Wai.Utilities.Server as Server import qualified Network.Wai.Utilities.Swagger as Doc -runServer :: Opts -> IO () -runServer o = do - e <- newEnv o - s <- Server.newSettings (server e) - runSettingsWithShutdown s (pipeline e) 5 - `finally` closeEnv e - where - rtree = compile sitemap - server e = defaultServer (unpack $ o^.optCargohold.epHost) (o^.optCargohold.epPort) (e^.appLogger) (e^.metrics) - pipeline e = measureRequests (e^.metrics) (treeToPaths rtree) - . catchErrors (e^.appLogger) (e^.metrics) - . GZip.gzip GZip.def - $ serve e - - serve e r k = runHandler e r (Server.route rtree r k) k sitemap :: Routes Doc.ApiBuilder Handler () sitemap = do @@ -97,8 +75,7 @@ sitemap = do post "/assets/v3/resumable" (continue createResumableV3) $ header "Z-User" .&. header "Upload-Length" - .&. contentType "application" "json" - .&. request + .&. jsonRequest @V3.ResumableSettings -- TODO (Compliance): Require and check Tus-Resumable header -- against supported version(s). @@ -260,8 +237,8 @@ resumableOptionsV3 _ = do maxTotal <- view (settings.setMaxTotalBytes) return $ TUS.optionsResponse (fromIntegral maxTotal) empty -createResumableV3 :: UserId ::: V3.TotalSize ::: Media "application" "json" ::: Request -> Handler Response -createResumableV3 (u ::: size ::: _ ::: req) = do +createResumableV3 :: UserId ::: V3.TotalSize ::: JsonRequest V3.ResumableSettings -> Handler Response +createResumableV3 (u ::: size ::: req) = do sets <- parseBody req !>> Error.clientError res <- Resumable.create (V3.UserPrincipal u) sets size let key = res^.V3.resumableAsset.V3.assetKey @@ -269,13 +246,14 @@ createResumableV3 (u ::: size ::: _ ::: req) = do let loc = "/assets/v3/resumable/" <> toByteString' key return . TUS.createdResponse loc expiry $ json res -statusResumableV3 :: UserId ::: V3.AssetKey -> Handler Response +statusResumableV3 :: UserId ::: V3.AssetKey -> Handler Response statusResumableV3 (u ::: a) = do stat <- Resumable.status (V3.UserPrincipal u) a return $ case stat of Nothing -> setStatus status404 empty Just st -> TUS.headResponse st empty +-- Request = raw bytestring uploadResumableV3 :: UserId ::: V3.Offset ::: Word ::: Media "application" "offset+octet-stream" ::: V3.AssetKey ::: Request -> Handler Response uploadResumableV3 (usr ::: offset ::: size ::: _ ::: aid ::: req) = do (offset', expiry) <- Resumable.upload (V3.UserPrincipal usr) aid offset size (sourceRequestBody req) @@ -316,7 +294,10 @@ botDeleteV3 (bot ::: key) = do -------------------------------------------------------------------------------- -- Helpers -uploadSimpleV3 :: V3.Principal -> Request -> Handler Response +uploadSimpleV3 + :: V3.Principal + -> Request -- Raw bytestring + -> Handler Response uploadSimpleV3 prc req = do let src = sourceRequestBody req asset <- V3.upload prc src diff --git a/services/cargohold/src/CargoHold/App.hs b/services/cargohold/src/CargoHold/App.hs index 82e730d73d1..959f80902be 100644 --- a/services/cargohold/src/CargoHold/App.hs +++ b/services/cargohold/src/CargoHold/App.hs @@ -55,7 +55,6 @@ import qualified Network.Wai.Utilities.Server as Server import qualified OpenSSL.Session as SSL import qualified OpenSSL.X509.SystemStore as SSL import qualified Ropes.Aws as Aws -import qualified System.Logger as Log import qualified System.Logger.Extended as Log ------------------------------------------------------------------------------- @@ -191,4 +190,4 @@ type Handler = ExceptT Error App runHandler :: Env -> Request -> Handler ResponseReceived -> Continue IO -> IO ResponseReceived runHandler e r h k = let e' = set requestId (maybe def RequestId (lookupRequestId r)) e - in runAppT e' (exceptT (Server.onError (_appLogger e) (_metrics e) r k) return h) + in runAppT e' (exceptT (Server.onError (_appLogger e) [Right $ _metrics e] r k) return h) diff --git a/services/cargohold/src/CargoHold/Run.hs b/services/cargohold/src/CargoHold/Run.hs new file mode 100644 index 00000000000..c2d1924b867 --- /dev/null +++ b/services/cargohold/src/CargoHold/Run.hs @@ -0,0 +1,34 @@ +module CargoHold.Run (run) where + +import Imports +import Control.Lens ((^.)) +import Control.Monad.Catch (finally) +import Data.Metrics.WaiRoute (treeToPaths) +import Data.Metrics.Middleware.Prometheus (waiPrometheusMiddleware) +import Data.Text (unpack) +import Util.Options +import qualified Network.Wai as Wai +import qualified Network.Wai.Middleware.Gzip as GZip +import qualified Network.Wai.Utilities.Server as Server +import Network.Wai.Utilities.Server + +import CargoHold.Options +import CargoHold.App +import CargoHold.API (sitemap) + +run :: Opts -> IO () +run o = do + e <- newEnv o + s <- Server.newSettings (server e) + runSettingsWithShutdown s (middleware e $ serve e) 5 + `finally` closeEnv e + where + rtree = compile sitemap + server e = defaultServer (unpack $ o^.optCargohold.epHost) (o^.optCargohold.epPort) (e^.appLogger) (e^.metrics) + middleware :: Env -> Wai.Middleware + middleware e = waiPrometheusMiddleware sitemap + . measureRequests (e^.metrics) (treeToPaths rtree) + . catchErrors (e^.appLogger) [Right $ e^.metrics] + . GZip.gzip GZip.def + + serve e r k = runHandler e r (Server.route rtree r k) k diff --git a/services/cargohold/src/Main.hs b/services/cargohold/src/Main.hs index bcdf074f2fc..7d8acf6abb5 100644 --- a/services/cargohold/src/Main.hs +++ b/services/cargohold/src/Main.hs @@ -1,7 +1,7 @@ module Main (main) where import Imports -import CargoHold.API +import CargoHold.Run (run) import OpenSSL (withOpenSSL) import Util.Options @@ -9,7 +9,7 @@ import Util.Options main :: IO () main = withOpenSSL $ do options <- getOptions desc Nothing defaultPath - runServer options + run options where desc = "Cargohold - Asset Storage" defaultPath = "/etc/wire/cargohold/conf/cargohold.yaml" diff --git a/services/cargohold/test/integration/API/V3.hs b/services/cargohold/test/integration/API/V3.hs index 577b8bcc7a0..86adf630d17 100644 --- a/services/cargohold/test/integration/API/V3.hs +++ b/services/cargohold/test/integration/API/V3.hs @@ -1,6 +1,7 @@ module API.V3 where import Imports hiding (head) +import TestSetup import Bilge hiding (body) import Bilge.Assert import Control.Lens hiding (sets) @@ -28,24 +29,8 @@ import qualified Data.ByteString.Lazy as Lazy import qualified Data.ByteString.Char8 as C8 import qualified Data.UUID as UUID -type CargoHold = Request -> Request - -data TestSetup = TestSetup - { manager :: Manager - , cargohold :: CargoHold - } - -type TestSignature a = CargoHold -> Http a - -test :: IO TestSetup -> TestName -> (TestSignature a) -> TestTree -test s n h = testCase n runTest - where - runTest = do - setup <- s - (void $ runHttpT (manager setup) (h (cargohold setup))) - tests :: IO TestSetup -> TestTree -tests s = testGroup "v3" +tests s = testGroup "API Integration v3" [ testGroup "simple" [ test s "roundtrip" testSimpleRoundtrip , test s "tokens" testSimpleTokens diff --git a/services/cargohold/test/integration/Main.hs b/services/cargohold/test/integration/Main.hs index 109591da856..b1a2da62797 100644 --- a/services/cargohold/test/integration/Main.hs +++ b/services/cargohold/test/integration/Main.hs @@ -16,7 +16,9 @@ import Util.Test import Test.Tasty import Test.Tasty.Options +import TestSetup import qualified API.V3 +import qualified Metrics data IntegrationConfig = IntegrationConfig -- internal endpoint @@ -56,7 +58,9 @@ main :: IO () main = withOpenSSL $ runTests go where go c i = withResource (getOpts c i) releaseOpts $ \opts -> - testGroup "Cargohold API Integration" [API.V3.tests opts] + testGroup "Cargohold" [ API.V3.tests opts + , Metrics.tests opts + ] getOpts _ i = do -- TODO: It would actually be useful to read some @@ -69,7 +73,7 @@ main = withOpenSSL $ runTests go let local p = Endpoint { _epHost = "127.0.0.1", _epPort = p } iConf <- handleParseError =<< decodeFileEither i cargo <- mkRequest <$> optOrEnv cargohold iConf (local . read) "CARGOHOLD_WEB_PORT" - return $ API.V3.TestSetup m cargo + return $ TestSetup m cargo mkRequest (Endpoint h p) = host (encodeUtf8 h) . port p diff --git a/services/cargohold/test/integration/Metrics.hs b/services/cargohold/test/integration/Metrics.hs new file mode 100644 index 00000000000..956a0cd03be --- /dev/null +++ b/services/cargohold/test/integration/Metrics.hs @@ -0,0 +1,19 @@ +module Metrics (tests) where + +import Imports +import Bilge +import Bilge.Assert +import TestSetup +import Test.Tasty + +tests :: IO TestSetup -> TestTree +tests s = testGroup "Metrics" [test s "prometheus" testPrometheusMetrics] + +testPrometheusMetrics :: TestSignature () +testPrometheusMetrics cargohold = + get (cargohold . path "/i/metrics") !!! do + const 200 === statusCode + -- Should contain the request duration metric in its output + const (Just "TYPE http_request_duration_seconds histogram") =~= responseBody + + diff --git a/services/cargohold/test/integration/TestSetup.hs b/services/cargohold/test/integration/TestSetup.hs new file mode 100644 index 00000000000..dfee5835085 --- /dev/null +++ b/services/cargohold/test/integration/TestSetup.hs @@ -0,0 +1,31 @@ +module TestSetup + ( test + , tsManager + , tsCargohold + , TestSignature + , TestSetup(..) + , CargoHold + ) where + +import Imports +import Bilge (Request) +import Bilge.IO (Http, Manager, runHttpT) +import Control.Lens ((^.), makeLenses) +import Test.Tasty +import Test.Tasty.HUnit + +type CargoHold = Request -> Request +type TestSignature a = CargoHold -> Http a + +data TestSetup = TestSetup + { _tsManager :: Manager + , _tsCargohold :: CargoHold + } +makeLenses ''TestSetup + +test :: IO TestSetup -> TestName -> TestSignature a -> TestTree +test s n h = testCase n runTest + where + runTest = do + setup <- s + (void $ runHttpT (setup ^. tsManager) (h (setup ^. tsCargohold))) diff --git a/services/galley/package.yaml b/services/galley/package.yaml index 57c36024406..985f92c292c 100644 --- a/services/galley/package.yaml +++ b/services/galley/package.yaml @@ -60,6 +60,7 @@ library: - mtl >=2.2 - ssl-util >=0.1 - optparse-applicative >=0.10 + - prometheus-client - protobuf >=0.2 - proto-lens >=0.2 - retry >=0.5 diff --git a/services/galley/schema/src/Main.hs b/services/galley/schema/src/Main.hs index ce77b172991..ca790716dd9 100644 --- a/services/galley/schema/src/Main.hs +++ b/services/galley/schema/src/Main.hs @@ -5,7 +5,6 @@ import Cassandra.Schema import Control.Exception (finally) import Options.Applicative -import qualified System.Logger as Log import qualified System.Logger.Extended as Log import qualified V20 diff --git a/services/galley/src/Galley/API.hs b/services/galley/src/Galley/API.hs index 42339b22348..536f0dd04a6 100644 --- a/services/galley/src/Galley/API.hs +++ b/services/galley/src/Galley/API.hs @@ -15,8 +15,11 @@ import Galley.API.Create import Galley.API.Update import Galley.API.Teams import Galley.API.Query -import Galley.Types (OtrFilterMissing (..)) -import Galley.Types.Teams (Perm (..)) +import Galley.Types +import Galley.Types.Teams +import Galley.Types.Teams.Intra +import Galley.Types.Bot.Service +import Galley.Types.Bot (AddBot, RemoveBot) import Network.HTTP.Types import Network.Wai import Network.Wai.Predicate @@ -40,9 +43,8 @@ sitemap = do post "/teams" (continue createNonBindingTeam) $ zauthUserId .&. zauthConnId - .&. request + .&. jsonRequest @NonBindingNewTeam .&. accept "application" "json" - .&. contentType "application" "json" document "POST" "createNonBindingTeam" $ do summary "Create a new non binding team" @@ -55,9 +57,8 @@ sitemap = do zauthUserId .&. zauthConnId .&. capture "id" - .&. request + .&. jsonRequest @TeamUpdateData .&. accept "application" "json" - .&. contentType "application" "json" document "PUT" "updateTeam" $ do summary "Update team properties" @@ -160,8 +161,7 @@ sitemap = do zauthUserId .&. zauthConnId .&. capture "id" - .&. request - .&. contentType "application" "json" + .&. jsonRequest @NewTeamMember .&. accept "application" "json" document "POST" "addTeamMember" $ do @@ -206,9 +206,8 @@ sitemap = do zauthUserId .&. zauthConnId .&. capture "id" - .&. request + .&. jsonRequest @NewTeamMember .&. accept "application" "json" - .&. contentType "application" "json" document "PUT" "updateTeamMember" $ do summary "Update an existing team member" @@ -287,8 +286,7 @@ sitemap = do .&> zauthBotId .&. zauthConvId .&. def OtrReportAllMissing filterMissing - .&. request - .&. contentType "application" "json" + .&. jsonRequest @NewOtrMessage .&. accept "application" "json" -- @@ -352,8 +350,7 @@ sitemap = do post "/conversations" (continue createGroupConversation) $ zauthUserId .&. zauthConnId - .&. request - .&. contentType "application" "json" + .&. jsonRequest @NewConvUnmanaged document "POST" "createGroupConversation" $ do summary "Create a new conversation" @@ -380,8 +377,7 @@ sitemap = do post "/conversations/one2one" (continue createOne2OneConversation) $ zauthUserId .&. zauthConnId - .&. request - .&. contentType "application" "json" + .&. jsonRequest @NewConvUnmanaged document "POST" "createOne2OneConversation" $ do summary "Create a 1:1-conversation" @@ -397,8 +393,7 @@ sitemap = do zauthUserId .&. zauthConnId .&. capture "cnv" - .&. request - .&. contentType "application" "json" + .&. jsonRequest @ConversationRename document "PUT" "updateConversation" $ do summary "Update conversation properties" @@ -428,8 +423,7 @@ sitemap = do --- post "/conversations/code-check" (continue checkReusableCode) $ - request - .&. contentType "application" "json" + jsonRequest @ConversationCode document "POST" "checkConversationCode" $ do summary "Check validity of a conversation code" @@ -442,8 +436,7 @@ sitemap = do post "/conversations/join" (continue joinConversationByReusableCode) $ zauthUserId .&. zauthConnId - .&. request - .&. contentType "application" "json" + .&. jsonRequest @ConversationCode document "POST" "joinConversationByCode" $ do summary "Join a conversation using a reusable code" @@ -510,8 +503,7 @@ sitemap = do zauthUserId .&. zauthConnId .&. capture "cnv" - .&. request - .&. contentType "application" "json" + .&. jsonRequest @ConversationAccessUpdate document "PUT" "updateConversationAccess" $ do summary "Update access modes for a conversation" @@ -535,8 +527,7 @@ sitemap = do zauthUserId .&. zauthConnId .&. capture "cnv" - .&. request - .&. contentType "application" "json" + .&. jsonRequest @ConversationReceiptModeUpdate .&. accept "application" "json" document "PUT" "updateConversationReceiptMode" $ do @@ -557,8 +548,7 @@ sitemap = do zauthUserId .&. zauthConnId .&. capture "cnv" - .&. request - .&. contentType "application" "json" + .&. jsonRequest @ConversationMessageTimerUpdate document "PUT" "updateConversationMessageTimer" $ do summary "Update the message timer for a conversation" @@ -581,8 +571,7 @@ sitemap = do zauthUserId .&. zauthConnId .&. capture "cnv" - .&. request - .&. contentType "application" "json" + .&. jsonRequest @Invite document "POST" "addMembers" $ do summary "Add users to an existing conversation" @@ -617,8 +606,7 @@ sitemap = do zauthUserId .&. zauthConnId .&. capture "cnv" - .&. request - .&. contentType "application" "json" + .&. jsonRequest @MemberUpdate document "PUT" "updateSelf" $ do summary "Update self membership properties" @@ -635,8 +623,7 @@ sitemap = do zauthUserId .&. zauthConnId .&. capture "cnv" - .&. request - .&. contentType "application" "json" + .&. jsonRequest @TypingData document "POST" "isTyping" $ do summary "Sending typing notifications" @@ -672,8 +659,7 @@ sitemap = do zauthUserId .&. zauthConnId .&. def OtrReportAllMissing filterMissing - .&. request - .&. contentType "application" "json" + .&. jsonRequest @NewOtrMessage document "POST" "postOtrBroadcast" $ do summary "Broadcast an encrypted message to all team members and all contacts (accepts JSON)" @@ -727,8 +713,7 @@ sitemap = do .&. zauthConnId .&. capture "cnv" .&. def OtrReportAllMissing filterMissing - .&. request - .&. contentType "application" "json" + .&. jsonRequest @NewOtrMessage document "POST" "postOtrMessage" $ do summary "Post an encrypted message to a conversation (accepts JSON)" @@ -806,14 +791,12 @@ sitemap = do post "/i/conversations/managed" (continue internalCreateManagedConversation) $ zauthUserId .&. zauthConnId - .&. request - .&. contentType "application" "json" + .&. jsonRequest @NewConvManaged post "/i/conversations/connect" (continue createConnectConversation) $ zauthUserId .&. opt zauthConnId - .&. request - .&. contentType "application" "json" + .&. jsonRequest @Connect put "/i/conversations/:cnv/accept/v2" (continue acceptConv) $ zauthUserId @@ -843,20 +826,17 @@ sitemap = do put "/i/teams/:tid" (continue createBindingTeam) $ zauthUserId .&. capture "tid" - .&. request - .&. contentType "application" "json" + .&. jsonRequest @BindingNewTeam .&. accept "application" "json" put "/i/teams/:tid/status" (continue updateTeamStatus) $ capture "tid" - .&. request - .&. contentType "application" "json" + .&. jsonRequest @TeamStatusUpdate .&. accept "application" "json" post "/i/teams/:tid/members" (continue uncheckedAddTeamMember) $ capture "tid" - .&. request - .&. contentType "application" "json" + .&. jsonRequest @NewTeamMember .&. accept "application" "json" get "/i/teams/:tid/members" (continue uncheckedGetTeamMembers) $ @@ -889,24 +869,20 @@ sitemap = do zauthUserId .&. opt zauthConnId post "/i/services" (continue addService) $ - request - .&. contentType "application" "json" + jsonRequest @Service delete "/i/services" (continue rmService) $ - request - .&. contentType "application" "json" + jsonRequest @ServiceRef post "/i/bots" (continue addBot) $ zauthUserId .&. zauthConnId - .&. request - .&. contentType "application" "json" + .&. jsonRequest @AddBot delete "/i/bots" (continue rmBot) $ zauthUserId .&. opt zauthConnId - .&. request - .&. contentType "application" "json" + .&. jsonRequest @RemoveBot type JSON = Media "application" "json" diff --git a/services/galley/src/Galley/API/Create.hs b/services/galley/src/Galley/API/Create.hs index 918b60950fc..cae775fe4a6 100644 --- a/services/galley/src/Galley/API/Create.hs +++ b/services/galley/src/Galley/API/Create.hs @@ -38,9 +38,9 @@ import qualified Galley.Types.Teams as Teams -- | The public-facing endpoint for creating group conversations. -- -- See Note [managed conversations]. -createGroupConversation :: UserId ::: ConnId ::: Request ::: JSON -> Galley Response -createGroupConversation (zusr ::: zcon ::: req ::: _) = do - wrapped@(NewConvUnmanaged body) <- fromBody req invalidPayload +createGroupConversation :: UserId ::: ConnId ::: JsonRequest NewConvUnmanaged -> Galley Response +createGroupConversation (zusr ::: zcon ::: req) = do + wrapped@(NewConvUnmanaged body) <- fromJsonBody req case newConvTeam body of Nothing -> createRegularGroupConv zusr zcon wrapped Just tinfo -> createTeamGroupConv zusr zcon tinfo body @@ -48,9 +48,9 @@ createGroupConversation (zusr ::: zcon ::: req ::: _) = do -- | An internal endpoint for creating managed group conversations. Will -- throw an error for everything else. internalCreateManagedConversation - :: UserId ::: ConnId ::: Request ::: JSON -> Galley Response -internalCreateManagedConversation (zusr ::: zcon ::: req ::: _) = do - NewConvManaged body <- fromBody req invalidPayload + :: UserId ::: ConnId ::: JsonRequest NewConvManaged -> Galley Response +internalCreateManagedConversation (zusr ::: zcon ::: req) = do + NewConvManaged body <- fromJsonBody req case newConvTeam body of Nothing -> throwM internalError Just tinfo -> createTeamGroupConv zusr zcon tinfo body @@ -109,9 +109,9 @@ createSelfConversation zusr = do c <- Data.createSelfConversation zusr Nothing conversationResponse status201 zusr c -createOne2OneConversation :: UserId ::: ConnId ::: Request ::: JSON -> Galley Response -createOne2OneConversation (zusr ::: zcon ::: req ::: _) = do - NewConvUnmanaged j <- fromBody req invalidPayload +createOne2OneConversation :: UserId ::: ConnId ::: JsonRequest NewConvUnmanaged -> Galley Response +createOne2OneConversation (zusr ::: zcon ::: req) = do + NewConvUnmanaged j <- fromJsonBody req other <- head . fromRange <$> (rangeChecked (newConvUsers j) :: Galley (Range 1 1 [UserId])) (x, y) <- toUUIDs zusr other when (x == y) $ @@ -135,9 +135,9 @@ createOne2OneConversation (zusr ::: zcon ::: req ::: _) = do notifyCreatedConversation Nothing zusr (Just zcon) c conversationResponse status201 zusr c -createConnectConversation :: UserId ::: Maybe ConnId ::: Request ::: JSON -> Galley Response -createConnectConversation (usr ::: conn ::: req ::: _) = do - j <- fromBody req invalidPayload +createConnectConversation :: UserId ::: Maybe ConnId ::: JsonRequest Connect -> Galley Response +createConnectConversation (usr ::: conn ::: req) = do + j <- fromJsonBody req (x, y) <- toUUIDs usr (cRecipient j) n <- rangeCheckedMaybe (cName j) conv <- Data.conversation (Data.one2OneConvId x y) diff --git a/services/galley/src/Galley/API/Teams.hs b/services/galley/src/Galley/API/Teams.hs index 338c9922ac3..9f01f9838bf 100644 --- a/services/galley/src/Galley/API/Teams.hs +++ b/services/galley/src/Galley/API/Teams.hs @@ -91,9 +91,9 @@ lookupTeam zusr tid = do else pure Nothing -createNonBindingTeam :: UserId ::: ConnId ::: Request ::: JSON ::: JSON -> Galley Response +createNonBindingTeam :: UserId ::: ConnId ::: JsonRequest NonBindingNewTeam ::: JSON -> Galley Response createNonBindingTeam (zusr::: zcon ::: req ::: _) = do - NonBindingNewTeam body <- fromBody req invalidPayload + NonBindingNewTeam body <- fromJsonBody req let owner = newTeamMember zusr fullPermissions Nothing let others = filter ((zusr /=) . view userId) . maybe [] fromRange @@ -104,16 +104,16 @@ createNonBindingTeam (zusr::: zcon ::: req ::: _) = do team <- Data.createTeam Nothing zusr (body^.newTeamName) (body^.newTeamIcon) (body^.newTeamIconKey) NonBinding finishCreateTeam team owner others (Just zcon) -createBindingTeam :: UserId ::: TeamId ::: Request ::: JSON ::: JSON -> Galley Response +createBindingTeam :: UserId ::: TeamId ::: JsonRequest BindingNewTeam ::: JSON -> Galley Response createBindingTeam (zusr ::: tid ::: req ::: _) = do - BindingNewTeam body <- fromBody req invalidPayload + BindingNewTeam body <- fromJsonBody req let owner = newTeamMember zusr fullPermissions Nothing team <- Data.createTeam (Just tid) zusr (body^.newTeamName) (body^.newTeamIcon) (body^.newTeamIconKey) Binding finishCreateTeam team owner [] Nothing -updateTeamStatus :: TeamId ::: Request ::: JSON ::: JSON -> Galley Response +updateTeamStatus :: TeamId ::: JsonRequest TeamStatusUpdate ::: JSON -> Galley Response updateTeamStatus (tid ::: req ::: _) = do - TeamStatusUpdate to cur <- fromBody req invalidPayload + TeamStatusUpdate to cur <- fromJsonBody req from <- tdStatus <$> (Data.team tid >>= ifNothing teamNotFound) valid <- validateTransition from to when valid $ do @@ -134,9 +134,9 @@ updateTeamStatus (tid ::: req ::: _) = do ( Suspended , Suspended ) -> return False ( _ , _ ) -> throwM invalidTeamStatusUpdate -updateTeam :: UserId ::: ConnId ::: TeamId ::: Request ::: JSON ::: JSON -> Galley Response +updateTeam :: UserId ::: ConnId ::: TeamId ::: JsonRequest TeamUpdateData ::: JSON -> Galley Response updateTeam (zusr::: zcon ::: tid ::: req ::: _) = do - body <- fromBody req invalidPayload + body <- fromJsonBody req membs <- Data.teamMembers tid void $ permissionCheck zusr SetTeamData membs Data.updateTeam tid body @@ -155,7 +155,7 @@ deleteTeam (zusr::: zcon ::: tid ::: req ::: _ ::: _) = do _ -> do void $ permissionCheck zusr DeleteTeam =<< Data.teamMembers tid when ((tdTeam team)^.teamBinding == Binding) $ do - body <- fromBody req invalidPayload + body <- fromJsonBody (JsonRequest req) ensureReAuthorised zusr (body^.tdAuthPassword) queueDelete where @@ -229,9 +229,9 @@ uncheckedGetTeamMembers (tid ::: _) = do mems <- Data.teamMembers tid return . json $ newTeamMemberList mems -addTeamMember :: UserId ::: ConnId ::: TeamId ::: Request ::: JSON ::: JSON -> Galley Response +addTeamMember :: UserId ::: ConnId ::: TeamId ::: JsonRequest NewTeamMember ::: JSON -> Galley Response addTeamMember (zusr ::: zcon ::: tid ::: req ::: _) = do - nmem <- fromBody req invalidPayload + nmem <- fromJsonBody req mems <- Data.teamMembers tid -- verify permissions @@ -245,19 +245,19 @@ addTeamMember (zusr ::: zcon ::: tid ::: req ::: _) = do addTeamMemberInternal tid (Just zusr) (Just zcon) nmem mems -- This function is "unchecked" because there is no need to check for user binding (invite only). -uncheckedAddTeamMember :: TeamId ::: Request ::: JSON ::: JSON -> Galley Response +uncheckedAddTeamMember :: TeamId ::: JsonRequest NewTeamMember ::: JSON -> Galley Response uncheckedAddTeamMember (tid ::: req ::: _) = do - nmem <- fromBody req invalidPayload + nmem <- fromJsonBody req mems <- Data.teamMembers tid rsp <- addTeamMemberInternal tid Nothing Nothing nmem mems Journal.teamUpdate tid (nmem^.ntmNewTeamMember : mems) return rsp -updateTeamMember :: UserId ::: ConnId ::: TeamId ::: Request ::: JSON ::: JSON +updateTeamMember :: UserId ::: ConnId ::: TeamId ::: JsonRequest NewTeamMember ::: JSON -> Galley Response updateTeamMember (zusr ::: zcon ::: tid ::: req ::: _) = do -- the team member to be updated - targetMember <- view ntmNewTeamMember <$> fromBody req invalidPayload + targetMember <- view ntmNewTeamMember <$> fromJsonBody req let targetId = targetMember^.userId targetPermissions = targetMember^.permissions @@ -310,7 +310,7 @@ deleteTeamMember (zusr::: zcon ::: tid ::: remove ::: req ::: _ ::: _) = do unless okToDelete $ throwM noOtherOwner team <- tdTeam <$> (Data.team tid >>= ifNothing teamNotFound) if team^.teamBinding == Binding && isTeamMember remove mems then do - body <- fromBody req invalidPayload + body <- fromJsonBody (JsonRequest req) ensureReAuthorised zusr (body^.tmdAuthPassword) deleteUser remove Journal.teamUpdate tid (filter (\u -> u^.userId /= remove) mems) diff --git a/services/galley/src/Galley/API/Update.hs b/services/galley/src/Galley/API/Update.hs index 6f1dd845b0b..5b26690958d 100644 --- a/services/galley/src/Galley/API/Update.hs +++ b/services/galley/src/Galley/API/Update.hs @@ -96,9 +96,9 @@ unblockConv (usr ::: conn ::: cnv) = do conv' <- acceptOne2One usr conv conn setStatus status200 . json <$> conversationView usr conv' -updateConversationAccess :: UserId ::: ConnId ::: ConvId ::: Request ::: JSON -> Galley Response -updateConversationAccess (usr ::: zcon ::: cnv ::: req ::: _ ) = do - body <- fromBody req invalidPayload :: Galley ConversationAccessUpdate +updateConversationAccess :: UserId ::: ConnId ::: ConvId ::: JsonRequest ConversationAccessUpdate -> Galley Response +updateConversationAccess (usr ::: zcon ::: cnv ::: req) = do + body <- fromJsonBody req let targetAccess = Set.fromList (toList (cupAccess body)) targetRole = cupAccessRole body -- 'PrivateAccessRole' is for self-conversations, 1:1 conversations and @@ -198,9 +198,9 @@ uncheckedUpdateConversationAccess body usr zcon conv (currentAccess, targetAcces botsL :: Lens' ([Member], [BotMember]) [BotMember] botsL = _2 -updateConversationReceiptMode :: UserId ::: ConnId ::: ConvId ::: Request ::: JSON ::: JSON -> Galley Response -updateConversationReceiptMode (usr ::: zcon ::: cnv ::: req ::: _ ::: _) = do - ConversationReceiptModeUpdate target <- fromBody req invalidPayload +updateConversationReceiptMode :: UserId ::: ConnId ::: ConvId ::: JsonRequest ConversationReceiptModeUpdate ::: JSON -> Galley Response +updateConversationReceiptMode (usr ::: zcon ::: cnv ::: req ::: _) = do + ConversationReceiptModeUpdate target <- fromJsonBody req permissionCheckTeamConv usr cnv ModifyConvMetadata (bots, users) <- botsAndUsers <$> Data.members cnv current <- Data.lookupReceiptMode cnv @@ -216,9 +216,9 @@ updateConversationReceiptMode (usr ::: zcon ::: cnv ::: req ::: _ ::: _) = do pushEvent receiptEvent users bots zcon return $ json receiptEvent & setStatus status200 -updateConversationMessageTimer :: UserId ::: ConnId ::: ConvId ::: Request ::: JSON -> Galley Response -updateConversationMessageTimer (usr ::: zcon ::: cnv ::: req ::: _ ) = do - body <- fromBody req invalidPayload :: Galley ConversationMessageTimerUpdate +updateConversationMessageTimer :: UserId ::: ConnId ::: ConvId ::: JsonRequest ConversationMessageTimerUpdate -> Galley Response +updateConversationMessageTimer (usr ::: zcon ::: cnv ::: req) = do + body <- fromJsonBody req let messageTimer = cupMessageTimer body -- checks and balances (bots, users) <- botsAndUsers <$> Data.members cnv @@ -303,15 +303,15 @@ returnCode c = do let res = mkConversationCode (codeKey c) (codeValue c) urlPrefix return $ setStatus status200 . json $ res -checkReusableCode :: Request ::: JSON -> Galley Response -checkReusableCode (req ::: _) = do - convCode <- fromBody req invalidPayload +checkReusableCode :: JsonRequest ConversationCode -> Galley Response +checkReusableCode req = do + convCode <- fromJsonBody req void $ verifyReusableCode convCode return empty -joinConversationByReusableCode :: UserId ::: ConnId ::: Request ::: JSON -> Galley Response -joinConversationByReusableCode (zusr ::: zcon ::: req ::: _) = do - convCode <- fromBody req invalidPayload +joinConversationByReusableCode :: UserId ::: ConnId ::: JsonRequest ConversationCode -> Galley Response +joinConversationByReusableCode (zusr ::: zcon ::: req) = do + convCode <- fromJsonBody req c <- verifyReusableCode convCode joinConversation zusr zcon (codeConversation c) CodeAccess @@ -335,9 +335,9 @@ joinConversation zusr zcon cnv access = do ensureMemberLimit (toList $ Data.convMembers conv) newUsers addToConversation (botsAndUsers (Data.convMembers conv)) zusr zcon newUsers conv -addMembers :: UserId ::: ConnId ::: ConvId ::: Request ::: JSON -> Galley Response -addMembers (zusr ::: zcon ::: cid ::: req ::: _) = do - body <- fromBody req invalidPayload +addMembers :: UserId ::: ConnId ::: ConvId ::: JsonRequest Invite -> Galley Response +addMembers (zusr ::: zcon ::: cid ::: req) = do + body <- fromJsonBody req conv <- Data.conversation cid >>= ifNothing convNotFound let mems = botsAndUsers (Data.convMembers conv) toAdd <- fromMemberSize <$> checkedMemberAddSize (toList $ invUsers body) @@ -362,13 +362,13 @@ addMembers (zusr ::: zcon ::: cid ::: req ::: _) = do let guests = notTeamMember newUsers tms ensureConnected zusr guests -updateMember :: UserId ::: ConnId ::: ConvId ::: Request ::: JSON -> Galley Response -updateMember (zusr ::: zcon ::: cid ::: req ::: _) = do +updateMember :: UserId ::: ConnId ::: ConvId ::: JsonRequest MemberUpdate -> Galley Response +updateMember (zusr ::: zcon ::: cid ::: req) = do alive <- Data.isConvAlive cid unless alive $ do Data.deleteConversation cid throwM convNotFound - body <- fromBody req invalidPayload + body <- fromJsonBody req m <- Data.member cid zusr >>= ifNothing convNotFound up <- Data.updateMember cid zusr body now <- liftIO getCurrentTime @@ -417,27 +417,27 @@ removeMember (zusr ::: zcon ::: cid ::: victim) = do when (maybe False (view managedConversation) tcv) $ throwM (invalidOp "Users can not be removed from managed conversations.") -postBotMessage :: BotId ::: ConvId ::: OtrFilterMissing ::: Request ::: JSON ::: JSON -> Galley Response +postBotMessage :: BotId ::: ConvId ::: OtrFilterMissing ::: JsonRequest NewOtrMessage ::: JSON -> Galley Response postBotMessage (zbot ::: zcnv ::: val ::: req ::: _) = do - msg <- fromBody req invalidPayload + msg <- fromJsonBody req postNewOtrMessage (botUserId zbot) Nothing zcnv val msg postProtoOtrMessage :: UserId ::: ConnId ::: ConvId ::: OtrFilterMissing ::: Request ::: Media "application" "x-protobuf" -> Galley Response postProtoOtrMessage (zusr ::: zcon ::: cnv ::: val ::: req ::: _) = - Proto.toNewOtrMessage <$> fromProtoBody req invalidPayload >>= + Proto.toNewOtrMessage <$> fromProtoBody req >>= postNewOtrMessage zusr (Just zcon) cnv val -postOtrMessage :: UserId ::: ConnId ::: ConvId ::: OtrFilterMissing ::: Request ::: JSON -> Galley Response -postOtrMessage (zusr ::: zcon ::: cnv ::: val ::: req ::: _) = - postNewOtrMessage zusr (Just zcon) cnv val =<< fromBody req invalidPayload +postOtrMessage :: UserId ::: ConnId ::: ConvId ::: OtrFilterMissing ::: JsonRequest NewOtrMessage -> Galley Response +postOtrMessage (zusr ::: zcon ::: cnv ::: val ::: req) = + postNewOtrMessage zusr (Just zcon) cnv val =<< fromJsonBody req -postOtrBroadcast :: UserId ::: ConnId ::: OtrFilterMissing ::: Request ::: JSON -> Galley Response -postOtrBroadcast (zusr ::: zcon ::: val ::: req ::: _) = - postNewOtrBroadcast zusr (Just zcon) val =<< fromBody req invalidPayload +postOtrBroadcast :: UserId ::: ConnId ::: OtrFilterMissing ::: JsonRequest NewOtrMessage -> Galley Response +postOtrBroadcast (zusr ::: zcon ::: val ::: req) = + postNewOtrBroadcast zusr (Just zcon) val =<< fromJsonBody req postProtoOtrBroadcast :: UserId ::: ConnId ::: OtrFilterMissing ::: Request ::: JSON -> Galley Response postProtoOtrBroadcast (zusr ::: zcon ::: val ::: req ::: _) = - Proto.toNewOtrMessage <$> fromProtoBody req invalidPayload >>= + Proto.toNewOtrMessage <$> fromProtoBody req >>= postNewOtrBroadcast zusr (Just zcon) val postNewOtrBroadcast :: UserId -> Maybe ConnId -> OtrFilterMissing -> NewOtrMessage -> Galley Response @@ -491,9 +491,9 @@ newMessage usr con cnv msg now (m, c, t) ~(toBots, toUsers) = . set pushTransient (newOtrTransient msg) in (toBots, p:toUsers) -updateConversation :: UserId ::: ConnId ::: ConvId ::: Request ::: JSON -> Galley Response -updateConversation (zusr ::: zcon ::: cnv ::: req ::: _) = do - body <- fromBody req invalidPayload +updateConversation :: UserId ::: ConnId ::: ConvId ::: JsonRequest ConversationRename -> Galley Response +updateConversation (zusr ::: zcon ::: cnv ::: req) = do + body <- fromJsonBody req permissionCheckTeamConv zusr cnv ModifyConvMetadata alive <- Data.isConvAlive cnv unless alive $ do @@ -511,9 +511,9 @@ updateConversation (zusr ::: zcon ::: cnv ::: req ::: _) = do void . forkIO $ void $ External.deliver (bots `zip` repeat e) return $ json e & setStatus status200 -isTyping :: UserId ::: ConnId ::: ConvId ::: Request ::: JSON -> Galley Response -isTyping (zusr ::: zcon ::: cnv ::: req ::: _) = do - body <- fromBody req invalidPayload +isTyping :: UserId ::: ConnId ::: ConvId ::: JsonRequest TypingData -> Galley Response +isTyping (zusr ::: zcon ::: cnv ::: req) = do + body <- fromJsonBody req mm <- Data.members cnv unless (zusr `isMember` mm) $ throwM convNotFound @@ -526,19 +526,19 @@ isTyping (zusr ::: zcon ::: cnv ::: req ::: _) = do & pushTransient .~ True return empty -addService :: Request ::: JSON -> Galley Response -addService (req ::: _) = do - Data.insertService =<< fromBody req invalidPayload +addService :: JsonRequest Service -> Galley Response +addService req = do + Data.insertService =<< fromJsonBody req return empty -rmService :: Request ::: JSON -> Galley Response -rmService (req ::: _) = do - Data.deleteService =<< fromBody req invalidPayload +rmService :: JsonRequest ServiceRef -> Galley Response +rmService req = do + Data.deleteService =<< fromJsonBody req return empty -addBot :: UserId ::: ConnId ::: Request ::: JSON -> Galley Response -addBot (zusr ::: zcon ::: req ::: _) = do - b <- fromBody req invalidPayload +addBot :: UserId ::: ConnId ::: JsonRequest AddBot -> Galley Response +addBot (zusr ::: zcon ::: req) = do + b <- fromJsonBody req c <- Data.conversation (b^.addBotConv) >>= ifNothing convNotFound -- Check some preconditions on adding bots to a conversation for_ (Data.convTeam c) $ teamConvChecks (b^.addBotConv) @@ -568,9 +568,9 @@ addBot (zusr ::: zcon ::: req ::: _) = do when (maybe True (view managedConversation) tcv) $ throwM noAddToManaged -rmBot :: UserId ::: Maybe ConnId ::: Request ::: JSON -> Galley Response -rmBot (zusr ::: zcon ::: req ::: _) = do - b <- fromBody req invalidPayload +rmBot :: UserId ::: Maybe ConnId ::: JsonRequest RemoveBot -> Galley Response +rmBot (zusr ::: zcon ::: req) = do + b <- fromJsonBody req c <- Data.conversation (b^.rmBotConv) >>= ifNothing convNotFound unless (zusr `isMember` Data.convMembers c) $ throwM convNotFound diff --git a/services/galley/src/Galley/App.hs b/services/galley/src/Galley/App.hs index 98da107812f..e0606ed3456 100644 --- a/services/galley/src/Galley/App.hs +++ b/services/galley/src/Galley/App.hs @@ -28,14 +28,14 @@ module Galley.App -- * Utilities , ifNothing - , fromBody + , fromJsonBody , fromProtoBody ) where import Imports import Bilge hiding (Request, header, statusCode, options) import Bilge.RPC -import Cassandra hiding (Error, Set) +import Cassandra hiding (Set) import Control.Error import Control.Lens hiding ((.=)) import Control.Monad.Catch hiding (tryJust) @@ -48,6 +48,7 @@ import Data.Misc (Fingerprint, Rsa) import Data.Serialize.Get (runGetLazy) import Data.Text (unpack) import Galley.Options +import Galley.API.Error import Network.HTTP.Client (responseTimeoutMicro) import Network.HTTP.Client.OpenSSL import Network.Wai @@ -62,11 +63,9 @@ import qualified Cassandra as C import qualified Cassandra.Settings as C import qualified Data.List.NonEmpty as NE import qualified Data.ProtocolBuffers as Proto -import qualified Data.Text.Lazy as Lazy import qualified Galley.Aws as Aws import qualified Galley.Queue as Q import qualified OpenSSL.X509.SystemStore as Ssl -import qualified System.Logger as Logger import qualified System.Logger.Extended as Logger data DeleteItem = TeamItem TeamId UserId (Maybe ConnId) @@ -202,14 +201,14 @@ reqIdMsg :: RequestId -> Msg -> Msg reqIdMsg = ("request" .=) . unRequestId {-# INLINE reqIdMsg #-} -fromBody :: FromJSON a => Request -> (Lazy.Text -> Error) -> Galley a -fromBody r f = exceptT (throwM . f) return (parseBody r) -{-# INLINE fromBody #-} +fromJsonBody :: FromJSON a => JsonRequest a -> Galley a +fromJsonBody r = exceptT (throwM . invalidPayload) return (parseBody r) +{-# INLINE fromJsonBody #-} -fromProtoBody :: Proto.Decode a => Request -> (Lazy.Text -> Error) -> Galley a -fromProtoBody r f = do +fromProtoBody :: Proto.Decode a => Request -> Galley a +fromProtoBody r = do b <- readBody r - either (throwM . f . fromString) return (runGetLazy Proto.decodeMessage b) + either (throwM . invalidPayload . fromString) return (runGetLazy Proto.decodeMessage b) {-# INLINE fromProtoBody #-} ifNothing :: Error -> Maybe a -> Galley a diff --git a/services/galley/src/Galley/Data/Instances.hs b/services/galley/src/Galley/Data/Instances.hs index b9a4354917a..758e857b0cd 100644 --- a/services/galley/src/Galley/Data/Instances.hs +++ b/services/galley/src/Galley/Data/Instances.hs @@ -2,7 +2,7 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} -module Galley.Data.Instances where +module Galley.Data.Instances () where import Imports import Cassandra.CQL diff --git a/services/galley/src/Galley/Data/Queries.hs b/services/galley/src/Galley/Data/Queries.hs index 0000990a500..8ac4e7c8c51 100644 --- a/services/galley/src/Galley/Data/Queries.hs +++ b/services/galley/src/Galley/Data/Queries.hs @@ -3,7 +3,7 @@ module Galley.Data.Queries where import Imports import Brig.Types.Code import Cassandra as C hiding (Value) -import Cassandra.Util +import Cassandra.Util (Writetime) import Data.Id import Data.Json.Util import Data.Misc diff --git a/services/galley/src/Galley/Run.hs b/services/galley/src/Galley/Run.hs index 8c2cfe79843..4c34bed6af5 100644 --- a/services/galley/src/Galley/Run.hs +++ b/services/galley/src/Galley/Run.hs @@ -45,7 +45,7 @@ run o = do middlewares :: Middleware middlewares = waiPrometheusMiddleware sitemap . measured - . catchErrors l m + . catchErrors l [Right m] . GZip.gunzip . GZip.gzip GZip.def runSettingsWithShutdown s (middlewares app) 5 `finally` do diff --git a/services/galley/test/integration/TestSetup.hs b/services/galley/test/integration/TestSetup.hs index 63df987a4f5..10985ba6920 100644 --- a/services/galley/test/integration/TestSetup.hs +++ b/services/galley/test/integration/TestSetup.hs @@ -15,27 +15,12 @@ module TestSetup import Imports import Test.Tasty (TestName, TestTree) import Test.Tasty.HUnit (Assertion, testCase) -import Control.Lens ((^.), makeLenses) +import Control.Lens (makeLenses, view) import Control.Monad.Catch (MonadCatch, MonadMask, MonadThrow) -import Bilge (HttpT(..), Manager, MonadHttp, Request, runHttpT) +import Bilge (Manager, MonadHttp(..), Request) import qualified Galley.Aws as Aws -newtype TestM a = - TestM { runTestM :: ReaderT TestSetup (HttpT IO) a - } - deriving ( Functor - , Applicative - , Monad - , MonadReader TestSetup - , MonadIO - , MonadCatch - , MonadThrow - , MonadMask - , MonadHttp - , MonadUnliftIO - ) - type GalleyR = Request -> Request type BrigR = Request -> Request type CannonR = Request -> Request @@ -51,6 +36,21 @@ data TestSetup = TestSetup makeLenses ''TestSetup +newtype TestM a = + TestM { runTestM :: ReaderT TestSetup IO a } + deriving ( Functor + , Applicative + , Monad + , MonadReader TestSetup + , MonadIO + , MonadCatch + , MonadThrow + , MonadMask + , MonadUnliftIO + ) + +instance MonadHttp TestM where + getManager = view tsManager test :: IO TestSetup -> TestName -> TestM a -> TestTree test s n h = testCase n runTest @@ -58,5 +58,4 @@ test s n h = testCase n runTest runTest :: Assertion runTest = do setup <- s - void . runHttpT (setup ^. tsManager) . flip runReaderT setup . runTestM $ h - + void . flip runReaderT setup . runTestM $ h diff --git a/services/gundeck/package.yaml b/services/gundeck/package.yaml index d6b9edf4b50..abe4d56c796 100644 --- a/services/gundeck/package.yaml +++ b/services/gundeck/package.yaml @@ -37,6 +37,7 @@ library: - Gundeck.Push.Native.Types - Gundeck.Push.Websocket - Gundeck.React + - Gundeck.Run - Gundeck.Util - Gundeck.Util.DelayQueue - Gundeck.Util.Redis @@ -77,6 +78,7 @@ library: - mtl >=2.2 - network-uri >=2.6 - optparse-applicative >=0.10 + - prometheus-client - psqueues >=0.2.2 - redis-io >=0.4 - resourcet >=1.1 diff --git a/services/gundeck/schema/src/Main.hs b/services/gundeck/schema/src/Main.hs index 63828afeb3a..9ff11bcda0b 100644 --- a/services/gundeck/schema/src/Main.hs +++ b/services/gundeck/schema/src/Main.hs @@ -5,7 +5,6 @@ import Cassandra.Schema import Control.Exception (finally) import Util.Options -import qualified System.Logger as Log import qualified System.Logger.Extended as Log import qualified V1 diff --git a/services/gundeck/src/Gundeck/API.hs b/services/gundeck/src/Gundeck/API.hs index 9a8540f6bda..06b8ab4abbd 100644 --- a/services/gundeck/src/Gundeck/API.hs +++ b/services/gundeck/src/Gundeck/API.hs @@ -1,65 +1,29 @@ -module Gundeck.API where +module Gundeck.API (sitemap) where import Imports hiding (head) -import Cassandra (runClient, shutdown) -import Cassandra.Schema (versionCheck) -import Control.Exception (finally) import Control.Lens hiding (enum) import Data.Aeson (encode) import Data.Metrics.Middleware -import Data.Metrics.WaiRoute (treeToPaths) import Data.Range import Data.Swagger.Build.Api hiding (def, min, Response) import Data.Text.Encoding (decodeLatin1) -import Data.Text (unpack) import Gundeck.API.Error import Gundeck.Env import Gundeck.Monad -import Gundeck.Options -import Gundeck.React +import Gundeck.Types import Network.HTTP.Types import Network.Wai import Network.Wai.Predicate hiding (setStatus) import Network.Wai.Routing hiding (route) import Network.Wai.Utilities import Network.Wai.Utilities.Swagger -import Network.Wai.Utilities.Server hiding (serverPort) -import Util.Options -import qualified Control.Concurrent.Async as Async import qualified Data.Swagger.Build.Api as Swagger -import qualified Gundeck.Aws as Aws import qualified Gundeck.Client as Client import qualified Gundeck.Notification as Notification import qualified Gundeck.Push as Push import qualified Gundeck.Presence as Presence import qualified Gundeck.Types.Swagger as Model -import qualified Network.Wai.Middleware.Gzip as GZip -import qualified Network.Wai.Middleware.Gunzip as GZip -import qualified System.Logger as Log - -runServer :: Opts -> IO () -runServer o = do - m <- metrics - e <- createEnv m o - runClient (e^.cstate) $ - versionCheck schemaVersion - let l = e^.applog - s <- newSettings $ defaultServer (unpack $ o^.optGundeck.epHost) (o^.optGundeck.epPort) l m - app <- pipeline e - lst <- Async.async $ Aws.execute (e^.awsEnv) (Aws.listen (runDirect e . onEvent)) - runSettingsWithShutdown s app 5 `finally` do - Log.info l $ Log.msg (Log.val "Shutting down ...") - shutdown (e^.cstate) - Async.cancel lst - Log.close (e^.applog) - where - pipeline e = do - let routes = compile sitemap - return $ measureRequests (e^.monitor) (treeToPaths routes) - . catchErrors (e^.applog) (e^.monitor) - . GZip.gunzip . GZip.gzip GZip.def - $ \r k -> runGundeck e r (route routes r k) sitemap :: Routes ApiBuilder Gundeck () sitemap = do @@ -69,9 +33,8 @@ sitemap = do post "/push/tokens" (continue Push.addToken) $ header "Z-User" .&. header "Z-Connection" - .&. request + .&. jsonRequest @PushToken .&. accept "application" "json" - .&. contentType "application" "json" document "POST" "registerPushToken" $ do summary "Register a native push token" diff --git a/services/gundeck/src/Gundeck/Env.hs b/services/gundeck/src/Gundeck/Env.hs index 94aa49f4ccc..01b8bc18732 100644 --- a/services/gundeck/src/Gundeck/Env.hs +++ b/services/gundeck/src/Gundeck/Env.hs @@ -20,7 +20,6 @@ import qualified Cassandra.Settings as C import qualified Database.Redis.IO as Redis import qualified Data.List.NonEmpty as NE import qualified Gundeck.Aws as Aws -import qualified System.Logger as Logger import qualified System.Logger.Extended as Logger data Env = Env diff --git a/services/gundeck/src/Gundeck/Monad.hs b/services/gundeck/src/Gundeck/Monad.hs index 6b4729237c3..31f74906382 100644 --- a/services/gundeck/src/Gundeck/Monad.hs +++ b/services/gundeck/src/Gundeck/Monad.hs @@ -15,7 +15,7 @@ module Gundeck.Monad , Gundeck , runDirect , runGundeck - , fromBody + , fromJsonBody , ifNothing , posixTime ) where @@ -23,7 +23,7 @@ module Gundeck.Monad import Imports import Bilge hiding (Request, header, statusCode, options) import Bilge.RPC -import Cassandra hiding (Error) +import Cassandra import Control.Error hiding (err) import Control.Lens hiding ((.=)) import Control.Monad.Catch hiding (tryJust) @@ -33,6 +33,7 @@ import Data.Misc (Milliseconds (..)) import Gundeck.Env import Network.Wai import Network.Wai.Utilities +import Network.HTTP.Types import System.Logger.Class hiding (Error, info) import qualified Database.Redis.IO as Redis @@ -83,9 +84,9 @@ lookupReqId :: Request -> RequestId lookupReqId = maybe def RequestId . lookup requestIdName . requestHeaders {-# INLINE lookupReqId #-} -fromBody :: FromJSON a => Request -> (LText -> Error) -> Gundeck a -fromBody r f = exceptT (throwM . f) return (parseBody r) -{-# INLINE fromBody #-} +fromJsonBody :: FromJSON a => JsonRequest a -> Gundeck a +fromJsonBody r = exceptT (throwM . Error status400 "bad-request") return (parseBody r) +{-# INLINE fromJsonBody #-} ifNothing :: Error -> Maybe a -> Gundeck a ifNothing e = maybe (throwM e) return diff --git a/services/gundeck/src/Gundeck/Presence.hs b/services/gundeck/src/Gundeck/Presence.hs index caed5aa686e..eccf35e41b0 100644 --- a/services/gundeck/src/Gundeck/Presence.hs +++ b/services/gundeck/src/Gundeck/Presence.hs @@ -27,7 +27,7 @@ listAll (uids ::: _) = setStatus status200 . json . concat add :: Request ::: JSON -> Gundeck Response add (req ::: _) = do - p <- fromBody req (Error status400 "bad-request") + p <- fromJsonBody (JsonRequest req) Data.add p return $ ( setStatus status201 . addHeader hLocation (toByteString' (resource p)) diff --git a/services/gundeck/src/Gundeck/Push.hs b/services/gundeck/src/Gundeck/Push.hs index 17c21dd4df2..84427c12911 100644 --- a/services/gundeck/src/Gundeck/Push.hs +++ b/services/gundeck/src/Gundeck/Push.hs @@ -54,7 +54,7 @@ import qualified System.Logger.Class as Log push :: Request ::: JSON -> Gundeck Response push (req ::: _) = do - ps :: [Push] <- fromBody req (Error status400 "bad-request") + ps :: [Push] <- fromJsonBody (JsonRequest req) bulk :: Bool <- view (options . optSettings . setBulkPush) rs <- if bulk then (Right <$> pushAll ps) `catch` (pure . Left . Seq.singleton) @@ -311,9 +311,9 @@ nativeTargets p pres = check (Left e) = mntgtLogErr e >> return [] check (Right r) = return r -addToken :: UserId ::: ConnId ::: Request ::: JSON ::: JSON -> Gundeck Response +addToken :: UserId ::: ConnId ::: JsonRequest PushToken ::: JSON -> Gundeck Response addToken (uid ::: cid ::: req ::: _) = do - new <- fromBody req (Error status400 "bad-request") + new <- fromJsonBody req (cur, old) <- foldl' (matching new) (Nothing, []) <$> Data.lookup uid Data.Quorum Log.info $ "user" .= UUID.toASCIIBytes (toUUID uid) ~~ "token" .= Text.take 16 (tokenText (new^.token)) diff --git a/services/gundeck/src/Gundeck/Run.hs b/services/gundeck/src/Gundeck/Run.hs new file mode 100644 index 00000000000..c80a0425a95 --- /dev/null +++ b/services/gundeck/src/Gundeck/Run.hs @@ -0,0 +1,49 @@ +module Gundeck.Run where + +import Imports hiding (head) +import Cassandra (runClient, shutdown) +import Cassandra.Schema (versionCheck) +import Control.Exception (finally) +import Control.Lens hiding (enum) +import Data.Metrics.Middleware +import Data.Metrics.Middleware.Prometheus (waiPrometheusMiddleware) +import Data.Metrics.WaiRoute (treeToPaths) +import Data.Text (unpack) +import Gundeck.API (sitemap) +import Gundeck.Env +import Gundeck.Monad +import Gundeck.Options +import Gundeck.React +import Network.Wai as Wai +import Network.Wai.Utilities.Server hiding (serverPort) +import Util.Options + +import qualified Control.Concurrent.Async as Async +import qualified Gundeck.Aws as Aws +import qualified Network.Wai.Middleware.Gzip as GZip +import qualified Network.Wai.Middleware.Gunzip as GZip +import qualified System.Logger as Log + +run :: Opts -> IO () +run o = do + m <- metrics + e <- createEnv m o + runClient (e^.cstate) $ + versionCheck schemaVersion + let l = e^.applog + s <- newSettings $ defaultServer (unpack $ o^.optGundeck.epHost) (o^.optGundeck.epPort) l m + lst <- Async.async $ Aws.execute (e^.awsEnv) (Aws.listen (runDirect e . onEvent)) + runSettingsWithShutdown s (middleware e $ app e) 5 `finally` do + Log.info l $ Log.msg (Log.val "Shutting down ...") + shutdown (e^.cstate) + Async.cancel lst + Log.close (e^.applog) + where + middleware :: Env -> Wai.Middleware + middleware e = waiPrometheusMiddleware sitemap + . measureRequests (e^.monitor) (treeToPaths routes) + . catchErrors (e^.applog) [Right $ e^.monitor] + . GZip.gunzip . GZip.gzip GZip.def + app :: Env -> Wai.Application + app e r k = runGundeck e r (route routes r k) + routes = compile sitemap diff --git a/services/gundeck/src/Main.hs b/services/gundeck/src/Main.hs index 4eb72df51b4..aefa40a879c 100644 --- a/services/gundeck/src/Main.hs +++ b/services/gundeck/src/Main.hs @@ -1,7 +1,7 @@ module Main (main) where import Imports -import Gundeck.API +import Gundeck.Run (run) import OpenSSL (withOpenSSL) import Util.Options @@ -9,7 +9,7 @@ import Util.Options main :: IO () main = withOpenSSL $ do options <- getOptions desc Nothing defaultPath - runServer options + run options where desc = "Gundeck - Push Notification Hub Service" defaultPath = "/etc/wire/gundeck/conf/gundeck.yaml" diff --git a/services/gundeck/test/integration/API.hs b/services/gundeck/test/integration/API.hs index 043154baeb0..dd381093350 100644 --- a/services/gundeck/test/integration/API.hs +++ b/services/gundeck/test/integration/API.hs @@ -1,6 +1,6 @@ {-# OPTIONS_GHC -fno-warn-incomplete-patterns #-} -module API (TestSetup(..), tests) where +module API (tests) where import Bilge import Bilge.Assert @@ -22,9 +22,9 @@ import Network.URI (parseURI) import Safe import System.Random (randomIO) import System.Timeout (timeout) -import TestSetup import Test.Tasty import Test.Tasty.HUnit +import TestSetup import qualified Cassandra as Cql import qualified Data.Aeson.Types as Aeson @@ -47,7 +47,7 @@ appName :: AppName appName = AppName "test" tests :: IO TestSetup -> TestTree -tests s = testGroup "Gundeck integration tests" [ +tests s = testGroup "API tests" [ testGroup "Push" [ test s "Register a user" $ addUser , test s "Delete a user" $ removeUser diff --git a/services/gundeck/test/integration/Main.hs b/services/gundeck/test/integration/Main.hs index 47a1da2af59..a98f70ae430 100644 --- a/services/gundeck/test/integration/Main.hs +++ b/services/gundeck/test/integration/Main.hs @@ -23,6 +23,7 @@ import Util.Test import TestSetup import qualified API +import qualified Metrics import qualified System.Logger as Logger data IntegrationConfig = IntegrationConfig @@ -65,9 +66,12 @@ runTests run = defaultMainWithIngredients ings $ main :: IO () main = withOpenSSL $ runTests go where - go g i = withResource (getOpts g i) releaseOpts $ \opts -> API.tests opts + go g i = withResource (getOpts g i) releaseOpts $ \opts -> + testGroup "Gundeck" [ API.tests opts + , Metrics.tests opts + ] - getOpts :: FilePath -> FilePath -> IO API.TestSetup + getOpts :: FilePath -> FilePath -> IO TestSetup getOpts gFile iFile = do m <- newManager tlsManagerSettings { managerResponseTimeout = responseTimeoutMicro 300000000 @@ -86,7 +90,7 @@ main = withOpenSSL $ runTests go lg <- Logger.new Logger.defSettings db <- defInitCassandra ck ch cp lg - return $ API.TestSetup m g c c2 b db lg + return $ TestSetup m g c c2 b db lg releaseOpts _ = return () diff --git a/services/gundeck/test/integration/Metrics.hs b/services/gundeck/test/integration/Metrics.hs new file mode 100644 index 00000000000..e92c3d781a6 --- /dev/null +++ b/services/gundeck/test/integration/Metrics.hs @@ -0,0 +1,32 @@ +module Metrics where + +import Imports +import TestSetup +import Bilge +import Bilge.Assert +import Test.Tasty +import Control.Lens (view) + +type TestSignature a = GundeckR -> Http a + +tests :: IO TestSetup -> TestTree +tests s = testGroup "Metrics" [ test s "prometheus gundeck" testPrometheusMetricsGundeck + , test s "prometheus cannon" testPrometheusMetricsCannon + ] + +testPrometheusMetricsGundeck :: TestM () +testPrometheusMetricsGundeck = do + gundeck <- view tsGundeck + get (runGundeckR gundeck . path "/i/metrics") !!! do + const 200 === statusCode + -- Should contain the request duration metric in its output + const (Just "TYPE http_request_duration_seconds histogram") =~= responseBody + +testPrometheusMetricsCannon :: TestM () +testPrometheusMetricsCannon = do + cannon <- view tsCannon + get (runCannonR cannon . path "/i/metrics") !!! do + const 200 === statusCode + -- Should contain the request duration metric in its output + const (Just "TYPE http_request_duration_seconds histogram") =~= responseBody + diff --git a/services/gundeck/test/integration/TestSetup.hs b/services/gundeck/test/integration/TestSetup.hs index 1bdfe284577..80a50ec93cb 100644 --- a/services/gundeck/test/integration/TestSetup.hs +++ b/services/gundeck/test/integration/TestSetup.hs @@ -57,7 +57,6 @@ data TestSetup = TestSetup makeLenses ''TestSetup - test :: IO TestSetup -> TestName -> TestM a -> TestTree test s n h = testCase n runTest where diff --git a/services/integration.sh b/services/integration.sh index 80f8bdb240f..6f8c5ec721f 100755 --- a/services/integration.sh +++ b/services/integration.sh @@ -77,8 +77,19 @@ function run() { service=$1 instance=$2 colour=$3 + # Check if we're on a Mac + if [[ "$OSTYPE" == "darwin"* ]]; then + # Mac sed uses '-l' to set line-by-line buffering + UNBUFFERED=-l + # Test if sed supports buffer settings. GNU sed does, busybox does not. + elif sed -u '' /dev/null 2>&1; then + UNBUFFERED=-u + else + echo -e "\n\nWARNING: log output is buffered and may not show on your screen!\n\n" + UNBUFFERED='' + fi ( ( cd "${DIR}/${service}" && "${TOP_LEVEL}/dist/${service}" -c "${service}${instance}.integration${integration_file_extension}" ) || kill_all) \ - | sed -e "s/^/$(tput setaf ${colour})[${service}] /" -e "s/$/$(tput sgr0)/" & + | sed ${UNBUFFERED} -e "s/^/$(tput setaf ${colour})[${service}] /" -e "s/$/$(tput sgr0)/" & } check_prerequisites diff --git a/services/proxy/deb/etc/sv/proxy/run b/services/proxy/deb/etc/sv/proxy/run index beff90dcb35..da553fc2cb3 100755 --- a/services/proxy/deb/etc/sv/proxy/run +++ b/services/proxy/deb/etc/sv/proxy/run @@ -3,29 +3,17 @@ set -e exec 2>&1 -APP=proxy - # defaults USER=${USER:-www-data} -CONFIG=${CONFIG:-/etc/$APP/.env} +APP=proxy +CONFIG=${CONFIG:-/etc/${APP}/${APP}.yaml} HOME=${APP_HOME:-/opt/$APP} BIN=$HOME/bin/$APP if [ ! -f $CONFIG ]; then exec chpst -u $USER get_config; fi -source $CONFIG - -export LOG_LEVEL=${PROXY_LOG_LEVEL:-Debug} -export LOG_BUFFER=${PROXY_LOG_BUFFER:-4096} -export LOG_NETSTR=${PROXY_LOG_NETSTR:-True} cd $HOME ulimit -n 65536 -exec chpst -u $USER \ - $BIN \ - --host=${PROXY_WEB_HOST?'unset'} \ - --port=${PROXY_WEB_PORT?'unset'} \ - --config=${PROXY_CONFIG?'unset'} \ - --http-pool-size=${PROXY_HTTP_POOL_SIZE:-256} \ - --max-connections=${PROXY_MAX_CONNECTIONS?'unset'} +exec chpst -u $USER $BIN --config-file=${CONFIG} diff --git a/services/proxy/package.yaml b/services/proxy/package.yaml index c5459360b30..83ca43747db 100644 --- a/services/proxy/package.yaml +++ b/services/proxy/package.yaml @@ -20,6 +20,7 @@ library: - Proxy.Env - Proxy.Options - Proxy.Proxy + - Proxy.Run dependencies: - base >=4.6 && <5 - aeson >=1.0 @@ -38,6 +39,7 @@ library: - mtl >=2.2 - network >=2.6 - optparse-applicative >=0.12 + - prometheus-client - retry >=0.7 - text >=1.2 - tinylog >=0.12 diff --git a/services/proxy/proxy.integration.yaml b/services/proxy/proxy.integration.yaml index 274d00107ed..76533910662 100644 --- a/services/proxy/proxy.integration.yaml +++ b/services/proxy/proxy.integration.yaml @@ -12,3 +12,7 @@ maxConns: 5000 # File containing upstream secrets. secretsConfig: doc/example.config + +# Logging settings +logLevel: Info +logNetStrings: false diff --git a/services/proxy/src/Main.hs b/services/proxy/src/Main.hs index 241cd819c59..70185398bb4 100644 --- a/services/proxy/src/Main.hs +++ b/services/proxy/src/Main.hs @@ -1,13 +1,12 @@ module Main (main) where import Imports -import Proxy.API -import Proxy.Options +import Proxy.Run (run) import Util.Options main :: IO () main = do - opts <- getOptions desc (Just optsParser) defaultPath + opts <- getOptions desc Nothing defaultPath run opts where desc = "Proxy - 3rd party proxy" diff --git a/services/proxy/src/Proxy/API.hs b/services/proxy/src/Proxy/API.hs index 6916da069e1..8cfd5124135 100644 --- a/services/proxy/src/Proxy/API.hs +++ b/services/proxy/src/Proxy/API.hs @@ -1,4 +1,4 @@ -module Proxy.API (Proxy.API.run) where +module Proxy.API (sitemap) where import Imports hiding (head) import Control.Monad.Catch @@ -7,19 +7,15 @@ import Control.Retry import Data.ByteString (breakSubstring) import Data.CaseInsensitive (CI) import Data.Metrics.Middleware hiding (path) -import Data.Metrics.WaiRoute (treeToPaths) import Network.HTTP.ReverseProxy import Network.HTTP.Types import Network.Wai -import Network.Wai.Handler.Warp import Network.Wai.Predicate hiding (err, Error, setStatus) import Network.Wai.Predicate.Request (getRequest) import Network.Wai.Routing hiding (path, route) import Network.Wai.Utilities -import Network.Wai.Utilities.Server hiding (serverPort) import Proxy.Env import Proxy.Proxy -import Proxy.Options import System.Logger.Class hiding (Error, info, render) import qualified Bilge.Request as Req @@ -33,17 +29,6 @@ import qualified Network.HTTP.Client as Client import qualified Network.Wai.Internal as I import qualified System.Logger as Logger -run :: Opts -> IO () -run o = do - m <- metrics - e <- createEnv m o - s <- newSettings $ defaultServer (o^.host) (o^.port) (e^.applog) m - let rtree = compile (sitemap e) - let measured = measureRequests m (treeToPaths rtree) - let app r k = runProxy e r (route rtree r k) - let start = measured . catchErrors (e^.applog) m $ app - runSettings s start `finally` destroyEnv e - sitemap :: Env -> Routes a Proxy () sitemap e = do diff --git a/services/proxy/src/Proxy/Env.hs b/services/proxy/src/Proxy/Env.hs index d086fbc9421..1fbb7f27c01 100644 --- a/services/proxy/src/Proxy/Env.hs +++ b/services/proxy/src/Proxy/Env.hs @@ -21,7 +21,6 @@ import Proxy.Options import Network.HTTP.Client import Network.HTTP.Client.TLS (tlsManagerSettings) -import qualified System.Logger as Logger import qualified System.Logger.Extended as Logger data Env = Env @@ -38,7 +37,7 @@ makeLenses ''Env createEnv :: Metrics -> Opts -> IO Env createEnv m o = do - g <- Logger.mkLogger' + g <- Logger.mkLogger (o^.logLevel) (o^.logNetStrings) n <- newManager tlsManagerSettings { managerConnCount = o^.httpPoolSize , managerIdleConnectionCount = 3 * (o^.httpPoolSize) diff --git a/services/proxy/src/Proxy/Options.hs b/services/proxy/src/Proxy/Options.hs index 1b70dedc7b1..a6ad4d01485 100644 --- a/services/proxy/src/Proxy/Options.hs +++ b/services/proxy/src/Proxy/Options.hs @@ -5,56 +5,28 @@ module Proxy.Options , secretsConfig , httpPoolSize , maxConns - , optsParser + , logLevel + , logNetStrings ) where import Imports -import Control.Lens -import Options.Applicative +import Control.Lens hiding (Level) import Data.Aeson import Data.Aeson.TH +import System.Logger (Level) data Opts = Opts - { _host :: !String - , _port :: !Word16 - , _secretsConfig :: !FilePath - , _httpPoolSize :: !Int - , _maxConns :: !Int + { _host :: !String -- ^ Host to listen on + , _port :: !Word16 -- ^ Port to listen on + , _secretsConfig :: !FilePath -- ^ File containing upstream secrets + , _httpPoolSize :: !Int -- ^ Number of connections for the HTTP pool + , _maxConns :: !Int -- ^ Maximum number of incoming connections + -- Logging + , _logLevel :: !Level -- ^ Log level (Debug, Info, etc) + , _logNetStrings :: !Bool -- ^ Use netstrings encoding (see + -- ) } deriving (Show, Generic) makeLenses ''Opts deriveJSON defaultOptions{fieldLabelModifier = drop 1} ''Opts - -optsParser :: Parser Opts -optsParser = Opts - <$> (strOption $ - long "host" - <> value "*4" - <> showDefault - <> metavar "HOSTNAME" - <> help "host to listen on") - - <*> (option auto $ - long "port" - <> short 'p' - <> metavar "PORT" - <> help "listen port") - - <*> (strOption $ - long "config" - <> metavar "FILE" - <> help "File containing upstream secrets" - <> action "file") - - <*> (option auto $ - long "http-pool-size" - <> metavar "SIZE" - <> showDefault - <> help "number of connections for the http pool" - <> value 256) - - <*> (option auto $ - long "max-connections" - <> metavar "SIZE" - <> help "maximum number of incoming connections") diff --git a/services/proxy/src/Proxy/Run.hs b/services/proxy/src/Proxy/Run.hs new file mode 100644 index 00000000000..1d29f553012 --- /dev/null +++ b/services/proxy/src/Proxy/Run.hs @@ -0,0 +1,27 @@ +module Proxy.Run (run) where + +import Imports hiding (head) +import Control.Monad.Catch +import Control.Lens hiding ((.=)) +import Data.Metrics.Middleware hiding (path) +import Data.Metrics.Middleware.Prometheus (waiPrometheusMiddleware) +import Data.Metrics.WaiRoute (treeToPaths) +import Network.Wai.Utilities.Server hiding (serverPort) +import Network.Wai.Handler.Warp (runSettings) +import Proxy.Env +import Proxy.Proxy +import Proxy.Options +import Proxy.API (sitemap) + +run :: Opts -> IO () +run o = do + m <- metrics + e <- createEnv m o + s <- newSettings $ defaultServer (o^.host) (o^.port) (e^.applog) m + let rtree = compile (sitemap e) + let measured = measureRequests m (treeToPaths rtree) + let app r k = runProxy e r (route rtree r k) + let middleware = waiPrometheusMiddleware (sitemap e) + . measured + . catchErrors (e^.applog) [Right m] + runSettings s (middleware app) `finally` destroyEnv e diff --git a/services/spar/package.yaml b/services/spar/package.yaml index 4210ba34542..473a3a89dfb 100644 --- a/services/spar/package.yaml +++ b/services/spar/package.yaml @@ -54,6 +54,7 @@ dependencies: - mtl - network-uri - optparse-applicative + - prometheus-client - raw-strings-qq - retry - saml2-web-sso >= 0.18 @@ -123,6 +124,7 @@ executables: - galley-types - hspec - hspec-discover + - hspec-wai - lens-aeson - MonadRandom - random @@ -132,6 +134,7 @@ executables: - stm - tinylog - wai + - wai-extra - warp-tls - xml-conduit - xml-hamlet diff --git a/services/spar/schema/src/Main.hs b/services/spar/schema/src/Main.hs index d8aa70ab13e..e443d29fed0 100644 --- a/services/spar/schema/src/Main.hs +++ b/services/spar/schema/src/Main.hs @@ -5,7 +5,6 @@ import Cassandra.Schema import Control.Exception (finally) import Util.Options -import qualified System.Logger as Log import qualified System.Logger.Extended as Log import qualified V0 diff --git a/services/spar/src/Spar/App.hs b/services/spar/src/Spar/App.hs index f0b61ef827a..6fbe46c8e45 100644 --- a/services/spar/src/Spar/App.hs +++ b/services/spar/src/Spar/App.hs @@ -9,8 +9,12 @@ module Spar.App , wrapMonadClientWithEnv , wrapMonadClient , verdictHandler + , getUser , insertUser - , createUser, createUser_ + , createSamlUser + , createSamlUserWithId + , autoprovisionSamlUser + , autoprovisionSamlUserWithId ) where import Imports @@ -21,7 +25,6 @@ import Control.Exception (assert) import Control.Lens hiding ((.=)) import Control.Monad.Except import Data.Aeson as Aeson (encode, object, (.=)) -import Data.EitherR (fmapL) import Data.Id import Data.String.Conversions import SAML2.Util (renderURI) @@ -159,20 +162,39 @@ getUser uref = do -- FUTUREWORK: once we support , brig will refuse to delete -- users that have an sso id, unless the request comes from spar. then we can make users -- undeletable in the team admin page, and ask admins to go talk to their IdP system. -createUser :: SAML.UserRef -> Maybe Name -> ManagedBy -> Spar UserId -createUser suid mbName managedBy = do +createSamlUser :: SAML.UserRef -> Maybe Name -> ManagedBy -> Spar UserId +createSamlUser suid mbName managedBy = do buid <- Id <$> liftIO UUID.nextRandom - createUser_ buid suid mbName managedBy + createSamlUserWithId buid suid mbName managedBy pure buid --- | Like 'createUser', but for an already existing 'UserId'. -createUser_ :: UserId -> SAML.UserRef -> Maybe Name -> ManagedBy -> Spar () -createUser_ buid suid mbName managedBy = do +-- | Like 'createSamlUser', but for an already existing 'UserId'. +createSamlUserWithId :: UserId -> SAML.UserRef -> Maybe Name -> ManagedBy -> Spar () +createSamlUserWithId buid suid mbName managedBy = do teamid <- (^. idpExtraInfo) <$> getIdPConfigByIssuer (suid ^. uidTenant) insertUser suid buid buid' <- Intra.createBrigUser suid buid teamid mbName managedBy assert (buid == buid') $ pure () +-- | If the team has no scim token, call 'createSamlUser'. Otherwise, raise "invalid +-- credentials". +autoprovisionSamlUser :: SAML.UserRef -> Maybe Name -> ManagedBy -> Spar UserId +autoprovisionSamlUser suid mbName managedBy = do + buid <- Id <$> liftIO UUID.nextRandom + autoprovisionSamlUserWithId buid suid mbName managedBy + pure buid + +-- | Like 'autoprovisionSamlUser', but for an already existing 'UserId'. +autoprovisionSamlUserWithId :: UserId -> SAML.UserRef -> Maybe Name -> ManagedBy -> Spar () +autoprovisionSamlUserWithId buid suid mbName managedBy = do + teamid <- (^. idpExtraInfo) <$> getIdPConfigByIssuer (suid ^. uidTenant) + scimtoks <- wrapMonadClient $ Data.getScimTokens teamid + if null scimtoks + then createSamlUserWithId buid suid mbName managedBy + else throwError . SAML.Forbidden $ + "bad credentials (note that your team has uses SCIM, " <> + "which disables saml auto-provisioning)" + -- | Check if 'UserId' is in the team that hosts the idp that owns the 'UserRef'. If so, write the -- 'UserRef' into the 'UserIdentity'. Otherwise, throw an error. bindUser :: UserId -> SAML.UserRef -> Spar UserId @@ -191,7 +213,18 @@ bindUser buid userref = do instance SPHandler SparError Spar where type NTCTX Spar = Env - nt ctx (Spar action) = Handler . ExceptT . fmap (fmapL sparToServantErr) . runExceptT $ runReaderT action ctx + nt :: forall a. Env -> Spar a -> Handler a + nt ctx (Spar action) = do + err <- actionHandler + throwErrorAsHandlerException err + where + actionHandler :: Handler (Either SparError a) + actionHandler = liftIO $ runExceptT $ runReaderT action ctx + + throwErrorAsHandlerException :: Either SparError a -> Handler a + throwErrorAsHandlerException (Left err) = + sparToServantErrWithLogging (sparCtxLogger ctx) err >>= throwError + throwErrorAsHandlerException (Right a) = pure a instance MonadHttp Spar where getManager = asks sparCtxHttpManager @@ -237,12 +270,15 @@ data VerdictHandlerResult | VerifyHandlerError { _vhrLabel :: ST, _vhrMessage :: ST } catchVerdictErrors :: Spar VerdictHandlerResult -> Spar VerdictHandlerResult -catchVerdictErrors = (`catchError` pure . hndlr) +catchVerdictErrors = (`catchError` hndlr) where - hndlr :: SparError -> VerdictHandlerResult - hndlr err = case sparToWaiError err of - Right (werr :: Wai.Error) -> VerifyHandlerError (cs $ Wai.label werr) (cs $ Wai.message werr) - Left (serr :: ServantErr) -> VerifyHandlerError "unknown-error" (cs (errReasonPhrase serr) <> " " <> cs (errBody serr)) + hndlr :: SparError -> Spar VerdictHandlerResult + hndlr err = do + logr <- asks sparCtxLogger + waiErr <- renderSparErrorWithLogging logr err + pure $ case waiErr of + Right (werr :: Wai.Error) -> VerifyHandlerError (cs $ Wai.label werr) (cs $ Wai.message werr) + Left (serr :: ServantErr) -> VerifyHandlerError "unknown-error" (cs (errReasonPhrase serr) <> " " <> cs (errBody serr)) verdictHandlerResult :: HasCallStack => Maybe BindCookie -> SAML.AccessVerdict -> Spar VerdictHandlerResult verdictHandlerResult bindCky = catchVerdictErrors . \case @@ -263,7 +299,7 @@ verdictHandlerResult bindCky = catchVerdictErrors . \case -- This is the first SSO authentication, so we auto-create a user. We know the user -- has not been created via SCIM because then we would've ended up in the -- "reauthentication" branch, so we pass 'ManagedByWire'. - (Nothing, Nothing) -> createUser userref Nothing ManagedByWire + (Nothing, Nothing) -> autoprovisionSamlUser userref Nothing ManagedByWire -- SSO reauthentication (Nothing, Just uid) -> pure uid -- Bind existing user (non-SSO or SSO) to ssoid diff --git a/services/spar/src/Spar/Data.hs b/services/spar/src/Spar/Data.hs index cc6ecd3a7d3..d88a2cdf932 100644 --- a/services/spar/src/Spar/Data.hs +++ b/services/spar/src/Spar/Data.hs @@ -508,33 +508,31 @@ deleteTeamScimTokens team = do -- in a separate column otherwise, allowing for fast version filtering on the database. insertScimUser :: (HasCallStack, MonadClient m) - => UserId -> ScimC.User.StoredUser ScimUserExtra -> m () + => UserId -> ScimC.User.StoredUser SparTag -> m () insertScimUser uid usr = retry x5 . write ins $ - params Quorum (uid, usr) + params Quorum (uid, WrappedScimStoredUser usr) where - ins :: PrepQuery W (UserId, ScimC.User.StoredUser ScimUserExtra) () + ins :: PrepQuery W (UserId, WrappedScimStoredUser SparTag) () ins = "INSERT INTO scim_user (id, json) VALUES (?, ?)" getScimUser :: (HasCallStack, MonadClient m) - => UserId -> m (Maybe (ScimC.User.StoredUser ScimUserExtra)) -getScimUser uid = runIdentity <$$> + => UserId -> m (Maybe (ScimC.User.StoredUser SparTag)) +getScimUser uid = fromWrappedScimStoredUser . runIdentity <$$> (retry x1 . query1 sel $ params Quorum (Identity uid)) where - sel :: PrepQuery R (Identity UserId) - (Identity (ScimC.User.StoredUser ScimUserExtra)) + sel :: PrepQuery R (Identity UserId) (Identity (WrappedScimStoredUser SparTag)) sel = "SELECT json FROM scim_user WHERE id = ?" -- | Return all users that can be found under a given list of 'UserId's. If some cannot be found, -- the output list will just be shorter (no errors). getScimUsers :: (HasCallStack, MonadClient m) - => [UserId] -> m [ScimC.User.StoredUser ScimUserExtra] -getScimUsers uids = runIdentity <$$> + => [UserId] -> m [ScimC.User.StoredUser SparTag] +getScimUsers uids = fromWrappedScimStoredUser . runIdentity <$$> retry x1 (query sel (params Quorum (Identity uids))) where - sel :: PrepQuery R (Identity [UserId]) - (Identity (ScimC.User.StoredUser ScimUserExtra)) + sel :: PrepQuery R (Identity [UserId]) (Identity (WrappedScimStoredUser SparTag)) sel = "SELECT json FROM scim_user WHERE id in ?" diff --git a/services/spar/src/Spar/Data/Instances.hs b/services/spar/src/Spar/Data/Instances.hs index 962f2bc22af..6a2bd00aaf2 100644 --- a/services/spar/src/Spar/Data/Instances.hs +++ b/services/spar/src/Spar/Data/Instances.hs @@ -21,12 +21,13 @@ import Data.String.Conversions import Data.X509 (SignedCertificate) import SAML2.Util (parseURI') import Spar.Types +import Spar.Scim.Types import Text.XML.DSig (renderKeyInfo, parseKeyInfo) import URI.ByteString import qualified Data.Aeson as Aeson import qualified SAML2.WebSSO as SAML -import qualified Web.Scim.Class.User as Scim +import qualified Web.Scim.Schema.User as Scim instance Cql SAML.XmlText where @@ -86,9 +87,13 @@ toVerdictFormat (VerdictFormatConMobile, Just succredir, Just errredir) = Just $ toVerdictFormat _ = Nothing deriving instance Cql ScimToken -instance (FromJSON extra, ToJSON extra) => Cql (Scim.StoredUser extra) where + +instance ( Scim.UserTypes tag, uid ~ Scim.UserId tag, extra ~ Scim.UserExtra tag + , FromJSON extra, ToJSON extra + , FromJSON uid, ToJSON uid + ) => Cql (WrappedScimStoredUser tag) where ctype = Tagged BlobColumn - toCql = CqlBlob . Aeson.encode + toCql = CqlBlob . Aeson.encode . fromWrappedScimStoredUser - fromCql (CqlBlob t) = Aeson.eitherDecode t + fromCql (CqlBlob t) = WrappedScimStoredUser <$> Aeson.eitherDecode t fromCql _ = fail "Scim.StoredUser: expected CqlBlob" diff --git a/services/spar/src/Spar/Error.hs b/services/spar/src/Spar/Error.hs index c94b139f3c5..e91e3620308 100644 --- a/services/spar/src/Spar/Error.hs +++ b/services/spar/src/Spar/Error.hs @@ -11,8 +11,8 @@ module Spar.Error ( SparError , SparCustomError(..) , throwSpar - , sparToServantErr - , sparToWaiError + , sparToServantErrWithLogging + , renderSparErrorWithLogging ) where import Imports @@ -23,8 +23,11 @@ import Network.HTTP.Types.Status import Servant import Spar.Types (TTLError) +import qualified Network.Wai as Wai import qualified Network.Wai.Utilities.Error as Wai +import qualified Network.Wai.Utilities.Server as Wai import qualified SAML2.WebSSO as SAML +import qualified System.Logger as Log type SparError = SAML.Error SparCustomError @@ -76,8 +79,18 @@ data SparCustomError | SparProvisioningTokenLimitReached deriving (Eq, Show) +sparToServantErrWithLogging :: MonadIO m => Log.Logger -> SparError -> m ServantErr +sparToServantErrWithLogging logger err = do + let errServant = sparToServantErr err + liftIO $ Wai.logError logger (Nothing :: Maybe Wai.Request) (servantToWaiError errServant) + pure errServant + +servantToWaiError :: ServantErr -> Wai.Error +servantToWaiError (ServantErr code phrase body _headers) = + Wai.Error (Status code (cs phrase)) (cs phrase) (cs body) + sparToServantErr :: SparError -> ServantErr -sparToServantErr = either id waiToServant . sparToWaiError +sparToServantErr = either id waiToServant . renderSparError waiToServant :: Wai.Error -> ServantErr waiToServant waierr@(Wai.Error status label _) = ServantErr @@ -87,58 +100,64 @@ waiToServant waierr@(Wai.Error status label _) = ServantErr , errHeaders = [] } -sparToWaiError :: SparError -> Either ServantErr Wai.Error -sparToWaiError (SAML.CustomError SparNoSuchRequest) = Right $ Wai.Error status500 "server-error" "AuthRequest seems to have disappeared (could not find verdict format)." -sparToWaiError (SAML.CustomError (SparNoRequestRefInResponse msg)) = Right $ Wai.Error status400 "server-error-unsupported-saml" ("The IdP needs to provide an InResponseTo attribute in the assertion: " <> msg) -sparToWaiError (SAML.CustomError (SparCouldNotSubstituteSuccessURI msg)) = Right $ Wai.Error status400 "bad-success-redirect" ("re-parsing the substituted URI failed: " <> msg) -sparToWaiError (SAML.CustomError (SparCouldNotSubstituteFailureURI msg)) = Right $ Wai.Error status400 "bad-failure-redirect" ("re-parsing the substituted URI failed: " <> msg) -sparToWaiError (SAML.CustomError (SparBadInitiateLoginQueryParams label)) = Right $ Wai.Error status400 label label -sparToWaiError (SAML.CustomError (SparBindFromWrongOrNoTeam msg)) = Right $ Wai.Error status403 "bad-team" ("Forbidden: wrong user team " <> msg) -sparToWaiError (SAML.CustomError SparBindUserRefTaken) = Right $ Wai.Error status403 "subject-id-taken" "Forbidden: SubjectID is used by another wire user. If you have an old user bound to this IdP, unbind or delete that user." - -sparToWaiError (SAML.CustomError (SparBadUserName msg)) = Right $ Wai.Error status400 "bad-username" ("Bad UserName in SAML response, except len [1, 128]: " <> msg) +renderSparErrorWithLogging :: MonadIO m => Log.Logger -> SparError -> m (Either ServantErr Wai.Error) +renderSparErrorWithLogging logger err = do + let errPossiblyWai = renderSparError err + liftIO $ Wai.logError logger (Nothing :: Maybe Wai.Request) (either servantToWaiError id $ errPossiblyWai) + pure errPossiblyWai + +renderSparError :: SparError -> Either ServantErr Wai.Error +renderSparError (SAML.CustomError SparNoSuchRequest) = Right $ Wai.Error status500 "server-error" "AuthRequest seems to have disappeared (could not find verdict format)." +renderSparError (SAML.CustomError (SparNoRequestRefInResponse msg)) = Right $ Wai.Error status400 "server-error-unsupported-saml" ("The IdP needs to provide an InResponseTo attribute in the assertion: " <> msg) +renderSparError (SAML.CustomError (SparCouldNotSubstituteSuccessURI msg)) = Right $ Wai.Error status400 "bad-success-redirect" ("re-parsing the substituted URI failed: " <> msg) +renderSparError (SAML.CustomError (SparCouldNotSubstituteFailureURI msg)) = Right $ Wai.Error status400 "bad-failure-redirect" ("re-parsing the substituted URI failed: " <> msg) +renderSparError (SAML.CustomError (SparBadInitiateLoginQueryParams label)) = Right $ Wai.Error status400 label label +renderSparError (SAML.CustomError (SparBindFromWrongOrNoTeam msg)) = Right $ Wai.Error status403 "bad-team" ("Forbidden: wrong user team " <> msg) +renderSparError (SAML.CustomError SparBindUserRefTaken) = Right $ Wai.Error status403 "subject-id-taken" "Forbidden: SubjectID is used by another wire user. If you have an old user bound to this IdP, unbind or delete that user." + +renderSparError (SAML.CustomError (SparBadUserName msg)) = Right $ Wai.Error status400 "bad-username" ("Bad UserName in SAML response, except len [1, 128]: " <> msg) -- Brig-specific errors -sparToWaiError (SAML.CustomError SparNoBodyInBrigResponse) = Right $ Wai.Error status502 "bad-upstream" "Failed to get a response from an upstream server." -sparToWaiError (SAML.CustomError (SparCouldNotParseBrigResponse msg)) = Right $ Wai.Error status502 "bad-upstream" ("Could not parse response body: " <> msg) -sparToWaiError (SAML.CustomError SparReAuthRequired) = Right $ Wai.Error status403 "access-denied" "This operation requires reauthentication." -sparToWaiError (SAML.CustomError (SparBrigError msg)) = Right $ Wai.Error status500 "bad-upstream" msg -sparToWaiError (SAML.CustomError (SparBrigErrorWith status msg)) = Right $ Wai.Error status "bad-upstream" msg +renderSparError (SAML.CustomError SparNoBodyInBrigResponse) = Right $ Wai.Error status502 "bad-upstream" "Failed to get a response from an upstream server." +renderSparError (SAML.CustomError (SparCouldNotParseBrigResponse msg)) = Right $ Wai.Error status502 "bad-upstream" ("Could not parse response body: " <> msg) +renderSparError (SAML.CustomError SparReAuthRequired) = Right $ Wai.Error status403 "access-denied" "This operation requires reauthentication." +renderSparError (SAML.CustomError (SparBrigError msg)) = Right $ Wai.Error status500 "bad-upstream" msg +renderSparError (SAML.CustomError (SparBrigErrorWith status msg)) = Right $ Wai.Error status "bad-upstream" msg -- Galley-specific errors -sparToWaiError (SAML.CustomError SparNoBodyInGalleyResponse) = Right $ Wai.Error status502 "bad-upstream" "Failed to get a response from an upstream server." -sparToWaiError (SAML.CustomError (SparCouldNotParseGalleyResponse msg)) = Right $ Wai.Error status502 "bad-upstream" ("Could not parse response body: " <> msg) -sparToWaiError (SAML.CustomError (SparGalleyError msg)) = Right $ Wai.Error status500 "bad-upstream" msg -sparToWaiError (SAML.CustomError SparCouldNotRetrieveCookie) = Right $ Wai.Error status502 "bad-upstream" "Unable to get a cookie from an upstream server." -sparToWaiError (SAML.CustomError (SparCassandraError msg)) = Right $ Wai.Error status500 "server-error" msg -- TODO: should we be more specific here and make it 'db-error'? -sparToWaiError (SAML.CustomError (SparCassandraTTLError ttlerr)) = Right $ Wai.Error status400 "ttl-error" (cs $ show ttlerr) -sparToWaiError (SAML.UnknownIdP _msg) = Right $ Wai.Error status404 "not-found" "IdP not found." -sparToWaiError (SAML.Forbidden msg) = Right $ Wai.Error status403 "forbidden" ("Forbidden: " <> msg) -sparToWaiError (SAML.BadSamlResponseBase64Error msg) = Right $ Wai.Error status400 "bad-response-encoding" ("Bad response: base64 error: " <> cs msg) -sparToWaiError (SAML.BadSamlResponseXmlError msg) = Right $ Wai.Error status400 "bad-response-xml" ("Bad response: XML parse error: " <> cs msg) -sparToWaiError (SAML.BadSamlResponseSamlError msg) = Right $ Wai.Error status400 "bad-response-saml" ("Bad response: SAML parse error: " <> cs msg) -sparToWaiError SAML.BadSamlResponseFormFieldMissing = Right $ Wai.Error status400 "bad-response-saml" ("Bad response: SAMLResponse form field missing from HTTP body") -sparToWaiError SAML.BadSamlResponseIssuerMissing = Right $ Wai.Error status400 "bad-response-saml" ("Bad response: no Issuer in AuthnResponse") -sparToWaiError SAML.BadSamlResponseNoAssertions = Right $ Wai.Error status400 "bad-response-saml" ("Bad response: no assertions in AuthnResponse") -sparToWaiError SAML.BadSamlResponseAssertionWithoutID = Right $ Wai.Error status400 "bad-response-saml" ("Bad response: assertion without ID") -sparToWaiError (SAML.BadSamlResponseInvalidSignature msg) = Right $ Wai.Error status400 "bad-response-signature" (cs msg) -sparToWaiError (SAML.CustomError SparNotFound) = Right $ Wai.Error status404 "not-found" "Could not find IdP." -sparToWaiError (SAML.CustomError SparMissingZUsr) = Right $ Wai.Error status400 "client-error" "[header] 'Z-User' required" -sparToWaiError (SAML.CustomError SparNotInTeam) = Right $ Wai.Error status403 "no-team-member" "Requesting user is not a team member or not a member of this team." -sparToWaiError (SAML.CustomError SparNotTeamOwner) = Right $ Wai.Error status403 "insufficient-permissions" "You need to be a team owner." -sparToWaiError (SAML.CustomError SparInitLoginWithAuth) = Right $ Wai.Error status403 "login-with-auth" "This end-point is only for login, not binding." -sparToWaiError (SAML.CustomError SparInitBindWithoutAuth) = Right $ Wai.Error status403 "bind-without-auth" "This end-point is only for binding, not login." -sparToWaiError (SAML.CustomError SparBindUserDisappearedFromBrig) = Right $ Wai.Error status404 "bind-user-disappeared" "Your user appears to have been deleted?" -sparToWaiError SAML.UnknownError = Right $ Wai.Error status500 "server-error" "Unknown server error." -sparToWaiError (SAML.BadServerConfig msg) = Right $ Wai.Error status500 "server-error" ("Error in server config: " <> msg) -sparToWaiError (SAML.InvalidCert msg) = Right $ Wai.Error status500 "invalid-certificate" ("Error in idp certificate: " <> msg) +renderSparError (SAML.CustomError SparNoBodyInGalleyResponse) = Right $ Wai.Error status502 "bad-upstream" "Failed to get a response from an upstream server." +renderSparError (SAML.CustomError (SparCouldNotParseGalleyResponse msg)) = Right $ Wai.Error status502 "bad-upstream" ("Could not parse response body: " <> msg) +renderSparError (SAML.CustomError (SparGalleyError msg)) = Right $ Wai.Error status500 "bad-upstream" msg +renderSparError (SAML.CustomError SparCouldNotRetrieveCookie) = Right $ Wai.Error status502 "bad-upstream" "Unable to get a cookie from an upstream server." +renderSparError (SAML.CustomError (SparCassandraError msg)) = Right $ Wai.Error status500 "server-error" msg -- TODO: should we be more specific here and make it 'db-error'? +renderSparError (SAML.CustomError (SparCassandraTTLError ttlerr)) = Right $ Wai.Error status400 "ttl-error" (cs $ show ttlerr) +renderSparError (SAML.UnknownIdP _msg) = Right $ Wai.Error status404 "not-found" "IdP not found." +renderSparError (SAML.Forbidden msg) = Right $ Wai.Error status403 "forbidden" ("Forbidden: " <> msg) +renderSparError (SAML.BadSamlResponseBase64Error msg) = Right $ Wai.Error status400 "bad-response-encoding" ("Bad response: base64 error: " <> cs msg) +renderSparError (SAML.BadSamlResponseXmlError msg) = Right $ Wai.Error status400 "bad-response-xml" ("Bad response: XML parse error: " <> cs msg) +renderSparError (SAML.BadSamlResponseSamlError msg) = Right $ Wai.Error status400 "bad-response-saml" ("Bad response: SAML parse error: " <> cs msg) +renderSparError SAML.BadSamlResponseFormFieldMissing = Right $ Wai.Error status400 "bad-response-saml" ("Bad response: SAMLResponse form field missing from HTTP body") +renderSparError SAML.BadSamlResponseIssuerMissing = Right $ Wai.Error status400 "bad-response-saml" ("Bad response: no Issuer in AuthnResponse") +renderSparError SAML.BadSamlResponseNoAssertions = Right $ Wai.Error status400 "bad-response-saml" ("Bad response: no assertions in AuthnResponse") +renderSparError SAML.BadSamlResponseAssertionWithoutID = Right $ Wai.Error status400 "bad-response-saml" ("Bad response: assertion without ID") +renderSparError (SAML.BadSamlResponseInvalidSignature msg) = Right $ Wai.Error status400 "bad-response-signature" (cs msg) +renderSparError (SAML.CustomError SparNotFound) = Right $ Wai.Error status404 "not-found" "Could not find IdP." +renderSparError (SAML.CustomError SparMissingZUsr) = Right $ Wai.Error status400 "client-error" "[header] 'Z-User' required" +renderSparError (SAML.CustomError SparNotInTeam) = Right $ Wai.Error status403 "no-team-member" "Requesting user is not a team member or not a member of this team." +renderSparError (SAML.CustomError SparNotTeamOwner) = Right $ Wai.Error status403 "insufficient-permissions" "You need to be a team owner." +renderSparError (SAML.CustomError SparInitLoginWithAuth) = Right $ Wai.Error status403 "login-with-auth" "This end-point is only for login, not binding." +renderSparError (SAML.CustomError SparInitBindWithoutAuth) = Right $ Wai.Error status403 "bind-without-auth" "This end-point is only for binding, not login." +renderSparError (SAML.CustomError SparBindUserDisappearedFromBrig) = Right $ Wai.Error status404 "bind-user-disappeared" "Your user appears to have been deleted?" +renderSparError SAML.UnknownError = Right $ Wai.Error status500 "server-error" "Unknown server error." +renderSparError (SAML.BadServerConfig msg) = Right $ Wai.Error status500 "server-error" ("Error in server config: " <> msg) +renderSparError (SAML.InvalidCert msg) = Right $ Wai.Error status500 "invalid-certificate" ("Error in idp certificate: " <> msg) -- Errors related to IdP creation -sparToWaiError (SAML.CustomError (SparNewIdPBadMetaUrl msg)) = Right $ Wai.Error status400 "idp-error" ("Bad or unresponsive metadata url: " <> msg) -sparToWaiError (SAML.CustomError SparNewIdPBadMetaSig) = Right $ Wai.Error status400 "invalid-signature" "bad metadata signature" -sparToWaiError (SAML.CustomError (SparNewIdPBadReqUrl msg)) = Right $ Wai.Error status400 "invalid-req-url" ("bad request url: " <> msg) -sparToWaiError (SAML.CustomError SparNewIdPPubkeyMismatch) = Right $ Wai.Error status400 "key-mismatch" "public keys in body, metadata do not match" -sparToWaiError (SAML.CustomError SparNewIdPAlreadyInUse) = Right $ Wai.Error status400 "idp-already-in-use" "an idp issuer can only be used within one team" -sparToWaiError (SAML.CustomError (SparNewIdPWantHttps msg)) = Right $ Wai.Error status400 "idp-must-be-https" ("an idp request uri must be https, not http or other: " <> msg) +renderSparError (SAML.CustomError (SparNewIdPBadMetaUrl msg)) = Right $ Wai.Error status400 "idp-error" ("Bad or unresponsive metadata url: " <> msg) +renderSparError (SAML.CustomError SparNewIdPBadMetaSig) = Right $ Wai.Error status400 "invalid-signature" "bad metadata signature" +renderSparError (SAML.CustomError (SparNewIdPBadReqUrl msg)) = Right $ Wai.Error status400 "invalid-req-url" ("bad request url: " <> msg) +renderSparError (SAML.CustomError SparNewIdPPubkeyMismatch) = Right $ Wai.Error status400 "key-mismatch" "public keys in body, metadata do not match" +renderSparError (SAML.CustomError SparNewIdPAlreadyInUse) = Right $ Wai.Error status400 "idp-already-in-use" "an idp issuer can only be used within one team" +renderSparError (SAML.CustomError (SparNewIdPWantHttps msg)) = Right $ Wai.Error status400 "idp-must-be-https" ("an idp request uri must be https, not http or other: " <> msg) -- Errors related to provisioning -sparToWaiError (SAML.CustomError (SparProvisioningNoSingleIdP msg)) = Right $ Wai.Error status400 "no-single-idp" ("Team should have exactly one IdP configured: " <> msg) -sparToWaiError (SAML.CustomError SparProvisioningTokenLimitReached) = Right $ Wai.Error status403 "token-limit-reached" "The limit of provisioning tokens per team has been reached" +renderSparError (SAML.CustomError (SparProvisioningNoSingleIdP msg)) = Right $ Wai.Error status400 "no-single-idp" ("Team should have exactly one IdP configured: " <> msg) +renderSparError (SAML.CustomError SparProvisioningTokenLimitReached) = Right $ Wai.Error status403 "token-limit-reached" "The limit of provisioning tokens per team has been reached" -- Other -sparToWaiError (SAML.CustomServant err) = Left err +renderSparError (SAML.CustomServant err) = Left err diff --git a/services/spar/src/Spar/Intra/Brig.hs b/services/spar/src/Spar/Intra/Brig.hs index 0202685afd0..41ea6c0f085 100644 --- a/services/spar/src/Spar/Intra/Brig.hs +++ b/services/spar/src/Spar/Intra/Brig.hs @@ -12,6 +12,7 @@ module Spar.Intra.Brig , setBrigUserHandle , setBrigUserManagedBy , setBrigUserRichInfo + , checkHandleAvailable , bindBrigUser , deleteBrigUser , createBrigUser @@ -45,7 +46,6 @@ import Network.HTTP.Types.Method import Spar.Error import Web.Cookie -import qualified Data.Text as Text import qualified SAML2.WebSSO as SAML @@ -89,7 +89,7 @@ instance MonadSparToBrig m => MonadSparToBrig (ReaderT r m) where call = lift . call --- | Create a user on brig. +-- | Create a user on brig. User name is derived from 'SAML.UserRef'. createBrigUser :: (HasCallStack, MonadSparToBrig m) => SAML.UserRef -- ^ SSO identity @@ -102,11 +102,15 @@ createBrigUser suid (Id buid) teamid mbName managedBy = do uname :: Name <- case mbName of Just n -> pure n Nothing -> do - let subject = suid ^. SAML.uidSubject - badName = throwSpar . SparBadUserName $ SAML.encodeElem subject - mkName = Name . fromRange <$> - (fmap (Text.take 128) . SAML.shortShowNameID >=> checked @ST @1 @128) subject - maybe badName pure mkName + -- 1. use 'SAML.unsafeShowNameID' to get a 'Name'. rationale: it does not need to be + -- unique. + let subj = suid ^. SAML.uidSubject + subjtxt = SAML.unsafeShowNameID subj + muname = checked @ST @1 @128 subjtxt + err = SparBadUserName $ "must have >= 1, <= 128 chars: " <> cs subjtxt + case muname of + Just uname -> pure . Name . fromRange $ uname + Nothing -> throwSpar err let newUser :: NewUser newUser = NewUser @@ -254,6 +258,25 @@ setBrigUserRichInfo buid richInfo = do | otherwise -> throwSpar . SparBrigError . cs $ "set richInfo failed with status " <> show sCode +-- | At the time of writing this, @HEAD /users/handles/:uid@ does not use the 'UserId' for +-- anything but authorization. +checkHandleAvailable :: (HasCallStack, MonadSparToBrig m) => Handle -> UserId -> m Bool +checkHandleAvailable hnd buid = do + resp <- call + $ method HEAD + . paths ["users", "handles", toByteString' hnd] + . header "Z-User" (toByteString' buid) + . header "Z-Connection" "" + let sCode = statusCode resp + if | sCode == 200 -- handle exists + -> pure False + | sCode == 404 -- handle not found + -> pure True + | sCode < 500 + -> throwSpar . SparBrigErrorWith (responseStatus resp) $ "check handle failed" + | otherwise + -> throwSpar . SparBrigError . cs $ "check handle failed with status " <> show sCode + -- | This works under the assumption that the user must exist on brig. If it does not, brig -- responds with 404 and this function returns 'False'. bindBrigUser :: (HasCallStack, MonadSparToBrig m) => UserId -> SAML.UserRef -> m Bool @@ -273,9 +296,9 @@ deleteBrigUser buid = do if | sCode < 300 -> pure () | inRange (400, 499) sCode - -> throwSpar . SparBrigErrorWith (responseStatus resp) $ "failed to delete user" - | otherwise -> throwSpar . SparBrigError . cs - $ "delete user failed with status " <> show sCode + -> throwSpar $ SparBrigErrorWith (responseStatus resp) "failed to delete user" + | otherwise + -> throwSpar $ SparBrigError ("delete user failed with status " <> cs (show sCode)) -- | Check that a user id exists on brig and has a team id. isTeamUser :: (HasCallStack, MonadSparToBrig m) => UserId -> m Bool diff --git a/services/spar/src/Spar/Run.hs b/services/spar/src/Spar/Run.hs index c9e52356449..00590dd0a5e 100644 --- a/services/spar/src/Spar/Run.hs +++ b/services/spar/src/Spar/Run.hs @@ -7,7 +7,7 @@ -- @exec/Main.hs@, but it's just a wrapper over 'runServer'.) module Spar.Run ( initCassandra - , runServer + , runServer, mkApp ) where import Imports @@ -16,7 +16,6 @@ import Cassandra as Cas import Control.Lens import Data.Default (def) import Data.List.NonEmpty as NE -import Data.Metrics (metrics) import Data.Metrics.Servant (routesToPaths) import Data.String.Conversions import Network.Wai (Application, Middleware) @@ -39,7 +38,6 @@ import qualified Network.Wai.Middleware.Prometheus as Promth import qualified Network.Wai.Utilities.Server as WU import qualified SAML2.WebSSO as SAML import qualified Spar.Data as Data -import qualified System.Logger as Log import qualified System.Logger.Extended as Log @@ -74,12 +72,19 @@ initCassandra opts lgr = do -- this would create the "Listening on..." log message there, but it may also have other benefits. runServer :: Opts -> IO () runServer sparCtxOpts = do - sparCtxLogger <- Log.mkLogger (toLevel $ saml sparCtxOpts ^. SAML.cfgLogLevel) (logNetStrings sparCtxOpts) - mx <- metrics - sparCtxCas <- initCassandra sparCtxOpts sparCtxLogger let settings = Warp.defaultSettings & Warp.setHost (fromString shost) . Warp.setPort sport shost :: String = sparCtxOpts ^. to saml . SAML.cfgSPHost sport :: Int = sparCtxOpts ^. to saml . SAML.cfgSPPort + (wrappedApp, ctxOpts) <- mkApp sparCtxOpts + let logger = sparCtxLogger ctxOpts + Log.info logger . Log.msg $ "Listening on " <> shost <> ":" <> show sport + WU.runSettingsWithShutdown settings wrappedApp 5 + +mkApp :: Opts -> IO (Application, Env) +mkApp sparCtxOpts = do + let logLevel = toLevel $ saml sparCtxOpts ^. SAML.cfgLogLevel + sparCtxLogger <- Log.mkLogger logLevel (logNetStrings sparCtxOpts) + sparCtxCas <- initCassandra sparCtxOpts sparCtxLogger sparCtxHttpManager <- newManager defaultManagerSettings let sparCtxHttpBrig = Bilge.host (sparCtxOpts ^. to brig . epHost . to cs) @@ -90,19 +95,30 @@ runServer sparCtxOpts = do . Bilge.port (sparCtxOpts ^. to galley . epPort) $ Bilge.empty let wrappedApp - = WU.catchErrors sparCtxLogger mx + = WU.heavyDebugLogging heavyLogOnly logLevel sparCtxLogger . promthRun + . WU.catchErrors sparCtxLogger [] + -- Error 'Response's are usually not thrown as exceptions, but logged in + -- 'renderSparErrorWithLogging' before the 'Application' can construct a 'Response' + -- value, when there is still all the type information around. 'WU.catchErrors' is + -- still here for errors outside the power of the 'Application', like network + -- outages. . SAML.setHttpCachePolicy . lookupRequestIdMiddleware $ \sparCtxRequestId -> app Env {..} - Log.info sparCtxLogger . Log.msg $ "Listening on " <> shost <> ":" <> show sport - WU.runSettingsWithShutdown settings wrappedApp 5 + heavyLogOnly :: (Wai.Request, LByteString) -> Maybe (Wai.Request, LByteString) + heavyLogOnly out@(req, _) = + if Wai.requestMethod req == "POST" && Wai.pathInfo req == ["sso", "finalize-login"] + then Just out + else Nothing + pure (wrappedApp, let sparCtxRequestId = RequestId "N/A" in Env {..}) lookupRequestIdMiddleware :: (RequestId -> Application) -> Application lookupRequestIdMiddleware mkapp req cont = do let reqid = maybe def RequestId $ lookupRequestId req mkapp reqid req cont +-- | This does not catch errors, so it must be called outside of 'WU.catchErrors'. promthRun :: Middleware promthRun = Promth.prometheus conf . Promth.instrumentHandlerValue promthNormalize where diff --git a/services/spar/src/Spar/Scim.hs b/services/spar/src/Spar/Scim.hs index d5a04fbfb5a..923285b9242 100644 --- a/services/spar/src/Spar/Scim.hs +++ b/services/spar/src/Spar/Scim.hs @@ -58,7 +58,6 @@ import Spar.App (Spar) import Spar.Scim.Types import Spar.Scim.Auth import Spar.Scim.User -import Spar.Types import qualified SAML2.WebSSO as SAML @@ -80,9 +79,9 @@ apiScim :: ServerT APIScim Spar apiScim = hoistScim (toServant (Scim.siteServer configuration)) :<|> apiScimToken where - hoistScim = hoistServer (Proxy @(Scim.SiteAPI ScimToken ScimUserExtra)) + hoistScim = hoistServer (Proxy @(Scim.SiteAPI SparTag)) (Scim.fromScimHandler fromError) fromError = throwError . SAML.CustomServant . Scim.scimToServantErr -instance Scim.Group.GroupDB Spar where +instance Scim.Group.GroupDB SparTag Spar where -- TODO diff --git a/services/spar/src/Spar/Scim/Auth.hs b/services/spar/src/Spar/Scim/Auth.hs index f81511c10da..c7f17d79940 100644 --- a/services/spar/src/Spar/Scim/Auth.hs +++ b/services/spar/src/Spar/Scim/Auth.hs @@ -38,12 +38,7 @@ import qualified Web.Scim.Handler as Scim import qualified Web.Scim.Schema.Error as Scim -- | An instance that tells @hscim@ how authentication should be done for SCIM routes. -instance Scim.Class.Auth.AuthDB Spar where - -- To authenticate, you need to provide a 'ScimToken' - type AuthData Spar = ScimToken - -- The result of authentication (passed to our handlers) is 'ScimTokenInfo' - type AuthInfo Spar = ScimTokenInfo - +instance Scim.Class.Auth.AuthDB SparTag Spar where -- Validate and resolve a given token authCheck :: Maybe ScimToken -> Scim.ScimHandler Spar ScimTokenInfo authCheck Nothing = diff --git a/services/spar/src/Spar/Scim/Types.hs b/services/spar/src/Spar/Scim/Types.hs index 2776d79abab..21d2d99f6e9 100644 --- a/services/spar/src/Spar/Scim/Types.hs +++ b/services/spar/src/Spar/Scim/Types.hs @@ -38,8 +38,11 @@ import Spar.Types import qualified Data.HashMap.Strict as HM import qualified Data.Text as T import qualified SAML2.WebSSO as SAML -import qualified Web.Scim.Schema.User as Scim.User +import qualified Web.Scim.Class.Auth as Scim.Auth +import qualified Web.Scim.Class.Group as Scim.Group +import qualified Web.Scim.Class.User as Scim.User import qualified Web.Scim.Schema.Schema as Scim +import qualified Web.Scim.Schema.User as Scim.User import qualified Web.Scim.Server as Scim @@ -56,6 +59,59 @@ userExtraURN = "urn:wire:scim:schemas:profile:1.0" ---------------------------------------------------------------------------- -- @hscim@ extensions and wrappers +data SparTag + +instance Scim.User.UserTypes SparTag where + type UserId SparTag = UserId + type UserExtra SparTag = ScimUserExtra + +instance Scim.Group.GroupTypes SparTag where + type GroupId SparTag = () + +instance Scim.Auth.AuthTypes SparTag where + type AuthData SparTag = ScimToken + type AuthInfo SparTag = ScimTokenInfo + + +-- | Wrapper to work around complications with type synonym family application in instances. +-- +-- Background: 'SparTag' is used to instantiate the open type families in the classes +-- @Scim.UserTypes@, @Scim.GroupTypes@, @Scim.AuthTypes@. Those type families are not +-- injective, and in general they shouldn't be: it should be possible to map two tags to +-- different user ids, but the same extra user info. This makes the type of the 'Cql' +-- instance for @'Scim.StoredUser' tag@ undecidable: if the type checker encounters a +-- constraint that gives it the user id and extra info, it can't compute the tag from that to +-- look up the instance. +-- +-- Possible solutions: +-- +-- * what we're doing here: wrap the type synonyms we can't instantiate into newtypes in the +-- code using hscim. + +-- * do not instantiate the type synonym, but its value (in this case +-- @Web.Scim.Schema.Meta.WithMeta (Web.Scim.Schema.Common.WithId (Id U) (Scim.User tag))@ +-- +-- * Use newtypes instead type in hscim. This will carry around the tag as a data type rather +-- than applying it, which in turn will enable ghc to type-check instances like @Cql +-- (Scim.StoredUser tag)@. +-- +-- * make the type classes parametric in not only the tag, but also all the values of the type +-- families, and add functional dependencies, like this: @class UserInfo tag uid extrainfo | +-- (uid, extrainfo) -> tag, tag -> (uid, extrainfo)@. this will make writing the instances +-- only a little more awkward, but the rest of the code should change very little, as long +-- as we just apply the type families rather than explicitly imposing the class constraints. +-- +-- * given a lot of time: extend ghc with something vaguely similar to @AllowAmbigiousTypes@, +-- where the instance typechecks, and non-injectivity errors are raised when checking the +-- constraint that "calls" the instance. :) +newtype WrappedScimStoredUser tag = WrappedScimStoredUser + { fromWrappedScimStoredUser :: Scim.User.StoredUser tag } + +-- | See 'WrappedScimStoredUser'. +newtype WrappedScimUser tag = WrappedScimUser + { fromWrappedScimUser :: Scim.User.User tag } + + -- | Extra Wire-specific data contained in a SCIM user profile. data ScimUserExtra = ScimUserExtra { _sueRichInfo :: RichInfo @@ -105,7 +161,7 @@ parseRichInfo v = -- the 'Scim.User.User' and b) be valid in regard to our own user schema requirements (only -- certain characters allowed in handles, etc). data ValidScimUser = ValidScimUser - { _vsuUser :: Scim.User.User ScimUserExtra + { _vsuUser :: Scim.User.User SparTag -- SAML SSO , _vsuSAMLUserRef :: SAML.UserRef @@ -189,7 +245,7 @@ instance ToJSON ScimTokenList where -- Servant APIs type APIScim - = OmitDocs :> "v2" :> Scim.SiteAPI ScimToken ScimUserExtra + = OmitDocs :> "v2" :> Scim.SiteAPI SparTag :<|> "auth-tokens" :> APIScimToken type APIScimToken diff --git a/services/spar/src/Spar/Scim/User.hs b/services/spar/src/Spar/Scim/User.hs index be51c0f9142..be9a7291d24 100644 --- a/services/spar/src/Spar/Scim/User.hs +++ b/services/spar/src/Spar/Scim/User.hs @@ -19,10 +19,12 @@ module Spar.Scim.User ( -- * Internals (for testing) validateScimUser' , toScimStoredUser' + , mkUserRef ) where import Imports -import Brig.Types.User as Brig +import Brig.Types.User as BrigTypes +import Spar.Intra.Brig as Brig import Control.Lens hiding ((.=), Strict) import Control.Monad.Except import Crypto.Hash @@ -33,7 +35,7 @@ import Data.String.Conversions import Galley.Types.Teams as Galley import Network.URI -import Spar.App (Spar, Env, wrapMonadClient, sparCtxOpts, sparCtxLogger, createUser_, wrapMonadClient) +import Spar.App (Spar, Env, wrapMonadClient, sparCtxOpts, sparCtxLogger, createSamlUserWithId, wrapMonadClient, getUser) import Spar.Intra.Galley import Spar.Scim.Types import Spar.Scim.Auth () @@ -61,20 +63,18 @@ import qualified Web.Scim.Schema.User as Scim ---------------------------------------------------------------------------- -- UserDB instance -instance Scim.UserDB Spar where - type UserExtra Spar = ScimUserExtra - +instance Scim.UserDB SparTag Spar where -- | List all users, possibly filtered by some predicate. - list :: ScimTokenInfo - -> Maybe Scim.Filter - -> Scim.ScimHandler Spar (Scim.ListResponse (Scim.StoredUser ScimUserExtra)) - list ScimTokenInfo{stiTeam} mbFilter = do + getUsers :: ScimTokenInfo + -> Maybe Scim.Filter + -> Scim.ScimHandler Spar (Scim.ListResponse (Scim.StoredUser SparTag)) + getUsers ScimTokenInfo{stiTeam} mbFilter = do members <- lift $ getTeamMembers stiTeam brigusers :: [User] <- filter (not . userDeleted) <$> lift (Intra.Brig.getBrigUsers ((^. Galley.userId) <$> members)) - scimusers :: [Scim.StoredUser ScimUserExtra] - <- lift . wrapMonadClient . Data.getScimUsers $ Brig.userId <$> brigusers + scimusers :: [Scim.StoredUser SparTag] + <- lift . wrapMonadClient . Data.getScimUsers $ BrigTypes.userId <$> brigusers let check user = case mbFilter of Nothing -> pure True Just filter_ -> @@ -87,77 +87,48 @@ instance Scim.UserDB Spar where Scim.fromList <$> filterM check scimusers -- | Get a single user by its ID. - get :: ScimTokenInfo - -> Text - -> Scim.ScimHandler Spar (Maybe (Scim.StoredUser ScimUserExtra)) - get ScimTokenInfo{stiTeam} uidText = do - uid <- parseUid uidText + getUser :: ScimTokenInfo + -> UserId + -> Scim.ScimHandler Spar (Scim.StoredUser SparTag) + getUser ScimTokenInfo{stiTeam} uid = do mbBrigUser <- lift (Intra.Brig.getBrigUser uid) - if isJust mbBrigUser && (userTeam =<< mbBrigUser) == Just stiTeam + mbScimUser <- if isJust mbBrigUser && (userTeam =<< mbBrigUser) == Just stiTeam then lift . wrapMonadClient . Data.getScimUser $ uid else pure Nothing + maybe (throwError . Scim.notFound "User" $ idToText uid) pure mbScimUser -- | Create a new user. - create :: ScimTokenInfo - -> Scim.User ScimUserExtra - -> Scim.ScimHandler Spar (Scim.StoredUser ScimUserExtra) - create tokinfo user = - createValidScimUser =<< validateScimUser tokinfo user - - update :: ScimTokenInfo - -> Text - -> Scim.User ScimUserExtra - -> Scim.ScimHandler Spar (Scim.StoredUser ScimUserExtra) - update tokinfo uidText newScimUser = - updateValidScimUser tokinfo uidText =<< validateScimUser tokinfo newScimUser - - delete :: ScimTokenInfo -> Text -> Scim.ScimHandler Spar Bool - delete ScimTokenInfo{stiTeam} uidText = do - uid :: UserId <- parseUid uidText - mbBrigUser <- lift (Intra.Brig.getBrigUser uid) - case mbBrigUser of - Nothing -> do - -- double-deletion gets you a 404. - throwError $ Scim.notFound "user" (cs $ show uid) - Just brigUser -> do - -- FUTUREWORK: currently it's impossible to delete the last available team owner via SCIM - -- (because that owner won't be managed by SCIM in the first place), but if it ever becomes - -- possible, we should do a check here and prohibit it. - unless (userTeam brigUser == Just stiTeam) $ - -- users from other teams get you a 404. - throwError $ Scim.notFound "user" (cs $ show uid) - ssoId <- maybe (logThenServerError $ "no userSSOId for user " <> cs uidText) - pure - $ Brig.userSSOId brigUser - uref <- either logThenServerError pure $ Intra.Brig.fromUserSSOId ssoId - lift . wrapMonadClient $ Data.deleteSAMLUser uref - lift . wrapMonadClient $ Data.deleteScimUser uid - lift $ Intra.Brig.deleteBrigUser uid - return True - where - logThenServerError :: String -> Scim.ScimHandler Spar b - logThenServerError err = do - logger <- asks sparCtxLogger - Log.err logger $ Log.msg err - throwError $ Scim.serverError "Server Error" - - - getMeta :: ScimTokenInfo -> Scim.ScimHandler Spar Scim.Meta - getMeta _ = - throwError $ Scim.ScimError - mempty - (Scim.Status 404) - Nothing - (Just "User getMeta is not implemented yet") -- TODO + postUser :: ScimTokenInfo + -> Scim.User SparTag + -> Scim.ScimHandler Spar (Scim.StoredUser SparTag) + postUser tokinfo user = createValidScimUser =<< validateScimUser tokinfo user + + putUser :: ScimTokenInfo + -> UserId + -> Scim.User SparTag + -> Scim.ScimHandler Spar (Scim.StoredUser SparTag) + putUser tokinfo uid newScimUser = + updateValidScimUser tokinfo uid =<< validateScimUser tokinfo newScimUser + + patchUser :: ScimTokenInfo + -> Scim.UserId SparTag + -> Value + -> Scim.ScimHandler Spar (Scim.StoredUser SparTag) + patchUser _ _ _ = throwError $ Scim.notFound "PATCH /Users" "not implemented" + + deleteUser :: ScimTokenInfo -> UserId -> Scim.ScimHandler Spar () + deleteUser = deleteScimUser + ---------------------------------------------------------------------------- -- User creation and validation --- | Validate a raw SCIM user record and extract data that we care about. +-- | Validate a raw SCIM user record and extract data that we care about. See also: +-- 'ValidScimUser''. validateScimUser :: forall m. (m ~ Scim.ScimHandler Spar) => ScimTokenInfo -- ^ Used to decide what IdP to assign the user to - -> Scim.User ScimUserExtra + -> Scim.User SparTag -> m ValidScimUser validateScimUser ScimTokenInfo{stiIdP} user = do idp <- case stiIdP of @@ -188,7 +159,7 @@ validateScimUser ScimTokenInfo{stiIdP} user = do -- -- FUTUREWORK: We may need to make the SAML NameID type derived from the available SCIM data -- configurable on a per-team basis in the future, to accomodate different legal uses of --- @externalId@ by different users. +-- @externalId@ by different teams. -- -- __Emails and phone numbers:__ we'd like to ensure that only verified emails and phone -- numbers end up in our database, and implementing verification requires design decisions @@ -198,43 +169,15 @@ validateScimUser' :: forall m. (MonadError Scim.ScimError m) => IdP -- ^ IdP that the resulting user will be assigned to -> Int -- ^ Rich info limit - -> Scim.User ScimUserExtra + -> Scim.User SparTag -> m ValidScimUser validateScimUser' idp richInfoLimit user = do - uref :: SAML.UserRef <- case Scim.externalId user of - Just subjectTxt -> do - let issuer = idp ^. SAML.idpMetadata . SAML.edIssuer - subject <- validateSubject subjectTxt - pure $ SAML.UserRef issuer subject - Nothing -> throwError $ Scim.badRequest Scim.InvalidValue - (Just "externalId is required for SAML users") + uref :: SAML.UserRef <- mkUserRef idp (Scim.externalId user) handl <- validateHandle (Scim.userName user) mbName <- mapM validateName (Scim.displayName user) richInfo <- validateRichInfo (Scim.extra user ^. sueRichInfo) - - -- NB: We assume that checking that the user does _not_ exist has already been done before; - -- the hscim library check does a 'get' before a 'create'. pure $ ValidScimUser user uref handl mbName richInfo - where - -- Validate a subject ID (@externalId@). - validateSubject :: Text -> m SAML.NameID - validateSubject txt = do - unameId :: SAML.UnqualifiedNameID <- do - let eEmail = SAML.mkUNameIDEmail txt - unspec = SAML.mkUNameIDUnspecified txt - pure . either (const unspec) id $ eEmail - case SAML.mkNameID unameId Nothing Nothing Nothing of - Right nameId -> pure nameId - Left err -> throwError $ Scim.ScimError - mempty - (Scim.Status 400) - Nothing - (Just $ "Can't construct a subject ID from externalId: " <> Text.pack err) - -- This cannot happen at the time of writing this comment, but there may be - -- valid scenarios in the future where this is not an internal error, eg. URI - -- too long. See 'mkNameID' for all possible errors. - -- Validate a handle (@userName@). validateHandle :: Text -> m Handle validateHandle txt = case parseHandle txt of @@ -261,35 +204,61 @@ validateScimUser' idp richInfoLimit user = do { Scim.status = Scim.Status 413 } pure richInfo +-- | Given an 'externalId' and an 'IdP', construct a 'SAML.UserRef'. +-- +-- This is needed primarily in 'validateScimUser', but also in 'updateValidScimUser' to +-- recover the 'SAML.UserRef' of the scim user before the update from the database. +mkUserRef + :: forall m. (MonadError Scim.ScimError m) + => IdP + -> Maybe Text + -> m SAML.UserRef +mkUserRef idp extid = case extid of + Just subjectTxt -> do + let issuer = idp ^. SAML.idpMetadata . SAML.edIssuer + subject <- validateSubject subjectTxt + pure $ SAML.UserRef issuer subject + Nothing -> throwError $ Scim.badRequest Scim.InvalidValue + (Just "externalId is required for SAML users") + where + -- Validate a subject ID (@externalId@). + validateSubject :: Text -> m SAML.NameID + validateSubject txt = do + unameId :: SAML.UnqualifiedNameID <- do + let eEmail = SAML.mkUNameIDEmail txt + unspec = SAML.mkUNameIDUnspecified txt + pure . either (const unspec) id $ eEmail + case SAML.mkNameID unameId Nothing Nothing Nothing of + Right nameId -> pure nameId + Left err -> throwError $ Scim.badRequest Scim.InvalidValue + (Just $ "Can't construct a subject ID from externalId: " <> Text.pack err) + + -- | We only allow SCIM users that authenticate via SAML. (This is by no means necessary, -- though. It can be relaxed to allow creating users with password authentication if that is a -- requirement.) createValidScimUser :: forall m. (m ~ Scim.ScimHandler Spar) - => ValidScimUser -> m (Scim.StoredUser ScimUserExtra) + => ValidScimUser -> m (Scim.StoredUser SparTag) createValidScimUser (ValidScimUser user uref handl mbName richInfo) = do - - -- FUTUREWORK: The @hscim@ library checks that the handle is not taken before 'create' is - -- even called. However, it does that in an inefficient manner. We should remove the check - -- from @hscim@ and do it here instead. - -- Generate a UserId will be used both for scim user in spar and for brig. buid <- Id <$> liftIO UUID.nextRandom - assertUserRefUnused buid uref + + -- ensure uniqueness constraints of all affected identifiers. + assertUserRefUnused uref + assertHandleUnused handl buid -- Create SCIM user here in spar. storedUser <- lift $ toScimStoredUser buid user lift . wrapMonadClient $ Data.insertScimUser buid storedUser + -- Create SAML user here in spar, which in turn creates a brig user. - -- - -- FUTUREWORK: it's annoying that we have duplicate checks (handles, rich info, etc are - -- validated both by Spar and by Brig), and we should somehow get rid of them. We could do - -- that by switching the order of 'createUser_' and 'insertScimUser', but then if Spar - -- crashes after 'insertScimUser', we would never finish creating that user. - lift $ createUser_ buid uref mbName ManagedByScim + lift $ createSamlUserWithId buid uref mbName ManagedByScim + -- Set user handle on brig (which can't be done during user creation yet). -- TODO: handle errors better here? lift $ Intra.Brig.setBrigUserHandle buid handl + -- Set rich info on brig lift $ Intra.Brig.setBrigUserRichInfo buid richInfo @@ -300,8 +269,8 @@ createValidScimUser (ValidScimUser user uref handl mbName richInfo) = do updateValidScimUser :: forall m. (m ~ Scim.ScimHandler Spar) - => ScimTokenInfo -> Text -> ValidScimUser -> m (Scim.StoredUser ScimUserExtra) -updateValidScimUser tokinfo uidText newScimUser = do + => ScimTokenInfo -> UserId -> ValidScimUser -> m (Scim.StoredUser SparTag) +updateValidScimUser tokinfo@ScimTokenInfo{stiIdP} uid newScimUser = do -- TODO: currently the types in @hscim@ are constructed in such a way that -- 'Scim.User.User' doesn't contain an ID, only 'Scim.StoredUser' @@ -315,29 +284,44 @@ updateValidScimUser tokinfo uidText newScimUser = do -- TODO: how do we get this safe w.r.t. race conditions / crashes? -- construct old and new user values with metadata. - uid :: UserId <- parseUid uidText - oldScimStoredUser :: Scim.StoredUser ScimUserExtra - <- let err = throwError $ Scim.notFound "user" uidText - in maybe err pure =<< Scim.get tokinfo uidText + oldScimStoredUser :: Scim.StoredUser SparTag + <- Scim.getUser tokinfo uid - let userRef = newScimUser ^. vsuSAMLUserRef - assertUserRefUnused uid userRef + assertUserRefNotUsedElsewhere (newScimUser ^. vsuSAMLUserRef) uid + assertHandleNotUsedElsewhere (newScimUser ^. vsuHandle) uid if Scim.value (Scim.thing oldScimStoredUser) == (newScimUser ^. vsuUser) then pure oldScimStoredUser else do - newScimStoredUser :: Scim.StoredUser ScimUserExtra + newScimStoredUser :: Scim.StoredUser SparTag <- lift $ updScimStoredUser (newScimUser ^. vsuUser) oldScimStoredUser - -- update 'SAML.UserRef' - let uref = newScimUser ^. vsuSAMLUserRef - lift . wrapMonadClient $ Data.insertSAMLUser uref uid -- on spar - bindok <- lift $ Intra.Brig.bindBrigUser uid uref -- on brig + -- update 'SAML.UserRef' on spar (also delete the old 'SAML.UserRef' if it exists and + -- is different from the new one) + let newuref = newScimUser ^. vsuSAMLUserRef + molduref <- do + let eid = Scim.externalId . Scim.value . Scim.thing $ oldScimStoredUser + (lift . wrapMonadClient . Data.getIdPConfig) `mapM` stiIdP >>= \case + Just (Just idp) -> Just <$> mkUserRef idp eid + _ -> pure Nothing + case molduref of + Just olduref -> when (olduref /= newuref) $ do + lift . wrapMonadClient $ Data.deleteSAMLUser olduref + lift . wrapMonadClient $ Data.insertSAMLUser newuref uid + Nothing -> do + -- if there was no uref before. (can't currently happen because we require saml + -- for scim to work, but this would be the right way to handle the case.) + lift . wrapMonadClient $ Data.insertSAMLUser newuref uid + + -- update 'SAML.UserRef' on brig + bindok <- lift $ Intra.Brig.bindBrigUser uid newuref unless bindok . throwError $ Scim.serverError "Failed to update SAML UserRef on brig." -- this can only happen if user is found in spar.scim_user, but missing on brig. -- (internal error? race condition?) + -- TODO: rich info and/or user handle may not have changed. in that case don't write + -- it. maybe (pure ()) (lift . Intra.Brig.setBrigUserName uid) $ newScimUser ^. vsuName lift . Intra.Brig.setBrigUserHandle uid $ newScimUser ^. vsuHandle lift . Intra.Brig.setBrigUserRichInfo uid $ newScimUser ^. vsuRichInfo @@ -351,7 +335,7 @@ updateValidScimUser tokinfo uidText newScimUser = do toScimStoredUser :: forall m. (SAML.HasNow m, MonadReader Env m) - => UserId -> Scim.User ScimUserExtra -> m (Scim.StoredUser ScimUserExtra) + => UserId -> Scim.User SparTag -> m (Scim.StoredUser SparTag) toScimStoredUser uid usr = do now <- SAML.getNow baseuri <- asks $ derivedOptsScimBaseURI . derivedOpts . sparCtxOpts @@ -362,9 +346,9 @@ toScimStoredUser' => SAML.Time -> URIBS.URI -> UserId - -> Scim.User ScimUserExtra - -> Scim.StoredUser ScimUserExtra -toScimStoredUser' (SAML.Time now) baseuri (idToText -> uid) usr = + -> Scim.User SparTag + -> Scim.StoredUser SparTag +toScimStoredUser' (SAML.Time now) baseuri uid usr = Scim.WithMeta meta (Scim.WithId uid usr) where mkLocation :: String -> URI @@ -380,23 +364,23 @@ toScimStoredUser' (SAML.Time now) baseuri (idToText -> uid) usr = , Scim.version = calculateVersion uid usr -- TODO: it looks like we need to add this to the HTTP header. -- https://tools.ietf.org/html/rfc7644#section-3.14 - , Scim.location = Scim.URI . mkLocation $ "/Users/" <> cs uid + , Scim.location = Scim.URI . mkLocation $ "/Users/" <> cs (idToText uid) } updScimStoredUser :: forall m. (SAML.HasNow m) - => Scim.User ScimUserExtra - -> Scim.StoredUser ScimUserExtra - -> m (Scim.StoredUser ScimUserExtra) + => Scim.User SparTag + -> Scim.StoredUser SparTag + -> m (Scim.StoredUser SparTag) updScimStoredUser usr storedusr = do now <- SAML.getNow pure $ updScimStoredUser' now usr storedusr updScimStoredUser' :: SAML.Time - -> Scim.User ScimUserExtra - -> Scim.StoredUser ScimUserExtra - -> Scim.StoredUser ScimUserExtra + -> Scim.User SparTag + -> Scim.StoredUser SparTag + -> Scim.StoredUser SparTag updScimStoredUser' (SAML.Time moddate) usr (Scim.WithMeta meta (Scim.WithId scimuid _)) = Scim.WithMeta meta' (Scim.WithId scimuid usr) where @@ -405,15 +389,41 @@ updScimStoredUser' (SAML.Time moddate) usr (Scim.WithMeta meta (Scim.WithId scim , Scim.version = calculateVersion scimuid usr } + +deleteScimUser + :: ScimTokenInfo -> UserId -> Scim.ScimHandler Spar () +deleteScimUser ScimTokenInfo{stiTeam} uid = do + mbBrigUser <- lift (Intra.Brig.getBrigUser uid) + case mbBrigUser of + Nothing -> do + -- double-deletion gets you a 404. + throwError $ Scim.notFound "user" (idToText uid) + Just brigUser -> do + -- FUTUREWORK: currently it's impossible to delete the last available team owner via SCIM + -- (because that owner won't be managed by SCIM in the first place), but if it ever becomes + -- possible, we should do a check here and prohibit it. + unless (userTeam brigUser == Just stiTeam) $ + -- users from other teams get you a 404. + throwError $ Scim.notFound "user" (idToText uid) + ssoId <- maybe (logThenServerError $ "no userSSOId for user " <> cs (idToText uid)) + pure + $ BrigTypes.userSSOId brigUser + uref <- either logThenServerError pure $ Intra.Brig.fromUserSSOId ssoId + lift . wrapMonadClient $ Data.deleteSAMLUser uref + lift . wrapMonadClient $ Data.deleteScimUser uid + lift $ Intra.Brig.deleteBrigUser uid + return () + where + logThenServerError :: String -> Scim.ScimHandler Spar b + logThenServerError err = do + logger <- asks sparCtxLogger + Log.err logger $ Log.msg err + throwError $ Scim.serverError "Server Error" + + ---------------------------------------------------------------------------- -- Utilities -parseUid - :: forall m m'. (m ~ Scim.ScimHandler m', Monad m') - => Text -> m UserId -parseUid uidText = maybe err pure $ readMaybe (Text.unpack uidText) - where err = throwError $ Scim.notFound "user" uidText - -- | Calculate resource version (currently only for 'Scim.User's). -- -- Spec: . @@ -425,30 +435,52 @@ parseUid uidText = maybe err pure $ readMaybe (Text.unpack uidText) -- JSON rendering will remain stable between releases, and therefore we can't satisfy the -- requirements of strong ETags ("same resources have the same version"). calculateVersion - :: Text -- ^ User ID - -> Scim.User ScimUserExtra + :: UserId + -> Scim.User SparTag -> Scim.ETag -calculateVersion uidText usr = Scim.Weak (Text.pack (show h)) +calculateVersion uid usr = Scim.Weak (Text.pack (show h)) where h :: Digest SHA256 - h = hashlazy (Aeson.encode (Scim.WithId uidText usr)) + h = hashlazy (Aeson.encode (Scim.WithId uid usr)) + +{-| +Check that the UserRef is not taken. + +ASSUMPTION: every scim user has a 'SAML.UserRef', and the `SAML.NameID` in it corresponds +to a single `externalId`. +-} +assertUserRefUnused :: SAML.UserRef -> Scim.ScimHandler Spar () +assertUserRefUnused userRef = do + mExistingUserId <- lift $ getUser userRef + unless (isNothing mExistingUserId) $ + throwError Scim.conflict {Scim.detail = Just "externalId is already taken"} {-| -Check that the UserRef is not taken; or that it's taken by the given user id. +Check that the UserRef is not taken any user other than the passed 'UserId' +(it is also acceptable if it is not taken by anybody). ASSUMPTION: every scim user has a 'SAML.UserRef', and the `SAML.NameID` in it corresponds to a single `externalId`. -} -assertUserRefUnused :: UserId -> SAML.UserRef -> Scim.ScimHandler Spar () -assertUserRefUnused wireUserId userRef = do - mExistingUserId <- lift $ wrapMonadClient (Data.getSAMLUser userRef) - case mExistingUserId of - -- No existing user for this userRef; it's okay to set it - Nothing -> return () - -- A user exists; verify that it's the same user before updating - Just existingUserId -> - unless (existingUserId == wireUserId) $ - throwError Scim.conflict {Scim.detail = Just "externalId is already taken"} +assertUserRefNotUsedElsewhere :: SAML.UserRef -> UserId -> Scim.ScimHandler Spar () +assertUserRefNotUsedElsewhere userRef wireUserId = do + mExistingUserId <- lift $ getUser userRef + unless (mExistingUserId `elem` [Nothing, Just wireUserId]) $ do + throwError Scim.conflict {Scim.detail = Just "externalId does not match UserId"} + +assertHandleUnused :: Handle -> UserId -> Scim.ScimHandler Spar () +assertHandleUnused = assertHandleUnused' "userName is already taken" + +assertHandleUnused' :: Text -> Handle -> UserId -> Scim.ScimHandler Spar () +assertHandleUnused' msg hndl uid = lift (Brig.checkHandleAvailable hndl uid) >>= \case + True -> pure () + False -> throwError Scim.conflict {Scim.detail = Just msg} + +assertHandleNotUsedElsewhere :: Handle -> UserId -> Scim.ScimHandler Spar () +assertHandleNotUsedElsewhere hndl uid = do + musr <- lift $ Brig.getBrigUser uid + unless ((userHandle =<< musr) == Just hndl) $ + assertHandleUnused' "userName does not match UserId" hndl uid {- TODO: might be useful later. ~~~~~~~~~~~~~~~~~~~~~~~~~ diff --git a/services/spar/test-integration/Test/LoggingSpec.hs b/services/spar/test-integration/Test/LoggingSpec.hs index 496e3e45ca8..70093959afa 100644 --- a/services/spar/test-integration/Test/LoggingSpec.hs +++ b/services/spar/test-integration/Test/LoggingSpec.hs @@ -2,13 +2,20 @@ module Test.LoggingSpec (spec) where import Imports import Control.Lens +import Data.String.Conversions (cs) +import Network.HTTP.Types.Status (statusCode) import Spar.App -import System.Logger as Log +import Spar.Run (mkApp) import System.IO.Silently (capture) +import System.Logger as Log import Util +import qualified Network.Wai.Test as HW +import qualified Test.Hspec.Wai as HW +import qualified Test.Hspec.Wai.Internal as HW -spec :: HasCallStack => SpecWith TestEnv + +spec :: SpecWith TestEnv spec = describe "logging" $ do it "does not log newlines (see haddocks of simpleSettings)" $ do logger <- asks (^. teSparEnv . to sparCtxLogger) @@ -18,3 +25,15 @@ spec = describe "logging" $ do Log.flush logger out `shouldContain` "hrgh woaa" out `shouldNotContain` "hrgh\n\nwoaa" + + context "loglevel == debug" $ do + it "400 on finalize-login causes log of entire request" $ do + (app, env) <- liftIO . mkApp =<< view teOpts + let badbody = "@@badxml" + (out, resp) <- liftIO . capture $ do + resp <- HW.withApplication app $ HW.post "/sso/finalize-login" badbody + Log.flush (sparCtxLogger env) + pure resp + liftIO $ do + statusCode (HW.simpleStatus resp) `shouldBe` 400 + out `shouldContain` cs badbody diff --git a/services/spar/test-integration/Test/Spar/DataSpec.hs b/services/spar/test-integration/Test/Spar/DataSpec.hs index 53f734aba07..a1c19505071 100644 --- a/services/spar/test-integration/Test/Spar/DataSpec.hs +++ b/services/spar/test-integration/Test/Spar/DataSpec.hs @@ -7,7 +7,6 @@ import Cassandra import Control.Lens import Control.Monad.Except import Data.Kind (Type) -import Data.Text (unpack) import Data.Typeable import Data.UUID as UUID import Data.UUID.V4 as UUID @@ -118,6 +117,19 @@ spec = do muid <- runSparCass $ Data.getSAMLUser uref liftIO $ muid `shouldBe` Just uid' + describe "DELETE" $ do + it "works" $ do + uref <- nextUserRef + uid <- nextWireId + do + () <- runSparCass $ Data.insertSAMLUser uref uid + muid <- runSparCass (Data.getSAMLUser uref) + liftIO $ muid `shouldBe` Just uid + do + () <- runSparCass $ Data.deleteSAMLUser uref + muid <- runSparCass (Data.getSAMLUser uref) `aFewTimes` isNothing + liftIO $ muid `shouldBe` Nothing + describe "BindCookie" $ do let mkcky :: TestSpar SetBindCookie @@ -241,7 +253,7 @@ testDeleteTeam = it "cleans up all the right tables after deletion" $ do storedUser1 <- createUser tok user1 storedUser2 <- createUser tok user2 -- Resolve the users' SSO ids - let getUid = read . unpack . Scim.Common.id . Scim.Meta.thing + let getUid = Scim.Common.id . Scim.Meta.thing ssoid1 <- getSsoidViaSelf (getUid storedUser1) ssoid2 <- getSsoidViaSelf (getUid storedUser2) -- Delete the team diff --git a/services/spar/test-integration/Test/Spar/Scim/UserSpec.hs b/services/spar/test-integration/Test/Spar/Scim/UserSpec.hs index 3e49bf7652c..ebbc1303028 100644 --- a/services/spar/test-integration/Test/Spar/Scim/UserSpec.hs +++ b/services/spar/test-integration/Test/Spar/Scim/UserSpec.hs @@ -10,12 +10,18 @@ import Bilge.Assert import Brig.Types.User as Brig import Control.Lens import Data.ByteString.Conversion +import Data.String.Conversions (cs) import Data.Id (UserId) import Data.Ix (inRange) import Spar.Scim +import Spar.Types (IdP) import Util +import qualified SAML2.WebSSO.Types as SAML +import qualified SAML2.WebSSO.Test.MockResponse as SAML import qualified Spar.Data as Data +import qualified Spar.Intra.Brig as Intra +import qualified Web.Scim.Class.User as ScimC.User import qualified Web.Scim.Class.User as Scim.UserC import qualified Web.Scim.Schema.Common as Scim import qualified Web.Scim.Schema.Meta as Scim @@ -52,7 +58,7 @@ specCreateUser = describe "POST /Users" $ do testCreateSameExternalIds it "provides a correct location in the 'meta' field" $ testLocation it "handles rich info correctly (this also tests put, get)" $ testRichInfo - it "gives created user a valid 'SAML.UserRef' for SSO" $ pending + it "gives created user a valid 'SAML.UserRef' for SSO" $ testScimCreateVsUserRef it "attributes of {brig, scim, saml} user are mapped as documented" $ pending it "writes all the stuff to all the places" $ pendingWith "factor this out of the PUT tests we already wrote." @@ -74,7 +80,7 @@ testCreateUser = do . path "/self" . expect2xx ) - brigUser `userShouldMatch` scimStoredUser + brigUser `userShouldMatch` WrappedScimStoredUser scimStoredUser -- | Test that @externalId@ (for SSO login) is required when creating a user. testExternalIdIsRequired :: TestSpar () @@ -178,7 +184,7 @@ testRichInfo = do let -- validate response checkStoredUser :: HasCallStack - => Scim.UserC.StoredUser ScimUserExtra -> RichInfo -> TestSpar () + => Scim.UserC.StoredUser SparTag -> RichInfo -> TestSpar () checkStoredUser storedUser rinf = liftIO $ do (Scim.User.extra . Scim.value . Scim.thing) storedUser `shouldBe` (ScimUserExtra rinf) @@ -216,6 +222,77 @@ testRichInfo = do liftIO $ scimUserId scimStoredUser' `shouldBe` scimUserId scimStoredUser probeUser (scimUserId scimStoredUser) richInfo' +-- | Create a user implicitly via saml login; remove it via brig leaving a dangling entry in +-- @spar.user@; create it via scim. This should work despite the dangling database entry. +testScimCreateVsUserRef :: TestSpar () +testScimCreateVsUserRef = do + (_ownerid, teamid, idp) <- registerTestIdP + (usr, uname) :: (Scim.User.User SparTag, SAML.UnqualifiedNameID) + <- randomScimUserWithSubject + let uref = SAML.UserRef tenant subj + subj = either (error . show) id $ SAML.mkNameID uname Nothing Nothing Nothing + tenant = idp ^. SAML.idpMetadata . SAML.edIssuer + + !(Just !uid) <- createViaSaml idp uref + samlUserShouldSatisfy uref isJust + + deleteViaBrig uid + samlUserShouldSatisfy uref isJust -- brig doesn't talk to spar right now when users + -- are deleted there. we need to work around this + -- fact for now. (if the test fails here, this may + -- mean that you fixed the behavior and can + -- change this to 'isNothing'.) + + tok <- registerScimToken teamid (Just (idp ^. SAML.idpId)) + storedusr :: Scim.UserC.StoredUser SparTag + <- do + resp <- aFewTimes (createUser_ (Just tok) usr =<< view teSpar) ((== 201) . statusCode) + SAML.UserRef -> (Maybe UserId -> Bool) -> TestSpar () + samlUserShouldSatisfy uref property = do + muid <- getUserIdViaRef' uref + liftIO $ muid `shouldSatisfy` property + + createViaSamlResp :: HasCallStack => IdP -> SAML.UserRef -> TestSpar ResponseLBS + createViaSamlResp idp (SAML.UserRef _ subj) = do + (privCreds, authnReq) <- negotiateAuthnRequest idp + spmeta <- getTestSPMetadata + authnResp <- runSimpleSP $ + SAML.mkAuthnResponseWithSubj subj privCreds idp spmeta authnReq True + submitAuthnResponse authnResp IdP -> SAML.UserRef -> TestSpar () + createViaSamlFails idp uref = do + resp <- createViaSamlResp idp uref + liftIO $ do + maybe (error "no body") cs (responseBody resp) + `shouldContain` "wire:sso:error:forbidden" + + createViaSaml :: HasCallStack => IdP -> SAML.UserRef -> TestSpar (Maybe UserId) + createViaSaml idp uref = do + resp <- createViaSamlResp idp uref + liftIO $ do + maybe (error "no body") cs (responseBody resp) + `shouldContain` "wire:sso:success" + getUserIdViaRef' uref + + deleteViaBrig :: UserId -> TestSpar () + deleteViaBrig uid = do + brig <- view teBrig + (call . delete $ brig . paths ["i", "users", toByteString' uid]) + !!! const 202 === statusCode + ---------------------------------------------------------------------------- -- Listing users @@ -478,19 +555,32 @@ testUpdateSameHandle = do -- can find the user by the 'UserRef'. testUpdateUserRefIndex :: TestSpar () testUpdateUserRefIndex = do - -- Create a user via SCIM - user <- randomScimUser (tok, (_, _, idp)) <- registerIdPAndScimToken - storedUser <- createUser tok user - let userid = scimUserId storedUser - -- Overwrite the user with another randomly-generated user - user' <- randomScimUser - _ <- updateUser tok userid user' - vuser' <- either (error . show) pure $ - validateScimUser' idp 999999 user' -- 999999 = some big number - muserid' <- runSparCass $ Data.getSAMLUser (vuser' ^. vsuSAMLUserRef) - liftIO $ do - muserid' `shouldBe` Just userid + let checkUpdateUserRef :: Bool -> TestSpar () + checkUpdateUserRef changeUserRef = do + -- Create a user via SCIM + user <- randomScimUser + storedUser <- createUser tok user + let userid = scimUserId storedUser + uref <- either (error . show) pure $ mkUserRef idp (Scim.User.externalId user) + + -- Overwrite the user with another randomly-generated user + user' <- let upd u = if changeUserRef + then u + else u { Scim.User.externalId = Scim.User.externalId user } + in randomScimUser <&> upd + _ <- updateUser tok userid user' + uref' <- either (error . show) pure $ mkUserRef idp (Scim.User.externalId user') + muserid <- runSparCass $ Data.getSAMLUser uref + muserid' <- runSparCass $ Data.getSAMLUser uref' + liftIO $ do + (changeUserRef, muserid) `shouldBe` + (changeUserRef, if changeUserRef then Nothing else Just userid) + (changeUserRef, muserid') `shouldBe` + (changeUserRef, Just userid) + + checkUpdateUserRef True + checkUpdateUserRef False -- | Test that when the user is updated via SCIM, the data in Brig is also updated. testBrigSideIsUpdated :: TestSpar () @@ -503,7 +593,7 @@ testBrigSideIsUpdated = do _ <- updateUser tok userid user' validScimUser <- either (error . show) pure $ validateScimUser' idp 999999 user' - brigUser <- maybe (error "no brig user") pure =<< getSelf userid + brigUser <- maybe (error "no brig user") pure =<< runSpar (Intra.getBrigUser userid) brigUser `userShouldMatch` validScimUser ---------------------------------------------------------------------------- @@ -519,7 +609,29 @@ specDeleteUser = do !!! const 405 === statusCode describe "DELETE /Users/:id" $ do - it "should respond with 204" $ do + it "should delete user from brig, spar.scim_user, spar.user" $ do + (tok, _) <- registerIdPAndScimToken + user <- randomScimUser + storedUser <- createUser tok user + let uid :: UserId = scimUserId storedUser + uref :: SAML.UserRef <- do + usr <- runSpar $ Intra.getBrigUser uid + maybe (error "no UserRef from brig") pure $ urefFromBrig =<< usr + spar <- view teSpar + deleteUser_ (Just tok) (Just uid) spar + !!! const 204 === statusCode + + brigUser :: Maybe User + <- aFewTimes (runSpar $ Intra.getBrigUser uid) isNothing + samlUser :: Maybe UserId + <- aFewTimes (getUserIdViaRef' uref) isNothing + scimUser :: Maybe (ScimC.User.StoredUser SparTag) + <- aFewTimes (getScimUser uid) isNothing + + liftIO $ (brigUser, samlUser, scimUser) + `shouldBe` (Nothing, Nothing, Nothing) + + it "should respond with 204 on first deletion, then 404" $ do (tok, _) <- registerIdPAndScimToken user <- randomScimUser storedUser <- createUser tok user @@ -529,11 +641,20 @@ specDeleteUser = do -- Expect first call to succeed deleteUser_ (Just tok) (Just uid) spar !!! const 204 === statusCode - -- The second call may return either of 204 or 404 depending on whether Brig has - -- finished deletion. This assertion is here to document that this is currently - -- the expected behaviour + -- Subsequent calls will return 404 eventually + aFewTimes (deleteUser_ (Just tok) (Just uid) spar) ((== 404) . statusCode) + !!! const 404 === statusCode + + it "should free externalId and everything else in the scim user for re-use" $ do + (tok, _) <- registerIdPAndScimToken + user <- randomScimUser + storedUser <- createUser tok user + let uid :: UserId = scimUserId storedUser + spar <- view teSpar deleteUser_ (Just tok) (Just uid) spar - !!! assertTrue "expected one of 204, 404" ((`elem` [204, 404]) . statusCode) + !!! const 204 === statusCode + aFewTimes (createUser_ (Just tok) user spar) ((== 201) . statusCode) + !!! const 201 === statusCode -- FUTUREWORK: hscim has the the following test. we should probably go through all -- `delete` tests and see if they can move to hscim or are already included there. diff --git a/services/spar/test-integration/Util/Core.hs b/services/spar/test-integration/Util/Core.hs index c425b7f0a94..f9f078e9224 100644 --- a/services/spar/test-integration/Util/Core.hs +++ b/services/spar/test-integration/Util/Core.hs @@ -15,6 +15,7 @@ module Util.Core , passes, it, pending, pendingWith , shouldRespondWith , module Test.Hspec + , aFewTimes -- * HTTP , call , endpointToReq @@ -62,8 +63,9 @@ module Util.Core , runSparCass, runSparCassWithEnv , runSimpleSP , runSpar - , getSsoidViaSelf, getSsoidViaSelf', getSelf + , getSsoidViaSelf, getSsoidViaSelf' , getUserIdViaRef, getUserIdViaRef' + , getScimUser ) where import Imports hiding (head) @@ -97,6 +99,7 @@ import SAML2.WebSSO.Test.MockResponse import Spar.App (toLevel) import Spar.API.Types import Spar.Run +import Spar.Scim.Types import Spar.Types import System.Random (randomRIO) import Test.Hspec hiding (it, xit, pending, pendingWith) @@ -121,12 +124,13 @@ import qualified Spar.App as Spar import qualified Spar.Data as Data import qualified Spar.Intra.Brig as Intra import qualified Spar.Options +import qualified System.Logger.Extended as Log import qualified Test.Hspec import qualified Text.XML as XML import qualified Text.XML.Cursor as XML import qualified Text.XML.DSig as SAML import qualified Web.Cookie as Web -import qualified System.Logger.Extended as Log +import qualified Web.Scim.Class.User as ScimC.User -- | Call 'mkEnv' with options from config files. @@ -205,6 +209,18 @@ pendingWith :: (HasCallStack, MonadIO m) => String -> m () pendingWith = liftIO . Test.Hspec.pendingWith +-- | Run a probe several times, until a "good" value materializes or until patience runs out. +-- If all retries were unsuccessful, 'aFewTimes' will return the last obtained value, even +-- if it does not satisfy the predicate. +aFewTimes :: TestSpar a -> (a -> Bool) -> TestSpar a +aFewTimes action good = do + env <- ask + liftIO $ retrying + (exponentialBackoff 1000 <> limitRetries 10) + (\_ -> pure . not . good) + (\_ -> action `runReaderT` env) + + createUserWithTeam :: (HasCallStack, MonadHttp m, MonadIO m) => BrigReq -> GalleyReq -> m (UserId, TeamId) createUserWithTeam brg gly = do e <- randomEmail @@ -750,7 +766,7 @@ getSsoidViaSelf uid = maybe (error "not found") pure =<< getSsoidViaSelf' uid getSsoidViaSelf' :: HasCallStack => UserId -> TestSpar (Maybe UserSSOId) getSsoidViaSelf' uid = do - musr <- getSelf uid + musr <- aFewTimes (runSpar $ Intra.getBrigUser uid) isJust pure $ case userIdentity =<< musr of Just (SSOIdentity ssoid _ _) -> Just ssoid Just (FullIdentity _ _) -> Nothing @@ -758,36 +774,16 @@ getSsoidViaSelf' uid = do Just (PhoneIdentity _) -> Nothing Nothing -> Nothing -getSelf :: HasCallStack => UserId -> TestSpar (Maybe User) -getSelf uid = do - let probe :: HasCallStack => TestSpar (Maybe User) - probe = do - env <- ask - fmap selfToUser . call . get $ - ( (env ^. teBrig) - . header "Z-User" (toByteString' uid) - . path "/self" - . expect2xx - ) - - selfToUser :: HasCallStack => ResponseLBS -> Maybe User - selfToUser (fmap Aeson.eitherDecode . responseBody -> Just (Right selfprof)) - = Just $ selfUser selfprof - selfToUser _ = Nothing - - env <- ask - liftIO $ retrying - (exponentialBackoff 50 <> limitRetries 5) - (\_ -> pure . isNothing) - (\_ -> probe `runReaderT` env) - getUserIdViaRef :: HasCallStack => UserRef -> TestSpar UserId getUserIdViaRef uref = maybe (error "not found") pure =<< getUserIdViaRef' uref getUserIdViaRef' :: HasCallStack => UserRef -> TestSpar (Maybe UserId) getUserIdViaRef' uref = do - env <- ask - liftIO $ retrying - (exponentialBackoff 50 <> limitRetries 5) - (\_ -> pure . isNothing) - (\_ -> runClient (env ^. teCql) $ Data.getSAMLUser uref) + aFewTimes (runSparCass $ Data.getSAMLUser uref) isJust + +-- | FUTUREWORK: arguably this function should move to Util.Scim, but it also is related to +-- the other lookups above into the various user tables in the various cassandras. we should +-- probably clean this up a little, and also pick better names for everything. +getScimUser :: HasCallStack => UserId -> TestSpar (Maybe (ScimC.User.StoredUser SparTag)) +getScimUser uid = do + aFewTimes (runSparCass $ Data.getScimUser uid) isJust diff --git a/services/spar/test-integration/Util/Scim.hs b/services/spar/test-integration/Util/Scim.hs index c3ec8a19ffa..b9ce1242438 100644 --- a/services/spar/test-integration/Util/Scim.hs +++ b/services/spar/test-integration/Util/Scim.hs @@ -69,14 +69,14 @@ registerScimToken teamid midpid = do -- -- FUTUREWORK: make this more exhaustive. change everything that can be changed! move this to the -- hspec package when done. -randomScimUser :: MonadRandom m => m (Scim.User.User ScimUserExtra) +randomScimUser :: MonadRandom m => m (Scim.User.User SparTag) randomScimUser = fst <$> randomScimUserWithSubject -- | Like 'randomScimUser', but also returns the intended subject ID that the user should -- have. It's already available as 'Scim.User.externalId' but it's not structured. randomScimUserWithSubject :: (HasCallStack, MonadRandom m) - => m (Scim.User.User ScimUserExtra, SAML.UnqualifiedNameID) + => m (Scim.User.User SparTag, SAML.UnqualifiedNameID) randomScimUserWithSubject = do fieldCount <- getRandomR (0, 3) fields <- replicateM fieldCount $ @@ -87,7 +87,7 @@ randomScimUserWithSubject = do -- | See 'randomScimUser', 'randomScimUserWithSubject'. randomScimUserWithSubjectAndRichInfo :: MonadRandom m - => RichInfo -> m (Scim.User.User ScimUserExtra, SAML.UnqualifiedNameID) + => RichInfo -> m (Scim.User.User SparTag, SAML.UnqualifiedNameID) randomScimUserWithSubjectAndRichInfo richInfo = do suffix <- cs <$> replicateM 7 (getRandomR ('0', '9')) emails <- getRandomR (0, 3) >>= \n -> replicateM n randomScimEmail @@ -140,8 +140,8 @@ randomScimPhone = do createUser :: HasCallStack => ScimToken - -> Scim.User.User ScimUserExtra - -> TestSpar (Scim.StoredUser ScimUserExtra) + -> Scim.User.User SparTag + -> TestSpar (Scim.StoredUser SparTag) createUser tok user = do env <- ask r <- createUser_ @@ -156,8 +156,8 @@ updateUser :: HasCallStack => ScimToken -> UserId - -> Scim.User.User ScimUserExtra - -> TestSpar (Scim.StoredUser ScimUserExtra) + -> Scim.User.User SparTag + -> TestSpar (Scim.StoredUser SparTag) updateUser tok userid user = do env <- ask r <- updateUser_ @@ -173,7 +173,7 @@ deleteUser :: HasCallStack => ScimToken -> UserId - -> TestSpar (Scim.StoredUser ScimUserExtra) + -> TestSpar (Scim.StoredUser SparTag) deleteUser tok userid = do env <- ask r <- deleteUser_ @@ -188,7 +188,7 @@ listUsers :: HasCallStack => ScimToken -> Maybe Scim.Filter - -> TestSpar [(Scim.StoredUser ScimUserExtra)] + -> TestSpar [(Scim.StoredUser SparTag)] listUsers tok mbFilter = do env <- ask r <- listUsers_ @@ -207,7 +207,7 @@ getUser :: HasCallStack => ScimToken -> UserId - -> TestSpar (Scim.StoredUser ScimUserExtra) + -> TestSpar (Scim.StoredUser SparTag) getUser tok userid = do env <- ask r <- getUser_ @@ -265,7 +265,7 @@ listTokens zusr = do -- | Create a user. createUser_ :: Maybe ScimToken -- ^ Authentication - -> Scim.User.User ScimUserExtra -- ^ User data + -> Scim.User.User SparTag -- ^ User data -> SparReq -- ^ Spar endpoint -> TestSpar ResponseLBS createUser_ auth user spar_ = do @@ -290,7 +290,7 @@ updateUser_ :: Maybe ScimToken -- ^ Authentication -> Maybe UserId -- ^ User to update; when not provided, the request will -- return 4xx - -> Scim.User.User ScimUserExtra -- ^ User data + -> Scim.User.User SparTag -- ^ User data -> SparReq -- ^ Spar endpoint -> TestSpar ResponseLBS updateUser_ auth muid user spar_ = do @@ -406,11 +406,8 @@ acceptScim :: Request -> Request acceptScim = accept "application/scim+json" -- | Get ID of a user returned from SCIM. -scimUserId :: Scim.StoredUser ScimUserExtra -> UserId -scimUserId storedUser = either err id (readEither id_) - where - id_ = cs (Scim.id (Scim.thing storedUser)) - err e = error $ "scimUserId: couldn't parse ID " ++ id_ ++ ": " ++ e +scimUserId :: Scim.StoredUser SparTag -> UserId +scimUserId = Scim.id . Scim.thing -- | There are a number of user types that all partially map on each other. This class -- provides a uniform interface to data stored in those types. @@ -446,21 +443,24 @@ instance IsUser ValidScimUser where maybeSubject = Just (Just . view (vsuSAMLUserRef . SAML.uidSubject)) maybeSubjectRaw = Just (SAML.shortShowNameID . view (vsuSAMLUserRef . SAML.uidSubject)) -instance IsUser (Scim.StoredUser ScimUserExtra) where - maybeUserId = Just scimUserId - maybeHandle = maybeHandle <&> \f -> f . Scim.value . Scim.thing - maybeName = maybeName <&> \f -> f . Scim.value . Scim.thing - maybeTenant = maybeTenant <&> \f -> f . Scim.value . Scim.thing - maybeSubject = maybeSubject <&> \f -> f . Scim.value . Scim.thing - maybeSubjectRaw = maybeSubjectRaw <&> \f -> f . Scim.value . Scim.thing +instance IsUser (WrappedScimStoredUser SparTag) where + maybeUserId = Just $ scimUserId . fromWrappedScimStoredUser + maybeHandle = maybeHandle <&> _wrappedStoredUserToWrappedUser + maybeName = maybeName <&> _wrappedStoredUserToWrappedUser + maybeTenant = maybeTenant <&> _wrappedStoredUserToWrappedUser + maybeSubject = maybeSubject <&> _wrappedStoredUserToWrappedUser + maybeSubjectRaw = maybeSubjectRaw <&> _wrappedStoredUserToWrappedUser + +_wrappedStoredUserToWrappedUser :: (WrappedScimUser tag -> a) -> (WrappedScimStoredUser tag -> a) +_wrappedStoredUserToWrappedUser f = f . WrappedScimUser . Scim.value . Scim.thing . fromWrappedScimStoredUser -instance IsUser (Scim.User.User ScimUserExtra) where +instance IsUser (WrappedScimUser SparTag) where maybeUserId = Nothing - maybeHandle = Just (Just . Handle . Scim.User.userName) - maybeName = Just (fmap Name . Scim.User.displayName) + maybeHandle = Just (Just . Handle . Scim.User.userName . fromWrappedScimUser) + maybeName = Just (fmap Name . Scim.User.displayName. fromWrappedScimUser) maybeTenant = Nothing maybeSubject = Nothing - maybeSubjectRaw = Just Scim.User.externalId + maybeSubjectRaw = Just $ Scim.User.externalId . fromWrappedScimUser instance IsUser User where maybeUserId = Just userId diff --git a/services/spar/test/Test/Spar/ScimSpec.hs b/services/spar/test/Test/Spar/ScimSpec.hs index cc6de1c761b..7853ec343a7 100644 --- a/services/spar/test/Test/Spar/ScimSpec.hs +++ b/services/spar/test/Test/Spar/ScimSpec.hs @@ -32,7 +32,7 @@ import qualified Web.Scim.Schema.User.Name as ScimN spec :: Spec spec = describe "toScimStoredUser'" $ do it "works" $ do - let usr :: Scim.User ScimUserExtra + let usr :: Scim.User SparTag usr = Scim.User { Scim.schemas = [Scim.User20, Scim.CustomSchema "urn:wire:scim:schemas:profile:1.0"] @@ -80,7 +80,7 @@ spec = describe "toScimStoredUser'" $ do URI.ByteString.parseURI laxURIParserOptions "https://127.0.0.1/scim/v2/" uid = Id . fromJust . UUID.fromText $ "90b5ee1c-088e-11e9-9a16-73f80f483813" - result :: ScimC.StoredUser ScimUserExtra + result :: ScimC.StoredUser SparTag result = toScimStoredUser' now' baseuri uid usr Scim.meta result `shouldBe` meta diff --git a/snapshots/README.md b/snapshots/README.md new file mode 100644 index 00000000000..ff11c984d17 --- /dev/null +++ b/snapshots/README.md @@ -0,0 +1,23 @@ +This directory contains [custom Stack snapshots][custom] used for Wire code. + +[custom]: https://docs.haskellstack.org/en/stable/custom_snapshot/ + +Snapshot definitions should never be changed (once committed to `develop`), because in other +repositories we refer to snapshot definitions by URL. + +(Rationale: Stack only downloads snapshot definitions once, and never checks whether they have +changed. If a snapshot changes and you have a repo that depends on it, you will get +inconsistent results depending on whether you've built that repo before or not.) + +To add, modify, or remove packages, a new snapshot should be created. It can be based on the +previous snapshot version. For major changes, e.g. LTS bumps, it's better to create a snapshot +from scratch. + +Some packages in this snapshot reference tar files instead of Git repos. This is due to +several issues in Stack that make working with big Git repositories unpleasant: + + * https://github.com/commercialhaskell/stack/issues/4345 + * https://github.com/commercialhaskell/stack/issues/3551 + +Unless the fixes to those are released, it's recommended to use GitHub's tar releases for +packages with big repos. diff --git a/snapshots/wire-1.0.yaml b/snapshots/wire-1.0.yaml index 1f8044369da..0dc67092219 100644 --- a/snapshots/wire-1.0.yaml +++ b/snapshots/wire-1.0.yaml @@ -1,23 +1,4 @@ -# A custom Stack snapshot (https://docs.haskellstack.org/en/stable/custom_snapshot/) used for -# Wire code. -# -# Should never be changed once pushed to develop, because in other repositories we refer to -# snapshot definitions by URL. Stack only downloads snapshot definitions once and never checks -# whether they have changed. So, when building code from other repositories, people would be -# getting inconsistent results depending on whether they built that code before or not. -# -# To add, modify, or remove packages, a new snapshot should be created. It can be based on the -# previous snapshot version (please read the docs above to learn what the syntax is). For -# major changes, e.g. LTS bumps, it's better to create a snapshot from scratch. -# -# Some packages in this snapshot reference tar files instead of Git repos. This is due to -# several issues in Stack that make working with big Git repositories unpleasant: -# -# * https://github.com/commercialhaskell/stack/issues/4345 -# * https://github.com/commercialhaskell/stack/issues/3551 -# -# Unless the fixes to those are released, it's recommended to use Github's tar releases for -# forks of big/old packages. +# DO NOT MODIFY THIS FILE. See README.md to learn why. resolver: lts-12.10 name: wire-1.0 @@ -83,11 +64,11 @@ packages: ############################################################ # Our fork of multihash with relaxed upper bounds -- git: https://github.com/tiago-loureiro/haskell-multihash.git +- git: https://github.com/wireapp/haskell-multihash.git commit: 300a6f46384bfca33e545c8bab52ef3717452d12 # Our fork of aws with minor fixes -- git: https://github.com/tiago-loureiro/aws +- git: https://github.com/wireapp/aws commit: 42695688fc20f80bf89cec845c57403954aab0a2 # https://github.com/hspec/hspec-wai/pull/49 @@ -99,10 +80,10 @@ packages: # # The important commits for us are: # -# * https://github.com/snoyberg/http-client/compare/master...neongreen:connection-guts +# * https://github.com/snoyberg/http-client/compare/master...wireapp:connection-guts # # The archive corresponds to commit 6a4ac55edf5e62574210c77a1468fa7accb81670. -- archive: https://github.com/neongreen/http-client/archive/wire-2019-01-25.tar.gz +- archive: https://github.com/wireapp/http-client/archive/wire-2019-01-25.tar.gz subdirs: - http-client - http-client-openssl @@ -122,7 +103,7 @@ packages: # * https://github.com/brendanhay/amazonka/pull/493/files # # The archive corresponds to commit 52896fd46ef6812708e9e4d7456becc692698f6b. -- archive: https://github.com/neongreen/amazonka/archive/wire-2019-01-25.tar.gz +- archive: https://github.com/wireapp/amazonka/archive/wire-2019-01-25.tar.gz subdirs: - amazonka - core @@ -136,3 +117,5 @@ packages: - git: https://github.com/wireapp/hsaml2 commit: 000868849efd85ba82d2bf0ac5757f801d49ad5a # master (Sep 10, 2018) + +# DO NOT MODIFY THIS FILE. See README.md to learn why. diff --git a/snapshots/wire-1.1.yaml b/snapshots/wire-1.1.yaml index 4cb8065a9eb..c3e61914ba6 100644 --- a/snapshots/wire-1.1.yaml +++ b/snapshots/wire-1.1.yaml @@ -1,4 +1,6 @@ -resolver: wire-1.0.yaml +# DO NOT MODIFY THIS FILE. See README.md to learn why. + +resolver: https://raw.githubusercontent.com/wireapp/wire-server/develop/snapshots/wire-1.0.yaml name: wire-1.1 packages: diff --git a/snapshots/wire-1.2.yaml b/snapshots/wire-1.2.yaml index 5d5a0d04ace..ce06e85e192 100644 --- a/snapshots/wire-1.2.yaml +++ b/snapshots/wire-1.2.yaml @@ -1,6 +1,8 @@ -resolver: wire-1.1.yaml +# DO NOT MODIFY THIS FILE. See README.md to learn why. + +resolver: https://raw.githubusercontent.com/wireapp/wire-server/develop/snapshots/wire-1.1.yaml name: wire-1.2 packages: -- cql-io-1.1.0 # the MR in wire-1.0.yaml has been released on hackage. +- cql-io-1.1.0 # the MR in wire-1.0.yaml has been released on hackage. - cql-io-tinylog-0.1.0 diff --git a/stack.yaml b/stack.yaml index ac42a625eb2..09f52a20f2b 100644 --- a/stack.yaml +++ b/stack.yaml @@ -38,9 +38,9 @@ packages: extra-deps: - git: https://github.com/wireapp/saml2-web-sso - commit: e3aa52ac8637c168c122ad3e0eda02a7759dd56b # master (Mar 20, 2019) + commit: 68cc331da70c401cae114c24e6ba5373e1b5c190 # master (Apr 4, 2019) - git: https://github.com/wireapp/hscim - commit: b2ddde040426d332a2eddcddb00e81ffb1144a90 # master (Mar 13, 2019) + commit: 6b98b894c127eed4a5bde646ebf20febcfa656fa # master (Apr 2, 2019) - git: https://gitlab.com/fisx/tinylog commit: fd7155aaf6f090f48004a8f7857ce9d3cb4f9417 # https://gitlab.com/twittner/tinylog/merge_requests/6 diff --git a/tools/api-simulations/loadtest/src/Main.hs b/tools/api-simulations/loadtest/src/Main.hs index 63febe005b6..7222c9bca9c 100644 --- a/tools/api-simulations/loadtest/src/Main.hs +++ b/tools/api-simulations/loadtest/src/Main.hs @@ -12,6 +12,7 @@ import Network.Wire.Bot import Network.Wire.Bot.Report import Network.Wire.Simulations.LoadTest import Options.Applicative.Extended +import Data.Metrics (deprecatedRequestDurationHistogram) import qualified System.Logger as Log @@ -46,9 +47,12 @@ main = do <> eventTypeSection TConvMemberStateUpdate <> eventTypeSection TConvOtrMessageAdd <> section "Timings" - [ Buckets "Post Message" postMessageTime - , Buckets "Post Asset" postAssetTime - , Buckets "Get Asset" getAssetTime + [ Histogram "Post Message" postMessageTime + (deprecatedRequestDurationHistogram postMessageTime) + , Histogram "Post Asset" postAssetTime + (deprecatedRequestDurationHistogram postAssetTime) + , Histogram "Get Asset" getAssetTime + (deprecatedRequestDurationHistogram getAssetTime) ] parseOptions :: IO LoadTestSettings diff --git a/tools/db/service-backfill/src/Work.hs b/tools/db/service-backfill/src/Work.hs index efe082e6e12..0dd5990c999 100644 --- a/tools/db/service-backfill/src/Work.hs +++ b/tools/db/service-backfill/src/Work.hs @@ -10,7 +10,7 @@ module Work where import Imports import Brig.Types hiding (Client) -import Cassandra hiding (pageSize) +import Cassandra import Data.Id import System.Logger (Logger) import UnliftIO.Async (pooledMapConcurrentlyN)