ry
/
datarekisteri
6
0
Fork 0
Code Issues 10 Pull Requests Packages Projects Releases Wiki Activity

Update dependencies

This commit is contained in:
Saku Laesvuori 2023-04-10 11:44:51 +03:00
parent 60d9706fe6
commit 3c51fb5dda
Signed by: slaesvuo
GPG Key ID: 257D284A2A1D3A32
7 changed files with 123 additions and 95 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
Client/Handlers/Apply.hs
View File

@ -80,6 +80,7 @@ postApplyR :: (YesodAuth DataIdClient, AuthId DataIdClient ~ Text) => Handler Ht
postApplyR = do
((result, widget), enctype) <- runFormPost applyForm
case result of
FormSuccess application -> apiRequest @Apply False application >>= \x -> redirect $ ProfileR $ id (apply x :: ApplyApply)
FormSuccess application -> apiRequest @Apply False application >>= \x ->
redirect $ ProfileR $ let ApplyApply {..} = apply x in id
_ -> do
defaultLayout $ applyW (widget, enctype)

17
Client/Handlers/Profile.hs
View File

@ -60,18 +60,18 @@ passwordForm = renderDivs $ areq verifiedPasswordField "Uusi salasana" Nothing
profileForm :: (Maybe UserID) -> (Maybe ProfilePageUser) -> Form UpdateProfileArgs
profileForm userID user extraHtml = do
(nameRes, nameView) <- mopt textField "Nimi"
(Just $ maybe Nothing (\x -> Just $ name (x :: ProfilePageUser)) user)
(Just $ maybe Nothing (\x -> Just $ let ProfilePageUser {..} = x in name) user)
(homeRes, homeView) <- mopt textField "Kotipaikka"
(Just $ maybe Nothing (\x -> Just $ homeplace (x :: ProfilePageUser)) user)
(Just $ maybe Nothing (\x -> Just $ let ProfilePageUser {..} = x in homeplace) user)
(nicknameRes, nicknameView) <- mopt textField "Kutsumanimi"
(Just $ maybe Nothing (\x -> Just $ nickname (x :: ProfilePageUser)) user)
(Just $ maybe Nothing (\x -> Just $ let ProfilePageUser {..} = x in nickname) user)
(emailRes, emailView) <- mopt emailField "Sähköposti"
(maybe Nothing (\x -> Just $ email (x :: ProfilePageUser)) user)
(maybe Nothing (\x -> Just $ let ProfilePageUser {..} = x in email) user)
(phoneNumberRes, phoneNumberView) <- mopt telephoneField "Puhelinnumero"
(Just $ maybe Nothing (\x -> Just $ phoneNumber (x :: ProfilePageUser)) user)
(Just $ maybe Nothing (\x -> Just $ let ProfilePageUser {..} = x in phoneNumber) user)
let profileUpdateRes = UpdateProfileArgs userID <$>
nameRes <*> homeRes <*> nicknameRes <*> emailRes <*> phoneNumberRes
maybePendingEmail = user >>= \x -> pendingEmail (x :: ProfilePageUser)
maybePendingEmail = user >>= \x -> let ProfilePageUser {..} = x in pendingEmail
inputField FieldView {..} = [whamlet|
<label for="#{fvId}">
^{fvLabel}
@ -113,8 +113,9 @@ getProfile userID = do
ProfilePage {..} <- apiRequest True (ProfilePageArgs {id = userID})
passwordForm <- liftHandler $ generateFormPost passwordForm
profileForm <- liftHandler $ generateFormPost $
profileForm ((\x -> id (x :: ProfilePageUser)) <$> user) user
defaultLayout $ profile ((\x -> id (x :: ProfilePageUser)) $ fromJust user) profileForm passwordForm
profileForm ((\x -> let ProfilePageUser {..} = x in id) <$> user) user
defaultLayout $ profile ((\x -> let ProfilePageUser {..} = x in id) $ fromJust user)
profileForm passwordForm
where fromJust = fromMaybe $ error "Tried to access the profile of an inexistent user"
getOwnProfileR :: (YesodAuth DataIdClient, AuthId DataIdClient ~ Text) => Handler Html

48
Client/Types.hs
View File

@ -34,6 +34,10 @@ import Data.Map (findWithDefault)
data DataIdClient = DataIdClient { getStatic :: Static }
instance PathPiece UserID where
toPathPiece (UserID id) = show id
fromPathPiece s = UserID <$> readMaybe (toString s)
mkYesodData "DataIdClient" [parseRoutes|
/ HomeR GET
@ -62,6 +66,26 @@ query GetPermissions {
}
|]
declareLocalTypesInline "schema.gql" [raw|
mutation GetWebUIToken {
newToken(comment: "id.datat.fi webui") {
tokenData
}
}
|]
instance YesodAuth DataIdClient where
type AuthId DataIdClient = Text
maybeAuthId = lookupSession credsKey
loginDest = const HomeR
logoutDest = const HomeR
authPlugins = const $
[ authExternalBasic $
fmap (fmap (tokenData . newToken) . rightToMaybe) .
flip (apiRequestAuth @GetWebUIToken []) () . Just
]
authenticate = pure . Authenticated . credsIdent
withAuthenticated :: (AuthId DataIdClient -> Handler AuthResult) -> Handler AuthResult
withAuthenticated m = maybeAuthId >>= maybe (pure AuthenticationRequired) m
@ -296,26 +320,6 @@ instance Yesod DataIdClient where
^{pageBody p}
|]
declareLocalTypesInline "schema.gql" [raw|
mutation GetWebUIToken {
newToken(comment: "id.datat.fi webui") {
tokenData
}
}
|]
instance YesodAuth DataIdClient where
type AuthId DataIdClient = Text
maybeAuthId = lookupSession credsKey
loginDest = const HomeR
logoutDest = const HomeR
authPlugins = const $
[ authExternalBasic $
fmap (fmap (tokenData . newToken) . rightToMaybe) .
flip (apiRequestAuth @GetWebUIToken []) () . Just
]
authenticate = pure . Authenticated . credsIdent
instance ApiRequest DataIdClient where
getApiUrl = ($ ApiR) <$> getUrlRender
authIdToAuthorization = flip const
@ -323,8 +327,4 @@ instance ApiRequest DataIdClient where
instance RenderMessage DataIdClient FormMessage where
renderMessage _ _ = defaultFormMessage
instance PathPiece UserID where
toPathPiece (UserID id) = show id
fromPathPiece s = UserID <$> readMaybe (toString s)
type Form a = Html -> MForm Handler (FormResult a, Widget)

