Update dependencies

Client/Handlers/Apply.hs

@@ -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)

Client/Handlers/Profile.hs

@@ -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
+        profileForm ((\x -> let ProfilePageUser {..} = x in id) <$> user) user
-    defaultLayout $ profile ((\x -> id (x :: ProfilePageUser)) $ fromJust user) profileForm passwordForm
+    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

Client/Types.hs

@@ -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)

Server/API.hs

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

channels.scm

@@ -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")))))

datarekisteri.cabal

@@ -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

guix.scm

@@ -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