2
Server/API.hs
View File

@ -12,6 +12,8 @@
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE NoGeneralizedNewtypeDeriving #-}
{-# LANGUAGE NoImplicitPrelude #-}
module Server.API (coreApp, runApp, resolver) where

11
channels.scm Normal file
View File

@ -0,0 +1,11 @@
(list (channel
(name 'guix)
(url "https://git.savannah.gnu.org/git/guix.git")
(branch "master")
(commit
"4bbd0f8c7ad304c52308cf6387acfab2bd12425b")
(introduction
(make-channel-introduction
"9edb3f66fd807b096b48283debdcddccfea34bad"
(openpgp-fingerprint
"BBB0 2DDF 2CEA F6A8 0D1D E643 A2A0 6DF2 A33A 54FA")))))

51
datarekisteri.cabal
View File

@ -8,7 +8,56 @@ build-type: Simple
stability: alpha
executable datarekisteri
build-depends: aeson, base, base64-bytestring, cryptonite, email-validate, esqueleto, memory, mime-mail, monad-logger, morpheus-graphql, morpheus-graphql-app, morpheus-graphql-client, morpheus-graphql-core, morpheus-graphql-server, mtl, persistent, persistent-postgresql, relude, scotty, smtp-mail, text, time, yesod, yesod-auth
build-depends:
aeson,
base,
base64-bytestring,
cryptonite,
email-validate,
esqueleto,
memory,
mime-mail,
monad-logger,
morpheus-graphql,
morpheus-graphql-app,
morpheus-graphql-client,
morpheus-graphql-core,
morpheus-graphql-server,
mtl,
persistent,
persistent-postgresql,
relude,
scotty,
smtp-mail,
text,
time,
yesod,
yesod-auth,
containers,
wai,
warp,
wai-cors,
wai-extra,
yesod-core,
yesod-static,
directory
main-is: Client.hs
other-modules:
Client.ApiRequests,
Client.Auth,
Client.FormFields,
Client.Handlers,
Client.Handlers.Applications,
Client.Handlers.Apply,
Client.Handlers.Profile,
Client.Handlers.VerifyEmail,
Client.Types,
Server,
Server.API,
Server.DB,
Server.DB.Queries,
Server.Email,
Server.Types,
Server.Utils
hs-source-dirs: .
default-language: Haskell2010

86
guix.scm
View File

@ -196,13 +196,13 @@ Sinatra + Warp = Scotty. . [WAI] <http://hackage.haskell.org/package/wai> .
(define-public ghc-morpheus-graphql
(package
(name "ghc-morpheus-graphql")
(version "0.27.0")
(version "0.27.1")
(source (origin
(method url-fetch)
(uri (hackage-uri "morpheus-graphql" version))
(sha256
(base32
"1d2wk0zw3qb22skv7g4xagl04las5xnh9f4223c4as9cf39pcrp9"))))
"1n9qflbgl7f4qd3sxc6rwnv0rmg0dj731rf1b9avc6xw199ydr3w"))))
(build-system haskell-build-system)
(inputs (list ghc-aeson
ghc-morpheus-graphql-app
@ -222,13 +222,13 @@ Sinatra + Warp = Scotty. . [WAI] <http://hackage.haskell.org/package/wai> .
(define-public ghc-morpheus-graphql-code-gen
(package
(name "ghc-morpheus-graphql-code-gen")
(version "0.27.0")
(version "0.27.1")
(source (origin
(method url-fetch)
(uri (hackage-uri "morpheus-graphql-code-gen" version))
(sha256
(base32
"0aw9fl0hzl657w2arybyk0zqxvbdz897kiqwsv52r50dnb5x2izf"))))
"0qvk2zpqhhjjfha5hfd9nkv30m07qbbnpil9h00w3skdw33mqqqk"))))
(build-system haskell-build-system)
(inputs (list ghc-file-embed
ghc-morpheus-graphql-code-gen-utils
@ -250,13 +250,13 @@ Sinatra + Warp = Scotty. . [WAI] <http://hackage.haskell.org/package/wai> .
(define-public ghc-morpheus-graphql-core
(package
(name "ghc-morpheus-graphql-core")
(version "0.27.0")
(version "0.27.1")
(source (origin
(method url-fetch)
(uri (hackage-uri "morpheus-graphql-core" version))
(sha256
(base32
"0001pq7zj5rpjcg0jasd3vklisan2i8nxyk8d7xa31d4f1grn5ff"))))
"1id4dxi4kpgd25ffhw5qgkl05b2642qpz5dss68nq0n1cs2c021b"))))
(build-system haskell-build-system)
(inputs (list ghc-aeson
ghc-hashable
@ -276,13 +276,13 @@ Sinatra + Warp = Scotty. . [WAI] <http://hackage.haskell.org/package/wai> .
(define-public ghc-morpheus-graphql-app
(package
(name "ghc-morpheus-graphql-app")
(version "0.27.0")
(version "0.27.1")
(source (origin
(method url-fetch)
(uri (hackage-uri "morpheus-graphql-app" version))
(sha256
(base32
"0mg12a8s2zcxcbm1zm5a4gn6vz8d9d1qdhk930zddxqbll5gq7nq"))))
"0qs5gx7k1ix4i0mqkmy681xlg7ckr8fy089rj4c25vgv8rm0p36w"))))
(build-system haskell-build-system)
(inputs (list ghc-aeson
ghc-hashable
@ -303,13 +303,13 @@ Sinatra + Warp = Scotty. . [WAI] <http://hackage.haskell.org/package/wai> .
(define-public ghc-morpheus-graphql-subscriptions
(package
(name "ghc-morpheus-graphql-subscriptions")
(version "0.27.0")
(version "0.27.1")
(source (origin
(method url-fetch)
(uri (hackage-uri "morpheus-graphql-subscriptions" version))
(sha256
(base32
"138fcganlaj4fyq1aygiyy6f4hhw58n26ldrdkxhd66hr1mqv6j9"))))
"0nj05ywj460v8kd821w7br44bx8wzqbbil0jb42sv442py69d6lj"))))
(build-system haskell-build-system)
(inputs (list ghc-aeson
ghc-morpheus-graphql-app
@ -328,13 +328,13 @@ Sinatra + Warp = Scotty. . [WAI] <http://hackage.haskell.org/package/wai> .
(define-public ghc-morpheus-graphql-client
(package
(name "ghc-morpheus-graphql-client")
(version "0.27.0")
(version "0.27.1")
(source (origin
(method url-fetch)
(uri (hackage-uri "morpheus-graphql-client" version))
(sha256
(base32
"120414v0rcvzgm9dc2fx8598d88dqnpvhkc8zh3y2gl3b1bl31jb"))))
"095kyjyv7gyrlqsdbw1aab2l990risr72c2j5gcwskbgqm7p3fip"))))
(build-system haskell-build-system)
(inputs (list ghc-aeson
ghc-file-embed
@ -359,13 +359,13 @@ Sinatra + Warp = Scotty. . [WAI] <http://hackage.haskell.org/package/wai> .
(define-public ghc-morpheus-graphql-tests
(package
(name "ghc-morpheus-graphql-tests")
(version "0.27.0")
(version "0.27.1")
(source (origin
(method url-fetch)
(uri (hackage-uri "morpheus-graphql-tests" version))
(sha256
(base32
"1h6nri73s5ibzidhwrkxffldardx6khq9kvhmqklm06cilwr56xi"))))
"1nhpcai8lk3jq676zp6y6jcylm3zjzl4s6hk0f3g7vmg971ycd9w"))))
(build-system haskell-build-system)
(inputs (list ghc-aeson ghc-relude ghc-tasty ghc-tasty-hunit
ghc-unordered-containers))
@ -378,13 +378,13 @@ Sinatra + Warp = Scotty. . [WAI] <http://hackage.haskell.org/package/wai> .
(define-public ghc-morpheus-graphql-server
(package
(name "ghc-morpheus-graphql-server")
(version "0.27.0")
(version "0.27.1")
(source (origin
(method url-fetch)
(uri (hackage-uri "morpheus-graphql-server" version))
(sha256
(base32
"0cd6qczbb5cm12xv181pzq6d62nv7nf4w1yd3gmhzjfrks62lhwy"))))
"0b8hipwp5ddxn92appn2n6s43kmqvqrp2rg055jkb2kcfwh8g828"))))
(build-system haskell-build-system)
(inputs (list ghc-aeson
ghc-morpheus-graphql-app
@ -411,7 +411,7 @@ Sinatra + Warp = Scotty. . [WAI] <http://hackage.haskell.org/package/wai> .
"02dn99v2qmykj0l1qmn15k36hyxccy71b7iqavfk24zgjf5g07dm"))))
(build-system haskell-build-system)
(inputs (list ghc-hashable ghc-unordered-containers))
(native-inputs (list ghc-hedgehog ghc-doctest-20 ghc-glob))
(native-inputs (list ghc-hedgehog ghc-doctest ghc-glob))
(home-page "https://github.com/kowainik/relude")
(synopsis
"Safe, performant, user-friendly and lightweight Haskell Standard Library")
@ -475,52 +475,16 @@ new functionality without breaking anything and let the users decide to use it
or not.")
(license license:expat)))
(define-public ghc-doctest-20
(package
(name "ghc-doctest-20")
(version "0.20.0")
(source (origin
(method url-fetch)
(uri (hackage-uri "doctest" version))
(sha256
(base32
"0sk50b8zxq4hvc8qphlmfha1lsv3xha7q7ka081jgswf1qpg34y4"))))
(build-system haskell-build-system)
(inputs (list ghc-base-compat ghc-code-page ghc-paths ghc-syb))
(native-inputs (list ghc-hunit
ghc-quickcheck
ghc-hspec
hspec-discover
ghc-hspec-core
ghc-mockery
ghc-setenv
ghc-silently
ghc-stringbuilder))
(arguments
`(#:cabal-revision ("5"
"0d7xgi71zdfbg3an6v2ss4lj6lvlmvq36hy788nd94ja2bgfsmpx")))
(home-page "https://github.com/sol/doctest#readme")
(synopsis "Test interactive Haskell examples")
(description
"`doctest` is a tool that checks
[examples](https://www.haskell.org/haddock/doc/html/ch03s08.html#idm140354810775744)
and
[properties](https://www.haskell.org/haddock/doc/html/ch03s08.html#idm140354810771856)
in Haddock comments. It is similar in spirit to the [popular Python module with
the same name](https://docs.python.org/3/library/doctest.html). . Documentation
is at <https://github.com/sol/doctest#readme>.")
(license license:expat)))
(define-public ghc-morpheus-graphql-code-gen-utils
(package
(name "ghc-morpheus-graphql-code-gen-utils")
(version "0.27.0")
(version "0.27.1")
(source (origin
(method url-fetch)
(uri (hackage-uri "morpheus-graphql-code-gen-utils" version))
(sha256
(base32
"1d5v3b63v9yf47a5hh2am6v09hwm4sfxls38iwvlxva3km0s1qgn"))))
"0f8152jzjynfl65k8f4iyyi8akqrcn9dhx8pi20yhf152h5w0clp"))))
(build-system haskell-build-system)
(inputs (list ghc-morpheus-graphql-core ghc-prettyprinter ghc-relude
ghc-unordered-containers))
@ -532,13 +496,13 @@ or not.")
(define-public ghc-wuss
(package
(name "ghc-wuss")
(version "2.0.0.2")
(version "2.0.1.3")
(source (origin
(method url-fetch)
(uri (hackage-uri "wuss" version))
(sha256
(base32
"04jqq3blzyxqyymhcjsm5z89whk5y7cvnd9dw6nlc40vq4w4v802"))))
"037dsx4mrp5mz2fif9zqlsp1n35g7v8749wmji281ing8jfiyl37"))))
(build-system haskell-build-system)
(inputs (list ghc-connection ghc-network ghc-websockets))
(home-page "http://hackage.haskell.org/package/wuss")
@ -625,13 +589,13 @@ Standard for RSA, version 2.1 (a.k.a, PKCS#1 v2.1).")
(define-public ghc-req
(package
(name "ghc-req")
(version "3.12.0")
(version "3.13.0")
(source (origin
(method url-fetch)
(uri (hackage-uri "req" version))
(sha256
(base32
"1gwdqmqmj3acim5r8c4sjzcvr3hvlbcjwkrpcsvq95ckr1wmzpqp"))))
"1igs75bj57vs1fwpxj1765l6zkqd4r3p2gbwp6cv2l37drfxjck4"))))
(build-system haskell-build-system)
(inputs (list ghc-aeson
ghc-authenticate-oauth
@ -658,13 +622,13 @@ Standard for RSA, version 2.1 (a.k.a, PKCS#1 v2.1).")
(define-public ghc-modern-uri
(package
(name "ghc-modern-uri")
(version "0.3.4.4")
(version "0.3.6.0")
(source (origin
(method url-fetch)
(uri (hackage-uri "modern-uri" version))
(sha256
(base32
"19fffy7kb7ibajagdryjy872x56045zi6c1div8wvr8aisd55qsz"))))
"1lj3il9wg7v88l1hj08k07g3f76xas0gz20l2wy8z6xbpcn5ng6g"))))
(build-system haskell-build-system)
(inputs (list ghc-quickcheck
ghc-contravariant