.gitignore

@@ -0,0 +1,2 @@
+**/db/schema.sql
+**/client_session_key.aes

.guix-authorizations

@@ -0,0 +1,4 @@
+(authorizations
+ (version 0)
+ (("A0C9 1947 734F 076F 5F08 E9FF 257D 284A 2A1D 3A32"
+   (name "Saku Laesvuori"))))

.guix-channel

@@ -0,0 +1,4 @@
+(channel
+  (version 0)
+  (url "https://git.datat.fi/ry/datarekisteri.git")
+  (directory ".guix/modules"))

.guix/modules/datarekisteri-package.scm

@@ -0,0 +1,988 @@
+(define-module (datarekisteri-package)
+  #:use-module (guix)
+  #:use-module (guix build-system go)
+  #:use-module (guix build-system haskell)
+  #:use-module (guix download)
+  #:use-module (guix git-download)
+  #:use-module ((guix licenses) #:prefix license:)
+  #:use-module (guix packages)
+  #:use-module (gnu packages golang)
+  #:use-module (gnu packages golang-check)
+  #:use-module (gnu packages syncthing)
+  #:use-module (gnu packages haskell)
+  #:use-module (gnu packages haskell-check)
+  #:use-module (gnu packages haskell-crypto)
+  #:use-module (gnu packages haskell-web)
+  #:use-module (gnu packages haskell-xyz))
+
+(define vcs-file?
+  (or (git-predicate (string-append (current-source-directory) "/../.."))
+      (const #t)))
+
+(define-public datarekisteri-backend
+  (package
+    (name "datarekisteri-backend")
+    (version "0.0.1")
+    (source (local-file "../../backend" "datarekisteri-backend-checkout"
+                        #:recursive? #t
+                        #:select? vcs-file?))
+    (build-system haskell-build-system)
+    (inputs (list dbmate
+                  ghc-base64
+                  ghc-cryptonite
+                  ghc-datarekisteri-core
+                  ghc-data-default
+                  ghc-echo
+                  ghc-email-validate
+                  ghc-esqueleto
+                  ghc-mime-mail
+                  ghc-morpheus-graphql
+                  ghc-optparse-applicative
+                  ghc-persistent
+                  ghc-persistent-postgresql
+                  ghc-scotty
+                  ghc-smtp-mail
+                  ghc-wai-cors
+                  ghc-wai-extra))
+    (arguments
+     (list
+      #:phases
+      #~(modify-phases %standard-phases
+          (add-after 'install 'wrap-binaries
+            (lambda _
+              (wrap-program
+                (string-append #$output "/bin/datarekisteri-backend")
+                `("PATH" prefix (,(string-append #$(this-package-input "dbmate") "/bin")))))))))
+    (home-page "")
+    (synopsis "")
+    (description "")
+    (license license:agpl3+)))
+
+(define-public datarekisteri-frontend
+  (package
+    (name "datarekisteri-frontend")
+    (version "0.0.1")
+    (source (local-file "../../frontend" "datarekisteri-frontend-checkout"
+                        #:recursive? #t
+                        #:select? vcs-file?))
+    (build-system haskell-build-system)
+    (inputs (list dbmate
+                  ghc-base64
+                  ghc-cryptonite
+                  ghc-datarekisteri-core
+                  ghc-email-validate
+                  ghc-esqueleto
+                  ghc-mime-mail
+                  ghc-morpheus-graphql
+                  ghc-morpheus-graphql-client
+                  ghc-optparse-applicative
+                  ghc-persistent
+                  ghc-persistent-postgresql
+                  ghc-wai-extra
+                  ghc-yesod
+                  ghc-yesod-static
+                  ghc-yesod-auth))
+    (home-page "")
+    (synopsis "")
+    (description "")
+    (license license:agpl3+)))
+
+(define-public ghc-datarekisteri-core
+  (package
+    (name "datarekisteri-core")
+    (version "0.0.1")
+    (source (local-file "../../core" "datarekisteri-core-checkout"
+                        #:recursive? #t
+                        #:select? vcs-file?))
+    (build-system haskell-build-system)
+    (inputs (list ghc-base64
+                  ghc-cryptonite
+                  ghc-email-validate
+                  ghc-mime-mail
+                  ghc-morpheus-graphql
+                  ghc-morpheus-graphql-client
+                  ghc-persistent
+                  ghc-persistent-postgresql))
+    (home-page "")
+    (synopsis "")
+    (description "")
+    (license license:agpl3+)))
+
+
+(define ghc-authenticate
+  (package
+    (name "ghc-authenticate")
+    (version "1.3.5.1")
+    (source (origin
+              (method url-fetch)
+              (uri (hackage-uri "authenticate" version))
+              (sha256
+               (base32
+                "1rhbvdgwdr68gp13p5piddfdqf3l9lmx4w7k249lc98y23780c3x"))))
+    (build-system haskell-build-system)
+    (inputs (list ghc-aeson
+                  ghc-http-conduit
+                  ghc-case-insensitive
+                  ghc-http-types
+                  ghc-xml-conduit
+                  ghc-blaze-builder
+                  ghc-attoparsec
+                  ghc-unordered-containers
+                  ghc-conduit
+                  ghc-html-conduit
+                  ghc-resourcet
+                  ghc-network-uri))
+    (home-page "http://github.com/yesodweb/authenticate")
+    (synopsis "Authentication methods for Haskell web applications.")
+    (description "API docs and the README are available at
+<http://www.stackage.org/package/authenticate>.")
+    (license license:expat)))
+
+(define ghc-yesod-auth
+  (package
+    (name "ghc-yesod-auth")
+    (version "1.6.11")
+    (source (origin
+              (method url-fetch)
+              (uri (hackage-uri "yesod-auth" version))
+              (sha256
+               (base32
+                "0fdahk5mc63g0zsafk8axry01qaxahmclpmmwygp2lhfsjy8mby2"))))
+    (build-system haskell-build-system)
+    (inputs (list ghc-aeson
+                  ghc-authenticate
+                  ghc-base16-bytestring
+                  ghc-base64-bytestring
+                  ghc-blaze-builder
+                  ghc-blaze-html
+                  ghc-blaze-markup
+                  ghc-conduit
+                  ghc-conduit-extra
+                  ghc-cryptonite
+                  ghc-data-default
+                  ghc-email-validate
+                  ghc-file-embed
+                  ghc-http-client
+                  ghc-http-client-tls
+                  ghc-http-conduit
+                  ghc-http-types
+                  ghc-memory
+                  ghc-nonce
+                  ghc-persistent
+                  ghc-random
+                  ghc-safe
+                  ghc-shakespeare
+                  ghc-unliftio
+                  ghc-unliftio-core
+                  ghc-unordered-containers
+                  ghc-wai
+                  ghc-yesod-core
+                  ghc-yesod-form
+                  ghc-yesod-persistent
+                  ghc-network-uri))
+    (home-page "http://www.yesodweb.com/")
+    (synopsis "Authentication for Yesod.")
+    (description "API docs and the README are available at
+<http://www.stackage.org/package/yesod-auth>")
+    (license license:expat)))
+
+(define ghc-scotty
+  (package
+    (name "ghc-scotty")
+    (version "0.12")
+    (source (origin
+              (method url-fetch)
+              (uri (hackage-uri "scotty" version))
+              (sha256
+               (base32
+                "1lpggpdzgjk23mq7aa64yylds5dbm4ynhcvbarqihjxabvh7xmz1"))))
+    (build-system haskell-build-system)
+    (inputs (list ghc-aeson
+                  ghc-base-compat-batteries
+                  ghc-blaze-builder
+                  ghc-case-insensitive
+                  ghc-data-default-class
+                  ghc-fail
+                  ghc-http-types
+                  ghc-monad-control
+                  ghc-nats
+                  ghc-network
+                  ghc-regex-compat
+                  ghc-transformers-base
+                  ghc-transformers-compat
+                  ghc-wai
+                  ghc-wai-extra
+                  ghc-warp))
+    (native-inputs (list ghc-async ghc-hspec ghc-hspec-wai ghc-lifted-base hspec-discover))
+    (arguments
+     `(#:cabal-revision ("7"
+                         "1i8icc612w4dbmqmnf99drqpmjvhjnkmqgk9xr63amj8jkz5lp4m")))
+    (home-page "https://github.com/scotty-web/scotty")
+    (synopsis
+     "Haskell web framework inspired by Ruby's Sinatra, using WAI and Warp")
+    (description
+     "This package provides a Haskell web framework inspired by Ruby's Sinatra, using
+WAI and Warp. . @ &#123;-&#35; LANGUAGE OverloadedStrings &#35;-&#125; .  import
+Web.Scotty .  import Data.Monoid (mconcat) .  main = scotty 3000 $ &#32;&#32;get
+&#34;/:word&#34; $ do &#32;&#32;&#32;&#32;beam <- param &#34;word&#34;
+&#32;&#32;&#32;&#32;html $ mconcat [&#34;&#60;h1&#62;Scotty, &#34;, beam, &#34;
+me up!&#60;/h1&#62;&#34;] @ . .  Scotty is the cheap and cheerful way to write
+RESTful, declarative web applications. . * A page is as simple as defining the
+verb, url pattern, and Text content. . * It is template-language agnostic.
+Anything that returns a Text value will do. . * Conforms to WAI Application
+interface. . * Uses very fast Warp webserver by default. .  As for the name:
+Sinatra + Warp = Scotty. . [WAI] <http://hackage.haskell.org/package/wai> .
+[Warp] <http://hackage.haskell.org/package/warp>")
+    (license license:bsd-3)))
+
+(define ghc-hspec-wai
+  (package
+    (name "ghc-hspec-wai")
+    (version "0.11.1")
+    (source (origin
+              (method url-fetch)
+              (uri (hackage-uri "hspec-wai" version))
+              (sha256
+               (base32
+                "03wiksic5y9a2g6a86nsxrnajdgdvpv17w02h5qla0zp9zs6pa1j"))))
+    (build-system haskell-build-system)
+    (inputs (list ghc-quickcheck
+                  ghc-base-compat
+                  ghc-case-insensitive
+                  ghc-hspec-core
+                  ghc-hspec-expectations
+                  ghc-http-types
+                  ghc-wai
+                  ghc-wai-extra))
+    (native-inputs (list ghc-hspec hspec-discover))
+    (home-page "https://github.com/hspec/hspec-wai#readme")
+    (synopsis "Experimental Hspec support for testing WAI applications")
+    (description "Experimental Hspec support for testing WAI applications")
+    (license license:expat)))
+
+(define ghc-morpheus-graphql
+  (package
+    (name "ghc-morpheus-graphql")
+    (version "0.27.3")
+    (source (origin
+              (method url-fetch)
+              (uri (hackage-uri "morpheus-graphql" version))
+              (sha256
+               (base32
+                "04qah7565dzq7v4q43zjz8778pdn5jwnway5rvz4kkibcrscfagn"))))
+    (build-system haskell-build-system)
+    (inputs (list ghc-aeson
+                  ghc-morpheus-graphql-app
+                  ghc-morpheus-graphql-code-gen
+                  ghc-morpheus-graphql-core
+                  ghc-morpheus-graphql-server
+                  ghc-relude
+                  ghc-unordered-containers
+                  ghc-vector))
+    (native-inputs (list ghc-morpheus-graphql-subscriptions
+                         ghc-morpheus-graphql-tests ghc-tasty ghc-tasty-hunit))
+    (home-page "https://morpheusgraphql.com")
+    (synopsis "Morpheus GraphQL")
+    (description "Build GraphQL APIs with your favourite functional language!")
+    (license license:expat)))
+
+(define ghc-morpheus-graphql-code-gen
+  (package
+    (name "ghc-morpheus-graphql-code-gen")
+    (version "0.27.3")
+    (source (origin
+              (method url-fetch)
+              (uri (hackage-uri "morpheus-graphql-code-gen" version))
+              (sha256
+               (base32
+                "1rmxcr17xjx99aam048a4sqlwlnxjk41hx8fnb363ljid74vrcrb"))))
+    (build-system haskell-build-system)
+    (inputs (list ghc-file-embed
+                  ghc-morpheus-graphql-code-gen-utils
+                  ghc-morpheus-graphql-core
+                  ghc-morpheus-graphql-server
+                  ghc-prettyprinter
+                  ghc-relude
+                  ghc-unordered-containers
+                  ghc-glob
+                  ghc-morpheus-graphql-client
+                  ghc-optparse-applicative
+                  ghc-yaml))
+    (home-page "https://morpheusgraphql.com")
+    (synopsis "Morpheus GraphQL CLI")
+    (description "code generator for Morpheus GraphQL")
+    (license license:bsd-3)))
+
+
+(define ghc-morpheus-graphql-core
+  (package
+    (name "ghc-morpheus-graphql-core")
+    (version "0.27.3")
+    (source (origin
+              (method url-fetch)
+              (uri (hackage-uri "morpheus-graphql-core" version))
+              (sha256
+               (base32
+                "0dd8bifn6qwpss06hbb0r730fqfkbd4nhwsr2bsrgxc7hvzv9wi7"))))
+    (build-system haskell-build-system)
+    (inputs (list ghc-aeson
+                  ghc-hashable
+                  ghc-megaparsec
+                  ghc-relude
+                  ghc-scientific
+                  ghc-th-lift-instances
+                  ghc-unordered-containers
+                  ghc-vector))
+    (native-inputs (list ghc-morpheus-graphql-tests ghc-tasty ghc-tasty-hunit))
+    (home-page "https://morpheusgraphql.com")
+    (synopsis "Morpheus GraphQL Core")
+    (description "Build GraphQL APIs with your favorite functional language!")
+    (license license:expat)))
+
+
+(define ghc-morpheus-graphql-app
+  (package
+    (name "ghc-morpheus-graphql-app")
+    (version "0.27.3")
+    (source (origin
+              (method url-fetch)
+              (uri (hackage-uri "morpheus-graphql-app" version))
+              (sha256
+               (base32
+                "0dicajcqgxpv1jhnywjjs0g4p5ryv0xlrywib1xwxrb04wy9aa3f"))))
+    (build-system haskell-build-system)
+    (inputs (list ghc-aeson
+                  ghc-hashable
+                  ghc-megaparsec
+                  ghc-morpheus-graphql-core
+                  ghc-relude
+                  ghc-scientific
+                  ghc-th-lift-instances
+                  ghc-unordered-containers
+                  ghc-vector))
+    (native-inputs (list ghc-morpheus-graphql-tests ghc-tasty ghc-tasty-hunit))
+    (home-page "https://morpheusgraphql.com")
+    (synopsis "Morpheus GraphQL App")
+    (description "Build GraphQL APIs with your favourite functional language!")
+    (license license:expat)))
+
+
+(define ghc-morpheus-graphql-subscriptions
+  (package
+    (name "ghc-morpheus-graphql-subscriptions")
+    (version "0.27.3")
+    (source (origin
+              (method url-fetch)
+              (uri (hackage-uri "morpheus-graphql-subscriptions" version))
+              (sha256
+               (base32
+                "0gynrshv858g36jwvmh3q2asc6ppkr7hv9w9lx1qfjqfwm7r0140"))))
+    (build-system haskell-build-system)
+    (inputs (list ghc-aeson
+                  ghc-morpheus-graphql-app
+                  ghc-morpheus-graphql-core
+                  ghc-relude
+                  ghc-unliftio-core
+                  ghc-unordered-containers
+                  ghc-uuid
+                  ghc-websockets))
+    (home-page "https://morpheusgraphql.com")
+    (synopsis "Morpheus GraphQL Subscriptions")
+    (description "Build GraphQL APIs with your favourite functional language!")
+    (license license:expat)))
+
+
+(define ghc-morpheus-graphql-client
+  (package
+    (name "ghc-morpheus-graphql-client")
+    (version "0.27.3")
+    (source (origin
+              (method url-fetch)
+              (uri (hackage-uri "morpheus-graphql-client" version))
+              (sha256
+               (base32
+                "1j4r6ar6l462aq8qvxikmwyxd2f8i60gd3j0qf5pxsslgjwmjbi9"))))
+    (build-system haskell-build-system)
+    (inputs (list ghc-aeson
+                  ghc-file-embed
+                  ghc-modern-uri
+                  ghc-morpheus-graphql-code-gen-utils
+                  ghc-morpheus-graphql-core
+                  ghc-morpheus-graphql-subscriptions
+                  ghc-prettyprinter
+                  ghc-relude
+                  ghc-req
+                  ghc-unliftio-core
+                  ghc-unordered-containers
+                  ghc-websockets
+                  ghc-wuss))
+    (native-inputs (list ghc-tasty ghc-tasty-hunit))
+    (home-page "https://morpheusgraphql.com")
+    (synopsis "Morpheus GraphQL Client")
+    (description "Build GraphQL APIs with your favorite functional language!")
+    (license license:expat)))
+
+
+(define ghc-morpheus-graphql-tests
+  (package
+    (name "ghc-morpheus-graphql-tests")
+    (version "0.27.3")
+    (source (origin
+              (method url-fetch)
+              (uri (hackage-uri "morpheus-graphql-tests" version))
+              (sha256
+               (base32
+                "1s9x4gcqd36gqf5w2wxiqhf7k9y44b7g7zm90y2kbclxqirs9rqf"))))
+    (build-system haskell-build-system)
+    (inputs (list ghc-aeson ghc-relude ghc-tasty ghc-tasty-hunit
+                  ghc-unordered-containers))
+    (home-page "https://morpheusgraphql.com")
+    (synopsis "Morpheus GraphQL Test")
+    (description "")
+    (license license:expat)))
+
+
+(define ghc-morpheus-graphql-server
+  (package
+    (name "ghc-morpheus-graphql-server")
+    (version "0.27.3")
+    (source (origin
+              (method url-fetch)
+              (uri (hackage-uri "morpheus-graphql-server" version))
+              (sha256
+               (base32
+                "1hl2c78pnx2rxx869p6ixvnyhzm46f1hzalqz2vbwrflshpmjv91"))))
+    (build-system haskell-build-system)
+    (inputs (list ghc-aeson
+                  ghc-morpheus-graphql-app
+                  ghc-morpheus-graphql-core
+                  ghc-relude
+                  ghc-unordered-containers
+                  ghc-vector))
+    (native-inputs (list ghc-file-embed ghc-morpheus-graphql-subscriptions
+                         ghc-morpheus-graphql-tests ghc-tasty ghc-tasty-hunit))
+    (home-page "https://morpheusgraphql.com")
+    (synopsis "Morpheus GraphQL")
+    (description "Build GraphQL APIs with your favourite functional language!")
+    (license license:expat)))
+
+(define ghc-relude
+  (package
+    (name "ghc-relude")
+    (version "1.1.0.0")
+    (source (origin
+              (method url-fetch)
+              (uri (hackage-uri "relude" version))
+              (sha256
+               (base32
+                "02dn99v2qmykj0l1qmn15k36hyxccy71b7iqavfk24zgjf5g07dm"))))
+    (build-system haskell-build-system)
+    (inputs (list ghc-hashable ghc-unordered-containers))
+    (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")
+    (description
+     "@__relude__@ is an alternative prelude library.  If you find the default
+@Prelude@ unsatisfying, despite its advantages, consider using @relude@ instead.
+== Relude goals and design principles * __Productivity.__ You can be more
+productive with a \"non-standard\" standard library, and @relude@ helps you with
+writing safer and more efficient code faster. * __Total programming__.  Usage of
+[/partial
+functions/](https://www.reddit.com/r/haskell/comments/5n51u3/why_are_partial_functions_as_in_head_tail_bad/)
+can lead to unexpected bugs and runtime exceptions in pure code.  The types of
+partial functions lie about their behaviour.  And even if it is not always
+possible to rely only on total functions, @relude@ strives to encourage
+best-practices and reduce the chances of introducing a bug.
++---------------------------------+--------------------------------------------+
+| __Partial__                     | __Total__                                  |
++=================================+============================================+
+| @head :: [a] -> a@              | @head :: NonEmpty a -> a@                  |
++---------------------------------+--------------------------------------------+
+| @tail :: [a] -> [a]@            | @tail :: NonEmpty a -> [a]@                |
++---------------------------------+--------------------------------------------+
+| @read :: Read a => String -> a@ | @readMaybe :: Read a => String -> Maybe a@ |
++---------------------------------+--------------------------------------------+
+| @fromJust :: Maybe a -> a@      | @fromMaybe :: a -> Maybe a -> a@           |
++---------------------------------+--------------------------------------------+
+* __Type-safety__.  We use the /\"make invalid states unrepresentable\"/ motto as
+one of our guiding principles.  If it is possible, we express this concept
+through the types. /Example:/ @ whenNotNull :: Applicative f => [a] -> (NonEmpty
+a -> f ()) -> f () @ * __Performance.__ We prefer @Text@ over
+@[String](https://www.reddit.com/r/haskell/comments/29jw0s/whats_wrong_with_string/)@,
+use space-leaks-free functions (e.g.  our custom performant @sum@ and
+@product@), introduce @\\{\\-\\# INLINE \\#\\-\\}@ and @\\{\\-\\# SPECIALIZE \\#\\-\\}@
+pragmas where appropriate, and make efficient container types (e.g. @Map@,
+@HashMap@, @Set@) more accessible. * __Minimalism__ (low number of
+dependencies).  We do not force users of @relude@ to stick to any specific lens
+or text formatting or logging library.  Where possible, @relude@ depends only on
+boot libraries.  The [Dependency
+graph](https://raw.githubusercontent.com/kowainik/relude/main/relude-dependency-graph.png)
+of @relude@ can give you a clearer picture. * __Convenience__.  Despite
+minimalism, we want to bring commonly used types and functions into scope, and
+make available functions easier to use.  Some examples of conveniences: 1.  No
+need to add @containers@, @unordered-containers@, @text@ and @bytestring@ to
+dependencies in your @.cabal@ file to use the main API of these libraries 2.  No
+need to import types like @NonEmpty@, @Text@, @Set@, @Reader[T]@, @MVar@, @STM@
+3.  Functions like @liftIO@, @fromMaybe@, @sortWith@ are available by default as
+well 4. @IO@ actions are lifted to @MonadIO@ * __Excellent documentation.__ 1.
+Tutorial 2.  Migration guide from @Prelude@ 3.  Haddock for every function with
+examples tested by [doctest](http://hackage.haskell.org/package/doctest).  4.
+Documentation regarding [internal module
+structure](http://hackage.haskell.org/package/relude/docs/Relude.html) 5.
+@relude@-specific [HLint](http://hackage.haskell.org/package/hlint) rules:
+@[.hlint.yaml](https://github.com/kowainik/relude/blob/main/.hlint.yaml)@ *
+__User-friendliness.__ Anyone should be able to quickly migrate to @relude@.
+Only some basic familiarity with the common libraries like @text@ and
+@containers@ should be enough (but not necessary). * __Exploration.__ We have
+space to experiment with new ideas and proposals without introducing breaking
+changes. @relude@ uses the approach with @Extra.*@ modules which are not
+exported by default.  The chosen approach makes it quite easy for us to provide
+new functionality without breaking anything and let the users decide to use it
+or not.")
+    (license license:expat)))
+
+(define ghc-morpheus-graphql-code-gen-utils
+  (package
+    (name "ghc-morpheus-graphql-code-gen-utils")
+    (version "0.27.3")
+    (source (origin
+              (method url-fetch)
+              (uri (hackage-uri "morpheus-graphql-code-gen-utils" version))
+              (sha256
+               (base32
+                "11dfnyd9wbrwjfjz1qkc188x6l4b149jsyzjwh1gqji0skzsk3f6"))))
+    (build-system haskell-build-system)
+    (inputs (list ghc-morpheus-graphql-core ghc-prettyprinter ghc-relude
+                  ghc-unordered-containers))
+    (home-page "https://morpheusgraphql.com")
+    (synopsis "Morpheus GraphQL CLI")
+    (description "code generator for Morpheus GraphQL")
+    (license license:bsd-3)))
+
+(define ghc-wuss
+  (package
+    (name "ghc-wuss")
+    (version "2.0.1.3")
+    (source (origin
+              (method url-fetch)
+              (uri (hackage-uri "wuss" version))
+              (sha256
+               (base32
+                "037dsx4mrp5mz2fif9zqlsp1n35g7v8749wmji281ing8jfiyl37"))))
+    (build-system haskell-build-system)
+    (inputs (list ghc-connection ghc-network ghc-websockets))
+    (home-page "http://hackage.haskell.org/package/wuss")
+    (synopsis "Secure WebSocket (WSS) clients")
+    (description
+     "Wuss is a library that lets you easily create secure WebSocket clients over the
+WSS protocol.  It is a small addition to
+<https://hackage.haskell.org/package/websockets the websockets package> and is
+adapted from existing solutions by <https://gist.github.com/jaspervdj/7198388
+@@jaspervdj>, <https://gist.github.com/mpickering/f1b7ba3190a4bb5884f3
+@@mpickering>, and <https://gist.github.com/elfenlaid/7b5c28065e67e4cf0767
+@@elfenlaid>.")
+    (license license:expat)))
+
+(define ghc-rsa
+  (package
+    (name "ghc-rsa")
+    (version "2.4.1")
+    (source (origin
+              (method url-fetch)
+              (uri (hackage-uri "RSA" version))
+              (sha256
+               (base32
+                "0hchsqrxpfw7mqrqwscfy8ig1w2di6w3nxpzi873w0gibv2diibj"))))
+    (build-system haskell-build-system)
+    (inputs (list ghc-crypto-api ghc-crypto-pubkey-types ghc-sha))
+    (native-inputs (list ghc-quickcheck ghc-tagged ghc-test-framework
+                         ghc-test-framework-quickcheck2))
+    (home-page "http://hackage.haskell.org/package/RSA")
+    (synopsis
+     "Implementation of RSA, using the padding schemes of PKCS#1 v2.1.")
+    (description
+     "This library implements the RSA encryption and signature algorithms for
+arbitrarily-sized ByteStrings.  While the implementations work, they are not
+necessarily the fastest ones on the planet.  Particularly key generation.  The
+algorithms included are based of RFC 3447, or the Public-Key Cryptography
+Standard for RSA, version 2.1 (a.k.a, PKCS#1 v2.1).")
+    (license license:bsd-3)))
+
+(define ghc-crypto-pubkey-types
+  (package
+    (name "ghc-crypto-pubkey-types")
+    (version "0.4.3")
+    (source (origin
+              (method url-fetch)
+              (uri (hackage-uri "crypto-pubkey-types" version))
+              (sha256
+               (base32
+                "0q0wlzjmpx536h1zcdzrpxjkvqw8abj8z0ci38138kpch4igbnby"))))
+    (build-system haskell-build-system)
+    (inputs (list ghc-asn1-types ghc-asn1-encoding))
+    (home-page "http://github.com/vincenthz/hs-crypto-pubkey-types")
+    (synopsis "Generic cryptography Public keys algorithm types")
+    (description "Generic cryptography public keys algorithm types")
+    (license license:bsd-3)))
+
+(define ghc-authenticate-oauth
+  (package
+    (name "ghc-authenticate-oauth")
+    (version "1.7")
+    (source (origin
+              (method url-fetch)
+              (uri (hackage-uri "authenticate-oauth" version))
+              (sha256
+               (base32
+                "0y4v46rn0cvm0sr1v8qq1zgzllrlrr3ji5gij1xprgf1zsazcvvl"))))
+    (build-system haskell-build-system)
+    (inputs (list ghc-http-client
+                  ghc-crypto-pubkey-types
+                  ghc-rsa
+                  ghc-data-default
+                  ghc-sha
+                  ghc-random
+                  ghc-http-types
+                  ghc-blaze-builder
+                  ghc-transformers-compat))
+    (home-page "http://github.com/yesodweb/authenticate")
+    (synopsis
+     "Library to authenticate with OAuth for Haskell web applications.")
+    (description "API docs and the README are available at
+<http://www.stackage.org/package/authenticate-oauth>.")
+    (license license:bsd-3)))
+
+(define ghc-req
+  (package
+    (name "ghc-req")
+    (version "3.13.0")
+    (source (origin
+              (method url-fetch)
+              (uri (hackage-uri "req" version))
+              (sha256
+               (base32
+                "1igs75bj57vs1fwpxj1765l6zkqd4r3p2gbwp6cv2l37drfxjck4"))))
+    (build-system haskell-build-system)
+    (inputs (list ghc-aeson
+                  ghc-authenticate-oauth
+                  ghc-blaze-builder
+                  ghc-case-insensitive
+                  ghc-connection
+                  ghc-http-api-data
+                  ghc-http-client
+                  ghc-http-client-tls
+                  ghc-http-types
+                  ghc-modern-uri
+                  ghc-monad-control
+                  ghc-retry
+                  ghc-transformers-base
+                  ghc-unliftio-core))
+    (native-inputs (list ghc-quickcheck ghc-hspec hspec-discover ghc-hspec-core
+                         ghc-quickcheck ghc-hspec))
+    (arguments '(#:tests? #f))
+    (home-page "https://github.com/mrkkrp/req")
+    (synopsis "HTTP client library")
+    (description "HTTP client library.")
+    (license license:bsd-3)))
+
+(define ghc-modern-uri
+  (package
+    (name "ghc-modern-uri")
+    (version "0.3.6.0")
+    (source (origin
+              (method url-fetch)
+              (uri (hackage-uri "modern-uri" version))
+              (sha256
+               (base32
+                "1lj3il9wg7v88l1hj08k07g3f76xas0gz20l2wy8z6xbpcn5ng6g"))))
+    (build-system haskell-build-system)
+    (inputs (list ghc-quickcheck
+                  ghc-contravariant
+                  ghc-hashable
+                  ghc-megaparsec
+                  ghc-profunctors
+                  ghc-reflection
+                  ghc-tagged))
+    (native-inputs (list ghc-hspec hspec-discover ghc-hspec-megaparsec))
+    (home-page "https://github.com/mrkkrp/modern-uri")
+    (synopsis "Modern library for working with URIs")
+    (description "Modern library for working with URIs.")
+    (license license:bsd-3)))
+
+(define ghc-mime-mail
+  (package
+    (name "ghc-mime-mail")
+    (version "0.5.1")
+    (source (origin
+              (method url-fetch)
+              (uri (hackage-uri "mime-mail" version))
+              (sha256
+               (base32
+                "1s1wp8v1xlvw3r4qk1lv9zpm99ihka7a785zjl6i3fq1maqq955g"))))
+    (build-system haskell-build-system)
+    (inputs (list ghc-base64-bytestring ghc-random ghc-blaze-builder))
+    (native-inputs (list ghc-hspec hspec-discover))
+    (home-page "http://github.com/snoyberg/mime-mail")
+    (synopsis "Compose MIME email messages.")
+    (description
+     "Hackage documentation generation is not reliable.  For up to date documentation,
+please see: <http://www.stackage.org/package/mime-mail>.")
+    (license license:expat)))
+
+(define ghc-smtp-mail
+  (package
+    (name "ghc-smtp-mail")
+    (version "0.3.0.0")
+    (source (origin
+              (method url-fetch)
+              (uri (hackage-uri "smtp-mail" version))
+              (sha256
+               (base32
+                "0q81m4mi43cd0f1azm6984xw3qw2s6ygszdn86j5z3g5sjj5dax4"))))
+    (build-system haskell-build-system)
+    (inputs (list ghc-base16-bytestring
+                  ghc-base64-bytestring
+                  ghc-connection
+                  ghc-mime-mail
+                  ghc-network
+                  ghc-network-bsd
+                  ghc-cryptonite
+                  ghc-memory))
+    (home-page "http://github.com/jhickner/smtp-mail")
+    (synopsis "Simple email sending via SMTP")
+    (description
+     "This packages provides a simple interface for mail over SMTP.  PLease see the
+README for more information.")
+    (license license:bsd-3)))
+
+(define-public go-github-com-jmoiron-sqlx
+  (package
+    (name "go-github-com-jmoiron-sqlx")
+    (version "1.3.5")
+    (source (origin
+              (method git-fetch)
+              (uri (git-reference
+                    (url "https://github.com/jmoiron/sqlx")
+                    (commit (string-append "v" version))))
+              (file-name (git-file-name name version))
+              (sha256
+               (base32
+                "09snd3gfi3sm3gib7jdc6p8zxpn2ah0isqnibbag6f63k473yj14"))))
+    (build-system go-build-system)
+    (arguments
+     '(#:import-path "github.com/jmoiron/sqlx"))
+    (propagated-inputs
+     (list go-github-com-mattn-go-sqlite3
+           go-github-com-lib-pq
+           go-github-com-go-sql-driver-mysql))
+    (home-page "https://github.com/jmoiron/sqlx")
+    (synopsis "sqlx")
+    (description
+     "Package sqlx provides general purpose extensions to database/sql.")
+    (license license:expat)))
+
+(define-public go-github-com-pierrec-lz4
+  (package
+    (name "go-github-com-pierrec-lz4")
+    (version "v2.0.5+incompatible")
+    (source (origin
+              (method git-fetch)
+              (uri (git-reference
+                    (url "https://github.com/pierrec/lz4")
+                    (commit (go-version->git-ref version))))
+              (file-name (git-file-name name version))
+              (sha256
+               (base32
+                "0y5rh7z01zycd59nnjpkqq0ydyjmcg9j1xw15q1i600l9j9g617p"))))
+    (build-system go-build-system)
+    (arguments
+     '(#:import-path "github.com/pierrec/lz4"))
+    (home-page "https://github.com/pierrec/lz4")
+    (synopsis "lz4 : LZ4 compression in pure Go")
+    (description
+     "Package lz4 implements reading and writing lz4 compressed data (a frame), as
+specified in
+@url{http://fastcompression.blogspot.fr/2013/04/lz4-streaming-format-final.html,http://fastcompression.blogspot.fr/2013/04/lz4-streaming-format-final.html}.")
+    (license license:bsd-3)))
+
+(define-public go-github-com-clickhouse-clickhouse-go
+  (package
+    (name "go-github-com-clickhouse-clickhouse-go")
+    (version "1.5.4")
+    (source (origin
+              (method git-fetch)
+              (uri (git-reference
+                    (url "https://github.com/ClickHouse/clickhouse-go")
+                    (commit (string-append "v" version))))
+              (file-name (git-file-name name version))
+              (sha256
+               (base32
+                "15yf96mx3fkjyyasb8gjw6ml476k9qacp54bdjrb14pafz3p3rgf"))))
+    (build-system go-build-system)
+    (arguments
+     '(#:import-path "github.com/ClickHouse/clickhouse-go"
+       #:tests? #f))
+    (propagated-inputs
+     (list go-github-com-stretchr-testify
+           go-github-com-pierrec-lz4
+           go-github-com-jmoiron-sqlx
+           go-github-com-cloudflare-golz4
+           go-github-com-bkaradzic-go-lz4))
+    (home-page "https://github.com/ClickHouse/clickhouse-go")
+    (synopsis "ClickHouse")
+    (description
+     "Golang SQL database driver for @url{https://clickhouse.yandex/,Yandex
+ClickHouse}")
+    (license license:expat)))
+
+(define-public go-github-com-joho-godotenv
+  (package
+    (name "go-github-com-joho-godotenv")
+    (version "1.4.0")
+    (source (origin
+              (method git-fetch)
+              (uri (git-reference
+                    (url "https://github.com/joho/godotenv")
+                    (commit (string-append "v" version))))
+              (file-name (git-file-name name version))
+              (sha256
+               (base32
+                "1036h59vyhb58n817az6yg0zw5wa87yb86i7fnbdq8cw46mnjgw8"))))
+    (build-system go-build-system)
+    (arguments
+     '(#:import-path "github.com/joho/godotenv"))
+    (home-page "https://github.com/joho/godotenv")
+    (synopsis "GoDotEnv")
+    (description
+     "Package godotenv is a go port of the ruby dotenv library
+(@url{https://github.com/bkeepers/dotenv,https://github.com/bkeepers/dotenv})")
+    (license license:expat)))
+
+(define-public go-github-com-kami-zh-go-capturer
+  (package
+    (name "go-github-com-kami-zh-go-capturer")
+    (version "0.0.0-20211219060012-52ea6c8fed04")
+    (source (origin
+              (method git-fetch)
+              (uri (git-reference
+                    (url "https://github.com/zenizh/go-capturer")
+                    (commit (go-version->git-ref version))))
+              (file-name (git-file-name name version))
+              (sha256
+               (base32
+                "0zwz9gr1863z32gz9nyysg66mg124w6nql4m99g2dg6fbq2klda4"))))
+    (build-system go-build-system)
+    (arguments
+     '(#:import-path "github.com/kami-zh/go-capturer"))
+    (home-page "https://github.com/kami-zh/go-capturer")
+    (synopsis "go-capturer")
+    (description
+     "Capture @code{os.Stdout} and/or @code{os.Stderr} in Go.  This package is useful
+for writing tests which print some outputs using @code{fmt} package.")
+    (license license:expat)))
+
+(define-public go-github-com-cloudflare-golz4
+  (package
+    (name "go-github-com-cloudflare-golz4")
+    (version "0.0.0-20150217214814-ef862a3cdc58")
+    (source (origin
+              (method git-fetch)
+              (uri (git-reference
+                    (url "https://github.com/cloudflare/golz4")
+                    (commit (go-version->git-ref version))))
+              (file-name (git-file-name name version))
+              (sha256
+               (base32
+                "0ckiwp3aa010sdnki6vd32f0n08768ppnggc8d7syzh3kkn9zvn1"))))
+    (build-system go-build-system)
+    (arguments
+     '(#:import-path "github.com/cloudflare/golz4"
+       #:tests? #f))
+    (home-page "https://github.com/cloudflare/golz4")
+    (synopsis "golz4")
+    (description "Package lz4 implements compression using lz4.c and lz4hc.c")
+    (license license:bsd-3)))
+
+(define-public go-github-com-cpuguy83-go-md2man-v2
+  (package
+    (name "go-github-com-cpuguy83-go-md2man-v2")
+    (version "2.0.2")
+    (source (origin
+              (method git-fetch)
+              (uri (git-reference
+                    (url "https://github.com/cpuguy83/go-md2man")
+                    (commit (string-append "v" version))))
+              (file-name (git-file-name name version))
+              (sha256
+               (base32
+                "19qri18cinpzxblkid6ngz2vcxslv73s1aid900q0gfzvc71mqqb"))))
+    (build-system go-build-system)
+    (arguments
+     '(#:import-path "github.com/cpuguy83/go-md2man/v2"))
+    (propagated-inputs (list go-github-com-russross-blackfriday-v2))
+    (home-page "https://github.com/cpuguy83/go-md2man")
+    (synopsis "go-md2man")
+    (description "Converts markdown into roff (man pages).")
+    (license license:expat)))
+
+(define-public go-github-com-russross-blackfriday-v2
+  (package
+    (name "go-github-com-russross-blackfriday-v2")
+    (version "2.1.0")
+    (source (origin
+              (method git-fetch)
+              (uri (git-reference
+                    (url "https://github.com/russross/blackfriday")
+                    (commit (string-append "v" version))))
+              (file-name (git-file-name name version))
+              (sha256
+               (base32
+                "0d1rg1drrfmabilqjjayklsz5d0n3hkf979sr3wsrw92bfbkivs7"))))
+    (build-system go-build-system)
+    (arguments
+     '(#:import-path "github.com/russross/blackfriday/v2"))
+    (home-page "https://github.com/russross/blackfriday")
+    (synopsis "Blackfriday")
+    (description "Package blackfriday is a markdown processor.")
+    (license license:bsd-2)))
+
+(define-public dbmate
+  (package
+    (name "dbmate")
+    (version "1.15.0")
+    (source (origin
+              (method git-fetch)
+              (uri (git-reference
+                    (url "https://github.com/amacneil/dbmate")
+                    (commit (string-append "v" version))))
+              (file-name (git-file-name name version))
+              (sha256
+               (base32
+                "1dbhm2aqppn4m55xnx18017shsy109hqv2nhksxb4ix83bjaq5vq"))))
+    (build-system go-build-system)
+    (arguments
+     '(#:import-path "github.com/amacneil/dbmate"))
+    (propagated-inputs
+     (list go-gopkg-in-yaml-v3
+           go-github-com-russross-blackfriday-v2
+           go-github-com-pmezard-go-difflib
+           go-github-com-davecgh-go-spew
+           go-github-com-cpuguy83-go-md2man-v2
+           go-github-com-cloudflare-golz4
+           go-github-com-urfave-cli-v2
+           go-github-com-stretchr-testify
+           go-github-com-mattn-go-sqlite3
+           go-github-com-lib-pq
+           go-github-com-kami-zh-go-capturer
+           go-github-com-joho-godotenv
+           go-github-com-go-sql-driver-mysql
+           go-github-com-clickhouse-clickhouse-go))
+    (home-page "https://github.com/amacneil/dbmate")
+    (synopsis "Sql database migration tool")
+    (description
+     "Dbmate is a database migration tool, to keep your database schema in sync across
+multiple developers and your production servers.")
+    (license license:expat)))
+
+(list datarekisteri-backend datarekisteri-frontend ghc-datarekisteri-core)

.guix/modules/datarekisteri-service.scm

@@ -0,0 +1,191 @@
+(define-module (datarekisteri-service)
+  #:use-module (datarekisteri-package)
+  #:use-module (guix gexp)
+  #:use-module (guix records)
+  #:use-module (gnu packages admin)
+  #:use-module (gnu services)
+  #:use-module (gnu services certbot)
+  #:use-module (gnu services configuration)
+  #:use-module (gnu services databases)
+  #:use-module (gnu services mcron)
+  #:use-module (gnu services shepherd)
+  #:use-module (gnu services web)
+  #:use-module (gnu system shadow)
+
+  #:export (plain-datarekisteri-frontend-service-type
+            plain-datarekisteri-frontend-configuration
+
+            plain-datarekisteri-backend-service-type
+            plain-datarekisteri-backend-configuration))
+
+(define-maybe/no-serialization string)
+
+(define-configuration/no-serialization plain-datarekisteri-frontend-configuration
+  (datarekisteri-frontend
+   (file-like datarekisteri-frontend)
+   "The datarekisteri-frontend package to use.")
+  (backend-url
+   (string)
+   "The URL for the datarekisteri backend server.")
+  (port
+   (integer 3000)
+   "The TCP port to listen on.")
+  (root-url
+   (string)
+   "The root URL for this server."))
+
+(define (frontend-shepherd-service config)
+  (match-record config <plain-datarekisteri-frontend-configuration>
+    (backend-url port root-url datarekisteri-frontend)
+    (list (shepherd-service
+           (documentation "Run the datarekisteri frontend HTTP server")
+           (requirement '(networking))
+           (provision '(datarekisteri-frontend))
+           (start
+            #~(make-forkexec-constructor
+               (list #$(file-append datarekisteri-frontend "/bin/datarekisteri-frontend")
+                     "--server-url" #$backend-url
+                     "--port" #$(number->string port)
+                     "--approot" #$root-url)
+               #:user "datarekisteri-frontend"
+               #:group "datarekisteri-frontend"
+               #:directory "/var/lib/datarekisteri-frontend"))
+           (stop #~(make-kill-destructor))))))
+
+(define (frontend-accounts _)
+  (list (user-group
+         (name "datarekisteri-frontend")
+         (system? #t))
+        (user-account
+         (name "datarekisteri-frontend")
+         (system? #t)
+         (group "datarekisteri-frontend")
+         (home-directory "/var/lib/datarekisteri-frontend")
+         (shell (file-append shadow "/bin/nologin")))))
+
+(define plain-datarekisteri-frontend-service-type
+  (service-type
+   (name 'plain-datarekisteri-frontend)
+   (extensions
+     (list (service-extension account-service-type frontend-accounts)
+           (service-extension shepherd-root-service-type frontend-shepherd-service)))
+   (description "Run the datarekisteri HTTP frontend server")))
+
+(define (file-like-or-string? x)
+  (or (file-like? x)
+      (string? x)))
+
+(define-configuration/no-serialization plain-datarekisteri-backend-configuration
+  (datarekisteri-backend
+   (file-like datarekisteri-backend)
+   "The datarekisteri-backend package to use.")
+  (email-address
+   (string)
+   "The email address to send emails from.")
+  (email-sender
+   (maybe-string)
+   "The display name for sending emails.")
+  (port
+   (integer 3100)
+   "The TCP port to listen on.")
+  (sendmail
+   (file-like-or-string)
+   "Path to the sendmail program to send emails with."))
+
+(define (backend-shepherd-service config)
+  (match-record config <plain-datarekisteri-backend-configuration>
+    (email-address email-sender sendmail port datarekisteri-backend)
+    (list (shepherd-service
+           (documentation "Run the datarekisteri backend HTTP server")
+           (requirement '(networking postgres))
+           (provision '(datarekisteri-backend))
+           (start
+            #~(make-forkexec-constructor
+               (list #$(file-append datarekisteri-backend "/bin/datarekisteri-backend")
+                     "--address" #$email-address
+                     #$@(if (maybe-value-set? email-sender) (list "--sender-name" email-sender) '())
+                     "--port" #$(number->string port)
+                     "--sendmail" #$sendmail)
+               #:user "datarekisteri-backend"
+               #:group "datarekisteri-backend"
+               #:directory "/var/lib/datarekisteri-backend"))
+           (stop #~(make-kill-destructor))))))
+
+(define (backend-accounts _)
+  (list (user-group
+         (name "datarekisteri-backend")
+         (system? #t))
+        (user-account
+         (name "datarekisteri-backend")
+         (system? #t)
+         (group "datarekisteri-backend")
+         (home-directory "/var/lib/datarekisteri-backend")
+         (shell (file-append shadow "/bin/nologin")))))
+
+(define (backend-postgresql-roles _)
+  (list (postgresql-role
+          (name "datarekisteri-backend")
+          (create-database? #t))))
+
+(define (backend-profile config)
+  (match-record config <plain-datarekisteri-backend-configuration>
+    (datarekisteri-backend)
+    (list datarekisteri-backend)))
+
+(define (backend-mcron-jobs config)
+  (match-record config <plain-datarekisteri-backend-configuration>
+    (datarekisteri-backend)
+    (list
+     #~(job '(next-minute '(0))
+            (string-append #$datarekisteri-backend "/bin/datarekisteri-cli gc")
+            #:user "datarekisteri-backend"))))
+
+(define plain-datarekisteri-backend-service-type
+  (service-type
+   (name 'plain-datarekisteri-backend)
+   (extensions
+     (list (service-extension account-service-type backend-accounts)
+           (service-extension mcron-service-type backend-mcron-jobs)
+           (service-extension postgresql-role-service-type backend-postgresql-roles)
+           (service-extension profile-service-type backend-profile)
+           (service-extension shepherd-root-service-type backend-shepherd-service)))
+   (description "Run the datarekisteri backend HTTP server")))
+
+; (define datarekisteri-client-service-type
+;   (service-type
+;    (name 'datarekisteri-client)
+;    (extensions
+;      (list (service-extension certbot-service-type client-certbot)
+;            (service-extension nginx-service-type client-nginx)
+;            (service-extension shepherd-root-service-type client-shepherd-service)))
+;    (description "Run the datarekisteri HTTP client server")
+;    (default-value (datarekisteri-client-configuration))))
+
+; (define datarekisteri-api-service-type
+;   (service-type
+;    (name 'datarekisteri-api)
+;    (extensions
+;      (list (service-extension certbot-service-type api-certbot)
+;            (service-extension nginx-service-type api-nginx)
+;            (service-extension postgresql-role-service-type api-postgresql-roles)
+;            (service-extension shepherd-root-service-type api-shepherd-service)))
+;    (description "Run the datarekisteri HTTP api server")
+;    (default-value (datarekisteri-api-configuration))))
+
+; (define-configuration datarekisteri-client-configuration
+;   (https?
+;    (boolean #t)
+;    "Whether to configure HTTPS with certbot.")
+;   (nginx?
+;    (boolean #t)
+;    "Whether to configure nginx as a reverse proxy.")
+;   (api-url
+;    (string)
+;    "The URL for the graphql API server.")
+;   (port
+;    (integer 3000)
+;    "The TCP port to listen on.")
+;   (root-url
+;    (string)
+;    ""))
+

COPYING.md

@@ -0,0 +1,660 @@
+### GNU AFFERO GENERAL PUBLIC LICENSE
+
+Version 3, 19 November 2007
+
+Copyright (C) 2007 Free Software Foundation, Inc.
+<https://fsf.org/>
+
+Everyone is permitted to copy and distribute verbatim copies of this
+license document, but changing it is not allowed.
+
+### Preamble
+
+The GNU Affero General Public License is a free, copyleft license for
+software and other kinds of works, specifically designed to ensure
+cooperation with the community in the case of network server software.
+
+The licenses for most software and other practical works are designed
+to take away your freedom to share and change the works. By contrast,
+our General Public Licenses are intended to guarantee your freedom to
+share and change all versions of a program--to make sure it remains
+free software for all its users.
+
+When we speak of free software, we are referring to freedom, not
+price. Our General Public Licenses are designed to make sure that you
+have the freedom to distribute copies of free software (and charge for
+them if you wish), that you receive source code or can get it if you
+want it, that you can change the software or use pieces of it in new
+free programs, and that you know you can do these things.
+
+Developers that use our General Public Licenses protect your rights
+with two steps: (1) assert copyright on the software, and (2) offer
+you this License which gives you legal permission to copy, distribute
+and/or modify the software.
+
+A secondary benefit of defending all users' freedom is that
+improvements made in alternate versions of the program, if they
+receive widespread use, become available for other developers to
+incorporate. Many developers of free software are heartened and
+encouraged by the resulting cooperation. However, in the case of
+software used on network servers, this result may fail to come about.
+The GNU General Public License permits making a modified version and
+letting the public access it on a server without ever releasing its
+source code to the public.
+
+The GNU Affero General Public License is designed specifically to
+ensure that, in such cases, the modified source code becomes available
+to the community. It requires the operator of a network server to
+provide the source code of the modified version running there to the
+users of that server. Therefore, public use of a modified version, on
+a publicly accessible server, gives the public access to the source
+code of the modified version.
+
+An older license, called the Affero General Public License and
+published by Affero, was designed to accomplish similar goals. This is
+a different license, not a version of the Affero GPL, but Affero has
+released a new version of the Affero GPL which permits relicensing
+under this license.
+
+The precise terms and conditions for copying, distribution and
+modification follow.
+
+### TERMS AND CONDITIONS
+
+#### 0. Definitions.
+
+"This License" refers to version 3 of the GNU Affero General Public
+License.
+
+"Copyright" also means copyright-like laws that apply to other kinds
+of works, such as semiconductor masks.
+
+"The Program" refers to any copyrightable work licensed under this
+License. Each licensee is addressed as "you". "Licensees" and
+"recipients" may be individuals or organizations.
+
+To "modify" a work means to copy from or adapt all or part of the work
+in a fashion requiring copyright permission, other than the making of
+an exact copy. The resulting work is called a "modified version" of
+the earlier work or a work "based on" the earlier work.
+
+A "covered work" means either the unmodified Program or a work based
+on the Program.
+
+To "propagate" a work means to do anything with it that, without
+permission, would make you directly or secondarily liable for
+infringement under applicable copyright law, except executing it on a
+computer or modifying a private copy. Propagation includes copying,
+distribution (with or without modification), making available to the
+public, and in some countries other activities as well.
+
+To "convey" a work means any kind of propagation that enables other
+parties to make or receive copies. Mere interaction with a user
+through a computer network, with no transfer of a copy, is not
+conveying.
+
+An interactive user interface displays "Appropriate Legal Notices" to
+the extent that it includes a convenient and prominently visible
+feature that (1) displays an appropriate copyright notice, and (2)
+tells the user that there is no warranty for the work (except to the
+extent that warranties are provided), that licensees may convey the
+work under this License, and how to view a copy of this License. If
+the interface presents a list of user commands or options, such as a
+menu, a prominent item in the list meets this criterion.
+
+#### 1. Source Code.
+
+The "source code" for a work means the preferred form of the work for
+making modifications to it. "Object code" means any non-source form of
+a work.
+
+A "Standard Interface" means an interface that either is an official
+standard defined by a recognized standards body, or, in the case of
+interfaces specified for a particular programming language, one that
+is widely used among developers working in that language.
+
+The "System Libraries" of an executable work include anything, other
+than the work as a whole, that (a) is included in the normal form of
+packaging a Major Component, but which is not part of that Major
+Component, and (b) serves only to enable use of the work with that
+Major Component, or to implement a Standard Interface for which an
+implementation is available to the public in source code form. A
+"Major Component", in this context, means a major essential component
+(kernel, window system, and so on) of the specific operating system
+(if any) on which the executable work runs, or a compiler used to
+produce the work, or an object code interpreter used to run it.
+
+The "Corresponding Source" for a work in object code form means all
+the source code needed to generate, install, and (for an executable
+work) run the object code and to modify the work, including scripts to
+control those activities. However, it does not include the work's
+System Libraries, or general-purpose tools or generally available free
+programs which are used unmodified in performing those activities but
+which are not part of the work. For example, Corresponding Source
+includes interface definition files associated with source files for
+the work, and the source code for shared libraries and dynamically
+linked subprograms that the work is specifically designed to require,
+such as by intimate data communication or control flow between those
+subprograms and other parts of the work.
+
+The Corresponding Source need not include anything that users can
+regenerate automatically from other parts of the Corresponding Source.
+
+The Corresponding Source for a work in source code form is that same
+work.
+
+#### 2. Basic Permissions.
+
+All rights granted under this License are granted for the term of
+copyright on the Program, and are irrevocable provided the stated
+conditions are met. This License explicitly affirms your unlimited
+permission to run the unmodified Program. The output from running a
+covered work is covered by this License only if the output, given its
+content, constitutes a covered work. This License acknowledges your
+rights of fair use or other equivalent, as provided by copyright law.
+
+You may make, run and propagate covered works that you do not convey,
+without conditions so long as your license otherwise remains in force.
+You may convey covered works to others for the sole purpose of having
+them make modifications exclusively for you, or provide you with
+facilities for running those works, provided that you comply with the
+terms of this License in conveying all material for which you do not
+control copyright. Those thus making or running the covered works for
+you must do so exclusively on your behalf, under your direction and
+control, on terms that prohibit them from making any copies of your
+copyrighted material outside their relationship with you.
+
+Conveying under any other circumstances is permitted solely under the
+conditions stated below. Sublicensing is not allowed; section 10 makes
+it unnecessary.
+
+#### 3. Protecting Users' Legal Rights From Anti-Circumvention Law.
+
+No covered work shall be deemed part of an effective technological
+measure under any applicable law fulfilling obligations under article
+11 of the WIPO copyright treaty adopted on 20 December 1996, or
+similar laws prohibiting or restricting circumvention of such
+measures.
+
+When you convey a covered work, you waive any legal power to forbid
+circumvention of technological measures to the extent such
+circumvention is effected by exercising rights under this License with
+respect to the covered work, and you disclaim any intention to limit
+operation or modification of the work as a means of enforcing, against
+the work's users, your or third parties' legal rights to forbid
+circumvention of technological measures.
+
+#### 4. Conveying Verbatim Copies.
+
+You may convey verbatim copies of the Program's source code as you
+receive it, in any medium, provided that you conspicuously and
+appropriately publish on each copy an appropriate copyright notice;
+keep intact all notices stating that this License and any
+non-permissive terms added in accord with section 7 apply to the code;
+keep intact all notices of the absence of any warranty; and give all
+recipients a copy of this License along with the Program.
+
+You may charge any price or no price for each copy that you convey,
+and you may offer support or warranty protection for a fee.
+
+#### 5. Conveying Modified Source Versions.
+
+You may convey a work based on the Program, or the modifications to
+produce it from the Program, in the form of source code under the
+terms of section 4, provided that you also meet all of these
+conditions:
+
+-   a) The work must carry prominent notices stating that you modified
+    it, and giving a relevant date.
+-   b) The work must carry prominent notices stating that it is
+    released under this License and any conditions added under
+    section 7. This requirement modifies the requirement in section 4
+    to "keep intact all notices".
+-   c) You must license the entire work, as a whole, under this
+    License to anyone who comes into possession of a copy. This
+    License will therefore apply, along with any applicable section 7
+    additional terms, to the whole of the work, and all its parts,
+    regardless of how they are packaged. This License gives no
+    permission to license the work in any other way, but it does not
+    invalidate such permission if you have separately received it.
+-   d) If the work has interactive user interfaces, each must display
+    Appropriate Legal Notices; however, if the Program has interactive
+    interfaces that do not display Appropriate Legal Notices, your
+    work need not make them do so.
+
+A compilation of a covered work with other separate and independent
+works, which are not by their nature extensions of the covered work,
+and which are not combined with it such as to form a larger program,
+in or on a volume of a storage or distribution medium, is called an
+"aggregate" if the compilation and its resulting copyright are not
+used to limit the access or legal rights of the compilation's users
+beyond what the individual works permit. Inclusion of a covered work
+in an aggregate does not cause this License to apply to the other
+parts of the aggregate.
+
+#### 6. Conveying Non-Source Forms.
+
+You may convey a covered work in object code form under the terms of
+sections 4 and 5, provided that you also convey the machine-readable
+Corresponding Source under the terms of this License, in one of these
+ways:
+
+-   a) Convey the object code in, or embodied in, a physical product
+    (including a physical distribution medium), accompanied by the
+    Corresponding Source fixed on a durable physical medium
+    customarily used for software interchange.
+-   b) Convey the object code in, or embodied in, a physical product
+    (including a physical distribution medium), accompanied by a
+    written offer, valid for at least three years and valid for as
+    long as you offer spare parts or customer support for that product
+    model, to give anyone who possesses the object code either (1) a
+    copy of the Corresponding Source for all the software in the
+    product that is covered by this License, on a durable physical
+    medium customarily used for software interchange, for a price no
+    more than your reasonable cost of physically performing this
+    conveying of source, or (2) access to copy the Corresponding
+    Source from a network server at no charge.
+-   c) Convey individual copies of the object code with a copy of the
+    written offer to provide the Corresponding Source. This
+    alternative is allowed only occasionally and noncommercially, and
+    only if you received the object code with such an offer, in accord
+    with subsection 6b.
+-   d) Convey the object code by offering access from a designated
+    place (gratis or for a charge), and offer equivalent access to the
+    Corresponding Source in the same way through the same place at no
+    further charge. You need not require recipients to copy the
+    Corresponding Source along with the object code. If the place to
+    copy the object code is a network server, the Corresponding Source
+    may be on a different server (operated by you or a third party)
+    that supports equivalent copying facilities, provided you maintain
+    clear directions next to the object code saying where to find the
+    Corresponding Source. Regardless of what server hosts the
+    Corresponding Source, you remain obligated to ensure that it is
+    available for as long as needed to satisfy these requirements.
+-   e) Convey the object code using peer-to-peer transmission,
+    provided you inform other peers where the object code and
+    Corresponding Source of the work are being offered to the general
+    public at no charge under subsection 6d.
+
+A separable portion of the object code, whose source code is excluded
+from the Corresponding Source as a System Library, need not be
+included in conveying the object code work.
+
+A "User Product" is either (1) a "consumer product", which means any
+tangible personal property which is normally used for personal,
+family, or household purposes, or (2) anything designed or sold for
+incorporation into a dwelling. In determining whether a product is a
+consumer product, doubtful cases shall be resolved in favor of
+coverage. For a particular product received by a particular user,
+"normally used" refers to a typical or common use of that class of
+product, regardless of the status of the particular user or of the way
+in which the particular user actually uses, or expects or is expected
+to use, the product. A product is a consumer product regardless of
+whether the product has substantial commercial, industrial or
+non-consumer uses, unless such uses represent the only significant
+mode of use of the product.
+
+"Installation Information" for a User Product means any methods,
+procedures, authorization keys, or other information required to
+install and execute modified versions of a covered work in that User
+Product from a modified version of its Corresponding Source. The
+information must suffice to ensure that the continued functioning of
+the modified object code is in no case prevented or interfered with
+solely because modification has been made.
+
+If you convey an object code work under this section in, or with, or
+specifically for use in, a User Product, and the conveying occurs as
+part of a transaction in which the right of possession and use of the
+User Product is transferred to the recipient in perpetuity or for a
+fixed term (regardless of how the transaction is characterized), the
+Corresponding Source conveyed under this section must be accompanied
+by the Installation Information. But this requirement does not apply
+if neither you nor any third party retains the ability to install
+modified object code on the User Product (for example, the work has
+been installed in ROM).
+
+The requirement to provide Installation Information does not include a
+requirement to continue to provide support service, warranty, or
+updates for a work that has been modified or installed by the
+recipient, or for the User Product in which it has been modified or
+installed. Access to a network may be denied when the modification
+itself materially and adversely affects the operation of the network
+or violates the rules and protocols for communication across the
+network.
+
+Corresponding Source conveyed, and Installation Information provided,
+in accord with this section must be in a format that is publicly
+documented (and with an implementation available to the public in
+source code form), and must require no special password or key for
+unpacking, reading or copying.
+
+#### 7. Additional Terms.
+
+"Additional permissions" are terms that supplement the terms of this
+License by making exceptions from one or more of its conditions.
+Additional permissions that are applicable to the entire Program shall
+be treated as though they were included in this License, to the extent
+that they are valid under applicable law. If additional permissions
+apply only to part of the Program, that part may be used separately
+under those permissions, but the entire Program remains governed by
+this License without regard to the additional permissions.
+
+When you convey a copy of a covered work, you may at your option
+remove any additional permissions from that copy, or from any part of
+it. (Additional permissions may be written to require their own
+removal in certain cases when you modify the work.) You may place
+additional permissions on material, added by you to a covered work,
+for which you have or can give appropriate copyright permission.
+
+Notwithstanding any other provision of this License, for material you
+add to a covered work, you may (if authorized by the copyright holders
+of that material) supplement the terms of this License with terms:
+
+-   a) Disclaiming warranty or limiting liability differently from the
+    terms of sections 15 and 16 of this License; or
+-   b) Requiring preservation of specified reasonable legal notices or
+    author attributions in that material or in the Appropriate Legal
+    Notices displayed by works containing it; or
+-   c) Prohibiting misrepresentation of the origin of that material,
+    or requiring that modified versions of such material be marked in
+    reasonable ways as different from the original version; or
+-   d) Limiting the use for publicity purposes of names of licensors
+    or authors of the material; or
+-   e) Declining to grant rights under trademark law for use of some
+    trade names, trademarks, or service marks; or
+-   f) Requiring indemnification of licensors and authors of that
+    material by anyone who conveys the material (or modified versions
+    of it) with contractual assumptions of liability to the recipient,
+    for any liability that these contractual assumptions directly
+    impose on those licensors and authors.
+
+All other non-permissive additional terms are considered "further
+restrictions" within the meaning of section 10. If the Program as you
+received it, or any part of it, contains a notice stating that it is
+governed by this License along with a term that is a further
+restriction, you may remove that term. If a license document contains
+a further restriction but permits relicensing or conveying under this
+License, you may add to a covered work material governed by the terms
+of that license document, provided that the further restriction does
+not survive such relicensing or conveying.
+
+If you add terms to a covered work in accord with this section, you
+must place, in the relevant source files, a statement of the
+additional terms that apply to those files, or a notice indicating
+where to find the applicable terms.
+
+Additional terms, permissive or non-permissive, may be stated in the
+form of a separately written license, or stated as exceptions; the
+above requirements apply either way.
+
+#### 8. Termination.
+
+You may not propagate or modify a covered work except as expressly
+provided under this License. Any attempt otherwise to propagate or
+modify it is void, and will automatically terminate your rights under
+this License (including any patent licenses granted under the third
+paragraph of section 11).
+
+However, if you cease all violation of this License, then your license
+from a particular copyright holder is reinstated (a) provisionally,
+unless and until the copyright holder explicitly and finally
+terminates your license, and (b) permanently, if the copyright holder
+fails to notify you of the violation by some reasonable means prior to
+60 days after the cessation.
+
+Moreover, your license from a particular copyright holder is
+reinstated permanently if the copyright holder notifies you of the
+violation by some reasonable means, this is the first time you have
+received notice of violation of this License (for any work) from that
+copyright holder, and you cure the violation prior to 30 days after
+your receipt of the notice.
+
+Termination of your rights under this section does not terminate the
+licenses of parties who have received copies or rights from you under
+this License. If your rights have been terminated and not permanently
+reinstated, you do not qualify to receive new licenses for the same
+material under section 10.
+
+#### 9. Acceptance Not Required for Having Copies.
+
+You are not required to accept this License in order to receive or run
+a copy of the Program. Ancillary propagation of a covered work
+occurring solely as a consequence of using peer-to-peer transmission
+to receive a copy likewise does not require acceptance. However,
+nothing other than this License grants you permission to propagate or
+modify any covered work. These actions infringe copyright if you do
+not accept this License. Therefore, by modifying or propagating a
+covered work, you indicate your acceptance of this License to do so.
+
+#### 10. Automatic Licensing of Downstream Recipients.
+
+Each time you convey a covered work, the recipient automatically
+receives a license from the original licensors, to run, modify and
+propagate that work, subject to this License. You are not responsible
+for enforcing compliance by third parties with this License.
+
+An "entity transaction" is a transaction transferring control of an
+organization, or substantially all assets of one, or subdividing an
+organization, or merging organizations. If propagation of a covered
+work results from an entity transaction, each party to that
+transaction who receives a copy of the work also receives whatever
+licenses to the work the party's predecessor in interest had or could
+give under the previous paragraph, plus a right to possession of the
+Corresponding Source of the work from the predecessor in interest, if
+the predecessor has it or can get it with reasonable efforts.
+
+You may not impose any further restrictions on the exercise of the
+rights granted or affirmed under this License. For example, you may
+not impose a license fee, royalty, or other charge for exercise of
+rights granted under this License, and you may not initiate litigation
+(including a cross-claim or counterclaim in a lawsuit) alleging that
+any patent claim is infringed by making, using, selling, offering for
+sale, or importing the Program or any portion of it.
+
+#### 11. Patents.
+
+A "contributor" is a copyright holder who authorizes use under this
+License of the Program or a work on which the Program is based. The
+work thus licensed is called the contributor's "contributor version".
+
+A contributor's "essential patent claims" are all patent claims owned
+or controlled by the contributor, whether already acquired or
+hereafter acquired, that would be infringed by some manner, permitted
+by this License, of making, using, or selling its contributor version,
+but do not include claims that would be infringed only as a
+consequence of further modification of the contributor version. For
+purposes of this definition, "control" includes the right to grant
+patent sublicenses in a manner consistent with the requirements of
+this License.
+
+Each contributor grants you a non-exclusive, worldwide, royalty-free
+patent license under the contributor's essential patent claims, to
+make, use, sell, offer for sale, import and otherwise run, modify and
+propagate the contents of its contributor version.
+
+In the following three paragraphs, a "patent license" is any express
+agreement or commitment, however denominated, not to enforce a patent
+(such as an express permission to practice a patent or covenant not to
+sue for patent infringement). To "grant" such a patent license to a
+party means to make such an agreement or commitment not to enforce a
+patent against the party.
+
+If you convey a covered work, knowingly relying on a patent license,
+and the Corresponding Source of the work is not available for anyone
+to copy, free of charge and under the terms of this License, through a
+publicly available network server or other readily accessible means,
+then you must either (1) cause the Corresponding Source to be so
+available, or (2) arrange to deprive yourself of the benefit of the
+patent license for this particular work, or (3) arrange, in a manner
+consistent with the requirements of this License, to extend the patent
+license to downstream recipients. "Knowingly relying" means you have
+actual knowledge that, but for the patent license, your conveying the
+covered work in a country, or your recipient's use of the covered work
+in a country, would infringe one or more identifiable patents in that
+country that you have reason to believe are valid.
+
+If, pursuant to or in connection with a single transaction or
+arrangement, you convey, or propagate by procuring conveyance of, a
+covered work, and grant a patent license to some of the parties
+receiving the covered work authorizing them to use, propagate, modify
+or convey a specific copy of the covered work, then the patent license
+you grant is automatically extended to all recipients of the covered
+work and works based on it.
+
+A patent license is "discriminatory" if it does not include within the
+scope of its coverage, prohibits the exercise of, or is conditioned on
+the non-exercise of one or more of the rights that are specifically
+granted under this License. You may not convey a covered work if you
+are a party to an arrangement with a third party that is in the
+business of distributing software, under which you make payment to the
+third party based on the extent of your activity of conveying the
+work, and under which the third party grants, to any of the parties
+who would receive the covered work from you, a discriminatory patent
+license (a) in connection with copies of the covered work conveyed by
+you (or copies made from those copies), or (b) primarily for and in
+connection with specific products or compilations that contain the
+covered work, unless you entered into that arrangement, or that patent
+license was granted, prior to 28 March 2007.
+
+Nothing in this License shall be construed as excluding or limiting
+any implied license or other defenses to infringement that may
+otherwise be available to you under applicable patent law.
+
+#### 12. No Surrender of Others' Freedom.
+
+If conditions are imposed on you (whether by court order, agreement or
+otherwise) that contradict the conditions of this License, they do not
+excuse you from the conditions of this License. If you cannot convey a
+covered work so as to satisfy simultaneously your obligations under
+this License and any other pertinent obligations, then as a
+consequence you may not convey it at all. For example, if you agree to
+terms that obligate you to collect a royalty for further conveying
+from those to whom you convey the Program, the only way you could
+satisfy both those terms and this License would be to refrain entirely
+from conveying the Program.
+
+#### 13. Remote Network Interaction; Use with the GNU General Public License.
+
+Notwithstanding any other provision of this License, if you modify the
+Program, your modified version must prominently offer all users
+interacting with it remotely through a computer network (if your
+version supports such interaction) an opportunity to receive the
+Corresponding Source of your version by providing access to the
+Corresponding Source from a network server at no charge, through some
+standard or customary means of facilitating copying of software. This
+Corresponding Source shall include the Corresponding Source for any
+work covered by version 3 of the GNU General Public License that is
+incorporated pursuant to the following paragraph.
+
+Notwithstanding any other provision of this License, you have
+permission to link or combine any covered work with a work licensed
+under version 3 of the GNU General Public License into a single
+combined work, and to convey the resulting work. The terms of this
+License will continue to apply to the part which is the covered work,
+but the work with which it is combined will remain governed by version
+3 of the GNU General Public License.
+
+#### 14. Revised Versions of this License.
+
+The Free Software Foundation may publish revised and/or new versions
+of the GNU Affero General Public License from time to time. Such new
+versions will be similar in spirit to the present version, but may
+differ in detail to address new problems or concerns.
+
+Each version is given a distinguishing version number. If the Program
+specifies that a certain numbered version of the GNU Affero General
+Public License "or any later version" applies to it, you have the
+option of following the terms and conditions either of that numbered
+version or of any later version published by the Free Software
+Foundation. If the Program does not specify a version number of the
+GNU Affero General Public License, you may choose any version ever
+published by the Free Software Foundation.
+
+If the Program specifies that a proxy can decide which future versions
+of the GNU Affero General Public License can be used, that proxy's
+public statement of acceptance of a version permanently authorizes you
+to choose that version for the Program.
+
+Later license versions may give you additional or different
+permissions. However, no additional obligations are imposed on any
+author or copyright holder as a result of your choosing to follow a
+later version.
+
+#### 15. Disclaimer of Warranty.
+
+THERE IS NO WARRANTY FOR THE PROGRAM, TO THE EXTENT PERMITTED BY
+APPLICABLE LAW. EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT
+HOLDERS AND/OR OTHER PARTIES PROVIDE THE PROGRAM "AS IS" WITHOUT
+WARRANTY OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT
+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+A PARTICULAR PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND
+PERFORMANCE OF THE PROGRAM IS WITH YOU. SHOULD THE PROGRAM PROVE
+DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING, REPAIR OR
+CORRECTION.
+
+#### 16. Limitation of Liability.
+
+IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING
+WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MODIFIES AND/OR
+CONVEYS THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES,
+INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES
+ARISING OUT OF THE USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT
+NOT LIMITED TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR
+LOSSES SUSTAINED BY YOU OR THIRD PARTIES OR A FAILURE OF THE PROGRAM
+TO OPERATE WITH ANY OTHER PROGRAMS), EVEN IF SUCH HOLDER OR OTHER
+PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGES.
+
+#### 17. Interpretation of Sections 15 and 16.
+
+If the disclaimer of warranty and limitation of liability provided
+above cannot be given local legal effect according to their terms,
+reviewing courts shall apply local law that most closely approximates
+an absolute waiver of all civil liability in connection with the
+Program, unless a warranty or assumption of liability accompanies a
+copy of the Program in return for a fee.
+
+END OF TERMS AND CONDITIONS
+
+### How to Apply These Terms to Your New Programs
+
+If you develop a new program, and you want it to be of the greatest
+possible use to the public, the best way to achieve this is to make it
+free software which everyone can redistribute and change under these
+terms.
+
+To do so, attach the following notices to the program. It is safest to
+attach them to the start of each source file to most effectively state
+the exclusion of warranty; and each file should have at least the
+"copyright" line and a pointer to where the full notice is found.
+
+        <one line to give the program's name and a brief idea of what it does.>
+        Copyright (C) <year>  <name of author>
+
+        This program is free software: you can redistribute it and/or modify
+        it under the terms of the GNU Affero General Public License as
+        published by the Free Software Foundation, either version 3 of the
+        License, or (at your option) any later version.
+
+        This program is distributed in the hope that it will be useful,
+        but WITHOUT ANY WARRANTY; without even the implied warranty of
+        MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+        GNU Affero General Public License for more details.
+
+        You should have received a copy of the GNU Affero General Public License
+        along with this program.  If not, see <https://www.gnu.org/licenses/>.
+
+Also add information on how to contact you by electronic and paper
+mail.
+
+If your software can interact with users remotely through a computer
+network, you should also make sure that it provides a way for users to
+get its source. For example, if your program is a web application, its
+interface could display a "Source" link that leads users to an archive
+of the code. There are many ways you could offer source, and different
+solutions will be better for different programs; see section 13 for
+the specific requirements.
+
+You should also get your employer (if you work as a programmer) or
+school, if any, to sign a "copyright disclaimer" for the program, if
+necessary. For more information on this, and how to apply and follow
+the GNU AGPL, see <https://www.gnu.org/licenses/>.

PrintSchema.hs

@@ -0,0 +1,6 @@
+import Data.Morpheus.Types (render, App)
+import Datarekisteri.Backend.API (coreApp)
+import qualified Data.ByteString.Lazy.Char8 as C8
+import Datarekisteri.Backend (APIM)
+
+main = C8.putStrLn $ render (coreApp :: App () APIM)

README.md

@@ -0,0 +1,71 @@
+# Datarekisteri – Datat RY:n jäsenrekisteri
+
+Datayhdistyksen jäsenrekisterin lähdekoodi. Pitkällä aikavälillä tavoitteena on
+saada mahdollisimman paljon toiminnallisuudesta abstraktoitua ja siirrettyä
+[`rekisteri`](https://hub.sr.ht/~slaesvuo/rekisteri):iin, mutta tällä hetkellä
+se ei ole mahdollista.
+
+## Kehitykseen osallistuminen
+
+Toimivan kehitysympäristön saat helposti ajamalla komennon [`guix
+shell`](https://guix.gnu.org/manual/devel/en/guix.html#Invoking-guix-shell)
+tämän hakemiston sisällä. Mikäli Guix ei saa luotua ympäristöä, aja sama
+komento toimivaksi tiedettyssä Guix-versiossa
+([`guix time-machine -C channels.scm -- shell`](https://guix.gnu.org/manual/devel/en/guix.html#Invoking-guix-time_002dmachine))
+
+Vikoja ja kehitysehdotuksia voi lähettää sähköpostilla (<admin@datat.fi>) tai
+[kirjata giteaan](https://git.datat.fi/ry/datarekisteri/issues). Samoin
+muutoksia voi [lähettää gitean
+kautta](https://git.datat.fi/ry/datarekisteri/pulls) tai sähköpostilla
+käyttämällä komentoa [`git send-email`](https://git-send-email.io/).
+
+Tähän tietovarantoon kirjoitusoikeudellisten henkilöiden pitää varmistaa, että
+he puskevat vain GPG-allekirjoitettua koodia ja että allekirjoittamiseen
+käytettyn avaimen julkinen osa on lisätty `keyring`-kehityshaaraan ja avaimen
+sormenjälki on lisätty `.guix-authorizations`-tiedostoon. Muuten datarekisterin
+Guix-kanavan lataaminen ei toimi ja julkaistua datarekisteriä ei voida
+päivittää ennen kuin allekirjoittamattomat muutokset on poistettu
+git-historiasta.
+
+## Asentaminen
+
+Datarekisterin voit asentaa helposti lisäämällä alla olevan pätkän guix:in
+[kanavalistaan](https://guix.gnu.org/manual/en/guix.html#Specifying-Additional-Channels).
+
+```lisp
+(channel
+ (name 'datarekisteri)
+ (url "https://git.datat.fi/ry/datarekisteri.git")
+ (branch "main")
+ (introduction
+  (make-channel-introduction
+   "e93c797eefb1538e7defe04786e0bb5adb039799"
+   (openpgp-fingerprint
+    "A0C9 1947 734F 076F 5F08 E9FF 257D 284A 2A1D 3A32"))))
+```
+
+### Käänteisen välityspalvelimen asetukset
+
+Käänteisen välityspalvelimen pitäisi määritellä CSP estämään kaikkien skriptien
+ajaminen, koska datarekisterin ei tarvitse ajaa koodia käyttäjän laitteella.
+Datarekisterin ei pitäisi myöskään lähettää koodia ajettavaksi, mutta on
+parempi varmistaa. Content-Type-Options estää selaimia tulkitsemasta tiedostoja
+virheellisesti skripteiksi tai tyylitiedostoiksi. 
+
+```
+Content-Security-Policy: default-src 'self'; scrip-src 'none'; object-src 'none'
+X-Content-Type-Options: nosniff
+```
+
+**Käänteisen välityspalvelimen pitää myös pakottaa kaikki liikenne kulkemaan
+HTTPS:n yli uudelleenohjaamalla kaikki HTTP-kyselyt**. Lisäksi voi asettaa
+Strict-Transport-Security otsikon. Kaikki käyttäjätiedot, salasanat
+mukaanlukien, ovat käytännössä julkisia, jos salaamattomat HTTP-kyselyt
+sallitaan.
+
+## Kopiointi
+
+Saat käyttää tätä ohjelmaa ja lähdekoodia
+[AGPL-lisenssin](https://www.gnu.org/licenses/agpl-3.0.en.html) version 3 tai
+minkä tahansa myöhemmän Free Software Foundationin julkaiseman version
+ehdoilla.

backend/COPYING.md

@@ -0,0 +1,660 @@
+### GNU AFFERO GENERAL PUBLIC LICENSE
+
+Version 3, 19 November 2007
+
+Copyright (C) 2007 Free Software Foundation, Inc.
+<https://fsf.org/>
+
+Everyone is permitted to copy and distribute verbatim copies of this
+license document, but changing it is not allowed.
+
+### Preamble
+
+The GNU Affero General Public License is a free, copyleft license for
+software and other kinds of works, specifically designed to ensure
+cooperation with the community in the case of network server software.
+
+The licenses for most software and other practical works are designed
+to take away your freedom to share and change the works. By contrast,
+our General Public Licenses are intended to guarantee your freedom to
+share and change all versions of a program--to make sure it remains
+free software for all its users.
+
+When we speak of free software, we are referring to freedom, not
+price. Our General Public Licenses are designed to make sure that you
+have the freedom to distribute copies of free software (and charge for
+them if you wish), that you receive source code or can get it if you
+want it, that you can change the software or use pieces of it in new
+free programs, and that you know you can do these things.
+
+Developers that use our General Public Licenses protect your rights
+with two steps: (1) assert copyright on the software, and (2) offer
+you this License which gives you legal permission to copy, distribute
+and/or modify the software.
+
+A secondary benefit of defending all users' freedom is that
+improvements made in alternate versions of the program, if they
+receive widespread use, become available for other developers to
+incorporate. Many developers of free software are heartened and
+encouraged by the resulting cooperation. However, in the case of
+software used on network servers, this result may fail to come about.
+The GNU General Public License permits making a modified version and
+letting the public access it on a server without ever releasing its
+source code to the public.
+
+The GNU Affero General Public License is designed specifically to
+ensure that, in such cases, the modified source code becomes available
+to the community. It requires the operator of a network server to
+provide the source code of the modified version running there to the
+users of that server. Therefore, public use of a modified version, on
+a publicly accessible server, gives the public access to the source
+code of the modified version.
+
+An older license, called the Affero General Public License and
+published by Affero, was designed to accomplish similar goals. This is
+a different license, not a version of the Affero GPL, but Affero has
+released a new version of the Affero GPL which permits relicensing
+under this license.
+
+The precise terms and conditions for copying, distribution and
+modification follow.
+
+### TERMS AND CONDITIONS
+
+#### 0. Definitions.
+
+"This License" refers to version 3 of the GNU Affero General Public
+License.
+
+"Copyright" also means copyright-like laws that apply to other kinds
+of works, such as semiconductor masks.
+
+"The Program" refers to any copyrightable work licensed under this
+License. Each licensee is addressed as "you". "Licensees" and
+"recipients" may be individuals or organizations.
+
+To "modify" a work means to copy from or adapt all or part of the work
+in a fashion requiring copyright permission, other than the making of
+an exact copy. The resulting work is called a "modified version" of
+the earlier work or a work "based on" the earlier work.
+
+A "covered work" means either the unmodified Program or a work based
+on the Program.
+
+To "propagate" a work means to do anything with it that, without
+permission, would make you directly or secondarily liable for
+infringement under applicable copyright law, except executing it on a
+computer or modifying a private copy. Propagation includes copying,
+distribution (with or without modification), making available to the
+public, and in some countries other activities as well.
+
+To "convey" a work means any kind of propagation that enables other
+parties to make or receive copies. Mere interaction with a user
+through a computer network, with no transfer of a copy, is not
+conveying.
+
+An interactive user interface displays "Appropriate Legal Notices" to
+the extent that it includes a convenient and prominently visible
+feature that (1) displays an appropriate copyright notice, and (2)
+tells the user that there is no warranty for the work (except to the
+extent that warranties are provided), that licensees may convey the
+work under this License, and how to view a copy of this License. If
+the interface presents a list of user commands or options, such as a
+menu, a prominent item in the list meets this criterion.
+
+#### 1. Source Code.
+
+The "source code" for a work means the preferred form of the work for
+making modifications to it. "Object code" means any non-source form of
+a work.
+
+A "Standard Interface" means an interface that either is an official
+standard defined by a recognized standards body, or, in the case of
+interfaces specified for a particular programming language, one that
+is widely used among developers working in that language.
+
+The "System Libraries" of an executable work include anything, other
+than the work as a whole, that (a) is included in the normal form of
+packaging a Major Component, but which is not part of that Major
+Component, and (b) serves only to enable use of the work with that
+Major Component, or to implement a Standard Interface for which an
+implementation is available to the public in source code form. A
+"Major Component", in this context, means a major essential component
+(kernel, window system, and so on) of the specific operating system
+(if any) on which the executable work runs, or a compiler used to
+produce the work, or an object code interpreter used to run it.
+
+The "Corresponding Source" for a work in object code form means all
+the source code needed to generate, install, and (for an executable
+work) run the object code and to modify the work, including scripts to
+control those activities. However, it does not include the work's
+System Libraries, or general-purpose tools or generally available free
+programs which are used unmodified in performing those activities but
+which are not part of the work. For example, Corresponding Source
+includes interface definition files associated with source files for
+the work, and the source code for shared libraries and dynamically
+linked subprograms that the work is specifically designed to require,
+such as by intimate data communication or control flow between those
+subprograms and other parts of the work.
+
+The Corresponding Source need not include anything that users can
+regenerate automatically from other parts of the Corresponding Source.
+
+The Corresponding Source for a work in source code form is that same
+work.
+
+#### 2. Basic Permissions.
+
+All rights granted under this License are granted for the term of
+copyright on the Program, and are irrevocable provided the stated
+conditions are met. This License explicitly affirms your unlimited
+permission to run the unmodified Program. The output from running a
+covered work is covered by this License only if the output, given its
+content, constitutes a covered work. This License acknowledges your
+rights of fair use or other equivalent, as provided by copyright law.
+
+You may make, run and propagate covered works that you do not convey,
+without conditions so long as your license otherwise remains in force.
+You may convey covered works to others for the sole purpose of having
+them make modifications exclusively for you, or provide you with
+facilities for running those works, provided that you comply with the
+terms of this License in conveying all material for which you do not
+control copyright. Those thus making or running the covered works for
+you must do so exclusively on your behalf, under your direction and
+control, on terms that prohibit them from making any copies of your
+copyrighted material outside their relationship with you.
+
+Conveying under any other circumstances is permitted solely under the
+conditions stated below. Sublicensing is not allowed; section 10 makes
+it unnecessary.
+
+#### 3. Protecting Users' Legal Rights From Anti-Circumvention Law.
+
+No covered work shall be deemed part of an effective technological
+measure under any applicable law fulfilling obligations under article
+11 of the WIPO copyright treaty adopted on 20 December 1996, or
+similar laws prohibiting or restricting circumvention of such
+measures.
+
+When you convey a covered work, you waive any legal power to forbid
+circumvention of technological measures to the extent such
+circumvention is effected by exercising rights under this License with
+respect to the covered work, and you disclaim any intention to limit
+operation or modification of the work as a means of enforcing, against
+the work's users, your or third parties' legal rights to forbid
+circumvention of technological measures.
+
+#### 4. Conveying Verbatim Copies.
+
+You may convey verbatim copies of the Program's source code as you
+receive it, in any medium, provided that you conspicuously and
+appropriately publish on each copy an appropriate copyright notice;
+keep intact all notices stating that this License and any
+non-permissive terms added in accord with section 7 apply to the code;
+keep intact all notices of the absence of any warranty; and give all
+recipients a copy of this License along with the Program.
+
+You may charge any price or no price for each copy that you convey,
+and you may offer support or warranty protection for a fee.
+
+#### 5. Conveying Modified Source Versions.
+
+You may convey a work based on the Program, or the modifications to
+produce it from the Program, in the form of source code under the
+terms of section 4, provided that you also meet all of these
+conditions:
+
+-   a) The work must carry prominent notices stating that you modified
+    it, and giving a relevant date.
+-   b) The work must carry prominent notices stating that it is
+    released under this License and any conditions added under
+    section 7. This requirement modifies the requirement in section 4
+    to "keep intact all notices".
+-   c) You must license the entire work, as a whole, under this
+    License to anyone who comes into possession of a copy. This
+    License will therefore apply, along with any applicable section 7
+    additional terms, to the whole of the work, and all its parts,
+    regardless of how they are packaged. This License gives no
+    permission to license the work in any other way, but it does not
+    invalidate such permission if you have separately received it.
+-   d) If the work has interactive user interfaces, each must display
+    Appropriate Legal Notices; however, if the Program has interactive
+    interfaces that do not display Appropriate Legal Notices, your
+    work need not make them do so.
+
+A compilation of a covered work with other separate and independent
+works, which are not by their nature extensions of the covered work,
+and which are not combined with it such as to form a larger program,
+in or on a volume of a storage or distribution medium, is called an
+"aggregate" if the compilation and its resulting copyright are not
+used to limit the access or legal rights of the compilation's users
+beyond what the individual works permit. Inclusion of a covered work
+in an aggregate does not cause this License to apply to the other
+parts of the aggregate.
+
+#### 6. Conveying Non-Source Forms.
+
+You may convey a covered work in object code form under the terms of
+sections 4 and 5, provided that you also convey the machine-readable
+Corresponding Source under the terms of this License, in one of these
+ways:
+
+-   a) Convey the object code in, or embodied in, a physical product
+    (including a physical distribution medium), accompanied by the
+    Corresponding Source fixed on a durable physical medium
+    customarily used for software interchange.
+-   b) Convey the object code in, or embodied in, a physical product
+    (including a physical distribution medium), accompanied by a
+    written offer, valid for at least three years and valid for as
+    long as you offer spare parts or customer support for that product
+    model, to give anyone who possesses the object code either (1) a
+    copy of the Corresponding Source for all the software in the
+    product that is covered by this License, on a durable physical
+    medium customarily used for software interchange, for a price no
+    more than your reasonable cost of physically performing this
+    conveying of source, or (2) access to copy the Corresponding
+    Source from a network server at no charge.
+-   c) Convey individual copies of the object code with a copy of the
+    written offer to provide the Corresponding Source. This
+    alternative is allowed only occasionally and noncommercially, and
+    only if you received the object code with such an offer, in accord
+    with subsection 6b.
+-   d) Convey the object code by offering access from a designated
+    place (gratis or for a charge), and offer equivalent access to the
+    Corresponding Source in the same way through the same place at no
+    further charge. You need not require recipients to copy the
+    Corresponding Source along with the object code. If the place to
+    copy the object code is a network server, the Corresponding Source
+    may be on a different server (operated by you or a third party)
+    that supports equivalent copying facilities, provided you maintain
+    clear directions next to the object code saying where to find the
+    Corresponding Source. Regardless of what server hosts the
+    Corresponding Source, you remain obligated to ensure that it is
+    available for as long as needed to satisfy these requirements.
+-   e) Convey the object code using peer-to-peer transmission,
+    provided you inform other peers where the object code and
+    Corresponding Source of the work are being offered to the general
+    public at no charge under subsection 6d.
+
+A separable portion of the object code, whose source code is excluded
+from the Corresponding Source as a System Library, need not be
+included in conveying the object code work.
+
+A "User Product" is either (1) a "consumer product", which means any
+tangible personal property which is normally used for personal,
+family, or household purposes, or (2) anything designed or sold for
+incorporation into a dwelling. In determining whether a product is a
+consumer product, doubtful cases shall be resolved in favor of
+coverage. For a particular product received by a particular user,
+"normally used" refers to a typical or common use of that class of
+product, regardless of the status of the particular user or of the way
+in which the particular user actually uses, or expects or is expected
+to use, the product. A product is a consumer product regardless of
+whether the product has substantial commercial, industrial or
+non-consumer uses, unless such uses represent the only significant
+mode of use of the product.
+
+"Installation Information" for a User Product means any methods,
+procedures, authorization keys, or other information required to
+install and execute modified versions of a covered work in that User
+Product from a modified version of its Corresponding Source. The
+information must suffice to ensure that the continued functioning of
+the modified object code is in no case prevented or interfered with
+solely because modification has been made.
+
+If you convey an object code work under this section in, or with, or
+specifically for use in, a User Product, and the conveying occurs as
+part of a transaction in which the right of possession and use of the
+User Product is transferred to the recipient in perpetuity or for a
+fixed term (regardless of how the transaction is characterized), the
+Corresponding Source conveyed under this section must be accompanied
+by the Installation Information. But this requirement does not apply
+if neither you nor any third party retains the ability to install
+modified object code on the User Product (for example, the work has
+been installed in ROM).
+
+The requirement to provide Installation Information does not include a
+requirement to continue to provide support service, warranty, or
+updates for a work that has been modified or installed by the
+recipient, or for the User Product in which it has been modified or
+installed. Access to a network may be denied when the modification
+itself materially and adversely affects the operation of the network
+or violates the rules and protocols for communication across the
+network.
+
+Corresponding Source conveyed, and Installation Information provided,
+in accord with this section must be in a format that is publicly
+documented (and with an implementation available to the public in
+source code form), and must require no special password or key for
+unpacking, reading or copying.
+
+#### 7. Additional Terms.
+
+"Additional permissions" are terms that supplement the terms of this
+License by making exceptions from one or more of its conditions.
+Additional permissions that are applicable to the entire Program shall
+be treated as though they were included in this License, to the extent
+that they are valid under applicable law. If additional permissions
+apply only to part of the Program, that part may be used separately
+under those permissions, but the entire Program remains governed by
+this License without regard to the additional permissions.
+
+When you convey a copy of a covered work, you may at your option
+remove any additional permissions from that copy, or from any part of
+it. (Additional permissions may be written to require their own
+removal in certain cases when you modify the work.) You may place
+additional permissions on material, added by you to a covered work,
+for which you have or can give appropriate copyright permission.
+
+Notwithstanding any other provision of this License, for material you
+add to a covered work, you may (if authorized by the copyright holders
+of that material) supplement the terms of this License with terms:
+
+-   a) Disclaiming warranty or limiting liability differently from the
+    terms of sections 15 and 16 of this License; or
+-   b) Requiring preservation of specified reasonable legal notices or
+    author attributions in that material or in the Appropriate Legal
+    Notices displayed by works containing it; or
+-   c) Prohibiting misrepresentation of the origin of that material,
+    or requiring that modified versions of such material be marked in
+    reasonable ways as different from the original version; or
+-   d) Limiting the use for publicity purposes of names of licensors
+    or authors of the material; or
+-   e) Declining to grant rights under trademark law for use of some
+    trade names, trademarks, or service marks; or
+-   f) Requiring indemnification of licensors and authors of that
+    material by anyone who conveys the material (or modified versions
+    of it) with contractual assumptions of liability to the recipient,
+    for any liability that these contractual assumptions directly
+    impose on those licensors and authors.
+
+All other non-permissive additional terms are considered "further
+restrictions" within the meaning of section 10. If the Program as you
+received it, or any part of it, contains a notice stating that it is
+governed by this License along with a term that is a further
+restriction, you may remove that term. If a license document contains
+a further restriction but permits relicensing or conveying under this
+License, you may add to a covered work material governed by the terms
+of that license document, provided that the further restriction does
+not survive such relicensing or conveying.
+
+If you add terms to a covered work in accord with this section, you
+must place, in the relevant source files, a statement of the
+additional terms that apply to those files, or a notice indicating
+where to find the applicable terms.
+
+Additional terms, permissive or non-permissive, may be stated in the
+form of a separately written license, or stated as exceptions; the
+above requirements apply either way.
+
+#### 8. Termination.
+
+You may not propagate or modify a covered work except as expressly
+provided under this License. Any attempt otherwise to propagate or
+modify it is void, and will automatically terminate your rights under
+this License (including any patent licenses granted under the third
+paragraph of section 11).
+
+However, if you cease all violation of this License, then your license
+from a particular copyright holder is reinstated (a) provisionally,
+unless and until the copyright holder explicitly and finally
+terminates your license, and (b) permanently, if the copyright holder
+fails to notify you of the violation by some reasonable means prior to
+60 days after the cessation.
+
+Moreover, your license from a particular copyright holder is
+reinstated permanently if the copyright holder notifies you of the
+violation by some reasonable means, this is the first time you have
+received notice of violation of this License (for any work) from that
+copyright holder, and you cure the violation prior to 30 days after
+your receipt of the notice.
+
+Termination of your rights under this section does not terminate the
+licenses of parties who have received copies or rights from you under
+this License. If your rights have been terminated and not permanently
+reinstated, you do not qualify to receive new licenses for the same
+material under section 10.
+
+#### 9. Acceptance Not Required for Having Copies.
+
+You are not required to accept this License in order to receive or run
+a copy of the Program. Ancillary propagation of a covered work
+occurring solely as a consequence of using peer-to-peer transmission
+to receive a copy likewise does not require acceptance. However,
+nothing other than this License grants you permission to propagate or
+modify any covered work. These actions infringe copyright if you do
+not accept this License. Therefore, by modifying or propagating a
+covered work, you indicate your acceptance of this License to do so.
+
+#### 10. Automatic Licensing of Downstream Recipients.
+
+Each time you convey a covered work, the recipient automatically
+receives a license from the original licensors, to run, modify and
+propagate that work, subject to this License. You are not responsible
+for enforcing compliance by third parties with this License.
+
+An "entity transaction" is a transaction transferring control of an
+organization, or substantially all assets of one, or subdividing an
+organization, or merging organizations. If propagation of a covered
+work results from an entity transaction, each party to that
+transaction who receives a copy of the work also receives whatever
+licenses to the work the party's predecessor in interest had or could
+give under the previous paragraph, plus a right to possession of the
+Corresponding Source of the work from the predecessor in interest, if
+the predecessor has it or can get it with reasonable efforts.
+
+You may not impose any further restrictions on the exercise of the
+rights granted or affirmed under this License. For example, you may
+not impose a license fee, royalty, or other charge for exercise of
+rights granted under this License, and you may not initiate litigation
+(including a cross-claim or counterclaim in a lawsuit) alleging that
+any patent claim is infringed by making, using, selling, offering for
+sale, or importing the Program or any portion of it.
+
+#### 11. Patents.
+
+A "contributor" is a copyright holder who authorizes use under this
+License of the Program or a work on which the Program is based. The
+work thus licensed is called the contributor's "contributor version".
+
+A contributor's "essential patent claims" are all patent claims owned
+or controlled by the contributor, whether already acquired or
+hereafter acquired, that would be infringed by some manner, permitted
+by this License, of making, using, or selling its contributor version,
+but do not include claims that would be infringed only as a
+consequence of further modification of the contributor version. For
+purposes of this definition, "control" includes the right to grant
+patent sublicenses in a manner consistent with the requirements of
+this License.
+
+Each contributor grants you a non-exclusive, worldwide, royalty-free
+patent license under the contributor's essential patent claims, to
+make, use, sell, offer for sale, import and otherwise run, modify and
+propagate the contents of its contributor version.
+
+In the following three paragraphs, a "patent license" is any express
+agreement or commitment, however denominated, not to enforce a patent
+(such as an express permission to practice a patent or covenant not to
+sue for patent infringement). To "grant" such a patent license to a
+party means to make such an agreement or commitment not to enforce a
+patent against the party.
+
+If you convey a covered work, knowingly relying on a patent license,
+and the Corresponding Source of the work is not available for anyone
+to copy, free of charge and under the terms of this License, through a
+publicly available network server or other readily accessible means,
+then you must either (1) cause the Corresponding Source to be so
+available, or (2) arrange to deprive yourself of the benefit of the
+patent license for this particular work, or (3) arrange, in a manner
+consistent with the requirements of this License, to extend the patent
+license to downstream recipients. "Knowingly relying" means you have
+actual knowledge that, but for the patent license, your conveying the
+covered work in a country, or your recipient's use of the covered work
+in a country, would infringe one or more identifiable patents in that
+country that you have reason to believe are valid.
+
+If, pursuant to or in connection with a single transaction or
+arrangement, you convey, or propagate by procuring conveyance of, a
+covered work, and grant a patent license to some of the parties
+receiving the covered work authorizing them to use, propagate, modify
+or convey a specific copy of the covered work, then the patent license
+you grant is automatically extended to all recipients of the covered
+work and works based on it.
+
+A patent license is "discriminatory" if it does not include within the
+scope of its coverage, prohibits the exercise of, or is conditioned on
+the non-exercise of one or more of the rights that are specifically
+granted under this License. You may not convey a covered work if you
+are a party to an arrangement with a third party that is in the
+business of distributing software, under which you make payment to the
+third party based on the extent of your activity of conveying the
+work, and under which the third party grants, to any of the parties
+who would receive the covered work from you, a discriminatory patent
+license (a) in connection with copies of the covered work conveyed by
+you (or copies made from those copies), or (b) primarily for and in
+connection with specific products or compilations that contain the
+covered work, unless you entered into that arrangement, or that patent
+license was granted, prior to 28 March 2007.
+
+Nothing in this License shall be construed as excluding or limiting
+any implied license or other defenses to infringement that may
+otherwise be available to you under applicable patent law.
+
+#### 12. No Surrender of Others' Freedom.
+
+If conditions are imposed on you (whether by court order, agreement or
+otherwise) that contradict the conditions of this License, they do not
+excuse you from the conditions of this License. If you cannot convey a
+covered work so as to satisfy simultaneously your obligations under
+this License and any other pertinent obligations, then as a
+consequence you may not convey it at all. For example, if you agree to
+terms that obligate you to collect a royalty for further conveying
+from those to whom you convey the Program, the only way you could
+satisfy both those terms and this License would be to refrain entirely
+from conveying the Program.
+
+#### 13. Remote Network Interaction; Use with the GNU General Public License.
+
+Notwithstanding any other provision of this License, if you modify the
+Program, your modified version must prominently offer all users
+interacting with it remotely through a computer network (if your
+version supports such interaction) an opportunity to receive the
+Corresponding Source of your version by providing access to the
+Corresponding Source from a network server at no charge, through some
+standard or customary means of facilitating copying of software. This
+Corresponding Source shall include the Corresponding Source for any
+work covered by version 3 of the GNU General Public License that is
+incorporated pursuant to the following paragraph.
+
+Notwithstanding any other provision of this License, you have
+permission to link or combine any covered work with a work licensed
+under version 3 of the GNU General Public License into a single
+combined work, and to convey the resulting work. The terms of this
+License will continue to apply to the part which is the covered work,
+but the work with which it is combined will remain governed by version
+3 of the GNU General Public License.
+
+#### 14. Revised Versions of this License.
+
+The Free Software Foundation may publish revised and/or new versions
+of the GNU Affero General Public License from time to time. Such new
+versions will be similar in spirit to the present version, but may
+differ in detail to address new problems or concerns.
+
+Each version is given a distinguishing version number. If the Program
+specifies that a certain numbered version of the GNU Affero General
+Public License "or any later version" applies to it, you have the
+option of following the terms and conditions either of that numbered
+version or of any later version published by the Free Software
+Foundation. If the Program does not specify a version number of the
+GNU Affero General Public License, you may choose any version ever
+published by the Free Software Foundation.
+
+If the Program specifies that a proxy can decide which future versions
+of the GNU Affero General Public License can be used, that proxy's
+public statement of acceptance of a version permanently authorizes you
+to choose that version for the Program.
+
+Later license versions may give you additional or different
+permissions. However, no additional obligations are imposed on any
+author or copyright holder as a result of your choosing to follow a
+later version.
+
+#### 15. Disclaimer of Warranty.
+
+THERE IS NO WARRANTY FOR THE PROGRAM, TO THE EXTENT PERMITTED BY
+APPLICABLE LAW. EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT
+HOLDERS AND/OR OTHER PARTIES PROVIDE THE PROGRAM "AS IS" WITHOUT
+WARRANTY OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT
+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+A PARTICULAR PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND
+PERFORMANCE OF THE PROGRAM IS WITH YOU. SHOULD THE PROGRAM PROVE
+DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING, REPAIR OR
+CORRECTION.
+
+#### 16. Limitation of Liability.
+
+IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING
+WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MODIFIES AND/OR
+CONVEYS THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES,
+INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES
+ARISING OUT OF THE USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT
+NOT LIMITED TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR
+LOSSES SUSTAINED BY YOU OR THIRD PARTIES OR A FAILURE OF THE PROGRAM
+TO OPERATE WITH ANY OTHER PROGRAMS), EVEN IF SUCH HOLDER OR OTHER
+PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGES.
+
+#### 17. Interpretation of Sections 15 and 16.
+
+If the disclaimer of warranty and limitation of liability provided
+above cannot be given local legal effect according to their terms,
+reviewing courts shall apply local law that most closely approximates
+an absolute waiver of all civil liability in connection with the
+Program, unless a warranty or assumption of liability accompanies a
+copy of the Program in return for a fee.
+
+END OF TERMS AND CONDITIONS
+
+### How to Apply These Terms to Your New Programs
+
+If you develop a new program, and you want it to be of the greatest
+possible use to the public, the best way to achieve this is to make it
+free software which everyone can redistribute and change under these
+terms.
+
+To do so, attach the following notices to the program. It is safest to
+attach them to the start of each source file to most effectively state
+the exclusion of warranty; and each file should have at least the
+"copyright" line and a pointer to where the full notice is found.
+
+        <one line to give the program's name and a brief idea of what it does.>
+        Copyright (C) <year>  <name of author>
+
+        This program is free software: you can redistribute it and/or modify
+        it under the terms of the GNU Affero General Public License as
+        published by the Free Software Foundation, either version 3 of the
+        License, or (at your option) any later version.
+
+        This program is distributed in the hope that it will be useful,
+        but WITHOUT ANY WARRANTY; without even the implied warranty of
+        MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+        GNU Affero General Public License for more details.
+
+        You should have received a copy of the GNU Affero General Public License
+        along with this program.  If not, see <https://www.gnu.org/licenses/>.
+
+Also add information on how to contact you by electronic and paper
+mail.
+
+If your software can interact with users remotely through a computer
+network, you should also make sure that it provides a way for users to
+get its source. For example, if your program is a web application, its
+interface could display a "Source" link that leads users to an archive
+of the code. There are many ways you could offer source, and different
+solutions will be better for different programs; see section 13 for
+the specific requirements.
+
+You should also get your employer (if you work as a programmer) or
+school, if any, to sign a "copyright disclaimer" for the program, if
+necessary. For more information on this, and how to apply and follow
+the GNU AGPL, see <https://www.gnu.org/licenses/>.

backend/Setup.hs

@@ -0,0 +1,4 @@
+import Distribution.Simple
+
+main :: IO ()
+main = defaultMain

backend/datarekisteri-backend.cabal

@@ -0,0 +1,96 @@
+cabal-version: 3.6
+name: datarekisteri-backend
+version: 0.0.1
+author: Saku Laesvuori
+license: AGPL-3.0-or-later
+license-file: COPYING.md
+build-type: Simple
+stability: alpha
+data-files:
+  db/migrations/*.sql
+
+executable datarekisteri-backend
+  build-depends:
+    aeson,
+    base,
+    base64,
+    cryptonite,
+    datarekisteri-core,
+    data-default,
+    email-validate,
+    esqueleto,
+    http-types,
+    memory,
+    mime-mail,
+    monad-logger,
+    morpheus-graphql,
+    morpheus-graphql-app,
+    morpheus-graphql-core,
+    morpheus-graphql-server,
+    mtl,
+    optparse-applicative,
+    persistent,
+    persistent-postgresql,
+    process,
+    relude,
+    scotty,
+    smtp-mail,
+    text,
+    time,
+    containers,
+    wai,
+    warp,
+    wai-cors,
+    wai-extra,
+    directory
+  main-is: Main.hs
+  other-modules:
+    Datarekisteri.Backend,
+    Datarekisteri.Backend.API,
+    Datarekisteri.Backend.DB,
+    Datarekisteri.Backend.Sql,
+    Datarekisteri.Backend.Sql.Types,
+    Datarekisteri.Backend.Sql.Queries,
+    Datarekisteri.Backend.Email,
+    Datarekisteri.Backend.Types,
+    Datarekisteri.Backend.Utils,
+    Paths_datarekisteri_backend
+  autogen-modules:
+    Paths_datarekisteri_backend
+  hs-source-dirs: src
+  default-language: Haskell2010
+
+executable datarekisteri-cli
+  build-depends:
+    aeson,
+    base,
+    base64,
+    containers,
+    cryptonite,
+    datarekisteri-core,
+    echo,
+    email-validate,
+    esqueleto,
+    memory,
+    mime-mail,
+    monad-logger,
+    morpheus-graphql,
+    morpheus-graphql-app,
+    morpheus-graphql-core,
+    morpheus-graphql-server,
+    mtl,
+    optparse-applicative,
+    persistent,
+    persistent-postgresql,
+    relude,
+    text,
+    time
+  main-is: Datarekisteri/CLI.hs
+  other-modules:
+    Datarekisteri.Backend.Sql,
+    Datarekisteri.Backend.Sql.Types,
+    Datarekisteri.Backend.Sql.Queries,
+    Datarekisteri.Backend.Types,
+    Datarekisteri.Backend.Utils,
+  hs-source-dirs: src
+  default-language: Haskell2010

backend/db/migrations/20221208114323_init-db.sql

@@ -0,0 +1,53 @@
+-- migrate:up
+
+create table "users" (
+    "id" serial primary key,
+    "email" varchar(255) unique,
+    "pendingEmail" varchar(255) unique,
+    "emailVerificationSecret" varchar(255) unique,
+    "registered" timestamp not null,
+    "passwordCrypt" bytea not null,
+    "permissions" text not null,
+    "accepted" timestamp,
+    "rejected" timestamp,
+    "seceded" timestamp,
+    "toBeDeleted" timestamp,
+    "memberData" jsonb not null
+);
+
+create index "users_memberData_index" on "users" using gin ("memberData");
+
+create table "keys" (
+    "id" serial primary key,
+    "uid" integer not null references "users" on delete cascade,
+    "data" bytea not null,
+    "expires" timestamp,
+    "uploaded" timestamp not null,
+    "comment" text not null,
+    "isPrimaryEncryptionKey" bool not null
+);
+
+create unique index "keys_isPrimaryEncryptionKey_constraint" on "keys" ("uid")
+where "isPrimaryEncryptionKey";
+
+create index "keys_uid_index" on "keys" ("uid");
+
+create table "tokens" (
+    "id" serial primary key,
+    "uid" integer not null references "users" on delete cascade,
+    "name" text,
+    "data" text unique not null,
+    "comment" text not null,
+    "issued" timestamp not null,
+    "expires" timestamp,
+    "permissions" text,
+    unique ("name", "uid")
+);
+
+create index "tokens_data_index" on "tokens" ("data");
+
+-- migrate:down
+
+drop table "tokens";
+drop table "keys";
+drop table "users";

backend/db/migrations/20230917064352_split-emails-from-users.sql

@@ -0,0 +1,40 @@
+-- migrate:up
+
+create table "emails" (
+    "id" serial primary key,
+    "uid" integer not null references "users" on delete cascade,
+    "email" varchar(320) unique not null, -- local 64 + domain 255 + '@' 1 per RFC5321
+    "verificationSecret" varchar(255) unique
+);
+
+create unique index "emails_uid_verified" on "emails" ("uid", ("verificationSecret" is not null));
+-- at most one verified and one pending email per user
+
+insert into "emails" ("uid", "email", "verificationSecret")
+    select "id", "email", null as "verificationSecret" from "users" where "email" is not null;
+
+insert into "emails" ("uid", "email", "verificationSecret")
+    select "id", "pendingEmail", "emailVerificationSecret" from "users" where "pendingEmail" is not null;
+
+alter table "users"
+    drop "email" cascade,
+    drop "pendingEmail" cascade,
+    drop "emailVerificationSecret" cascade;
+
+-- migrate:down
+
+alter table "users"
+    add "email" varchar(320) unique,
+    add "pendingEmail" varchar(320) unique,
+    add "emailVerificationSecret" varchar(255) unique;
+
+update "users" set "email" = "emails"."email"
+    from "emails"
+    where "users"."id" = "emails"."uid" and "emails"."verificationSecret" is null;
+
+update "users" set "pendingEmail" = "emails"."email",
+    "emailVerificationSecret" = "emails"."verificationSecret"
+    from "emails"
+    where "users"."id" = "emails"."uid" and "emails"."verificationSecret" is not null;
+
+drop table "emails";

backend/db/migrations/20230928083120_add-expiry-time-to-emails.sql

@@ -0,0 +1,36 @@
+-- migrate:up
+
+create table "emailVerifications" (
+    "id" serial primary key,
+    "secret" varchar(255) unique not null,
+    "expires" timestamp not null
+);
+
+alter table "emails" add "verification" integer unique references "emailVerifications" on delete cascade;
+
+insert into "emailVerifications" ("secret", "expires")
+    select "verificationSecret", (localtimestamp + '7 days') as "expires" from "emails"
+        where "verificationSecret" is not null;
+
+update "emails" set
+    "verification" = (select "id" from "emailVerifications" where "secret" = "verificationSecret");
+
+alter table "emails" drop "verificationSecret" cascade;
+
+create unique index "emails_uid_verified" on "emails" ("uid", ("verification" is not null));
+-- at most one verified and one pending email per user
+
+-- migrate:down
+
+alter table "emails" add "verificationSecret" varchar(255) unique;
+
+update "emails" set
+    "verificationSecret" = (select "secret" from "emailVerifications"
+        where "emailVerifications"."id" = "emails"."verification");
+
+alter table "emails" drop "verification";
+
+drop table "emailVerifications";
+
+create unique index "emails_uid_verified" on "emails" ("uid", ("verificationSecret" is not null));
+-- at most one verified and one pending email per user

backend/db/migrations/20230928115610_remove-deletion-times.sql

@@ -0,0 +1,16 @@
+-- migrate:up
+
+delete from "users"
+    where "rejected" is not null or "seceded" is not null or "toBeDeleted" is not null;
+
+alter table "users"
+    drop "rejected",
+    drop "seceded",
+    drop "toBeDeleted";
+
+-- migrate:down
+
+alter table "users"
+    add "rejected" timestamp,
+    add "seceded" timestamp,
+    add "toBeDeleted" timestamp;

backend/src/Datarekisteri/Backend.hs

@@ -0,0 +1,243 @@
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE PackageImports #-}
+{-# LANGUAGE RecordWildCards #-}
+
+{-# LANGUAGE NoImplicitPrelude #-}
+
+module Datarekisteri.Backend where
+
+import Relude
+
+import "cryptonite" Crypto.Random (MonadRandom(..))
+import qualified "base64" Data.ByteString.Base64 as B64
+
+import Control.Monad.Except (catchError)
+import Control.Monad.Logger (runStderrLoggingT)
+import Data.Default (def)
+import Data.Map (findWithDefault)
+import Data.Text (toLower, breakOn, stripPrefix)
+import Database.Persist.Postgresql (withPostgresqlConn, runSqlConn)
+import Network.HTTP.Types.Status (status500, status401)
+import Network.Mail.Mime (renderSendMailCustom, Address(..))
+import Network.Wai (Application)
+import Network.Wai.Handler.Warp (Port, run)
+import Network.Wai.Middleware.Cors (CorsResourcePolicy(..), cors)
+import Network.Wai.Middleware.Gzip (gzip)
+import System.Directory (findExecutable)
+import System.Process (callProcess)
+
+import qualified Options.Applicative as O
+
+import Options.Applicative hiding (Success, header)
+import Web.Scotty.Trans hiding (readEither)
+
+import Datarekisteri.Backend.Sql (MonadSql)
+import Datarekisteri.Backend.Utils (checkPassword)
+
+import qualified Datarekisteri.Backend.Sql as Sql
+
+import Datarekisteri.Backend.API
+import Datarekisteri.Backend.Types
+import Datarekisteri.Core.Types
+
+import Paths_datarekisteri_backend
+
+main :: IO ()
+main = do
+    config <- readConfig >>= checkSendmailPath
+    runMigrations (configDbUrl config)
+    serverApp config >>= run 3100
+
+readConfig :: IO Config
+readConfig = do
+    execParser $ info (configOpts <**> helper)
+            (fullDesc <> progDesc "Serve a GraphQL API for datarekisteri"
+            <> O.header "Backend API server for datarekisteri")
+
+checkSendmailPath :: Config -> IO Config
+checkSendmailPath config = do
+    sendmailPath <- maybe (error "Sendmail command or file not found!") pure =<<
+        findExecutable (configSendmail config)
+    pure $ config {configSendmail = sendmailPath}
+
+configOpts :: Parser Config
+configOpts = Config
+    <$> strOption (long "sendmail" <> short 'm' <> metavar "COMMAND" <> value "sendmail" <> help "Sendmail command")
+    <*> (Address
+        <$> optional (strOption (long "sender-name" <> short 'n' <> metavar "NAME" <> help "Display name for email address"))
+        <*> strOption (long "address" <> short 'a' <> metavar "EMAIL" <> help "Email address to send mail"))
+    <*> option auto (long "port" <> short 'p' <> metavar "PORT" <> value 3100 <> help "Port to listen on")
+    <*> strOption (long "db-url" <> short 'u' <> metavar "URL" <> value "postgres:///datarekisteri-backend" <> help "Postgresql database url")
+
+runMigrations :: Text -> IO ()
+runMigrations dbUrl = do
+    migrationsPath <- getDataFileName "db/migrations"
+    callProcess "dbmate" ["--url", toString dbUrl, "--migrations-dir", migrationsPath, "up"]
+
+serverApp :: Config -> IO Application
+serverApp config = scottyAppT (runAPIM config) $ do
+    middleware $ gzip def
+    middleware $ cors $ const $ Just CorsResourcePolicy
+        { corsOrigins = Nothing -- all
+        , corsMethods = ["POST"]
+        , corsRequestHeaders = ["Authorization"]
+        , corsExposedHeaders = Nothing
+        , corsMaxAge = Just (60*60*24)
+        , corsVaryOrigin = False
+        , corsRequireOrigin = False
+        , corsIgnoreFailures = False
+        }
+    post "/" $ do
+        maybeAuthorization <- fmap toText <$> header "Authorization"
+        let maybeBasic = parseBasic maybeAuthorization
+            maybeBearer = parseBearer maybeAuthorization
+            auth = case maybeBasic of
+                     Just _ -> authBasic maybeBasic
+                     Nothing -> authBearer maybeBearer
+        auth $ do
+            setHeader "Content-Type" "text/json"
+            body >>= lift . runApp coreApp >>= raw
+
+data BasicAuth = BasicAuth { emailAddress :: Email, password :: Text } deriving (Show)
+
+data BearerToken = BearerToken Text deriving (Show)
+
+parseBearer :: Maybe Text -> Maybe BearerToken
+parseBearer auth = do
+    [authType, authData] <- words <$> auth
+    guard $ toLower authType == "bearer"
+    pure $ BearerToken authData
+
+authBearer :: Maybe BearerToken -> ActionT LText APIM a -> ActionT LText APIM a
+authBearer Nothing m = m
+authBearer (Just (BearerToken bearer)) m = do
+    let getUserPermissions = do
+            Right DBToken {..} <- lift $ dbGetTokenBySecret bearer
+            permissions' <- fromMaybe mempty . readPermission <$> lift dbTokenPermissions
+            DBUser {..} <- lift dbTokenUser
+            userID <- lift dbUserId
+            pure (Just userID, permissions')
+    (user, permissions) <- getUserPermissions `catchError` const (pure (Nothing, mempty))
+    flip local m $ \state -> state
+        { stateCurrentUser = user
+        , statePermissions = permissions
+        }
+
+parseBasic :: Maybe Text -> Maybe BasicAuth
+parseBasic txt = do
+    [authType, authData] <- words <$> txt
+    guard $ toLower authType == "basic"
+    (email, password) <- rightToMaybe $
+        breakOn' ":" . decodeUtf8 <$> B64.decodeBase64 (encodeUtf8 authData)
+    emailAddress <- toEmail email
+    pure $ BasicAuth {..}
+        where breakOn' x xs = let (fst, snd) = breakOn x xs
+                              in (fst, fromMaybe "" $ stripPrefix x snd)
+
+
+authBasic :: Maybe BasicAuth -> ActionT LText APIM a -> ActionT LText APIM a
+authBasic Nothing m = m
+authBasic (Just basic) m = do
+    DBUser {..} <- verifyBasic basic
+    permissions <- readPermission <$> lift dbUserPermissions >>=
+        fromMaybeFail status500 "Internal server error"
+    userID <- lift dbUserId
+    flip local m $ \state -> state
+        { stateCurrentUser = Just userID
+        , statePermissions = permissions
+        }
+
+verifyBasic :: BasicAuth -> ActionT LText APIM (DBUser APIM)
+verifyBasic BasicAuth {..} = do
+    maybeUser <- lift $ dbGetUserByEmail emailAddress
+    let unauthorized = do
+            setHeader "WWW-Authenticate" "Basic realm=\"GraphQL API\", Bearer realm=\"GraphQL API\""
+            raiseStatus status401 "Wrong password or email"
+    case maybeUser of
+      Left _ -> unauthorized
+      Right user@DBUser {..} -> do
+          correctPassword <- checkPassword password <$> lift dbUserPasswordHash
+          unless correctPassword unauthorized
+          pure user
+
+newtype APIM a = APIM (ReaderT RequestState IO a)
+    deriving (Functor, Applicative, Monad, MonadIO, MonadReader RequestState)
+
+data RequestState = RequestState
+    { stateCurrentUser :: Maybe UserID
+    , statePermissions :: Map Scope Permission
+    , stateConfig :: Config
+    }
+
+data Config = Config
+    { configSendmail :: FilePath
+    , configEmailAddress :: Address
+    , configPort :: Port
+    , configDbUrl :: Text
+    }
+
+instance MonadTime APIM where
+    currentTime = liftIO currentTime
+
+instance MonadSql APIM where
+    runQuery query = do
+        dbUrl <- fmap encodeUtf8 $ asks $ configDbUrl . stateConfig
+        liftIO $ runStderrLoggingT $ withPostgresqlConn dbUrl $ runSqlConn query
+
+-- TODO: Catch database exceptions into Left values
+instance MonadDB APIM where
+    dbUpdateUser = Sql.dbUpdateUser
+    dbAddUser = Sql.dbAddUser
+    dbAcceptApplication = Sql.dbAcceptApplication
+    dbRejectApplication = Sql.dbRejectApplication
+    dbVerifyEmail = Sql.dbVerifyEmail
+    dbAddToken = Sql.dbAddToken
+    dbAddKey = Sql.dbAddKey
+    dbGetUser = Sql.dbGetUser
+    dbGetUserByEmail = Sql.dbGetUserByEmail
+    dbGetUsers = Sql.dbGetUsers
+    dbGetApplications = Sql.dbGetApplications
+    dbGetEmailVerificationSecret = Sql.dbGetEmailVerificationSecret
+    dbGetTokenBySecret = Sql.dbGetTokenBySecret
+
+instance MonadEmail APIM where
+    sendEmail email = do
+        sendmailPath <- asks $ configSendmail . stateConfig
+        liftIO $ renderSendMailCustom sendmailPath ["-t"] email
+    fromAddress = asks $ configEmailAddress . stateConfig
+
+instance MonadRequest APIM where
+    currentUser = asks stateCurrentUser
+
+instance MonadRandom APIM where
+    getRandomBytes = liftIO . getRandomBytes
+
+instance MonadPermissions APIM where
+    currentPermissions = show <$> asks statePermissions
+    defaultPermissions = pure $ show $ (fromList [(OwnProfile, ReadWrite)] :: Map Scope Permission)
+    toPermissions = pure . fmap show . readPermission
+    hasPermission scope permission = (>= permission) <$> findPermission scope
+        where findPermission :: Scope -> APIM Permission
+              findPermission scope@(Profile user) = selfPermissions scope user OwnProfile
+              findPermission scope@(Tokens user) = selfPermissions scope user OwnTokens
+              findPermission scope = findPermission' scope <$> asks statePermissions
+              findPermission' :: Scope -> Map Scope Permission -> Permission
+              findPermission' = findWithDefault None
+              selfPermissions :: Scope -> UserID -> Scope -> APIM Permission
+              selfPermissions scope user own = do
+                  isSelf <- (Just user ==) <$> currentUser
+                  let f = if isSelf then max <$> findPermission' own <*> findPermission' scope
+                                    else findPermission' scope
+
+                  f <$> asks statePermissions
+
+runAPIM :: Config -> APIM a -> IO a
+runAPIM config (APIM m) = runReaderT m RequestState
+    { stateCurrentUser = Nothing
+    , statePermissions = fromList []
+    , stateConfig = config
+    }
+
+fromMaybeFail status err Nothing = raiseStatus status err
+fromMaybeFail _ _ (Just x) = pure x

backend/src/Datarekisteri/Backend/API.hs

@@ -0,0 +1,308 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE DeriveAnyClass #-}
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE DuplicateRecordFields #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE PackageImports #-}
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TupleSections #-}
+{-# LANGUAGE TypeFamilies #-}
+
+{-# LANGUAGE NoGeneralizedNewtypeDeriving #-}
+
+{-# LANGUAGE NoImplicitPrelude #-}
+
+module Datarekisteri.Backend.API (coreApp, runApp, resolver) where
+
+import Relude hiding (Undefined, get)
+
+import "cryptonite" Crypto.Random (getRandomBytes, MonadRandom)
+import qualified "base64" Data.ByteString.Base64 as B64
+
+import Control.Monad.Except (MonadError, throwError, catchError)
+import Data.Morpheus.Server (deriveApp, runApp)
+import Data.Morpheus.Server.Types (defaultRootResolver, RootResolver(..), Undefined)
+import Data.Morpheus.Types (Arg(..), GQLType, GQLError, App)
+
+import qualified Data.Text as T
+
+import Datarekisteri.Backend.Email
+import Datarekisteri.Backend.DB
+import Datarekisteri.Backend.Types
+import Datarekisteri.Backend.Utils
+import Datarekisteri.Core.Types
+
+-- General functions, maybe migrate to Utils or API.Utils
+
+targetUser :: (MonadError GQLError m, MonadRequest m) => Maybe UserID -> m UserID
+targetUser = maybe (fromMaybeFail "No target user specified!" =<< currentUser) pure
+
+fromMaybeFail :: MonadError GQLError m => GQLError -> Maybe a -> m a
+fromMaybeFail txt = maybe (throwError txt) pure
+
+voidU :: Monad m => m a -> m Unit
+voidU m = m >> pure Unit
+
+liftDBEither :: MonadError GQLError m => DBEither a -> m a
+liftDBEither = either (throwError . fromString) pure
+
+applicationArgsToData :: (MonadTime m, MonadRandom m, MonadPermissions m, MonadError GQLError m) =>
+    ApplicationArgs -> m ApplicationData
+applicationArgsToData ApplicationArgs {..} = do
+    registered <- currentTime
+    verificationSecret <- genVerificationSecret
+    passwordHash <- hashPassword password
+    permissions <- defaultPermissions
+    when (T.null name) $ throwError "Name must not be empty"
+    when (T.null password) $ throwError "Password must not be empty"
+    when (T.null homeplace) $ throwError "Homeplace must not be empty"
+    pure ApplicationData {..}
+
+newUser :: (MonadEmail m, MonadDB m, MonadRandom m, MonadTime m, MonadError GQLError m, MonadPermissions m) =>
+    ApplicationArgs -> m (User m)
+newUser args = do
+    applicationData <- applicationArgsToData args
+    user <- dbAddUser applicationData >>= liftDBEither
+    sendVerificationSecret user >>= flip unless (throwError "Sending email verification failed!")
+    return $ dbUserToUser user
+
+genVerificationSecret :: MonadRandom m => m Text
+genVerificationSecret = T.intercalate "-" . T.chunksOf 4 . base32 <$> getRandomBytes 10
+
+sendVerificationSecret :: (MonadEmail m, MonadDB m, MonadError GQLError m) => DBUser m -> m Bool
+sendVerificationSecret DBUser {..} = do
+    secret <- dbUserId >>= dbGetEmailVerificationSecret >>= liftDBEither
+    pendingEmail <- dbUserPendingEmail
+    case (secret, pendingEmail) of
+      (Just secret', Just pendingEmail') ->
+          sendVerificationEmail secret' pendingEmail' >> pure True
+      _ -> pure False
+
+updateArgsToData :: (MonadTime m, MonadRandom m, MonadError GQLError m, MonadDB m) =>
+    UpdateArgs -> UserID -> m UpdateData
+updateArgsToData UpdateArgs {..} user = do
+    when (maybe False T.null name) $ throwError "Name must not be empty"
+    when (maybe False T.null password) $ throwError "Password must not be empty"
+    when (maybe False T.null homeplace) $ throwError "Homeplace must not be empty"
+    isMember <- dbGetUser user >>= liftDBEither >>= fmap isJust . dbUserAccepted
+    when (isMember && isJust application) $ throwError "Members can't update their applications"
+    passwordHash <- sequence $ hashPassword <$> password
+    updateTime <- currentTime
+    verificationSecret <- genVerificationSecret
+    pure UpdateData {..}
+
+updateUser :: (MonadRandom m, MonadDB m, MonadEmail m,
+    MonadError GQLError m, MonadTime m, MonadPermissions m) => UserID -> UpdateArgs -> m (User m)
+updateUser user args = do
+    updateData@(UpdateData {..}) <- updateArgsToData args user
+    updatedUser <- dbUpdateUser updateData >>= liftDBEither
+    when (isJust email) $ void $ sendVerificationSecret updatedUser
+    pure $ dbUserToUser updatedUser
+
+newTokenArgsToData :: (MonadRandom m, MonadTime m, MonadPermissions m) =>
+    NewTokenArgs -> UserID -> m NewTokenData
+newTokenArgsToData NewTokenArgs {..} user = do
+    tokenData <- B64.encodeBase64 <$> getRandomBytes 128
+    issued <- currentTime
+    permissions <- maybe currentPermissions pure =<< maybe (pure Nothing) toPermissions permissions
+    let expires = Nothing
+    pure NewTokenData {..}
+
+makeNewToken :: (MonadError GQLError m, MonadDB m, MonadTime m, MonadRandom m, MonadPermissions m) =>
+    NewTokenArgs -> UserID -> m (Token m)
+makeNewToken args user = do
+    tokenData <- newTokenArgsToData args user
+    fmap dbTokenToToken $ dbAddToken tokenData >>= liftDBEither
+
+newKeyArgsToData :: (MonadTime m, MonadError GQLError m) => NewKeyArgs -> UserID -> m NewKeyData
+newKeyArgsToData NewKeyArgs {..} user = do
+    uploaded <- currentTime
+    keyData <- maybe (throwError "Invalid base64") pure $ base64Decode keyData
+    pure NewKeyData {..}
+
+makeNewKey :: (MonadRequest m, MonadDB m, MonadTime m, MonadError GQLError m) =>
+    NewKeyArgs -> UserID -> m (PGPKey m)
+makeNewKey args user = do
+    newKeyData <- newKeyArgsToData args user
+    fmap dbPGPKeyToPGPKey $ dbAddKey newKeyData >>= liftDBEither
+
+acceptApplication :: (MonadDB m, MonadTime m, MonadError GQLError m, MonadEmail m) => UserID -> m Unit
+acceptApplication user = voidU $ do
+    maybeEmail <- dbGetUserEmail user >>= liftDBEither
+    case maybeEmail of
+      Nothing -> throwError $ "No valid application for " <> show user <> "!"
+      Just email -> do
+          time <- currentTime
+          dbAcceptApplication user time >>= liftDBEither
+          sendApplicationAcceptedEmail email
+
+rejectApplication :: (MonadDB m, MonadTime m, MonadError GQLError m, MonadEmail m) => UserID -> m Unit
+rejectApplication user = voidU $ do
+    maybeEmail <- dbGetUserEmail user >>= liftDBEither
+    case maybeEmail of
+      Nothing -> throwError $ "No valid application for " <> show user <> "!"
+      Just email -> do
+          dbRejectApplication user
+          sendApplicationRejectedEmail email
+
+resolveQuery :: (MonadRequest m, MonadDB m, MonadError GQLError m, MonadPermissions m) => Query m
+resolveQuery = Query
+    { users = requirePermission Members ReadOnly >> map dbUserToUser <$> dbGetUsers
+    , user = \(Arg id) -> targetUser id >>= \user -> requirePermission (Profile user) ReadOnly >>
+        (Just . dbUserToUser <$> (dbGetUser user >>= liftDBEither)) `catchError` const (pure Nothing)
+    , applications = requirePermission Applications ReadOnly >> map dbUserToUser <$> dbGetApplications
+    , permissions = currentPermissions
+    }
+
+resolveMutation :: (MonadRequest m, MonadEmail m, MonadRandom m, MonadTime m,
+    MonadDB m, MonadError GQLError m, MonadPermissions m) => Mutation m
+resolveMutation = Mutation
+    { apply = newUser
+    , verifyEmail = \(Arg secret) -> either (const False) (const True) <$> dbVerifyEmail secret
+    , resendVerificationEmail = \(Arg id) -> targetUser id >>= dbGetUserPendingEmail >>= liftDBEither >>=
+        maybe (pure Unit) (dbGetUserByEmail >=> liftDBEither >=> voidU . sendVerificationSecret)
+    , update = \updateArgs (Arg id) -> targetUser id >>= \user ->
+        requirePermission (Profile user) ReadWrite >> updateUser user updateArgs
+    , newToken = \args -> currentUser >>= fromMaybeFail "" >>= \user ->
+        requirePermission (Profile user) ReadWrite >> makeNewToken args user
+    , newKey = \args -> currentUser >>= fromMaybeFail "" >>= \user ->
+        requirePermission (Profile user) ReadWrite >> makeNewKey args user
+    , accept = \(Arg id) -> requirePermission Applications ReadWrite >> acceptApplication id
+    , reject = \(Arg id) -> requirePermission Applications ReadWrite >> rejectApplication id
+    }
+
+-- ScopedTypeVariables requires explicit forall m.
+coreApp :: forall m. (Typeable m, MonadRequest m, MonadEmail m, MonadRandom m,
+    MonadTime m, MonadDB m, MonadPermissions m) => App () m
+coreApp = deriveApp resolver
+
+resolver :: forall m. (Typeable m, MonadRequest m, MonadEmail m, MonadRandom m,
+    MonadTime m, MonadDB m, MonadPermissions m) => RootResolver m () Query Mutation Undefined
+resolver = defaultRootResolver { queryResolver = resolveQuery, mutationResolver = resolveMutation }
+
+data ApplicationArgs = ApplicationArgs
+    { email :: Email
+    , phoneNumber :: PhoneNumber
+    , password :: Text
+    , name :: Text
+    , nickname :: Maybe Text
+    , birthdate :: Date
+    , homeplace :: Text
+    , application :: Text
+    } deriving (Generic, GQLType, Eq, Show)
+
+data UpdateArgs = UpdateArgs
+    { email :: Maybe Email
+    , phoneNumber :: Maybe PhoneNumber
+    , password :: Maybe Text
+    , name :: Maybe Text
+    , nickname :: Maybe Text
+    , homeplace :: Maybe Text
+    , application :: Maybe Text
+    } deriving (Generic, GQLType, Eq, Show)
+
+data NewKeyArgs = NewKeyArgs { comment :: Maybe Text, keyData :: Base64, expires :: Maybe Time }
+    deriving (Generic, GQLType, Eq, Show)
+
+data NewTokenArgs = NewTokenArgs
+    { comment :: Maybe Text, name :: Maybe Text, permissions :: Maybe Text }
+    deriving (Generic, GQLType)
+
+data User m = User
+    { id :: m UserID
+    , email :: m (Maybe Email)
+    , pendingEmail :: m (Maybe Email)
+    , name :: m Text
+    , nickname :: m Text
+    , phoneNumber :: m PhoneNumber
+    , birthdate :: m Date
+    , homeplace :: m Text
+    , registered :: m Time
+    , accepted :: m (Maybe Time)
+    , permissions :: m Text
+    , isMember :: m Bool
+    , application :: m Text
+    , tokens :: m [Token m]
+    , keys :: m [PGPKey m]
+    , primaryKey :: m (Maybe (PGPKey m))
+    } deriving (Generic, GQLType)
+
+data PGPKey m = PGPKey
+    { id :: m KeyID
+    , pgpKeyData :: m Base64
+    , expires :: m (Maybe Time)
+    , uploaded :: m Time
+    , comment :: m Text
+    } deriving (Generic, GQLType)
+
+data Token m = Token
+    { id :: m TokenID
+    , name :: m (Maybe Text)
+    , tokenData :: m Text
+    , comment :: m Text
+    , issued :: m Time
+    , expires :: m (Maybe Time)
+    , permissions :: m Text
+    } deriving (Generic, GQLType)
+
+data Query m = Query
+    { users :: m [User m]
+    , user :: Arg "id" (Maybe UserID) -> m (Maybe (User m))
+    , applications :: m [User m]
+    , permissions :: m Text
+    } deriving (Generic, GQLType)
+
+data Mutation m = Mutation
+    { apply :: ApplicationArgs -> m (User m)
+    , verifyEmail :: Arg "secret" Text -> m Bool
+    , resendVerificationEmail :: Arg "user" (Maybe UserID) -> m Unit
+    , update :: UpdateArgs -> Arg "user" (Maybe UserID) -> m (User m)
+    , newToken :: NewTokenArgs -> m (Token m)
+    , newKey :: NewKeyArgs -> m (PGPKey m)
+    , accept :: Arg "user" UserID -> m Unit
+    , reject :: Arg "user" UserID -> m Unit
+    } deriving (Generic, GQLType)
+
+dbUserToUser :: (MonadPermissions m, MonadError GQLError m) => DBUser m -> User m
+dbUserToUser DBUser {..} = User
+    { id = dbUserId
+    , email = dbUserEmail
+    , pendingEmail = dbUserPendingEmail
+    , name = dbUserName
+    , nickname = dbUserNickname
+    , phoneNumber = dbUserPhoneNumber
+    , birthdate = dbUserBirthdate
+    , homeplace = dbUserHomeplace
+    , registered = dbUserRegistered
+    , accepted = dbUserAccepted
+    , permissions = dbUserPermissions
+    , isMember = isJust <$> dbUserAccepted
+    , application = dbUserApplication
+    , tokens = dbUserId >>= flip requirePermission ReadOnly . Tokens >> map dbTokenToToken <$> dbUserTokens
+    , keys = map dbPGPKeyToPGPKey <$> dbUserKeys
+    , primaryKey = fmap dbPGPKeyToPGPKey <$> dbUserPrimaryKey
+    }
+
+dbPGPKeyToPGPKey :: Monad m => DBPGPKey m -> PGPKey m
+dbPGPKeyToPGPKey DBPGPKey {..} = PGPKey
+    { id = dbPGPKeyId
+    , pgpKeyData = dbPGPKeyData
+    , expires = dbPGPKeyExpires
+    , uploaded = dbPGPKeyUploaded
+    , comment = dbPGPKeyComment
+    }
+
+dbTokenToToken :: Monad m => DBToken m -> Token m
+dbTokenToToken DBToken {..} = Token
+    { id = dbTokenId
+    , name = dbTokenName
+    , tokenData = dbTokenData
+    , comment = dbTokenComment
+    , issued = dbTokenIssued
+    , expires = dbTokenExpires
+    , permissions = dbTokenPermissions
+    }

backend/src/Datarekisteri/Backend/DB.hs

@@ -0,0 +1,24 @@
+{-# LANGUAGE RecordWildCards #-}
+
+{-# LANGUAGE NoImplicitPrelude #-}
+
+module Datarekisteri.Backend.DB where
+
+import Relude
+
+import Datarekisteri.Backend.Types
+import Datarekisteri.Core.Types
+
+dbGetUserEmail :: MonadDB m => UserID -> m (DBEither (Maybe Email))
+dbGetUserEmail userID = do
+    userOrErr <- dbGetUser userID
+    case userOrErr of
+      Left err -> pure $ Left err
+      Right DBUser {..} -> Right <$> dbUserEmail
+
+dbGetUserPendingEmail :: MonadDB m => UserID -> m (DBEither (Maybe Email))
+dbGetUserPendingEmail userID = do
+    userOrErr <- dbGetUser userID
+    case userOrErr of
+      Left err -> pure $ Left err
+      Right DBUser {..} -> Right <$> dbUserPendingEmail

backend/src/Datarekisteri/Backend/Email.hs

@@ -0,0 +1,30 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module Datarekisteri.Backend.Email where
+
+import Data.Text (Text)
+import Data.Text.Lazy (fromStrict)
+import Network.Mail.Mime (Address(..), simpleMail')
+
+import Datarekisteri.Backend.Types
+import Datarekisteri.Core.Types
+
+sendDatarekisteriEmail :: MonadEmail m => Text -> Text -> Email -> m ()
+sendDatarekisteriEmail subject content to = do
+    from <- fromAddress
+    sendEmail $ simpleMail' (Address Nothing $ renderEmail to) from subject $ fromStrict content
+
+sendVerificationEmail :: MonadEmail m => Text -> Email -> m ()
+sendVerificationEmail secret = sendDatarekisteriEmail "Sähköpostin vahvistuskoodi" $
+        "Vahvista sähköpostisi syöttämällä alla oleva koodi rekisteriin:\n\n"
+        <> secret <> "\n\n"
+        <> "Mikäli et odottanut tätä viestiä, voit jättää sen turvallisesti huomiotta."
+
+sendApplicationAcceptedEmail :: MonadEmail m => Email -> m ()
+sendApplicationAcceptedEmail = sendDatarekisteriEmail "Jäsenhakemus hyväksytty" $
+        "Jäsenhakemuksesi Datat RY:lle on hyväksytty. Olet nyt yhdistyksen jäsen."
+
+sendApplicationRejectedEmail :: MonadEmail m => Email -> m ()
+sendApplicationRejectedEmail = sendDatarekisteriEmail "Jäsenhakemus hylätty" $
+        "Jäsenhakemuksesi Datat RY:lle on hylätty. Voit halutessasi kysyä hakemuksen"
+        <> " hylkäämisen syistä yhdistyksen hallitukselta <hallitus@datat.fi>."

backend/src/Datarekisteri/Backend/Sql.hs

@@ -0,0 +1,212 @@
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RecordWildCards #-}
+
+{-# LANGUAGE NoImplicitPrelude #-}
+
+module Datarekisteri.Backend.Sql where
+
+import Relude
+
+import Data.Aeson (Result(..), fromJSON, toJSON)
+import Data.Time (nominalDay)
+import Database.Persist (Entity(..), (=.))
+
+import Datarekisteri.Backend.Sql.Queries (SqlM, UserUpdate(..))
+
+import qualified Datarekisteri.Backend.Sql.Queries as Sql
+
+import Datarekisteri.Backend.Sql.Types
+import Datarekisteri.Backend.Types
+import Datarekisteri.Core.Types
+
+class Monad m => MonadSql m where
+    runQuery :: SqlM a -> m a
+
+dbUpdateUser :: MonadSql m => UpdateData -> m (DBEither (DBUser m))
+dbUpdateUser UpdateData {..} = do
+    let memberDataUpdates = catMaybes
+            [ SetUserName <$> name
+            , SetUserNickname . Just <$> nickname
+            , SetUserHomeplace <$> homeplace
+            , SetUserPhoneNumber <$> phoneNumber
+            , SetUserApplication <$> application
+            ]
+        userUpdates = maybeToList $ (SqlUserPasswordCrypt =.) <$> passwordHash
+    sqlUser <- runQuery $ do
+        Sql.updateUserData user userUpdates memberDataUpdates
+        case email of
+          Nothing -> pure ()
+          Just newEmail -> do
+              Sql.deleteUnverifiedEmail user
+              maybeOldEmail <- fmap (sqlEmailEmail . entityVal) <$> Sql.getUserEmail user
+              when (maybe True (/= newEmail) maybeOldEmail) $ do
+                  verificationID <- Sql.addEmailVerification verificationSecret updateTime
+                  void $ Sql.addEmail SqlEmail
+                      { sqlEmailUid = fromID user
+                      , sqlEmailEmail = newEmail
+                      , sqlEmailVid = Just verificationID
+                      }
+        fromMaybe (error "Inconsistent DB at APIM dbUpdateUser!") <$> Sql.getUser user
+    pure $ Right $ sqlUserToDBUser user sqlUser
+
+dbAddUser :: MonadSql m => ApplicationData -> m (DBEither (DBUser m))
+dbAddUser ApplicationData {..} = runQuery $ do
+    userID <- Sql.addUser SqlUser
+        { sqlUserRegistered = registered
+        , sqlUserPasswordCrypt = passwordHash
+        , sqlUserPermissions = permissions
+        , sqlUserAccepted = Nothing
+        , sqlUserMemberData = toJSON $ MemberData {..}
+        }
+    verificationID <- Sql.addEmailVerification verificationSecret (addTime (7*nominalDay) registered)
+    void $ Sql.addEmail SqlEmail
+        { sqlEmailUid = fromID userID
+        , sqlEmailEmail = email
+        , sqlEmailVid = Just verificationID
+        }
+    Right . sqlUserToDBUser userID . fromMaybe (error "") <$> Sql.getUser userID
+
+dbAcceptApplication :: MonadSql m => UserID -> Time -> m (DBEither ())
+dbAcceptApplication userID time = do
+    marked <- runQuery $ Sql.markAsAccepted userID time
+    if marked
+       then pure $ Right ()
+       else pure $ Left $ "No application with id " <> show userID <> " found!"
+
+dbRejectApplication :: MonadSql m => UserID -> m (DBEither ())
+dbRejectApplication userID = do
+    deleted <- runQuery $ Sql.deleteApplication userID
+    if deleted
+       then pure $ Right ()
+       else pure $ Left $ "No application with id " <> show userID <> " found!"
+
+dbVerifyEmail :: MonadSql m => Text -> m (DBEither ())
+dbVerifyEmail secret = do
+    verified <- runQuery $ Sql.verifyEmailSecret secret
+    if verified
+       then pure $ Right ()
+       else pure $ Left $ "Invalid verification secret"
+
+dbAddToken :: MonadSql m => NewTokenData -> m (DBEither (DBToken m))
+dbAddToken NewTokenData {..} = do
+    (sqlTokenID, sqlToken) <- runQuery $ do
+        tokenID <- Sql.addToken SqlToken
+            { sqlTokenUid = fromID user
+            , sqlTokenName = name
+            , sqlTokenData = tokenData
+            , sqlTokenComment = fromMaybe "" comment
+            , sqlTokenIssued = issued
+            , sqlTokenExpires = expires
+            , sqlTokenPermissions = permissions
+            }
+        token <- fromMaybe (error "Inconsistent DB at APIM dbAddToken!") <$> Sql.getToken tokenID
+        pure (tokenID, token)
+    pure $ Right $ sqlTokenToDBToken sqlTokenID sqlToken
+
+dbAddKey :: MonadSql m => NewKeyData -> m (DBEither (DBPGPKey m))
+dbAddKey NewKeyData {..} = do
+    (keyID, sqlKey) <- runQuery $ do
+        keyID <- Sql.addKey SqlKey
+            { sqlKeyUid = fromID user
+            , sqlKeyData = keyData
+            , sqlKeyExpires = expires
+            , sqlKeyUploaded = uploaded
+            , sqlKeyComment = fromMaybe "" comment
+            , sqlKeyIsPrimaryEncryptionKey = False
+            }
+        sqlKey <- fromMaybe (error "Inconsistent DB at APIM dbAddKey") <$> Sql.getKey keyID
+        pure (keyID, sqlKey)
+    pure $ Right $ sqlKeyToDBKey keyID sqlKey
+
+dbGetUser :: MonadSql m => UserID -> m (DBEither (DBUser m))
+dbGetUser userID = do
+    maybeUser <- runQuery $ Sql.getUser userID
+    pure $ case maybeUser of
+      Nothing -> Left $ "Invalid user ID"
+      Just sqlUser -> Right $ sqlUserToDBUser userID sqlUser
+
+dbGetUserByEmail :: MonadSql m => Email -> m (DBEither (DBUser m))
+dbGetUserByEmail email = do
+    maybeUser <- runQuery $ Sql.getUserByEmail email
+    pure $ case maybeUser of
+      Nothing -> Left $ "No user with such email"
+      Just userEntity -> Right $ entityToDBUser userEntity
+
+dbGetUsers :: MonadSql m => m [DBUser m]
+dbGetUsers = map entityToDBUser <$> runQuery Sql.getAllUsers
+
+dbGetUserTokens :: MonadSql m => UserID -> m (DBEither [DBToken m])
+dbGetUserTokens userID = Right . map entityToDBToken <$> runQuery (Sql.getUserTokens userID)
+
+dbGetUserKeys :: MonadSql m => UserID -> m (DBEither [DBPGPKey m])
+dbGetUserKeys userID = Right . map entityToDBKey <$> runQuery (Sql.getKeys userID)
+
+dbGetUserPrimaryKey :: MonadSql m => UserID -> m (DBEither (Maybe (DBPGPKey m)))
+dbGetUserPrimaryKey userID = Right . fmap entityToDBKey <$> runQuery (Sql.getPrimaryKey userID)
+
+dbGetApplications :: MonadSql m => m [DBUser m]
+dbGetApplications = map entityToDBUser <$> runQuery Sql.getApplicants
+
+dbGetEmailVerificationSecret :: MonadSql m => UserID -> m (DBEither (Maybe Text))
+dbGetEmailVerificationSecret userID = fmap Right $ runQuery $ Sql.getEmailVerificationSecret userID
+
+dbGetTokenBySecret :: MonadSql m => Text -> m (DBEither (DBToken m))
+dbGetTokenBySecret secret = maybe (Left "Invalid secret") Right . fmap entityToDBToken <$>
+    runQuery (Sql.getTokenBySecret secret)
+
+entityToDBUser :: MonadSql m => Entity SqlUser -> DBUser m
+entityToDBUser (Entity userKey sqlUser) = sqlUserToDBUser (toID userKey) sqlUser
+
+sqlUserToDBUser :: MonadSql m => UserID -> SqlUser -> DBUser m
+sqlUserToDBUser userID SqlUser {..} =
+    let Success MemberData {..} = fromJSON sqlUserMemberData
+     in DBUser
+         { dbUserId = pure userID
+         , dbUserEmail = fmap (fmap $ sqlEmailEmail . entityVal) $ runQuery $ Sql.getUserEmail userID
+         , dbUserPendingEmail = fmap (fmap $ sqlEmailEmail . entityVal) $ runQuery $
+             Sql.getUserPendingEmail userID
+         , dbUserName = pure name
+         , dbUserNickname = pure $ fromMaybe (fromMaybe (error "Invalid name in the database") $
+             viaNonEmpty head $ words name) nickname
+         , dbUserBirthdate = pure birthdate
+         , dbUserHomeplace = pure homeplace
+         , dbUserApplication = pure application
+         , dbUserPhoneNumber = pure phoneNumber
+         , dbUserRegistered = pure sqlUserRegistered
+         , dbUserAccepted = pure sqlUserAccepted
+         , dbUserPermissions = pure sqlUserPermissions
+         , dbUserPasswordHash = pure sqlUserPasswordCrypt
+         , dbUserTokens = fmap (map entityToDBToken) $ runQuery $ Sql.getUserTokens userID
+         , dbUserKeys = fmap (map entityToDBKey) $ runQuery $ Sql.getKeys userID
+         , dbUserPrimaryKey = fmap (fmap entityToDBKey) $ runQuery $ Sql.getPrimaryKey userID
+         }
+
+entityToDBToken :: MonadSql m => Entity SqlToken -> DBToken m
+entityToDBToken (Entity tokenKey sqlToken) = sqlTokenToDBToken (toID tokenKey) sqlToken
+
+sqlTokenToDBToken :: MonadSql m => TokenID -> SqlToken -> DBToken m
+sqlTokenToDBToken tokenID SqlToken {..} = DBToken
+    { dbTokenId = pure tokenID
+    , dbTokenUser =
+        let userID = toID sqlTokenUid
+         in fmap (sqlUserToDBUser userID . fromMaybe (error "Inconsistent DB at sqlTokenToDBToken!")) $
+             runQuery $ Sql.getUser userID
+    , dbTokenName = pure sqlTokenName
+    , dbTokenData = pure sqlTokenData
+    , dbTokenComment = pure sqlTokenComment
+    , dbTokenIssued = pure sqlTokenIssued
+    , dbTokenExpires = pure sqlTokenExpires
+    , dbTokenPermissions = pure sqlTokenPermissions
+    }
+
+entityToDBKey :: MonadSql m => Entity SqlKey -> DBPGPKey m
+entityToDBKey (Entity keyKey sqlKey) = sqlKeyToDBKey (toID keyKey) sqlKey
+
+sqlKeyToDBKey :: MonadSql m => KeyID -> SqlKey -> DBPGPKey m
+sqlKeyToDBKey keyID SqlKey {..} = DBPGPKey
+    { dbPGPKeyId = pure keyID
+    , dbPGPKeyData = pure $ base64Encode sqlKeyData
+    , dbPGPKeyExpires = pure sqlKeyExpires
+    , dbPGPKeyUploaded = pure sqlKeyUploaded
+    , dbPGPKeyComment = pure sqlKeyComment
+    }

backend/src/Datarekisteri/Backend/Sql/Queries.hs

@@ -0,0 +1,239 @@
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE TypeFamilies #-}
+
+module Datarekisteri.Backend.Sql.Queries where
+
+import Control.Monad.Logger (LoggingT)
+import Data.Aeson (fromJSON, toJSON, Result(..))
+import Data.Maybe (listToMaybe)
+import Data.Text (Text)
+
+import qualified Database.Persist as Persist
+
+import Database.Esqueleto.Experimental
+
+import Datarekisteri.Backend.Types (MemberData(..))
+
+import Datarekisteri.Backend.Sql.Types
+import Datarekisteri.Core.Types
+
+type SqlM a = SqlPersistT (LoggingT IO) a
+
+getUserByEmail :: Email -> SqlM (Maybe (Entity SqlUser))
+getUserByEmail email = fmap listToMaybe $ select $ do
+    (dbUser :& dbEmail) <- from $ table @SqlUser `crossJoin` table @SqlEmail
+    where_ $ dbEmail ^. SqlEmailEmail ==. val email &&. dbUser ^. SqlUserId ==. dbEmail ^. SqlEmailUid
+    -- There is only one row in SqlEmail with a given email (unique constraint) and a SqlEmail only
+    -- has one user id and there is only row in SqlUser with a given user id (primary key). Thus
+    -- there is at most one combination of rows from SqlEmail and SqlUser that satisfy this query.
+    pure dbUser
+
+addUser :: SqlUser -> SqlM UserID
+addUser = fmap toID . insert
+
+getUser :: UserID -> SqlM (Maybe SqlUser)
+getUser = get . fromID
+
+getKeys :: UserID -> SqlM [Entity SqlKey]
+getKeys user = select $ do
+    keys <- from $ table @SqlKey
+    where_ $ keys ^. SqlKeyUid ==. val (fromID user)
+    pure $ keys
+
+getKey :: KeyID -> SqlM (Maybe SqlKey)
+getKey = get . fromID
+
+getPermissions :: UserID -> SqlM (Maybe Text)
+getPermissions user = fmap (fmap sqlUserPermissions) $ get $ fromID user
+
+setPermissions :: UserID -> Text -> SqlM ()
+setPermissions user txt = updateUserData user [SqlUserPermissions Persist.=. txt] [] >> return ()
+
+getPrimaryKey :: UserID -> SqlM (Maybe (Entity SqlKey))
+getPrimaryKey user = fmap listToMaybe $ select $ do
+    keys <- from $ table @SqlKey
+    where_ $ keys ^. SqlKeyIsPrimaryEncryptionKey &&. keys ^. SqlKeyUid ==. val (fromID user)
+    pure $ keys
+
+getUserTokens :: UserID -> SqlM [Entity SqlToken]
+getUserTokens user = select $ do 
+    tokens <- from $ table @SqlToken
+    where_ $ tokens ^. SqlTokenUid ==. val (fromID user)
+    pure $ tokens
+
+addToken :: SqlToken -> SqlM TokenID
+addToken = fmap toID . insert
+
+getToken :: TokenID -> SqlM (Maybe SqlToken)
+getToken = get . fromID
+
+getTokenBySecret :: Text -> SqlM (Maybe (Entity SqlToken))
+getTokenBySecret = getBy . UniqueData
+
+addKey :: SqlKey -> SqlM KeyID
+addKey = fmap toID . insert
+
+getAllUsers :: SqlM [Entity SqlUser]
+getAllUsers = select $ do
+    users <- from $ table @SqlUser
+    where_ $ isMember users
+    pure $ users
+
+getApplicants :: SqlM [Entity SqlUser]
+getApplicants = select $ do
+    users <- from $ table @SqlUser
+    where_ $ isApplicant users
+    pure $ users
+
+isVerified :: SqlExpr (Entity SqlEmail) -> SqlExpr (Value Bool)
+isVerified email = isNothing $ email ^. SqlEmailVid
+
+hasVerifiedEmail :: SqlExpr (Value SqlUserId) -> SqlExpr (Value Bool)
+hasVerifiedEmail userId = not_ $ isNothing $ subSelect $ do
+    emails <- from $ table @SqlEmail
+    where_ $ emails ^. SqlEmailUid ==. userId &&. isVerified emails
+    pure $ val True -- This is not used anywhere, there just isn't a PersistField instance for ()
+
+isApplicant :: SqlExpr (Entity SqlUser) -> SqlExpr (Value Bool)
+isApplicant user = isNothing (user ^. SqlUserAccepted)
+    &&. hasVerifiedEmail (user ^. SqlUserId)
+
+isMember :: SqlExpr (Entity SqlUser) -> SqlExpr (Value Bool)
+isMember user = not_ $ isApplicant user
+
+verifyEmailSecret :: Text -> SqlM Bool
+verifyEmailSecret secret = do
+    pendingEmail <- selectOne $ do
+        email <- from $ table @SqlEmail
+        where_ $ (>. val (0 :: Int)) $ subSelectCount $ do
+            verification <- from $ table @SqlEmailVerification
+            where_ $ email ^. SqlEmailVid ==. just (verification ^. SqlEmailVerificationId)
+                &&. verification ^. SqlEmailVerificationSecret ==. val secret
+        pure email
+    case pendingEmail of
+      Nothing -> pure False
+      Just (Entity _ SqlEmail {..}) -> do
+          delete $ do
+              email <- from $ table @SqlEmail
+              where_ $ val sqlEmailUid ==. email ^. SqlEmailUid &&. isVerified email
+          update $ \email -> do
+              set email [SqlEmailVid =. val Nothing]
+              where_ $ (>. val (0 :: Int)) $ subSelectCount $ do
+                  verification <- from $ table @SqlEmailVerification
+                  where_ $ email ^. SqlEmailVid ==. just (verification ^. SqlEmailVerificationId)
+                      &&. verification ^. SqlEmailVerificationSecret ==. val secret
+          fmap (> 0) $ deleteCount $ do
+              verification <- from (table @SqlEmailVerification)
+              where_ $ verification ^. SqlEmailVerificationSecret ==. val secret
+
+getUserEmail' :: UserID -> Bool -> SqlM (Maybe (Entity SqlEmail))
+getUserEmail' user verified = fmap listToMaybe $ select $ do
+    email <- from $ table @SqlEmail
+    where_ $ email ^. SqlEmailUid ==. val (fromID user)
+        &&. isNothing (email ^. SqlEmailVid) ==. val verified
+    pure email
+
+getUserEmail :: UserID -> SqlM (Maybe (Entity SqlEmail))
+getUserEmail user = getUserEmail' user True
+
+getUserPendingEmail :: UserID -> SqlM (Maybe (Entity SqlEmail))
+getUserPendingEmail user = getUserEmail' user False
+
+addEmail :: SqlEmail -> SqlM (Key SqlEmail)
+addEmail = insert
+
+addEmailVerification :: Text -> Time -> SqlM (Key SqlEmailVerification)
+addEmailVerification secret expires = do
+    insert $ SqlEmailVerification
+        { sqlEmailVerificationSecret = secret
+        , sqlEmailVerificationExpires = expires
+        }
+
+getEmailVerificationSecret :: UserID -> SqlM (Maybe Text)
+getEmailVerificationSecret userID = fmap (listToMaybe . fmap unValue) $ select $ do
+    verification <- from $ table @SqlEmailVerification
+    where_ $ (>. val (0 :: Int)) $ subSelectCount $ do
+        email <- from $ table @SqlEmail
+        where_ $ email ^. SqlEmailUid ==. val (fromID userID) &&.
+            email ^. SqlEmailVid ==. just (verification ^. SqlEmailVerificationId)
+    pure $ verification ^. SqlEmailVerificationSecret
+
+deleteExpiredEmails :: Time -> SqlM ()
+deleteExpiredEmails time = delete $ do
+    verification <- from $ table @SqlEmailVerification
+    where_ $ verification ^. SqlEmailVerificationExpires <=. val time
+
+deleteUnverifiedEmail :: UserID -> SqlM ()
+deleteUnverifiedEmail user = delete $ do
+    email <- from $ table @SqlEmail
+    where_ $ email ^. SqlEmailUid ==. val (fromID user) &&. not_ (isVerified email)
+
+deleteOrphanedVerifications :: SqlM ()
+deleteOrphanedVerifications = delete $ do
+    verification <- from $ table @SqlEmailVerification
+    where_ $ (==. val (0 :: Int)) $ subSelectCount $ do
+        email <- from $ table @SqlEmail
+        where_ $ email ^. SqlEmailVid ==. just (verification ^. SqlEmailVerificationId)
+
+deleteUsersWithoutEmail :: SqlM ()
+deleteUsersWithoutEmail = delete $ do
+    user <- from $ table @SqlUser
+    where_ $ (==. val (0 :: Int)) $ subSelectCount $ do
+        email <- from $ table @SqlEmail
+        where_ $ email ^. SqlEmailUid ==. user ^. SqlUserId
+        pure $ email ^. SqlEmailId -- Not used anywhere
+
+updateEmail :: UserID -> Email -> Text -> Time -> SqlM (Key SqlEmail)
+updateEmail user email secret expires = do
+    delete $ do
+        dbEmail <- from $ table @SqlEmail
+        where_ $ dbEmail ^. SqlEmailUid ==. val (fromID user) &&. not_ (isVerified dbEmail)
+    verifiedEmail <- fmap listToMaybe $ select $ do
+        dbEmail <- from $ table @SqlEmail
+        where_ $ dbEmail ^. SqlEmailUid ==. val (fromID user)
+            &&. dbEmail ^. SqlEmailEmail ==. val email
+        pure dbEmail
+    case verifiedEmail of
+      Just (Entity key _) -> pure key
+      Nothing -> do
+          verificationId <- insert SqlEmailVerification
+              { sqlEmailVerificationSecret = secret
+              , sqlEmailVerificationExpires = expires
+              }
+          insert SqlEmail
+              { sqlEmailUid = fromID user
+              , sqlEmailEmail = email
+              , sqlEmailVid = Just verificationId
+              }
+
+markAsAccepted :: UserID -> Time -> SqlM Bool
+markAsAccepted userID time = fmap (> 0) $ updateCount $ \user -> do
+    set user [SqlUserAccepted =. just (val time)]
+    where_ $ user ^. SqlUserId ==. val (fromID userID) &&. isApplicant user
+
+deleteApplication :: UserID -> SqlM Bool
+deleteApplication userID = fmap (> 0) $ deleteCount $ do
+    user <- from $ table @SqlUser
+    where_ $ user ^. SqlUserId ==. val (fromID userID) &&. isApplicant user
+
+updateUserData :: UserID -> [Persist.Update SqlUser] -> [UserUpdate] -> SqlM ()
+updateUserData user updates memberDataUpdates = do
+    let key = fromID user
+    Just userData <- get key
+    let Success memberData = fromJSON $ sqlUserMemberData userData :: Result MemberData
+        userUpdates = [SqlUserMemberData Persist.=. (toJSON $ foldr updateData memberData memberDataUpdates)]
+        updateData (SetUserName x) memberData = memberData { name = x }
+        updateData (SetUserNickname x) memberData = memberData { nickname = x }
+        updateData (SetUserHomeplace x) memberData = memberData { homeplace = x }
+        updateData (SetUserPhoneNumber x) memberData = memberData { phoneNumber = x }
+        updateData (SetUserApplication x) memberData = memberData { application = x }
+    Persist.update key (userUpdates <> updates)
+
+data UserUpdate = SetUserName Text
+                | SetUserNickname (Maybe Text)
+                | SetUserHomeplace Text
+                | SetUserPhoneNumber PhoneNumber
+                | SetUserApplication Text

backend/src/Datarekisteri/Backend/Sql/Types.hs

@@ -0,0 +1,98 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE DerivingStrategies #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE QuasiQuotes #-}
+{-# LANGUAGE StandaloneDeriving #-}
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE UndecidableInstances #-}
+
+module Datarekisteri.Backend.Sql.Types where
+
+import Data.ByteString (ByteString)
+import Data.Text (Text)
+import Database.Persist (Entity, Key, entityKey, PersistEntity)
+import Database.Persist.Postgresql.JSON (Value)
+import Database.Persist.Sql (fromSqlKey, toSqlKey)
+import Database.Persist.TH (persistUpperCase, mkPersist, sqlSettings)
+
+import Datarekisteri.Core.Types
+import Datarekisteri.Backend.Types
+
+mkPersist sqlSettings [persistUpperCase|
+SqlUser sql=users
+  registered Time
+  passwordCrypt PasswordHash
+  permissions Text
+  accepted (Maybe Time)
+  memberData Value sqltype=jsonb
+
+  deriving (Show)
+
+SqlEmail sql=emails
+  uid SqlUserId
+  email Email sqltype=varchar(320)
+  vid (Maybe SqlEmailVerificationId) sql=verification
+
+  UniqueUserVerified uid vid
+  -- This enables using persistent functions to get unique verified emails. The real
+  -- constraint is stricter and doesn't allow having more than one null and one non-null
+  -- verification but it's too complicated for persistent to understand.
+
+  UniqueEmail email
+  UniqueVerification vid
+
+SqlEmailVerification sql=emailVerifications
+  secret Text sqltype=varchar(255)
+  expires Time
+
+  UniqueVerificationSecret secret
+
+SqlKey sql=keys
+  uid SqlUserId
+  data ByteString
+  expires (Maybe Time)
+  uploaded Time
+  comment Text
+  isPrimaryEncryptionKey Bool
+
+SqlToken sql=tokens
+  uid SqlUserId
+  name (Maybe Text)
+  data Text
+  comment Text
+  issued Time
+  expires (Maybe Time)
+  permissions Text
+
+  UniqueNameUid name uid
+  UniqueData data
+|]
+
+entityToID :: EntityID a => Entity (DB a) -> a
+entityToID = toID . entityKey
+
+class PersistEntity (DB a) =>  EntityID a where
+    type DB a
+    toID :: Key (DB a) -> a
+    fromID :: a -> Key (DB a)
+
+instance EntityID UserID where
+    type DB UserID = SqlUser
+    toID = UserID . fromIntegral . fromSqlKey
+    fromID (UserID x) = toSqlKey $ fromIntegral x
+
+instance EntityID TokenID where
+    type DB TokenID = SqlToken
+    toID = TokenID . fromIntegral . fromSqlKey
+    fromID (TokenID x) = toSqlKey $ fromIntegral x
+
+instance EntityID KeyID where
+    type DB KeyID = SqlKey
+    toID = KeyID . fromIntegral . fromSqlKey
+    fromID (KeyID x) = toSqlKey $ fromIntegral x

backend/src/Datarekisteri/Backend/Types.hs

@@ -0,0 +1,261 @@
+{-# LANGUAGE DeriveAnyClass #-}
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE DerivingStrategies #-}
+{-# LANGUAGE DuplicateRecordFields #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE PackageImports #-}
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE UndecidableInstances #-}
+
+{-# LANGUAGE NoImplicitPrelude #-}
+
+module Datarekisteri.Backend.Types where
+
+import Relude
+
+import "cryptonite" Crypto.Random (MonadRandom(..))
+
+import Control.Monad.Except (throwError)
+import Data.Aeson (ToJSON(..), FromJSON(..))
+import Data.ByteArray (ByteArray, ByteArrayAccess)
+import Data.Morpheus.App.Internal.Resolving (Resolver, LiftOperation)
+import Data.Morpheus.Types (MonadError, GQLError, GQLType)
+import Data.Time (getCurrentTime)
+import Database.Persist.Class (PersistField(..))
+import Database.Persist.Sql (PersistFieldSql(..))
+import Network.Mail.Mime (Mail, Address(..))
+
+import Datarekisteri.Core.Types
+
+forward :: Monad m => [a] -> m [Maybe a]
+forward = pure . map Just
+
+requirePermission :: (MonadPermissions m, MonadError GQLError m) => Scope -> Permission -> m ()
+requirePermission scope permission = unlessM (hasPermission scope permission) $
+    throwError $ "Insufficient permissions, " <> show permission <> " for "
+        <> show scope <> " required."
+
+data MemberData = MemberData
+    { name :: Text
+    , nickname :: Maybe Text
+    , birthdate :: Date
+    , homeplace :: Text
+    , application :: Text
+    , phoneNumber :: PhoneNumber
+    } deriving (Show, Eq, Generic)
+
+instance FromJSON MemberData
+instance ToJSON MemberData
+
+data ApplicationData = ApplicationData
+    { email :: Email
+    , phoneNumber :: PhoneNumber
+    , password :: Text
+    , name :: Text
+    , nickname :: Maybe Text
+    , birthdate :: Date
+    , homeplace :: Text
+    , application :: Text
+    , registered :: Time
+    , verificationSecret :: Text
+    , passwordHash :: PasswordHash
+    , permissions :: Text
+    } deriving (Generic, Eq, Show)
+
+data UpdateData = UpdateData
+    { email :: Maybe Email
+    , phoneNumber :: Maybe PhoneNumber
+    , passwordHash :: Maybe PasswordHash
+    , name :: Maybe Text
+    , nickname :: Maybe Text
+    , homeplace :: Maybe Text
+    , application :: Maybe Text
+    , user :: UserID
+    , updateTime :: Time
+    , verificationSecret :: Text
+    } deriving (Generic, Eq, Show)
+
+data NewKeyData = NewKeyData
+    { comment :: Maybe Text
+    , keyData :: ByteString
+    , expires :: Maybe Time
+    , uploaded :: Time
+    , user :: UserID
+    }
+    deriving (Generic, Eq, Show)
+
+newtype Cursor = Cursor Text
+    deriving (Generic, Eq, Show)
+    deriving anyclass GQLType
+
+data Page a m = Page { pageData :: m a, cursor :: m (Maybe Cursor) }
+    deriving (Generic, GQLType)
+
+data NewTokenData = NewTokenData
+    { comment :: Maybe Text
+    , name :: Maybe Text
+    , permissions :: Text 
+    , tokenData :: Text
+    , issued :: Time
+    , expires :: Maybe Time
+    , user :: UserID
+    }
+    deriving (Generic, Eq, Show)
+
+newtype PasswordHash = PasswordHash ByteString
+    deriving newtype (Eq, Show, Ord, Semigroup, Monoid, ByteArrayAccess,
+        ByteArray, PersistField, PersistFieldSql)
+
+data DBUser m = DBUser
+    { dbUserId :: m UserID
+    , dbUserEmail :: m (Maybe Email)
+    , dbUserPendingEmail :: m (Maybe Email)
+    , dbUserName :: m Text
+    , dbUserNickname :: m Text
+    , dbUserPhoneNumber :: m PhoneNumber
+    , dbUserBirthdate :: m Date
+    , dbUserHomeplace :: m Text
+    , dbUserRegistered :: m Time
+    , dbUserAccepted :: m (Maybe Time)
+    , dbUserPermissions :: m Text
+    , dbUserApplication :: m Text
+    , dbUserPasswordHash :: m PasswordHash
+    , dbUserTokens :: m [DBToken m]
+    , dbUserKeys :: m [DBPGPKey m]
+    , dbUserPrimaryKey :: m (Maybe (DBPGPKey m))
+    }
+
+data DBPGPKey m = DBPGPKey
+    { dbPGPKeyId :: m KeyID
+    , dbPGPKeyData :: m Base64
+    , dbPGPKeyExpires :: m (Maybe Time)
+    , dbPGPKeyUploaded :: m Time
+    , dbPGPKeyComment :: m Text
+    }
+
+data DBToken m = DBToken
+    { dbTokenId :: m TokenID
+    , dbTokenUser :: m (DBUser m)
+    , dbTokenName :: m (Maybe Text)
+    , dbTokenData :: m Text
+    , dbTokenComment :: m Text
+    , dbTokenIssued :: m Time
+    , dbTokenExpires :: m (Maybe Time)
+    , dbTokenPermissions :: m Text
+    }
+
+class Monad m => MonadTime m where
+    currentTime :: m Time
+
+instance MonadTime IO where
+    currentTime = Time <$> getCurrentTime
+
+type DBEither a = Either String a
+
+class Monad m => MonadDB m where
+    dbUpdateUser :: UpdateData -> m (DBEither (DBUser m))
+    dbAddUser :: ApplicationData -> m (DBEither (DBUser m))
+    dbAcceptApplication :: UserID -> Time -> m (DBEither ())
+    dbRejectApplication :: UserID -> m (DBEither ())
+    dbVerifyEmail :: Text -> m (DBEither ())
+    dbAddToken :: NewTokenData -> m (DBEither (DBToken m))
+    dbAddKey :: NewKeyData -> m (DBEither (DBPGPKey m))
+    dbGetUser :: UserID -> m (DBEither (DBUser m))
+    dbGetUserByEmail :: Email -> m (DBEither (DBUser m)) -- XXX should this be Maybe instead
+    dbGetUsers :: m [DBUser m]
+    dbGetApplications :: m [DBUser m]
+    dbGetTokenBySecret :: Text -> m (DBEither (DBToken m))
+    dbGetEmailVerificationSecret :: UserID -> m (DBEither (Maybe Text))
+
+class Monad m => MonadEmail m where
+    sendEmail :: Mail -> m ()
+    fromAddress :: m Address
+
+class Monad m => MonadRequest m where
+    currentUser :: m (Maybe UserID)
+
+class Monad m => MonadPermissions m where
+    hasPermission :: Scope -> Permission -> m Bool
+    currentPermissions :: m Text
+    defaultPermissions :: m Text
+    toPermissions :: Text -> m (Maybe Text)
+
+instance (MonadDB m, LiftOperation o) => MonadDB (Resolver o () m) where
+    dbUpdateUser = fmap (fmap liftUser) . lift . dbUpdateUser
+    dbAddUser = fmap (fmap liftUser) . lift . dbAddUser
+    dbAcceptApplication user = lift . dbAcceptApplication user
+    dbRejectApplication = lift . dbRejectApplication
+    dbVerifyEmail = lift . dbVerifyEmail
+    dbAddToken = fmap (fmap liftToken) . lift . dbAddToken
+    dbAddKey = fmap (fmap liftKey) . lift . dbAddKey
+    dbGetUser = fmap (fmap liftUser) . lift . dbGetUser
+    dbGetUserByEmail = fmap (fmap liftUser) . lift . dbGetUserByEmail
+    dbGetUsers = fmap (map liftUser) $ lift $ dbGetUsers
+    dbGetApplications = fmap (map liftUser) $ lift $ dbGetApplications
+    dbGetEmailVerificationSecret = lift . dbGetEmailVerificationSecret
+    dbGetTokenBySecret = fmap (fmap liftToken) . lift . dbGetTokenBySecret
+
+instance (MonadRequest m, LiftOperation o) => MonadRequest (Resolver o () m) where
+    currentUser = lift currentUser
+
+instance (MonadPermissions m, LiftOperation o) => MonadPermissions (Resolver o () m) where
+    hasPermission scope permission = lift $ hasPermission scope permission
+    defaultPermissions = lift defaultPermissions
+    currentPermissions = lift currentPermissions
+    toPermissions = lift . toPermissions
+
+instance (MonadEmail m, LiftOperation o) => MonadEmail (Resolver o () m) where
+    sendEmail = lift . sendEmail
+    fromAddress = lift fromAddress
+
+instance (MonadRandom m, LiftOperation o) => MonadRandom (Resolver o () m) where
+    getRandomBytes = lift . getRandomBytes
+
+instance (MonadTime m, LiftOperation o) => MonadTime (Resolver o () m) where
+    currentTime = lift currentTime
+
+liftUser :: (MonadTrans t, Monad m, Monad (t m)) => DBUser m -> DBUser (t m)
+liftUser DBUser {..} = DBUser
+    { dbUserId = lift dbUserId
+    , dbUserEmail = lift dbUserEmail
+    , dbUserPendingEmail = lift dbUserPendingEmail
+    , dbUserName = lift dbUserName
+    , dbUserNickname = lift dbUserNickname
+    , dbUserPhoneNumber = lift dbUserPhoneNumber
+    , dbUserBirthdate = lift dbUserBirthdate
+    , dbUserHomeplace = lift dbUserHomeplace
+    , dbUserRegistered = lift dbUserRegistered
+    , dbUserAccepted = lift dbUserAccepted
+    , dbUserPermissions = lift dbUserPermissions
+    , dbUserApplication = lift dbUserApplication
+    , dbUserPasswordHash = lift dbUserPasswordHash
+    , dbUserTokens = map liftToken <$> lift dbUserTokens
+    , dbUserKeys = map liftKey <$> lift dbUserKeys
+    , dbUserPrimaryKey = fmap liftKey <$> lift dbUserPrimaryKey
+    }
+
+liftToken :: (MonadTrans t, Monad m, Monad (t m)) => DBToken m -> DBToken (t m)
+liftToken DBToken {..} = DBToken
+    { dbTokenId = lift dbTokenId
+    , dbTokenUser = fmap liftUser $ lift dbTokenUser
+    , dbTokenName = lift dbTokenName
+    , dbTokenData = lift dbTokenData
+    , dbTokenComment = lift dbTokenComment
+    , dbTokenIssued = lift dbTokenIssued
+    , dbTokenExpires = lift dbTokenExpires
+    , dbTokenPermissions = lift dbTokenPermissions
+    }
+
+liftKey :: (MonadTrans t, Monad m, Monad (t m)) => DBPGPKey m -> DBPGPKey (t m)
+liftKey DBPGPKey {..} = DBPGPKey
+    { dbPGPKeyId = lift dbPGPKeyId
+    , dbPGPKeyData = lift dbPGPKeyData
+    , dbPGPKeyExpires = lift dbPGPKeyExpires
+    , dbPGPKeyUploaded = lift dbPGPKeyUploaded
+    , dbPGPKeyComment = lift dbPGPKeyComment
+    }

backend/src/Datarekisteri/Backend/Utils.hs

@@ -0,0 +1,23 @@
+{-# LANGUAGE PackageImports #-}
+
+module Datarekisteri.Backend.Utils where
+
+import "cryptonite" Crypto.Random (MonadRandom)
+
+import Data.ByteArray.Encoding (convertToBase, Base(..))
+import Data.ByteString (ByteString)
+import Data.Text (Text)
+import Data.Text.Encoding (decodeUtf8, encodeUtf8)
+
+import qualified Crypto.KDF.BCrypt as Crypt (hashPassword, validatePassword)
+
+import Datarekisteri.Backend.Types
+
+base32 :: ByteString -> Text
+base32 = decodeUtf8 . convertToBase Base32
+
+hashPassword :: MonadRandom m => Text -> m PasswordHash
+hashPassword = Crypt.hashPassword 12 . encodeUtf8
+
+checkPassword :: Text -> PasswordHash -> Bool
+checkPassword password = Crypt.validatePassword $ encodeUtf8 password

backend/src/Datarekisteri/CLI.hs

@@ -0,0 +1,168 @@
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE PackageImports #-}
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+
+{-# LANGUAGE NoImplicitPrelude #-}
+
+import Relude
+
+import "cryptonite" Crypto.Random (MonadRandom(..))
+
+import Control.Monad.Logger (runStderrLoggingT)
+import Data.Aeson (toJSON)
+import Database.Persist.Postgresql (withPostgresqlConn, runSqlConn)
+import System.IO.Echo (withoutInputEcho)
+
+import Options.Applicative
+
+import Datarekisteri.Backend.Sql (MonadSql, runQuery)
+
+import qualified Datarekisteri.Backend.Sql.Queries as Sql
+
+import Datarekisteri.Backend.Sql.Types
+import Datarekisteri.Backend.Types
+import Datarekisteri.Backend.Utils
+import Datarekisteri.Core.Types
+
+main :: IO ()
+main = do
+    CLIOptions {..} <- execParser $ info (cliOptions <**> helper) mempty
+    runCLIM optionsDBUrl $ case optionsSubCommand of
+      (AddUser addUserOpts) -> addUserMain addUserOpts
+      GCEmails -> gcEmailsMain
+      GCApplications -> gcApplicationsMain
+      GCAll -> gcAllMain
+      UpdateUser opts -> updateUserMain opts
+
+addUserMain :: AddUserOpts -> CLIM ()
+addUserMain AddUserOpts {..} = do
+    time <- currentTime
+    passwordHash <- putStr "Password: " >> hFlush stdout >> liftIO (withoutInputEcho getLine) >>= hashPassword
+    runQuery $ do
+        userID <- Sql.addUser $ SqlUser
+            { sqlUserRegistered = time
+            , sqlUserPasswordCrypt = passwordHash
+            , sqlUserPermissions = show addUserPermissions
+            , sqlUserAccepted = Just time
+            , sqlUserMemberData = toJSON $ MemberData
+                { nickname = addUserNickname
+                , name = addUserName
+                , birthdate = addUserBirthdate
+                , homeplace = addUserHomeplace
+                , application = addUserApplication
+                , phoneNumber = addUserPhoneNumber
+                }
+            }
+        void $ Sql.addEmail $ SqlEmail
+            { sqlEmailUid = fromID userID
+            , sqlEmailEmail = addUserEmail
+            , sqlEmailVid = Nothing
+            }
+
+gcEmailsMain :: CLIM ()
+gcEmailsMain = do
+    time <- currentTime
+    runQuery $ do
+        Sql.deleteExpiredEmails time
+        Sql.deleteOrphanedVerifications
+
+gcApplicationsMain :: CLIM ()
+gcApplicationsMain = runQuery $ Sql.deleteUsersWithoutEmail
+
+gcAllMain :: CLIM ()
+gcAllMain = do
+    gcEmailsMain
+    gcApplicationsMain
+
+updateUserMain :: UpdateUserOpts -> CLIM ()
+updateUserMain UpdateUserOpts {..} = runQuery $ do
+    case updateUserApplication of
+      Nothing -> pure ()
+      Just application -> Sql.updateUserData updateUserId [] [Sql.SetUserApplication application]
+    case updateUserPermissions of
+      Nothing -> pure ()
+      Just permissions -> Sql.setPermissions updateUserId $ show permissions
+
+cliOptions :: Parser CLIOptions
+cliOptions = CLIOptions
+    <$> strOption (short 'u' <> long "db-url" <> metavar "URL" <> value "postgres:///datarekisteri-backend")
+    <*> cliCommandParser
+
+cliCommandParser :: Parser CLISubCommand
+cliCommandParser = hsubparser
+    $ command "add-user" (info addUserCommand (progDesc "Add a user to datarekisteri"))
+    <> command "gc-expired-emails" (info (pure GCEmails) (progDesc "Delete emails that have not been verified in time."))
+    <> command "gc-applications" (info (pure GCApplications) (progDesc "Delete users without an email address"))
+    <> command "gc" (info (pure GCAll) (progDesc "Run all garbage collection jobs."))
+    <> command "update-user" (info updateUserCommand (progDesc "Update a datarekisteri user"))
+
+addUserCommand :: Parser CLISubCommand
+addUserCommand = fmap AddUser $ AddUserOpts
+    <$> optional (strOption (long "nickname" <> metavar "NAME"))
+    <*> strOption (long "name" <> metavar "NAME")
+    <*> option (maybeReader $ toDate . toText) (long "birthdate" <> metavar "DATE" <> help "The user's birthdate, YYYY-MM-DD")
+    <*> strOption (long "homeplace" <> metavar "NAME" <> help "The user's homeplace, usually a city")
+    <*> option (maybeReader $ toPhoneNumber . toText) (long "phone-number" <> metavar "PHONE" <> help "The user's phone number. Only numbers, spaces and the plus-sign are allowed")
+    <*> option (maybeReader $ toEmail . toText) (long "email" <> metavar "EMAIL" <> help "The user's email address.")
+    <*> permissionsParser
+    <*> strOption (long "application" <> metavar "TEXT" <> value "Added by the admin.")
+
+updateUserCommand :: Parser CLISubCommand
+updateUserCommand = fmap UpdateUser $ UpdateUserOpts
+    <$> (UserID <$> argument auto (metavar "USER"))
+    <*> optional (strOption (long "application" <> metavar "TEXT"))
+    <*> optional permissionsParser
+
+permissionsParser :: Parser (Map Scope Permission)
+permissionsParser = fromList <$> many permissionParser
+
+permissionParser :: Parser (Scope, Permission)
+permissionParser = (,)
+    <$> option auto (long "scope")
+    <*> option auto (long "permission")
+
+data CLIOptions = CLIOptions 
+    { optionsDBUrl :: String
+    , optionsSubCommand :: CLISubCommand
+    }
+
+data CLISubCommand = AddUser AddUserOpts
+                   | GCEmails
+                   | GCApplications
+                   | GCAll
+                   | UpdateUser UpdateUserOpts
+
+data UpdateUserOpts = UpdateUserOpts
+    { updateUserId :: UserID
+    , updateUserApplication :: Maybe Text
+    , updateUserPermissions :: Maybe (Map Scope Permission)
+    }
+
+data AddUserOpts = AddUserOpts
+        { addUserNickname :: Maybe Text
+        , addUserName :: Text
+        , addUserBirthdate :: Date
+        , addUserHomeplace :: Text
+        , addUserPhoneNumber :: PhoneNumber
+        , addUserEmail :: Email
+        , addUserPermissions :: Map Scope Permission
+        , addUserApplication :: Text
+        }
+
+newtype CLIM a = CLIM (ReaderT String IO a)
+    deriving (Functor, Applicative, Monad, MonadIO, MonadReader String)
+
+instance MonadTime CLIM where
+    currentTime = liftIO currentTime
+
+instance MonadSql CLIM where
+    runQuery query = do
+        dbUrl <- ask
+        liftIO $ runStderrLoggingT $ withPostgresqlConn (encodeUtf8 dbUrl) $ runSqlConn query
+
+instance MonadRandom CLIM where
+    getRandomBytes = liftIO . getRandomBytes
+
+runCLIM :: String -> CLIM a -> IO a
+runCLIM dbUrl (CLIM m) = runReaderT m dbUrl

backend/src/Main.hs

@@ -0,0 +1,4 @@
+import qualified Datarekisteri.Backend as Backend
+
+main :: IO ()
+main = Backend.main

channels.scm

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

core/COPYING.md

@@ -0,0 +1,660 @@
+### GNU AFFERO GENERAL PUBLIC LICENSE
+
+Version 3, 19 November 2007
+
+Copyright (C) 2007 Free Software Foundation, Inc.
+<https://fsf.org/>
+
+Everyone is permitted to copy and distribute verbatim copies of this
+license document, but changing it is not allowed.
+
+### Preamble
+
+The GNU Affero General Public License is a free, copyleft license for
+software and other kinds of works, specifically designed to ensure
+cooperation with the community in the case of network server software.
+
+The licenses for most software and other practical works are designed
+to take away your freedom to share and change the works. By contrast,
+our General Public Licenses are intended to guarantee your freedom to
+share and change all versions of a program--to make sure it remains
+free software for all its users.
+
+When we speak of free software, we are referring to freedom, not
+price. Our General Public Licenses are designed to make sure that you
+have the freedom to distribute copies of free software (and charge for
+them if you wish), that you receive source code or can get it if you
+want it, that you can change the software or use pieces of it in new
+free programs, and that you know you can do these things.
+
+Developers that use our General Public Licenses protect your rights
+with two steps: (1) assert copyright on the software, and (2) offer
+you this License which gives you legal permission to copy, distribute
+and/or modify the software.
+
+A secondary benefit of defending all users' freedom is that
+improvements made in alternate versions of the program, if they
+receive widespread use, become available for other developers to
+incorporate. Many developers of free software are heartened and
+encouraged by the resulting cooperation. However, in the case of
+software used on network servers, this result may fail to come about.
+The GNU General Public License permits making a modified version and
+letting the public access it on a server without ever releasing its
+source code to the public.
+
+The GNU Affero General Public License is designed specifically to
+ensure that, in such cases, the modified source code becomes available
+to the community. It requires the operator of a network server to
+provide the source code of the modified version running there to the
+users of that server. Therefore, public use of a modified version, on
+a publicly accessible server, gives the public access to the source
+code of the modified version.
+
+An older license, called the Affero General Public License and
+published by Affero, was designed to accomplish similar goals. This is
+a different license, not a version of the Affero GPL, but Affero has
+released a new version of the Affero GPL which permits relicensing
+under this license.
+
+The precise terms and conditions for copying, distribution and
+modification follow.
+
+### TERMS AND CONDITIONS
+
+#### 0. Definitions.
+
+"This License" refers to version 3 of the GNU Affero General Public
+License.
+
+"Copyright" also means copyright-like laws that apply to other kinds
+of works, such as semiconductor masks.
+
+"The Program" refers to any copyrightable work licensed under this
+License. Each licensee is addressed as "you". "Licensees" and
+"recipients" may be individuals or organizations.
+
+To "modify" a work means to copy from or adapt all or part of the work
+in a fashion requiring copyright permission, other than the making of
+an exact copy. The resulting work is called a "modified version" of
+the earlier work or a work "based on" the earlier work.
+
+A "covered work" means either the unmodified Program or a work based
+on the Program.
+
+To "propagate" a work means to do anything with it that, without
+permission, would make you directly or secondarily liable for
+infringement under applicable copyright law, except executing it on a
+computer or modifying a private copy. Propagation includes copying,
+distribution (with or without modification), making available to the
+public, and in some countries other activities as well.
+
+To "convey" a work means any kind of propagation that enables other
+parties to make or receive copies. Mere interaction with a user
+through a computer network, with no transfer of a copy, is not
+conveying.
+
+An interactive user interface displays "Appropriate Legal Notices" to
+the extent that it includes a convenient and prominently visible
+feature that (1) displays an appropriate copyright notice, and (2)
+tells the user that there is no warranty for the work (except to the
+extent that warranties are provided), that licensees may convey the
+work under this License, and how to view a copy of this License. If
+the interface presents a list of user commands or options, such as a
+menu, a prominent item in the list meets this criterion.
+
+#### 1. Source Code.
+
+The "source code" for a work means the preferred form of the work for
+making modifications to it. "Object code" means any non-source form of
+a work.
+
+A "Standard Interface" means an interface that either is an official
+standard defined by a recognized standards body, or, in the case of
+interfaces specified for a particular programming language, one that
+is widely used among developers working in that language.
+
+The "System Libraries" of an executable work include anything, other
+than the work as a whole, that (a) is included in the normal form of
+packaging a Major Component, but which is not part of that Major
+Component, and (b) serves only to enable use of the work with that
+Major Component, or to implement a Standard Interface for which an
+implementation is available to the public in source code form. A
+"Major Component", in this context, means a major essential component
+(kernel, window system, and so on) of the specific operating system
+(if any) on which the executable work runs, or a compiler used to
+produce the work, or an object code interpreter used to run it.
+
+The "Corresponding Source" for a work in object code form means all
+the source code needed to generate, install, and (for an executable
+work) run the object code and to modify the work, including scripts to
+control those activities. However, it does not include the work's
+System Libraries, or general-purpose tools or generally available free
+programs which are used unmodified in performing those activities but
+which are not part of the work. For example, Corresponding Source
+includes interface definition files associated with source files for
+the work, and the source code for shared libraries and dynamically
+linked subprograms that the work is specifically designed to require,
+such as by intimate data communication or control flow between those
+subprograms and other parts of the work.
+
+The Corresponding Source need not include anything that users can
+regenerate automatically from other parts of the Corresponding Source.
+
+The Corresponding Source for a work in source code form is that same
+work.
+
+#### 2. Basic Permissions.
+
+All rights granted under this License are granted for the term of
+copyright on the Program, and are irrevocable provided the stated
+conditions are met. This License explicitly affirms your unlimited
+permission to run the unmodified Program. The output from running a
+covered work is covered by this License only if the output, given its
+content, constitutes a covered work. This License acknowledges your
+rights of fair use or other equivalent, as provided by copyright law.
+
+You may make, run and propagate covered works that you do not convey,
+without conditions so long as your license otherwise remains in force.
+You may convey covered works to others for the sole purpose of having
+them make modifications exclusively for you, or provide you with
+facilities for running those works, provided that you comply with the
+terms of this License in conveying all material for which you do not
+control copyright. Those thus making or running the covered works for
+you must do so exclusively on your behalf, under your direction and
+control, on terms that prohibit them from making any copies of your
+copyrighted material outside their relationship with you.
+
+Conveying under any other circumstances is permitted solely under the
+conditions stated below. Sublicensing is not allowed; section 10 makes
+it unnecessary.
+
+#### 3. Protecting Users' Legal Rights From Anti-Circumvention Law.
+
+No covered work shall be deemed part of an effective technological
+measure under any applicable law fulfilling obligations under article
+11 of the WIPO copyright treaty adopted on 20 December 1996, or
+similar laws prohibiting or restricting circumvention of such
+measures.
+
+When you convey a covered work, you waive any legal power to forbid
+circumvention of technological measures to the extent such
+circumvention is effected by exercising rights under this License with
+respect to the covered work, and you disclaim any intention to limit
+operation or modification of the work as a means of enforcing, against
+the work's users, your or third parties' legal rights to forbid
+circumvention of technological measures.
+
+#### 4. Conveying Verbatim Copies.
+
+You may convey verbatim copies of the Program's source code as you
+receive it, in any medium, provided that you conspicuously and
+appropriately publish on each copy an appropriate copyright notice;
+keep intact all notices stating that this License and any
+non-permissive terms added in accord with section 7 apply to the code;
+keep intact all notices of the absence of any warranty; and give all
+recipients a copy of this License along with the Program.
+
+You may charge any price or no price for each copy that you convey,
+and you may offer support or warranty protection for a fee.
+
+#### 5. Conveying Modified Source Versions.
+
+You may convey a work based on the Program, or the modifications to
+produce it from the Program, in the form of source code under the
+terms of section 4, provided that you also meet all of these
+conditions:
+
+-   a) The work must carry prominent notices stating that you modified
+    it, and giving a relevant date.
+-   b) The work must carry prominent notices stating that it is
+    released under this License and any conditions added under
+    section 7. This requirement modifies the requirement in section 4
+    to "keep intact all notices".
+-   c) You must license the entire work, as a whole, under this
+    License to anyone who comes into possession of a copy. This
+    License will therefore apply, along with any applicable section 7
+    additional terms, to the whole of the work, and all its parts,
+    regardless of how they are packaged. This License gives no
+    permission to license the work in any other way, but it does not
+    invalidate such permission if you have separately received it.
+-   d) If the work has interactive user interfaces, each must display
+    Appropriate Legal Notices; however, if the Program has interactive
+    interfaces that do not display Appropriate Legal Notices, your
+    work need not make them do so.
+
+A compilation of a covered work with other separate and independent
+works, which are not by their nature extensions of the covered work,
+and which are not combined with it such as to form a larger program,
+in or on a volume of a storage or distribution medium, is called an
+"aggregate" if the compilation and its resulting copyright are not
+used to limit the access or legal rights of the compilation's users
+beyond what the individual works permit. Inclusion of a covered work
+in an aggregate does not cause this License to apply to the other
+parts of the aggregate.
+
+#### 6. Conveying Non-Source Forms.
+
+You may convey a covered work in object code form under the terms of
+sections 4 and 5, provided that you also convey the machine-readable
+Corresponding Source under the terms of this License, in one of these
+ways:
+
+-   a) Convey the object code in, or embodied in, a physical product
+    (including a physical distribution medium), accompanied by the
+    Corresponding Source fixed on a durable physical medium
+    customarily used for software interchange.
+-   b) Convey the object code in, or embodied in, a physical product
+    (including a physical distribution medium), accompanied by a
+    written offer, valid for at least three years and valid for as
+    long as you offer spare parts or customer support for that product
+    model, to give anyone who possesses the object code either (1) a
+    copy of the Corresponding Source for all the software in the
+    product that is covered by this License, on a durable physical
+    medium customarily used for software interchange, for a price no
+    more than your reasonable cost of physically performing this
+    conveying of source, or (2) access to copy the Corresponding
+    Source from a network server at no charge.
+-   c) Convey individual copies of the object code with a copy of the
+    written offer to provide the Corresponding Source. This
+    alternative is allowed only occasionally and noncommercially, and
+    only if you received the object code with such an offer, in accord
+    with subsection 6b.
+-   d) Convey the object code by offering access from a designated
+    place (gratis or for a charge), and offer equivalent access to the
+    Corresponding Source in the same way through the same place at no
+    further charge. You need not require recipients to copy the
+    Corresponding Source along with the object code. If the place to
+    copy the object code is a network server, the Corresponding Source
+    may be on a different server (operated by you or a third party)
+    that supports equivalent copying facilities, provided you maintain
+    clear directions next to the object code saying where to find the
+    Corresponding Source. Regardless of what server hosts the
+    Corresponding Source, you remain obligated to ensure that it is
+    available for as long as needed to satisfy these requirements.
+-   e) Convey the object code using peer-to-peer transmission,
+    provided you inform other peers where the object code and
+    Corresponding Source of the work are being offered to the general
+    public at no charge under subsection 6d.
+
+A separable portion of the object code, whose source code is excluded
+from the Corresponding Source as a System Library, need not be
+included in conveying the object code work.
+
+A "User Product" is either (1) a "consumer product", which means any
+tangible personal property which is normally used for personal,
+family, or household purposes, or (2) anything designed or sold for
+incorporation into a dwelling. In determining whether a product is a
+consumer product, doubtful cases shall be resolved in favor of
+coverage. For a particular product received by a particular user,
+"normally used" refers to a typical or common use of that class of
+product, regardless of the status of the particular user or of the way
+in which the particular user actually uses, or expects or is expected
+to use, the product. A product is a consumer product regardless of
+whether the product has substantial commercial, industrial or
+non-consumer uses, unless such uses represent the only significant
+mode of use of the product.
+
+"Installation Information" for a User Product means any methods,
+procedures, authorization keys, or other information required to
+install and execute modified versions of a covered work in that User
+Product from a modified version of its Corresponding Source. The
+information must suffice to ensure that the continued functioning of
+the modified object code is in no case prevented or interfered with
+solely because modification has been made.
+
+If you convey an object code work under this section in, or with, or
+specifically for use in, a User Product, and the conveying occurs as
+part of a transaction in which the right of possession and use of the
+User Product is transferred to the recipient in perpetuity or for a
+fixed term (regardless of how the transaction is characterized), the
+Corresponding Source conveyed under this section must be accompanied
+by the Installation Information. But this requirement does not apply
+if neither you nor any third party retains the ability to install
+modified object code on the User Product (for example, the work has
+been installed in ROM).
+
+The requirement to provide Installation Information does not include a
+requirement to continue to provide support service, warranty, or
+updates for a work that has been modified or installed by the
+recipient, or for the User Product in which it has been modified or
+installed. Access to a network may be denied when the modification
+itself materially and adversely affects the operation of the network
+or violates the rules and protocols for communication across the
+network.
+
+Corresponding Source conveyed, and Installation Information provided,
+in accord with this section must be in a format that is publicly
+documented (and with an implementation available to the public in
+source code form), and must require no special password or key for
+unpacking, reading or copying.
+
+#### 7. Additional Terms.
+
+"Additional permissions" are terms that supplement the terms of this
+License by making exceptions from one or more of its conditions.
+Additional permissions that are applicable to the entire Program shall
+be treated as though they were included in this License, to the extent
+that they are valid under applicable law. If additional permissions
+apply only to part of the Program, that part may be used separately
+under those permissions, but the entire Program remains governed by
+this License without regard to the additional permissions.
+
+When you convey a copy of a covered work, you may at your option
+remove any additional permissions from that copy, or from any part of
+it. (Additional permissions may be written to require their own
+removal in certain cases when you modify the work.) You may place
+additional permissions on material, added by you to a covered work,
+for which you have or can give appropriate copyright permission.
+
+Notwithstanding any other provision of this License, for material you
+add to a covered work, you may (if authorized by the copyright holders
+of that material) supplement the terms of this License with terms:
+
+-   a) Disclaiming warranty or limiting liability differently from the
+    terms of sections 15 and 16 of this License; or
+-   b) Requiring preservation of specified reasonable legal notices or
+    author attributions in that material or in the Appropriate Legal
+    Notices displayed by works containing it; or
+-   c) Prohibiting misrepresentation of the origin of that material,
+    or requiring that modified versions of such material be marked in
+    reasonable ways as different from the original version; or
+-   d) Limiting the use for publicity purposes of names of licensors
+    or authors of the material; or
+-   e) Declining to grant rights under trademark law for use of some
+    trade names, trademarks, or service marks; or
+-   f) Requiring indemnification of licensors and authors of that
+    material by anyone who conveys the material (or modified versions
+    of it) with contractual assumptions of liability to the recipient,
+    for any liability that these contractual assumptions directly
+    impose on those licensors and authors.
+
+All other non-permissive additional terms are considered "further
+restrictions" within the meaning of section 10. If the Program as you
+received it, or any part of it, contains a notice stating that it is
+governed by this License along with a term that is a further
+restriction, you may remove that term. If a license document contains
+a further restriction but permits relicensing or conveying under this
+License, you may add to a covered work material governed by the terms
+of that license document, provided that the further restriction does
+not survive such relicensing or conveying.
+
+If you add terms to a covered work in accord with this section, you
+must place, in the relevant source files, a statement of the
+additional terms that apply to those files, or a notice indicating
+where to find the applicable terms.
+
+Additional terms, permissive or non-permissive, may be stated in the
+form of a separately written license, or stated as exceptions; the
+above requirements apply either way.
+
+#### 8. Termination.
+
+You may not propagate or modify a covered work except as expressly
+provided under this License. Any attempt otherwise to propagate or
+modify it is void, and will automatically terminate your rights under
+this License (including any patent licenses granted under the third
+paragraph of section 11).
+
+However, if you cease all violation of this License, then your license
+from a particular copyright holder is reinstated (a) provisionally,
+unless and until the copyright holder explicitly and finally
+terminates your license, and (b) permanently, if the copyright holder
+fails to notify you of the violation by some reasonable means prior to
+60 days after the cessation.
+
+Moreover, your license from a particular copyright holder is
+reinstated permanently if the copyright holder notifies you of the
+violation by some reasonable means, this is the first time you have
+received notice of violation of this License (for any work) from that
+copyright holder, and you cure the violation prior to 30 days after
+your receipt of the notice.
+
+Termination of your rights under this section does not terminate the
+licenses of parties who have received copies or rights from you under
+this License. If your rights have been terminated and not permanently
+reinstated, you do not qualify to receive new licenses for the same
+material under section 10.
+
+#### 9. Acceptance Not Required for Having Copies.
+
+You are not required to accept this License in order to receive or run
+a copy of the Program. Ancillary propagation of a covered work
+occurring solely as a consequence of using peer-to-peer transmission
+to receive a copy likewise does not require acceptance. However,
+nothing other than this License grants you permission to propagate or
+modify any covered work. These actions infringe copyright if you do
+not accept this License. Therefore, by modifying or propagating a
+covered work, you indicate your acceptance of this License to do so.
+
+#### 10. Automatic Licensing of Downstream Recipients.
+
+Each time you convey a covered work, the recipient automatically
+receives a license from the original licensors, to run, modify and
+propagate that work, subject to this License. You are not responsible
+for enforcing compliance by third parties with this License.
+
+An "entity transaction" is a transaction transferring control of an
+organization, or substantially all assets of one, or subdividing an
+organization, or merging organizations. If propagation of a covered
+work results from an entity transaction, each party to that
+transaction who receives a copy of the work also receives whatever
+licenses to the work the party's predecessor in interest had or could
+give under the previous paragraph, plus a right to possession of the
+Corresponding Source of the work from the predecessor in interest, if
+the predecessor has it or can get it with reasonable efforts.
+
+You may not impose any further restrictions on the exercise of the
+rights granted or affirmed under this License. For example, you may
+not impose a license fee, royalty, or other charge for exercise of
+rights granted under this License, and you may not initiate litigation
+(including a cross-claim or counterclaim in a lawsuit) alleging that
+any patent claim is infringed by making, using, selling, offering for
+sale, or importing the Program or any portion of it.
+
+#### 11. Patents.
+
+A "contributor" is a copyright holder who authorizes use under this
+License of the Program or a work on which the Program is based. The
+work thus licensed is called the contributor's "contributor version".
+
+A contributor's "essential patent claims" are all patent claims owned
+or controlled by the contributor, whether already acquired or
+hereafter acquired, that would be infringed by some manner, permitted
+by this License, of making, using, or selling its contributor version,
+but do not include claims that would be infringed only as a
+consequence of further modification of the contributor version. For
+purposes of this definition, "control" includes the right to grant
+patent sublicenses in a manner consistent with the requirements of
+this License.
+
+Each contributor grants you a non-exclusive, worldwide, royalty-free
+patent license under the contributor's essential patent claims, to
+make, use, sell, offer for sale, import and otherwise run, modify and
+propagate the contents of its contributor version.
+
+In the following three paragraphs, a "patent license" is any express
+agreement or commitment, however denominated, not to enforce a patent
+(such as an express permission to practice a patent or covenant not to
+sue for patent infringement). To "grant" such a patent license to a
+party means to make such an agreement or commitment not to enforce a
+patent against the party.
+
+If you convey a covered work, knowingly relying on a patent license,
+and the Corresponding Source of the work is not available for anyone
+to copy, free of charge and under the terms of this License, through a
+publicly available network server or other readily accessible means,
+then you must either (1) cause the Corresponding Source to be so
+available, or (2) arrange to deprive yourself of the benefit of the
+patent license for this particular work, or (3) arrange, in a manner
+consistent with the requirements of this License, to extend the patent
+license to downstream recipients. "Knowingly relying" means you have
+actual knowledge that, but for the patent license, your conveying the
+covered work in a country, or your recipient's use of the covered work
+in a country, would infringe one or more identifiable patents in that
+country that you have reason to believe are valid.
+
+If, pursuant to or in connection with a single transaction or
+arrangement, you convey, or propagate by procuring conveyance of, a
+covered work, and grant a patent license to some of the parties
+receiving the covered work authorizing them to use, propagate, modify
+or convey a specific copy of the covered work, then the patent license
+you grant is automatically extended to all recipients of the covered
+work and works based on it.
+
+A patent license is "discriminatory" if it does not include within the
+scope of its coverage, prohibits the exercise of, or is conditioned on
+the non-exercise of one or more of the rights that are specifically
+granted under this License. You may not convey a covered work if you
+are a party to an arrangement with a third party that is in the
+business of distributing software, under which you make payment to the
+third party based on the extent of your activity of conveying the
+work, and under which the third party grants, to any of the parties
+who would receive the covered work from you, a discriminatory patent
+license (a) in connection with copies of the covered work conveyed by
+you (or copies made from those copies), or (b) primarily for and in
+connection with specific products or compilations that contain the
+covered work, unless you entered into that arrangement, or that patent
+license was granted, prior to 28 March 2007.
+
+Nothing in this License shall be construed as excluding or limiting
+any implied license or other defenses to infringement that may
+otherwise be available to you under applicable patent law.
+
+#### 12. No Surrender of Others' Freedom.
+
+If conditions are imposed on you (whether by court order, agreement or
+otherwise) that contradict the conditions of this License, they do not
+excuse you from the conditions of this License. If you cannot convey a
+covered work so as to satisfy simultaneously your obligations under
+this License and any other pertinent obligations, then as a
+consequence you may not convey it at all. For example, if you agree to
+terms that obligate you to collect a royalty for further conveying
+from those to whom you convey the Program, the only way you could
+satisfy both those terms and this License would be to refrain entirely
+from conveying the Program.
+
+#### 13. Remote Network Interaction; Use with the GNU General Public License.
+
+Notwithstanding any other provision of this License, if you modify the
+Program, your modified version must prominently offer all users
+interacting with it remotely through a computer network (if your
+version supports such interaction) an opportunity to receive the
+Corresponding Source of your version by providing access to the
+Corresponding Source from a network server at no charge, through some
+standard or customary means of facilitating copying of software. This
+Corresponding Source shall include the Corresponding Source for any
+work covered by version 3 of the GNU General Public License that is
+incorporated pursuant to the following paragraph.
+
+Notwithstanding any other provision of this License, you have
+permission to link or combine any covered work with a work licensed
+under version 3 of the GNU General Public License into a single
+combined work, and to convey the resulting work. The terms of this
+License will continue to apply to the part which is the covered work,
+but the work with which it is combined will remain governed by version
+3 of the GNU General Public License.
+
+#### 14. Revised Versions of this License.
+
+The Free Software Foundation may publish revised and/or new versions
+of the GNU Affero General Public License from time to time. Such new
+versions will be similar in spirit to the present version, but may
+differ in detail to address new problems or concerns.
+
+Each version is given a distinguishing version number. If the Program
+specifies that a certain numbered version of the GNU Affero General
+Public License "or any later version" applies to it, you have the
+option of following the terms and conditions either of that numbered
+version or of any later version published by the Free Software
+Foundation. If the Program does not specify a version number of the
+GNU Affero General Public License, you may choose any version ever
+published by the Free Software Foundation.
+
+If the Program specifies that a proxy can decide which future versions
+of the GNU Affero General Public License can be used, that proxy's
+public statement of acceptance of a version permanently authorizes you
+to choose that version for the Program.
+
+Later license versions may give you additional or different
+permissions. However, no additional obligations are imposed on any
+author or copyright holder as a result of your choosing to follow a
+later version.
+
+#### 15. Disclaimer of Warranty.
+
+THERE IS NO WARRANTY FOR THE PROGRAM, TO THE EXTENT PERMITTED BY
+APPLICABLE LAW. EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT
+HOLDERS AND/OR OTHER PARTIES PROVIDE THE PROGRAM "AS IS" WITHOUT
+WARRANTY OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT
+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+A PARTICULAR PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND
+PERFORMANCE OF THE PROGRAM IS WITH YOU. SHOULD THE PROGRAM PROVE
+DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING, REPAIR OR
+CORRECTION.
+
+#### 16. Limitation of Liability.
+
+IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING
+WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MODIFIES AND/OR
+CONVEYS THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES,
+INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES
+ARISING OUT OF THE USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT
+NOT LIMITED TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR
+LOSSES SUSTAINED BY YOU OR THIRD PARTIES OR A FAILURE OF THE PROGRAM
+TO OPERATE WITH ANY OTHER PROGRAMS), EVEN IF SUCH HOLDER OR OTHER
+PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGES.
+
+#### 17. Interpretation of Sections 15 and 16.
+
+If the disclaimer of warranty and limitation of liability provided
+above cannot be given local legal effect according to their terms,
+reviewing courts shall apply local law that most closely approximates
+an absolute waiver of all civil liability in connection with the
+Program, unless a warranty or assumption of liability accompanies a
+copy of the Program in return for a fee.
+
+END OF TERMS AND CONDITIONS
+
+### How to Apply These Terms to Your New Programs
+
+If you develop a new program, and you want it to be of the greatest
+possible use to the public, the best way to achieve this is to make it
+free software which everyone can redistribute and change under these
+terms.
+
+To do so, attach the following notices to the program. It is safest to
+attach them to the start of each source file to most effectively state
+the exclusion of warranty; and each file should have at least the
+"copyright" line and a pointer to where the full notice is found.
+
+        <one line to give the program's name and a brief idea of what it does.>
+        Copyright (C) <year>  <name of author>
+
+        This program is free software: you can redistribute it and/or modify
+        it under the terms of the GNU Affero General Public License as
+        published by the Free Software Foundation, either version 3 of the
+        License, or (at your option) any later version.
+
+        This program is distributed in the hope that it will be useful,
+        but WITHOUT ANY WARRANTY; without even the implied warranty of
+        MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+        GNU Affero General Public License for more details.
+
+        You should have received a copy of the GNU Affero General Public License
+        along with this program.  If not, see <https://www.gnu.org/licenses/>.
+
+Also add information on how to contact you by electronic and paper
+mail.
+
+If your software can interact with users remotely through a computer
+network, you should also make sure that it provides a way for users to
+get its source. For example, if your program is a web application, its
+interface could display a "Source" link that leads users to an archive
+of the code. There are many ways you could offer source, and different
+solutions will be better for different programs; see section 13 for
+the specific requirements.
+
+You should also get your employer (if you work as a programmer) or
+school, if any, to sign a "copyright disclaimer" for the program, if
+necessary. For more information on this, and how to apply and follow
+the GNU AGPL, see <https://www.gnu.org/licenses/>.

core/Setup.hs

@@ -0,0 +1,4 @@
+import Distribution.Simple
+
+main :: IO ()
+main = defaultMain

core/datarekisteri-core.cabal

@@ -0,0 +1,30 @@
+cabal-version: 3.6
+name: datarekisteri-core
+version: 0.0.1
+author: Saku Laesvuori
+license: AGPL-3.0-or-later
+license-file: COPYING.md
+build-type: Simple
+stability: alpha
+
+library
+  build-depends:
+    aeson,
+    base,
+    base64,
+    cryptonite,
+    email-validate,
+    memory,
+    morpheus-graphql,
+    morpheus-graphql-app,
+    morpheus-graphql-core,
+    morpheus-graphql-server,
+    persistent,
+    relude,
+    text,
+    time,
+    containers,
+  exposed-modules:
+    Datarekisteri.Core.Types
+  hs-source-dirs: src
+  default-language: Haskell2010

core/src/Datarekisteri/Core/Types.hs

@@ -0,0 +1,227 @@
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE PackageImports #-}
+{-# LANGUAGE TypeFamilies #-}
+
+{-# LANGUAGE NoImplicitPrelude #-}
+
+module Datarekisteri.Core.Types
+    ( Base64
+    , Date(..)
+    , Email
+    , KeyID(..)
+    , Permission(..)
+    , PhoneNumber
+    , Scope(..)
+    , Time(..)
+    , TokenID(..)
+    , Unit(Unit)
+    , UserID(..)
+    , addTime
+    , base64Decode
+    , base64Encode
+    , readPermission
+    , renderDate
+    , renderEmail
+    , renderPhoneNumber
+    , renderTime
+    , toDate
+    , toEmail
+    , toPhoneNumber
+    , toTime
+    ) where
+
+import Relude
+
+import qualified "base64" Data.ByteString.Base64 as B64
+
+import Data.Aeson (ToJSON(..), FromJSON(..))
+import Data.Char (isSpace)
+import Data.Morpheus.Server.Types (SCALAR)
+import Data.Morpheus.Types (GQLType, DecodeScalar(..), KIND, EncodeScalar(..), ScalarValue(..))
+import Data.Morpheus.Types.GQLScalar (scalarToJSON, scalarFromJSON)
+import Data.Time (UTCTime, NominalDiffTime, addUTCTime, Day)
+import Data.Time.Format.ISO8601 (iso8601Show, iso8601ParseM)
+import Database.Persist.Class (PersistField(..))
+import Database.Persist.PersistValue (PersistValue(..))
+import Database.Persist.Sql (PersistFieldSql(..))
+import Text.Email.Validate (EmailAddress, toByteString, validate, emailAddress)
+
+import qualified Data.Text as T
+
+base64Encode :: ByteString -> Base64
+base64Encode = Base64 . B64.encodeBase64
+
+base64Decode :: Base64 -> Maybe ByteString
+base64Decode (Base64 x) = either (const Nothing) Just $ B64.decodeBase64 $ encodeUtf8 x
+
+toEmail :: Text -> Maybe Email
+toEmail = fmap Email . emailAddress . encodeUtf8
+
+renderEmail :: Email -> Text
+renderEmail (Email x) = decodeUtf8 $ toByteString x
+
+renderTime :: Time -> Text
+renderTime (Time x) = toText $ iso8601Show x
+
+toTime :: Text -> Maybe Time
+toTime = fmap Time . iso8601ParseM . toString
+
+toDate :: Text -> Maybe Date
+toDate = fmap Date . iso8601ParseM . toString
+
+renderDate :: Date -> Text
+renderDate (Date x) = toText $ iso8601Show x
+
+addTime :: NominalDiffTime -> Time -> Time
+addTime diff (Time time) = Time $ addUTCTime diff time
+
+data Scope = OwnProfile
+           | OwnTokens
+           | Profile UserID
+           | Tokens UserID
+           | Members
+           | Applications
+           deriving (Show, Eq, Ord, Read)
+
+data Permission = None
+                | ReadOnly
+                | ReadWrite
+                deriving (Show, Eq, Ord, Read)
+
+readPermission :: Text -> Maybe (Map Scope Permission)
+readPermission = rightToMaybe . readEither . toString 
+
+newtype PhoneNumber = PhoneNumber Text deriving (Show, Generic)
+
+renderPhoneNumber :: PhoneNumber -> Text
+renderPhoneNumber (PhoneNumber txt) = txt
+
+toPhoneNumber :: Text -> Maybe PhoneNumber
+toPhoneNumber txt = do
+    guard $ not $ T.null txt
+    guard $ T.head txt `elem` ['+','0']
+    guard $ T.all (`elem` (" 0123456789" :: [Char])) $ T.tail txt
+    pure $ PhoneNumber txt
+
+instance Eq PhoneNumber where
+    a == b = normalize a == normalize b
+        where normalize (PhoneNumber txt) = case T.uncons txt of
+                                            Just ('0', rest) -> "+358" <> T.filter (not . isSpace) rest
+                                            Just x -> T.filter (not . isSpace) (uncurry T.cons x)
+                                            Nothing -> error "PhoneNumber must not be empty"
+
+instance DecodeScalar PhoneNumber where
+    decodeScalar (String s) =
+        maybe (Left $ "Couldn't parse \"" <> s <> "\" as a PhoneNumber") Right $ toPhoneNumber s
+    decodeScalar _ = Left "Invalid type for PhoneNumber, should be string"
+
+instance EncodeScalar PhoneNumber where
+    encodeScalar = String . renderPhoneNumber
+
+instance GQLType PhoneNumber where type KIND PhoneNumber = SCALAR
+instance ToJSON PhoneNumber where toJSON = scalarToJSON
+instance FromJSON PhoneNumber where parseJSON = scalarFromJSON <=< parseJSON
+
+newtype UserID = UserID Integer deriving (Eq, Show, Generic, Ord, Read)
+
+instance DecodeScalar UserID where
+    decodeScalar (String s) = first (const $ "invalid UserID: \"" <> s <> "\"") $
+        UserID <$> readEither (toString s)
+    decodeScalar _ = Left "Invalid type for UserID, should be string"
+
+instance EncodeScalar UserID where
+    encodeScalar (UserID x) = String $ show x
+
+instance GQLType UserID where type KIND UserID = SCALAR
+instance ToJSON UserID where toJSON = scalarToJSON
+instance FromJSON UserID where parseJSON = scalarFromJSON <=< parseJSON
+
+newtype KeyID = KeyID Integer deriving (Eq, Show, Generic)
+
+instance DecodeScalar KeyID where
+    decodeScalar (String s) = first (const $ "invalid KeyID: \"" <> s <> "\"") $
+        KeyID <$> readEither (toString s)
+    decodeScalar _ = Left "Invalid type for KeyID, should be string"
+
+instance EncodeScalar KeyID where
+    encodeScalar (KeyID s) = String $ show s
+
+instance GQLType KeyID where type KIND KeyID = SCALAR
+instance ToJSON KeyID where toJSON = scalarToJSON
+instance FromJSON KeyID where parseJSON = scalarFromJSON <=< parseJSON
+
+newtype TokenID = TokenID Integer deriving (Eq, Show, Generic)
+
+instance DecodeScalar TokenID where
+    decodeScalar (String s) = first (const $ "invalid TokenID: \"" <> s <> "\"") $
+        TokenID <$> readEither (toString s)
+    decodeScalar _ = Left "Invalid type for TokenID, should be string"
+
+instance EncodeScalar TokenID where
+    encodeScalar (TokenID s) = String $ show s
+
+instance GQLType TokenID where type KIND TokenID = SCALAR
+instance ToJSON TokenID where toJSON = scalarToJSON
+instance FromJSON TokenID where parseJSON = scalarFromJSON <=< parseJSON
+
+newtype Base64 = Base64 Text
+    deriving (Eq, Show, ToJSON, FromJSON, Generic, DecodeScalar, EncodeScalar)
+
+instance GQLType Base64 where type KIND Base64 = SCALAR
+
+newtype Email = Email EmailAddress deriving (Eq, Show)
+
+instance DecodeScalar Email where
+    decodeScalar (String s) = maybe (Left $ "Couldn't parse \"" <> s <> "\" as an email address") (Right . Email) $ emailAddress $ encodeUtf8 s
+    decodeScalar _ = Left "Invalid type for Email, should be string"
+
+instance EncodeScalar Email where
+    encodeScalar = String . renderEmail
+
+instance GQLType Email where type KIND Email = SCALAR
+instance ToJSON Email where toJSON = scalarToJSON
+instance FromJSON Email where parseJSON = scalarFromJSON <=< parseJSON 
+
+instance PersistField Email where
+    toPersistValue = PersistText . renderEmail
+    fromPersistValue (PersistText email) =
+        second Email $ first toText $ validate $ encodeUtf8 email
+    fromPersistValue x = Left $ "Wrong type for Email: " <> show x
+
+newtype Time = Time UTCTime deriving (Eq, Show, PersistField, PersistFieldSql)
+
+instance DecodeScalar Time where
+    decodeScalar (String s) = maybe
+        (Left $ "Couldn't parse \"" <> s <> "\" as an ISO8601 timestamp")
+        (Right) $ toTime s
+    decodeScalar _ = Left "Invalid type for Time, should be string"
+
+instance EncodeScalar Time where
+    encodeScalar  = String . renderTime
+
+instance GQLType Time where type KIND Time = SCALAR
+instance ToJSON Time where toJSON = scalarToJSON
+instance FromJSON Time where parseJSON = scalarFromJSON <=< parseJSON
+
+newtype Date = Date Day deriving (Eq, Show, PersistField, Generic)
+
+instance DecodeScalar Date where
+    decodeScalar (String s) = maybe
+        (Left $ "Couldn't parse \"" <> s <> "\" as an ISO8601 date")
+        (Right) $ toDate s
+    decodeScalar _ = Left "Invalid type for Date, should be string"
+
+instance EncodeScalar Date where
+    encodeScalar = String . renderDate
+
+instance GQLType Date where type KIND Date = SCALAR
+instance ToJSON Date where toJSON = scalarToJSON
+instance FromJSON Date where parseJSON = scalarFromJSON <=< parseJSON
+
+data Unit = Unit | Unit2 deriving (Eq, Generic, Show) -- XXX: why not just Unit
+
+instance GQLType Unit
+instance ToJSON Unit
+instance FromJSON Unit

frontend/COPYING.md

@@ -0,0 +1,660 @@
+### GNU AFFERO GENERAL PUBLIC LICENSE
+
+Version 3, 19 November 2007
+
+Copyright (C) 2007 Free Software Foundation, Inc.
+<https://fsf.org/>
+
+Everyone is permitted to copy and distribute verbatim copies of this
+license document, but changing it is not allowed.
+
+### Preamble
+
+The GNU Affero General Public License is a free, copyleft license for
+software and other kinds of works, specifically designed to ensure
+cooperation with the community in the case of network server software.
+
+The licenses for most software and other practical works are designed
+to take away your freedom to share and change the works. By contrast,
+our General Public Licenses are intended to guarantee your freedom to
+share and change all versions of a program--to make sure it remains
+free software for all its users.
+
+When we speak of free software, we are referring to freedom, not
+price. Our General Public Licenses are designed to make sure that you
+have the freedom to distribute copies of free software (and charge for
+them if you wish), that you receive source code or can get it if you
+want it, that you can change the software or use pieces of it in new
+free programs, and that you know you can do these things.
+
+Developers that use our General Public Licenses protect your rights
+with two steps: (1) assert copyright on the software, and (2) offer
+you this License which gives you legal permission to copy, distribute
+and/or modify the software.
+
+A secondary benefit of defending all users' freedom is that
+improvements made in alternate versions of the program, if they
+receive widespread use, become available for other developers to
+incorporate. Many developers of free software are heartened and
+encouraged by the resulting cooperation. However, in the case of
+software used on network servers, this result may fail to come about.
+The GNU General Public License permits making a modified version and
+letting the public access it on a server without ever releasing its
+source code to the public.
+
+The GNU Affero General Public License is designed specifically to
+ensure that, in such cases, the modified source code becomes available
+to the community. It requires the operator of a network server to
+provide the source code of the modified version running there to the
+users of that server. Therefore, public use of a modified version, on
+a publicly accessible server, gives the public access to the source
+code of the modified version.
+
+An older license, called the Affero General Public License and
+published by Affero, was designed to accomplish similar goals. This is
+a different license, not a version of the Affero GPL, but Affero has
+released a new version of the Affero GPL which permits relicensing
+under this license.
+
+The precise terms and conditions for copying, distribution and
+modification follow.
+
+### TERMS AND CONDITIONS
+
+#### 0. Definitions.
+
+"This License" refers to version 3 of the GNU Affero General Public
+License.
+
+"Copyright" also means copyright-like laws that apply to other kinds
+of works, such as semiconductor masks.
+
+"The Program" refers to any copyrightable work licensed under this
+License. Each licensee is addressed as "you". "Licensees" and
+"recipients" may be individuals or organizations.
+
+To "modify" a work means to copy from or adapt all or part of the work
+in a fashion requiring copyright permission, other than the making of
+an exact copy. The resulting work is called a "modified version" of
+the earlier work or a work "based on" the earlier work.
+
+A "covered work" means either the unmodified Program or a work based
+on the Program.
+
+To "propagate" a work means to do anything with it that, without
+permission, would make you directly or secondarily liable for
+infringement under applicable copyright law, except executing it on a
+computer or modifying a private copy. Propagation includes copying,
+distribution (with or without modification), making available to the
+public, and in some countries other activities as well.
+
+To "convey" a work means any kind of propagation that enables other
+parties to make or receive copies. Mere interaction with a user
+through a computer network, with no transfer of a copy, is not
+conveying.
+
+An interactive user interface displays "Appropriate Legal Notices" to
+the extent that it includes a convenient and prominently visible
+feature that (1) displays an appropriate copyright notice, and (2)
+tells the user that there is no warranty for the work (except to the
+extent that warranties are provided), that licensees may convey the
+work under this License, and how to view a copy of this License. If
+the interface presents a list of user commands or options, such as a
+menu, a prominent item in the list meets this criterion.
+
+#### 1. Source Code.
+
+The "source code" for a work means the preferred form of the work for
+making modifications to it. "Object code" means any non-source form of
+a work.
+
+A "Standard Interface" means an interface that either is an official
+standard defined by a recognized standards body, or, in the case of
+interfaces specified for a particular programming language, one that
+is widely used among developers working in that language.
+
+The "System Libraries" of an executable work include anything, other
+than the work as a whole, that (a) is included in the normal form of
+packaging a Major Component, but which is not part of that Major
+Component, and (b) serves only to enable use of the work with that
+Major Component, or to implement a Standard Interface for which an
+implementation is available to the public in source code form. A
+"Major Component", in this context, means a major essential component
+(kernel, window system, and so on) of the specific operating system
+(if any) on which the executable work runs, or a compiler used to
+produce the work, or an object code interpreter used to run it.
+
+The "Corresponding Source" for a work in object code form means all
+the source code needed to generate, install, and (for an executable
+work) run the object code and to modify the work, including scripts to
+control those activities. However, it does not include the work's
+System Libraries, or general-purpose tools or generally available free
+programs which are used unmodified in performing those activities but
+which are not part of the work. For example, Corresponding Source
+includes interface definition files associated with source files for
+the work, and the source code for shared libraries and dynamically
+linked subprograms that the work is specifically designed to require,
+such as by intimate data communication or control flow between those
+subprograms and other parts of the work.
+
+The Corresponding Source need not include anything that users can
+regenerate automatically from other parts of the Corresponding Source.
+
+The Corresponding Source for a work in source code form is that same
+work.
+
+#### 2. Basic Permissions.
+
+All rights granted under this License are granted for the term of
+copyright on the Program, and are irrevocable provided the stated
+conditions are met. This License explicitly affirms your unlimited
+permission to run the unmodified Program. The output from running a
+covered work is covered by this License only if the output, given its
+content, constitutes a covered work. This License acknowledges your
+rights of fair use or other equivalent, as provided by copyright law.
+
+You may make, run and propagate covered works that you do not convey,
+without conditions so long as your license otherwise remains in force.
+You may convey covered works to others for the sole purpose of having
+them make modifications exclusively for you, or provide you with
+facilities for running those works, provided that you comply with the
+terms of this License in conveying all material for which you do not
+control copyright. Those thus making or running the covered works for
+you must do so exclusively on your behalf, under your direction and
+control, on terms that prohibit them from making any copies of your
+copyrighted material outside their relationship with you.
+
+Conveying under any other circumstances is permitted solely under the
+conditions stated below. Sublicensing is not allowed; section 10 makes
+it unnecessary.
+
+#### 3. Protecting Users' Legal Rights From Anti-Circumvention Law.
+
+No covered work shall be deemed part of an effective technological
+measure under any applicable law fulfilling obligations under article
+11 of the WIPO copyright treaty adopted on 20 December 1996, or
+similar laws prohibiting or restricting circumvention of such
+measures.
+
+When you convey a covered work, you waive any legal power to forbid
+circumvention of technological measures to the extent such
+circumvention is effected by exercising rights under this License with
+respect to the covered work, and you disclaim any intention to limit
+operation or modification of the work as a means of enforcing, against
+the work's users, your or third parties' legal rights to forbid
+circumvention of technological measures.
+
+#### 4. Conveying Verbatim Copies.
+
+You may convey verbatim copies of the Program's source code as you
+receive it, in any medium, provided that you conspicuously and
+appropriately publish on each copy an appropriate copyright notice;
+keep intact all notices stating that this License and any
+non-permissive terms added in accord with section 7 apply to the code;
+keep intact all notices of the absence of any warranty; and give all
+recipients a copy of this License along with the Program.
+
+You may charge any price or no price for each copy that you convey,
+and you may offer support or warranty protection for a fee.
+
+#### 5. Conveying Modified Source Versions.
+
+You may convey a work based on the Program, or the modifications to
+produce it from the Program, in the form of source code under the
+terms of section 4, provided that you also meet all of these
+conditions:
+
+-   a) The work must carry prominent notices stating that you modified
+    it, and giving a relevant date.
+-   b) The work must carry prominent notices stating that it is
+    released under this License and any conditions added under
+    section 7. This requirement modifies the requirement in section 4
+    to "keep intact all notices".
+-   c) You must license the entire work, as a whole, under this
+    License to anyone who comes into possession of a copy. This
+    License will therefore apply, along with any applicable section 7
+    additional terms, to the whole of the work, and all its parts,
+    regardless of how they are packaged. This License gives no
+    permission to license the work in any other way, but it does not
+    invalidate such permission if you have separately received it.
+-   d) If the work has interactive user interfaces, each must display
+    Appropriate Legal Notices; however, if the Program has interactive
+    interfaces that do not display Appropriate Legal Notices, your
+    work need not make them do so.
+
+A compilation of a covered work with other separate and independent
+works, which are not by their nature extensions of the covered work,
+and which are not combined with it such as to form a larger program,
+in or on a volume of a storage or distribution medium, is called an
+"aggregate" if the compilation and its resulting copyright are not
+used to limit the access or legal rights of the compilation's users
+beyond what the individual works permit. Inclusion of a covered work
+in an aggregate does not cause this License to apply to the other
+parts of the aggregate.
+
+#### 6. Conveying Non-Source Forms.
+
+You may convey a covered work in object code form under the terms of
+sections 4 and 5, provided that you also convey the machine-readable
+Corresponding Source under the terms of this License, in one of these
+ways:
+
+-   a) Convey the object code in, or embodied in, a physical product
+    (including a physical distribution medium), accompanied by the
+    Corresponding Source fixed on a durable physical medium
+    customarily used for software interchange.
+-   b) Convey the object code in, or embodied in, a physical product
+    (including a physical distribution medium), accompanied by a
+    written offer, valid for at least three years and valid for as
+    long as you offer spare parts or customer support for that product
+    model, to give anyone who possesses the object code either (1) a
+    copy of the Corresponding Source for all the software in the
+    product that is covered by this License, on a durable physical
+    medium customarily used for software interchange, for a price no
+    more than your reasonable cost of physically performing this
+    conveying of source, or (2) access to copy the Corresponding
+    Source from a network server at no charge.
+-   c) Convey individual copies of the object code with a copy of the
+    written offer to provide the Corresponding Source. This
+    alternative is allowed only occasionally and noncommercially, and
+    only if you received the object code with such an offer, in accord
+    with subsection 6b.
+-   d) Convey the object code by offering access from a designated
+    place (gratis or for a charge), and offer equivalent access to the
+    Corresponding Source in the same way through the same place at no
+    further charge. You need not require recipients to copy the
+    Corresponding Source along with the object code. If the place to
+    copy the object code is a network server, the Corresponding Source
+    may be on a different server (operated by you or a third party)
+    that supports equivalent copying facilities, provided you maintain
+    clear directions next to the object code saying where to find the
+    Corresponding Source. Regardless of what server hosts the
+    Corresponding Source, you remain obligated to ensure that it is
+    available for as long as needed to satisfy these requirements.
+-   e) Convey the object code using peer-to-peer transmission,
+    provided you inform other peers where the object code and
+    Corresponding Source of the work are being offered to the general
+    public at no charge under subsection 6d.
+
+A separable portion of the object code, whose source code is excluded
+from the Corresponding Source as a System Library, need not be
+included in conveying the object code work.
+
+A "User Product" is either (1) a "consumer product", which means any
+tangible personal property which is normally used for personal,
+family, or household purposes, or (2) anything designed or sold for
+incorporation into a dwelling. In determining whether a product is a
+consumer product, doubtful cases shall be resolved in favor of
+coverage. For a particular product received by a particular user,
+"normally used" refers to a typical or common use of that class of
+product, regardless of the status of the particular user or of the way
+in which the particular user actually uses, or expects or is expected
+to use, the product. A product is a consumer product regardless of
+whether the product has substantial commercial, industrial or
+non-consumer uses, unless such uses represent the only significant
+mode of use of the product.
+
+"Installation Information" for a User Product means any methods,
+procedures, authorization keys, or other information required to
+install and execute modified versions of a covered work in that User
+Product from a modified version of its Corresponding Source. The
+information must suffice to ensure that the continued functioning of
+the modified object code is in no case prevented or interfered with
+solely because modification has been made.
+
+If you convey an object code work under this section in, or with, or
+specifically for use in, a User Product, and the conveying occurs as
+part of a transaction in which the right of possession and use of the
+User Product is transferred to the recipient in perpetuity or for a
+fixed term (regardless of how the transaction is characterized), the
+Corresponding Source conveyed under this section must be accompanied
+by the Installation Information. But this requirement does not apply
+if neither you nor any third party retains the ability to install
+modified object code on the User Product (for example, the work has
+been installed in ROM).
+
+The requirement to provide Installation Information does not include a
+requirement to continue to provide support service, warranty, or
+updates for a work that has been modified or installed by the
+recipient, or for the User Product in which it has been modified or
+installed. Access to a network may be denied when the modification
+itself materially and adversely affects the operation of the network
+or violates the rules and protocols for communication across the
+network.
+
+Corresponding Source conveyed, and Installation Information provided,
+in accord with this section must be in a format that is publicly
+documented (and with an implementation available to the public in
+source code form), and must require no special password or key for
+unpacking, reading or copying.
+
+#### 7. Additional Terms.
+
+"Additional permissions" are terms that supplement the terms of this
+License by making exceptions from one or more of its conditions.
+Additional permissions that are applicable to the entire Program shall
+be treated as though they were included in this License, to the extent
+that they are valid under applicable law. If additional permissions
+apply only to part of the Program, that part may be used separately
+under those permissions, but the entire Program remains governed by
+this License without regard to the additional permissions.
+
+When you convey a copy of a covered work, you may at your option
+remove any additional permissions from that copy, or from any part of
+it. (Additional permissions may be written to require their own
+removal in certain cases when you modify the work.) You may place
+additional permissions on material, added by you to a covered work,
+for which you have or can give appropriate copyright permission.
+
+Notwithstanding any other provision of this License, for material you
+add to a covered work, you may (if authorized by the copyright holders
+of that material) supplement the terms of this License with terms:
+
+-   a) Disclaiming warranty or limiting liability differently from the
+    terms of sections 15 and 16 of this License; or
+-   b) Requiring preservation of specified reasonable legal notices or
+    author attributions in that material or in the Appropriate Legal
+    Notices displayed by works containing it; or
+-   c) Prohibiting misrepresentation of the origin of that material,
+    or requiring that modified versions of such material be marked in
+    reasonable ways as different from the original version; or
+-   d) Limiting the use for publicity purposes of names of licensors
+    or authors of the material; or
+-   e) Declining to grant rights under trademark law for use of some
+    trade names, trademarks, or service marks; or
+-   f) Requiring indemnification of licensors and authors of that
+    material by anyone who conveys the material (or modified versions
+    of it) with contractual assumptions of liability to the recipient,
+    for any liability that these contractual assumptions directly
+    impose on those licensors and authors.
+
+All other non-permissive additional terms are considered "further
+restrictions" within the meaning of section 10. If the Program as you
+received it, or any part of it, contains a notice stating that it is
+governed by this License along with a term that is a further
+restriction, you may remove that term. If a license document contains
+a further restriction but permits relicensing or conveying under this
+License, you may add to a covered work material governed by the terms
+of that license document, provided that the further restriction does
+not survive such relicensing or conveying.
+
+If you add terms to a covered work in accord with this section, you
+must place, in the relevant source files, a statement of the
+additional terms that apply to those files, or a notice indicating
+where to find the applicable terms.
+
+Additional terms, permissive or non-permissive, may be stated in the
+form of a separately written license, or stated as exceptions; the
+above requirements apply either way.
+
+#### 8. Termination.
+
+You may not propagate or modify a covered work except as expressly
+provided under this License. Any attempt otherwise to propagate or
+modify it is void, and will automatically terminate your rights under
+this License (including any patent licenses granted under the third
+paragraph of section 11).
+
+However, if you cease all violation of this License, then your license
+from a particular copyright holder is reinstated (a) provisionally,
+unless and until the copyright holder explicitly and finally
+terminates your license, and (b) permanently, if the copyright holder
+fails to notify you of the violation by some reasonable means prior to
+60 days after the cessation.
+
+Moreover, your license from a particular copyright holder is
+reinstated permanently if the copyright holder notifies you of the
+violation by some reasonable means, this is the first time you have
+received notice of violation of this License (for any work) from that
+copyright holder, and you cure the violation prior to 30 days after
+your receipt of the notice.
+
+Termination of your rights under this section does not terminate the
+licenses of parties who have received copies or rights from you under
+this License. If your rights have been terminated and not permanently
+reinstated, you do not qualify to receive new licenses for the same
+material under section 10.
+
+#### 9. Acceptance Not Required for Having Copies.
+
+You are not required to accept this License in order to receive or run
+a copy of the Program. Ancillary propagation of a covered work
+occurring solely as a consequence of using peer-to-peer transmission
+to receive a copy likewise does not require acceptance. However,
+nothing other than this License grants you permission to propagate or
+modify any covered work. These actions infringe copyright if you do
+not accept this License. Therefore, by modifying or propagating a
+covered work, you indicate your acceptance of this License to do so.
+
+#### 10. Automatic Licensing of Downstream Recipients.
+
+Each time you convey a covered work, the recipient automatically
+receives a license from the original licensors, to run, modify and
+propagate that work, subject to this License. You are not responsible
+for enforcing compliance by third parties with this License.
+
+An "entity transaction" is a transaction transferring control of an
+organization, or substantially all assets of one, or subdividing an
+organization, or merging organizations. If propagation of a covered
+work results from an entity transaction, each party to that
+transaction who receives a copy of the work also receives whatever
+licenses to the work the party's predecessor in interest had or could
+give under the previous paragraph, plus a right to possession of the
+Corresponding Source of the work from the predecessor in interest, if
+the predecessor has it or can get it with reasonable efforts.
+
+You may not impose any further restrictions on the exercise of the
+rights granted or affirmed under this License. For example, you may
+not impose a license fee, royalty, or other charge for exercise of
+rights granted under this License, and you may not initiate litigation
+(including a cross-claim or counterclaim in a lawsuit) alleging that
+any patent claim is infringed by making, using, selling, offering for
+sale, or importing the Program or any portion of it.
+
+#### 11. Patents.
+
+A "contributor" is a copyright holder who authorizes use under this
+License of the Program or a work on which the Program is based. The
+work thus licensed is called the contributor's "contributor version".
+
+A contributor's "essential patent claims" are all patent claims owned
+or controlled by the contributor, whether already acquired or
+hereafter acquired, that would be infringed by some manner, permitted
+by this License, of making, using, or selling its contributor version,
+but do not include claims that would be infringed only as a
+consequence of further modification of the contributor version. For
+purposes of this definition, "control" includes the right to grant
+patent sublicenses in a manner consistent with the requirements of
+this License.
+
+Each contributor grants you a non-exclusive, worldwide, royalty-free
+patent license under the contributor's essential patent claims, to
+make, use, sell, offer for sale, import and otherwise run, modify and
+propagate the contents of its contributor version.
+
+In the following three paragraphs, a "patent license" is any express
+agreement or commitment, however denominated, not to enforce a patent
+(such as an express permission to practice a patent or covenant not to
+sue for patent infringement). To "grant" such a patent license to a
+party means to make such an agreement or commitment not to enforce a
+patent against the party.
+
+If you convey a covered work, knowingly relying on a patent license,
+and the Corresponding Source of the work is not available for anyone
+to copy, free of charge and under the terms of this License, through a
+publicly available network server or other readily accessible means,
+then you must either (1) cause the Corresponding Source to be so
+available, or (2) arrange to deprive yourself of the benefit of the
+patent license for this particular work, or (3) arrange, in a manner
+consistent with the requirements of this License, to extend the patent
+license to downstream recipients. "Knowingly relying" means you have
+actual knowledge that, but for the patent license, your conveying the
+covered work in a country, or your recipient's use of the covered work
+in a country, would infringe one or more identifiable patents in that
+country that you have reason to believe are valid.
+
+If, pursuant to or in connection with a single transaction or
+arrangement, you convey, or propagate by procuring conveyance of, a
+covered work, and grant a patent license to some of the parties
+receiving the covered work authorizing them to use, propagate, modify
+or convey a specific copy of the covered work, then the patent license
+you grant is automatically extended to all recipients of the covered
+work and works based on it.
+
+A patent license is "discriminatory" if it does not include within the
+scope of its coverage, prohibits the exercise of, or is conditioned on
+the non-exercise of one or more of the rights that are specifically
+granted under this License. You may not convey a covered work if you
+are a party to an arrangement with a third party that is in the
+business of distributing software, under which you make payment to the
+third party based on the extent of your activity of conveying the
+work, and under which the third party grants, to any of the parties
+who would receive the covered work from you, a discriminatory patent
+license (a) in connection with copies of the covered work conveyed by
+you (or copies made from those copies), or (b) primarily for and in
+connection with specific products or compilations that contain the
+covered work, unless you entered into that arrangement, or that patent
+license was granted, prior to 28 March 2007.
+
+Nothing in this License shall be construed as excluding or limiting
+any implied license or other defenses to infringement that may
+otherwise be available to you under applicable patent law.
+
+#### 12. No Surrender of Others' Freedom.
+
+If conditions are imposed on you (whether by court order, agreement or
+otherwise) that contradict the conditions of this License, they do not
+excuse you from the conditions of this License. If you cannot convey a
+covered work so as to satisfy simultaneously your obligations under
+this License and any other pertinent obligations, then as a
+consequence you may not convey it at all. For example, if you agree to
+terms that obligate you to collect a royalty for further conveying
+from those to whom you convey the Program, the only way you could
+satisfy both those terms and this License would be to refrain entirely
+from conveying the Program.
+
+#### 13. Remote Network Interaction; Use with the GNU General Public License.
+
+Notwithstanding any other provision of this License, if you modify the
+Program, your modified version must prominently offer all users
+interacting with it remotely through a computer network (if your
+version supports such interaction) an opportunity to receive the
+Corresponding Source of your version by providing access to the
+Corresponding Source from a network server at no charge, through some
+standard or customary means of facilitating copying of software. This
+Corresponding Source shall include the Corresponding Source for any
+work covered by version 3 of the GNU General Public License that is
+incorporated pursuant to the following paragraph.
+
+Notwithstanding any other provision of this License, you have
+permission to link or combine any covered work with a work licensed
+under version 3 of the GNU General Public License into a single
+combined work, and to convey the resulting work. The terms of this
+License will continue to apply to the part which is the covered work,
+but the work with which it is combined will remain governed by version
+3 of the GNU General Public License.
+
+#### 14. Revised Versions of this License.
+
+The Free Software Foundation may publish revised and/or new versions
+of the GNU Affero General Public License from time to time. Such new
+versions will be similar in spirit to the present version, but may
+differ in detail to address new problems or concerns.
+
+Each version is given a distinguishing version number. If the Program
+specifies that a certain numbered version of the GNU Affero General
+Public License "or any later version" applies to it, you have the
+option of following the terms and conditions either of that numbered
+version or of any later version published by the Free Software
+Foundation. If the Program does not specify a version number of the
+GNU Affero General Public License, you may choose any version ever
+published by the Free Software Foundation.
+
+If the Program specifies that a proxy can decide which future versions
+of the GNU Affero General Public License can be used, that proxy's
+public statement of acceptance of a version permanently authorizes you
+to choose that version for the Program.
+
+Later license versions may give you additional or different
+permissions. However, no additional obligations are imposed on any
+author or copyright holder as a result of your choosing to follow a
+later version.
+
+#### 15. Disclaimer of Warranty.
+
+THERE IS NO WARRANTY FOR THE PROGRAM, TO THE EXTENT PERMITTED BY
+APPLICABLE LAW. EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT
+HOLDERS AND/OR OTHER PARTIES PROVIDE THE PROGRAM "AS IS" WITHOUT
+WARRANTY OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT
+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+A PARTICULAR PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND
+PERFORMANCE OF THE PROGRAM IS WITH YOU. SHOULD THE PROGRAM PROVE
+DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING, REPAIR OR
+CORRECTION.
+
+#### 16. Limitation of Liability.
+
+IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING
+WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MODIFIES AND/OR
+CONVEYS THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES,
+INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES
+ARISING OUT OF THE USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT
+NOT LIMITED TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR
+LOSSES SUSTAINED BY YOU OR THIRD PARTIES OR A FAILURE OF THE PROGRAM
+TO OPERATE WITH ANY OTHER PROGRAMS), EVEN IF SUCH HOLDER OR OTHER
+PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGES.
+
+#### 17. Interpretation of Sections 15 and 16.
+
+If the disclaimer of warranty and limitation of liability provided
+above cannot be given local legal effect according to their terms,
+reviewing courts shall apply local law that most closely approximates
+an absolute waiver of all civil liability in connection with the
+Program, unless a warranty or assumption of liability accompanies a
+copy of the Program in return for a fee.
+
+END OF TERMS AND CONDITIONS
+
+### How to Apply These Terms to Your New Programs
+
+If you develop a new program, and you want it to be of the greatest
+possible use to the public, the best way to achieve this is to make it
+free software which everyone can redistribute and change under these
+terms.
+
+To do so, attach the following notices to the program. It is safest to
+attach them to the start of each source file to most effectively state
+the exclusion of warranty; and each file should have at least the
+"copyright" line and a pointer to where the full notice is found.
+
+        <one line to give the program's name and a brief idea of what it does.>
+        Copyright (C) <year>  <name of author>
+
+        This program is free software: you can redistribute it and/or modify
+        it under the terms of the GNU Affero General Public License as
+        published by the Free Software Foundation, either version 3 of the
+        License, or (at your option) any later version.
+
+        This program is distributed in the hope that it will be useful,
+        but WITHOUT ANY WARRANTY; without even the implied warranty of
+        MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+        GNU Affero General Public License for more details.
+
+        You should have received a copy of the GNU Affero General Public License
+        along with this program.  If not, see <https://www.gnu.org/licenses/>.
+
+Also add information on how to contact you by electronic and paper
+mail.
+
+If your software can interact with users remotely through a computer
+network, you should also make sure that it provides a way for users to
+get its source. For example, if your program is a web application, its
+interface could display a "Source" link that leads users to an archive
+of the code. There are many ways you could offer source, and different
+solutions will be better for different programs; see section 13 for
+the specific requirements.
+
+You should also get your employer (if you work as a programmer) or
+school, if any, to sign a "copyright disclaimer" for the program, if
+necessary. For more information on this, and how to apply and follow
+the GNU AGPL, see <https://www.gnu.org/licenses/>.

frontend/Setup.hs

@@ -0,0 +1,4 @@
+import Distribution.Simple
+
+main :: IO ()
+main = defaultMain

frontend/datarekisteri-frontend.cabal

@@ -0,0 +1,55 @@
+cabal-version: 3.6
+name: datarekisteri-frontend
+version: 0.0.1
+author: Saku Laesvuori
+license: AGPL-3.0-or-later
+license-file: COPYING.md
+build-type: Simple
+stability: alpha
+
+executable datarekisteri-frontend
+  build-depends:
+    aeson,
+    base,
+    base64,
+    datarekisteri-core,
+    email-validate,
+    http-client,
+    http-types,
+    memory,
+    monad-logger,
+    morpheus-graphql,
+    morpheus-graphql-app,
+    morpheus-graphql-client,
+    morpheus-graphql-core,
+    mtl,
+    optparse-applicative,
+    process,
+    relude,
+    req,
+    text,
+    time,
+    yesod,
+    yesod-auth,
+    containers,
+    wai,
+    warp,
+    wai-extra,
+    yesod-core,
+    yesod-static,
+    directory
+  main-is: Datarekisteri/Frontend.hs
+  other-modules:
+    Datarekisteri.Frontend.ApiRequests,
+    Datarekisteri.Frontend.Auth,
+    Datarekisteri.Frontend.FormFields,
+    Datarekisteri.Frontend.Handlers,
+    Datarekisteri.Frontend.Handlers.Applications,
+    Datarekisteri.Frontend.Handlers.Apply,
+    Datarekisteri.Frontend.Handlers.Profile,
+    Datarekisteri.Frontend.Handlers.VerifyEmail,
+    Datarekisteri.Frontend.Handlers.Members,
+    Datarekisteri.Frontend.Types,
+    Datarekisteri.Frontend.Widgets
+  hs-source-dirs: src
+  default-language: Haskell2010

frontend/schema.gql

@@ -0,0 +1,75 @@
+scalar Base64
+
+scalar Date
+
+scalar Email
+
+scalar KeyID
+
+scalar PhoneNumber
+
+scalar Time
+
+scalar TokenID
+
+scalar UserID
+
+enum Unit {
+  Unit
+  Unit2
+}
+
+type PGPKey {
+  id: KeyID!
+  pgpKeyData: Base64!
+  expires: Time
+  uploaded: Time!
+  comment: String!
+}
+
+type Token {
+  id: TokenID!
+  name: String
+  tokenData: String!
+  comment: String!
+  issued: Time!
+  expires: Time
+  permissions: String!
+}
+
+type User {
+  id: UserID!
+  email: Email
+  pendingEmail: Email
+  name: String!
+  nickname: String!
+  phoneNumber: PhoneNumber!
+  birthdate: Date!
+  homeplace: String!
+  registered: Time!
+  accepted: Time
+  permissions: String!
+  isMember: Boolean!
+  application: String!
+  tokens: [Token!]!
+  keys: [PGPKey!]!
+  primaryKey: PGPKey
+}
+
+type Query {
+  users: [User!]!
+  user(id: UserID): User
+  applications: [User!]!
+  permissions: String!
+}
+
+type Mutation {
+  apply(email: Email!, phoneNumber: PhoneNumber!, password: String!, name: String!, nickname: String, birthdate: Date!, homeplace: String!, application: String!): User!
+  verifyEmail(secret: String!): Boolean!
+  resendVerificationEmail(user: UserID): Unit!
+  update(email: Email, phoneNumber: PhoneNumber, password: String, name: String, nickname: String, homeplace: String, application: String, user: UserID): User!
+  newToken(comment: String, name: String, permissions: String): Token!
+  newKey(comment: String, keyData: Base64!, expires: Time): PGPKey!
+  accept(user: UserID!): Unit!
+  reject(user: UserID!): Unit!
+}

frontend/src/Datarekisteri/Frontend.hs

@@ -0,0 +1,47 @@
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE QuasiQuotes #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE ViewPatterns #-}
+
+{-# LANGUAGE NoImplicitPrelude #-}
+
+import Relude hiding (get)
+
+import System.Directory (createDirectoryIfMissing)
+import Yesod.Static (static, Static)
+import Yesod (mkYesodDispatch, warp)
+import Yesod.Auth (getAuth)
+
+import Options.Applicative
+
+import Datarekisteri.Frontend.Types
+import Datarekisteri.Frontend.Handlers
+
+mkYesodDispatch "DataIdClient" resourcesDataIdClient
+
+main :: IO ()
+main = do
+    config <- readConfig
+    static <- getStaticDir "/tmp/data-id"
+    warp (configPort config) $ DataIdClient static config
+
+readConfig :: IO Config
+readConfig = execParser $ info (configOpts' <**> helper)
+    (fullDesc <> progDesc "Serve datarekisteri HTTP client"
+    <> header "Client HTTP server for datarekisteri")
+
+configOpts' :: Parser Config
+configOpts' = Config
+    <$> option auto (long "port" <> short 'p' <> metavar "PORT" <> value 3000 <> help "Port to listen on")
+    <*> strOption (long "approot" <> short 'r' <> metavar "URL" <> value "http://localhost:3000" <> help "External URL of the server path /")
+    <*> strOption (long "server-url" <> short 's' <> metavar "URL" <> value "http://localhost:3100" <> help "Internal URL of the API server")
+    -- TODO make port depend on the --port flag
+
+getStaticDir :: FilePath -> IO Static
+getStaticDir dir = createDirectoryIfMissing True dir >> static dir

frontend/src/Datarekisteri/Frontend/ApiRequests.hs

@@ -0,0 +1,68 @@
+{-# LANGUAGE ConstraintKinds #-}
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE DuplicateRecordFields #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE QuasiQuotes #-}
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE TypeFamilies #-}
+
+{-# LANGUAGE NoImplicitPrelude #-}
+
+module Datarekisteri.Frontend.ApiRequests where
+
+import Relude
+
+import Control.Exception (handle, throwIO)
+import Data.Aeson (ToJSON, FromJSON)
+import Data.Morpheus.Client (RequestType, RequestArgs, Args, GQLClientResult, FetchError(..), single, request, withHeaders)
+import Network.HTTP.Client (HttpException(..), HttpExceptionContent(..), responseStatus)
+import Network.HTTP.Types.Status (status401)
+import Network.HTTP.Req (HttpException(..))
+import Yesod (HandlerFor, getYesod, liftHandler)
+import Yesod.Auth (YesodAuth, AuthId, requireAuthId, maybeAuthId)
+
+type ClientTypeConstraint (a :: Type) = (RequestType a, ToJSON (RequestArgs a), FromJSON a)
+-- From Data.Morpheus.Client.Fetch.RequestType
+type Header = (Text, Text)
+-- From Data.Morpheus.Client.Fetch.GQLClient
+-- No clue why these are not exported
+
+type RequestConstraint a site = (ClientTypeConstraint a, ApiRequest site)
+
+type Authorization = Text
+
+class YesodAuth site => ApiRequest site where
+    getApiUrl :: HandlerFor site Text
+    authIdToAuthorization :: site -> AuthId site -> Authorization
+
+apiRequest' :: RequestConstraint a site => [Header] -> Bool -> Args a -> HandlerFor site a
+apiRequest' extraHeaders authRequired args = do
+    yesod <- liftHandler getYesod
+    auth <- fmap (authIdToAuthorization yesod) <$> if authRequired then Just <$> requireAuthId else maybeAuthId
+    maybeResult <- apiRequestAuth extraHeaders (("Bearer " <>) <$> auth) args
+    case maybeResult of
+      Just result -> handleErrors result
+      Nothing ->  error "Unauthorized"
+
+apiRequestAuth :: RequestConstraint a site =>
+    [Header] -> Maybe Authorization -> Args a -> HandlerFor site (Maybe (GQLClientResult a))
+apiRequestAuth extraHeaders auth args = do
+    apiUrl <- getApiUrl
+    let headers = maybe [] (\x -> [("Authorization", x)]) auth <> extraHeaders
+        handleUnauthorized e@(VanillaHttpException (HttpExceptionRequest _ (StatusCodeException response _)))
+              | responseStatus response == status401 = pure Nothing
+              | otherwise = throwIO e
+        handleUnauthorized e = throwIO e
+    liftIO $ handle handleUnauthorized $
+        request (fromString (toString apiUrl) `withHeaders` headers) args >>= fmap Just . single
+
+apiRequest :: RequestConstraint a site => Bool -> Args a -> HandlerFor site a
+apiRequest authRequired = apiRequest' [] authRequired
+
+handleErrors :: RequestConstraint a site => GQLClientResult a -> HandlerFor site a
+handleErrors (Right a) = pure a
+handleErrors (Left (FetchErrorParseFailure s)) = error $ "GQL parse failure: " <> toText s
+handleErrors (Left (FetchErrorProducedErrors errs Nothing)) = error $ "GQL errors: " <> show errs
+handleErrors (Left (FetchErrorProducedErrors _ (Just a))) = pure a -- TODO log the errors?
+handleErrors (Left (FetchErrorNoResult)) = error $ "GQL no results"

frontend/src/Datarekisteri/Frontend/Auth.hs

@@ -0,0 +1,70 @@
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE PackageImports #-}
+{-# LANGUAGE QuasiQuotes #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE TypeFamilies #-}
+
+{-# LANGUAGE NoImplicitPrelude #-}
+
+module Datarekisteri.Frontend.Auth where
+
+import Relude
+
+import qualified "base64" Data.ByteString.Base64 as B64
+
+import Yesod
+import Yesod.Auth
+
+import qualified Yesod.Auth.Message as Msg
+
+import Datarekisteri.Frontend.Widgets
+
+pluginName = "externalBasic"
+
+loginR = PluginR pluginName ["login"]
+
+type Authorization = Text
+type CredsIdent = Text
+
+postLoginR :: YesodAuth master =>
+    (Authorization -> HandlerFor master (Maybe CredsIdent)) -> AuthHandler master TypedContent
+postLoginR authReq = do
+    res <- runInputPostResult $ (\x y -> x <> ":" <> y)
+        <$> ireq textField "email" <*> ireq textField "password"
+    case res of
+      FormSuccess auth -> do
+          maybeAuth <- liftHandler $ authReq $ ("Basic " <> ) $ B64.encodeBase64 $ encodeUtf8 auth
+          case maybeAuth of
+            Nothing -> loginErrorMessageI LoginR Msg.InvalidEmailPass -- invalid creds
+            Just txt -> do
+                setCredsRedirect Creds {credsPlugin = pluginName, credsIdent = txt, credsExtra = []}
+      _ -> loginErrorMessageI LoginR Msg.NoIdentifierProvided
+
+authExternalBasic :: forall site. YesodAuth site =>
+    (Authorization -> HandlerFor site (Maybe CredsIdent)) -> AuthPlugin site
+authExternalBasic authReq = AuthPlugin pluginName dispatch loginForm
+    where dispatch :: YesodAuth site => Text -> [Text] -> AuthHandler site TypedContent
+          dispatch "POST" ["login"] = postLoginR authReq >>= sendResponse
+          dispatch _ _ = notFound
+
+loginForm :: YesodAuth site => (Route Auth -> Route site) -> WidgetFor site ()
+loginForm toParent = do
+    emailId <- newIdent
+    passwordId <- newIdent
+    let formContent = [whamlet|
+            <label for="#{emailId}">
+                Sähköposti
+            <input id="#{emailId}" name="email" type="text" autofocus>
+            <label for="#{passwordId}">
+                Salasana
+            <input id="#{passwordId}" name="password" type="password">
+            <input type="submit" value="Kirjaudu">
+            |]
+    [whamlet|
+<h1>Kirjaudu
+^{form (toParent loginR) UrlEncoded formContent}
+|]

frontend/src/Datarekisteri/Frontend/FormFields.hs

@@ -0,0 +1,67 @@
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE QuasiQuotes #-}
+
+{-# LANGUAGE NoImplicitPrelude #-}
+
+module Datarekisteri.Frontend.FormFields where
+
+import Relude
+
+import Yesod
+
+import Datarekisteri.Core.Types
+import Datarekisteri.Frontend.Types
+
+emailField :: Field Handler Email
+emailField = Field
+    { fieldParse = \rawValues _ ->
+        case rawValues of
+          [] -> pure $ Right Nothing
+          [""] -> pure $ Right Nothing
+          [x] -> pure $ maybe (Left "could not parse as an email address") (Right . Just) $ toEmail x
+          _ -> pure $ Left $ "Expected one value"
+    , fieldView = \id name otherAttributes result isRequired ->
+        let result' = either (\x -> x) renderEmail result
+        in [whamlet|
+               <input type="email" id="#{id}" name="#{name}" value="#{result'}" *{otherAttributes} :isRequired:required="true">
+           |]
+    , fieldEnctype = UrlEncoded
+    }
+
+telephoneField :: Field Handler PhoneNumber
+telephoneField = Field
+    { fieldParse = \rawValues _ ->
+        case rawValues of
+          [] -> pure $ Right Nothing
+          [""] -> pure $ Right Nothing
+          [x] -> pure $ maybe (Left "could not parse as a phone number") (Right . Just) $ toPhoneNumber x
+          _ -> pure $ Left $ "Expected one value"
+    , fieldView = \id name otherAttributes result isRequired ->
+        let result' = either (\x -> x) renderPhoneNumber result
+        in [whamlet|
+               <input type="tel" id="#{id}" name="#{name}" value="#{result'}" pattern="[+0][ 0123456789]*" title="Only '+', spaces and numbers are allowed" "*{otherAttributes} :isRequired:required="true">
+           |]
+    , fieldEnctype = UrlEncoded
+    }
+
+textareaField' = checkMMap (pure . Right . unTextarea :: Textarea -> Handler (Either Text Text))
+    Textarea textareaField
+
+verifiedPasswordField :: Field Handler Text
+verifiedPasswordField = Field
+    { fieldParse = \rawValues _ ->
+        case rawValues of
+          [] -> pure $ Right Nothing
+          [x,y]
+            | x == y -> pure $ Right $ Just x
+            | otherwise -> pure $ Left "Salasanat eivät täsmää"
+          _ -> pure $ Left "Expected two values"
+    , fieldView = \id name otherAttributes _ isRequired ->
+        [whamlet|
+          <input type="password" id="#{id}" name="#{name}" :isRequired:required="true" *{otherAttributes}>
+          <label for="#{id}-confirm">
+            Toista salasana
+          <input type="password" id="#{id}-confirm" name="#{name}" :isRequired:required="true" *{otherAttributes}>
+        |]
+    , fieldEnctype = UrlEncoded
+    }

frontend/src/Datarekisteri/Frontend/Handlers.hs

@@ -0,0 +1,33 @@
+{-# LANGUAGE DisambiguateRecordFields #-}
+{-# LANGUAGE DuplicateRecordFields #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE TypeFamilies #-}
+
+{-# LANGUAGE NoImplicitPrelude #-}
+
+module Datarekisteri.Frontend.Handlers
+    ( module Datarekisteri.Frontend.Handlers.Profile
+    , module Datarekisteri.Frontend.Handlers.Applications
+    , module Datarekisteri.Frontend.Handlers.Apply
+    , module Datarekisteri.Frontend.Handlers.Members
+    , module Datarekisteri.Frontend.Handlers.VerifyEmail
+    , getHomeR
+    ) where
+
+import Relude
+
+import Yesod
+import Yesod.Auth
+
+import Datarekisteri.Frontend.Handlers.Profile
+import Datarekisteri.Frontend.Handlers.Apply
+import Datarekisteri.Frontend.Handlers.Applications
+import Datarekisteri.Frontend.Handlers.VerifyEmail
+import Datarekisteri.Frontend.Handlers.Members
+import Datarekisteri.Frontend.Types
+
+getHomeR :: Handler Html
+getHomeR = ifM (isJust <$> maybeAuthId) (redirect OwnProfileR) (redirect $ AuthR LoginR)

frontend/src/Datarekisteri/Frontend/Handlers/Applications.hs

@@ -0,0 +1,137 @@
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE DuplicateRecordFields #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE QuasiQuotes #-}
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE TypeFamilies #-}
+
+{-# LANGUAGE NoImplicitPrelude #-}
+
+module Datarekisteri.Frontend.Handlers.Applications where
+
+import Relude hiding (id)
+
+import Data.Maybe (fromJust)
+import Data.Time (Day)
+import Data.Morpheus.Client (raw, declareLocalTypesInline)
+
+import Yesod hiding (emailField)
+import Yesod.Auth
+
+import Datarekisteri.Core.Types hiding (Applications)
+import Datarekisteri.Frontend.ApiRequests
+import Datarekisteri.Frontend.FormFields
+import Datarekisteri.Frontend.Types
+import Datarekisteri.Frontend.Widgets
+
+declareLocalTypesInline "schema.gql" [raw|
+query Applications {
+  applications {
+    id
+    name
+    nickname
+    email
+    phoneNumber
+    homeplace
+    birthdate
+    application
+  }
+}
+|]
+
+declareLocalTypesInline "schema.gql" [raw|
+mutation Reject($user: UserID!) {
+  reject(user: $user)
+}
+|]
+
+declareLocalTypesInline "schema.gql" [raw|
+mutation Accept($user: UserID!) {
+  accept(user: $user)
+}
+|]
+
+resolveApplicationForm :: Maybe UserID -> Form UserID
+resolveApplicationForm user = renderDivs $ areq hiddenField "" user
+
+applicationsW :: [ApplicationsApplications] -> Widget
+applicationsW applications = do
+    setTitle "Jäsenhakemukset"
+    [whamlet|<h1>Käsiteltävät jäsenhakemukset|]
+    when (null applications) $ [whamlet|<p>Ei jäsenhakemuksia.|]
+    rejectRoute <- handlerToWidget $ maybeAuthorized RejectR True
+    acceptRoute <- handlerToWidget $ maybeAuthorized AcceptR True
+    forM_ applications $ \ApplicationsApplications {..} -> do
+        (widget, enctype) <- handlerToWidget $ generateFormPost $ resolveApplicationForm $ Just id
+        let keysAndValues =
+                [ ("Nimi" :: Text, name)
+                , ("Kutsumanimi", nickname)
+                , ("Kotipaikka", homeplace)
+                , ("Syntymäaika", renderDate birthdate)
+                , ("Sähköposti", renderEmail $ fromJust email)
+                , ("Puhelinnumero", renderPhoneNumber phoneNumber)
+                ]
+            acceptFormContent = [whamlet|
+                ^{widget}
+                ^{submitButton "Hyväksy"}
+                |]
+            rejectFormContent = [whamlet|
+                ^{widget}
+                ^{submitButtonBad "Hylkää"}
+                |]
+        detailsClass <- newIdent
+        [whamlet|
+            <details .#{detailsClass}>
+                <summary>
+                    <h2>#{name}
+                <article>
+                    <h3>Hakemus
+                    <p>#{Textarea application}
+                    ^{keyValueTable keysAndValues}
+                $maybe route <- acceptRoute
+                    ^{form route enctype acceptFormContent}
+                $maybe route <- rejectRoute
+                    ^{form route enctype rejectFormContent}
+        |]
+        toWidget [lucius|
+            .#{detailsClass} {
+                padding: 1.3em;
+                margin: 0.6em;
+                border-color: #00838a;
+                border-width: 0 0 0 0.6em;
+                border-style: solid;
+                border-radius: 0.4em;
+                background-color: #f6f8f8;
+                > summary > h2 {
+                    display: inline-block;
+                    margin-top: 0;
+                    margin-bottom: 0;
+                }
+                > article { margin-bottom: 1.5em }
+            }
+            .#{detailsClass}[open] { border-color: #339ca1; }
+        |]
+
+getApplicationsR :: (YesodAuth DataIdClient, AuthId DataIdClient ~ Text) => Handler Html
+getApplicationsR = do
+    Applications applications <- apiRequest @Applications True ()
+    defaultLayout $ applicationsW applications
+
+postAcceptR :: (YesodAuth DataIdClient, AuthId DataIdClient ~ Text) => Handler Html
+postAcceptR = do
+    ((result, _), _) <- runFormPost $ resolveApplicationForm Nothing
+    case result of
+      FormSuccess user -> void $ apiRequest @Accept True $ AcceptArgs user
+      _ -> pure ()
+    redirect ApplicationsR
+
+postRejectR :: (YesodAuth DataIdClient, AuthId DataIdClient ~ Text) => Handler Html
+postRejectR = do
+    ((result, _), _) <- runFormPost $ resolveApplicationForm Nothing
+    case result of
+      FormSuccess user -> void $ apiRequest @Reject True $ RejectArgs user
+      _ -> pure ()
+    redirect ApplicationsR

frontend/src/Datarekisteri/Frontend/Handlers/Apply.hs

@@ -0,0 +1,90 @@
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE DuplicateRecordFields #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE QuasiQuotes #-}
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE TypeFamilies #-}
+
+{-# LANGUAGE NoImplicitPrelude #-}
+
+module Datarekisteri.Frontend.Handlers.Apply where
+
+import Relude hiding (id)
+
+import Data.Morpheus.Client (raw, declareLocalTypesInline)
+import Data.Time (Day)
+
+import Yesod hiding (emailField)
+import Yesod.Auth
+
+import Datarekisteri.Core.Types
+import Datarekisteri.Frontend.ApiRequests
+import Datarekisteri.Frontend.FormFields
+import Datarekisteri.Frontend.Types
+import Datarekisteri.Frontend.Widgets
+
+declareLocalTypesInline "schema.gql" [raw|
+mutation Apply($name: String!, $nickname: String, $homeplace: String!,
+    $birthdate: Date!, $email: Email!, $phoneNumber: PhoneNumber!, $password: String!, $application: String!) {
+  apply(email: $email, password: $password, name: $name, nickname: $nickname,
+      birthdate: $birthdate, homeplace: $homeplace, application: $application, phoneNumber: $phoneNumber) {
+    id
+  }
+}
+|]
+
+applyForm :: Html -> MForm Handler (FormResult ApplyArgs, Widget)
+applyForm = renderDivs $ ApplyArgs
+    <$> areq textField nameSettings Nothing
+    <*> aopt textField nicknameSettings Nothing
+    <*> areq textField homeplaceSettings Nothing
+    <*> areq dayField' birthdateSettings Nothing
+    <*> areq emailField emailSettings Nothing
+    <*> areq telephoneField phoneSettings Nothing
+    <*> areq verifiedPasswordField "Salasana" Nothing
+    <*> areq textareaField' applicationSettings Nothing
+        where dayField' :: Field Handler Date
+              dayField' = checkMMap (pure . Right . Date :: Day -> Handler (Either Text Date))
+                  (\(Date x) -> x) dayField
+              nameSettings = "Nimi" {fsAttrs = [("placeholder","Erkki Juhani Esimerkki")]}
+              nicknameSettings = "Kutsumanimi" {fsAttrs = [("placeholder","Juhani")]}
+              homeplaceSettings = "Kotipaikka" {fsAttrs = [("placeholder","Espoo")]}
+              birthdateSettings = "Syntymäaika" {fsAttrs = [("placeholder","2000-01-01")]}
+              emailSettings = "Sähköposti" {fsAttrs = [("placeholder","erkki.juhani@esimerkki.fi")]}
+              phoneSettings = "Puhelinnumero" {fsAttrs = [("placeholder","+358 12 34567890")]}
+              applicationSettings = "Hakemus (eli miksi olet data)"
+                  {fsAttrs = [("placeholder","Aloitin opiskelun Otaniemen datalla vuonna 2020.")]}
+
+applyW :: (Widget, Enctype) -> Widget
+applyW (applyWidget, applyEnctype) = do
+    setTitle "Jäsenhakemus"
+    let formContent = [whamlet|
+            ^{applyWidget}
+            <p>
+                Lähettämällä jäsenhakemuksen vakuutat antamiesi tietojen oikeellisuuden ja puuttettomuuden
+                sekä sitoudut pitämään ne ajan tasalla. Rekisteriin kirjattuja tietoja käsitellään
+                <a href="https://datat.fi/rekisteriseloste">rekisteriselosteen</a> mukaisesti.
+            ^{submitButton "Hae Jäseneksi"}
+            |]
+    [whamlet|
+        <h1>
+            Jäsenhakemus
+        ^{form ApplyR applyEnctype formContent}
+    |]
+
+getApplyR :: (YesodAuth DataIdClient, AuthId DataIdClient ~ Text) => Handler Html
+getApplyR = do
+    applyForm <- liftHandler $ generateFormPost applyForm
+    defaultLayout $ applyW applyForm
+
+postApplyR :: (YesodAuth DataIdClient, AuthId DataIdClient ~ Text) => Handler Html
+postApplyR = do
+    ((result, widget), enctype) <- runFormPost applyForm
+    case result of
+      FormSuccess application -> apiRequest @Apply False application >> redirect VerifyEmailR
+      -- TODO: Automatically log in
+      _ -> do
+          defaultLayout $ applyW (widget, enctype)

frontend/src/Datarekisteri/Frontend/Handlers/Members.hs

@@ -0,0 +1,75 @@
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE QuasiQuotes #-}
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE TypeFamilies #-}
+
+{-# LANGUAGE NoImplicitPrelude #-}
+
+module Datarekisteri.Frontend.Handlers.Members where
+
+import Relude hiding (id)
+
+import Data.Morpheus.Client (raw, declareLocalTypesInline)
+
+import Yesod
+import Yesod.Auth
+
+import Datarekisteri.Frontend.Types
+import Datarekisteri.Frontend.ApiRequests
+import Datarekisteri.Frontend.Widgets
+import Datarekisteri.Core.Types
+
+declareLocalTypesInline "schema.gql" [raw|
+query MembersPage {
+  users {
+    id
+    name
+    nickname
+    homeplace
+  }
+}
+|]
+
+instance ToTableRow DataIdClient MembersPageUsers where
+    tableHeader _ = toWidget <$> ["Nimi" :: Text, "Kutsumanimi", "Kotipaikka"]
+    toCells MembersPageUsers {..} = toWidget <$> [name, nickname, homeplace]
+
+getMembersR :: (YesodAuth DataIdClient, AuthId DataIdClient ~ Text) => Handler Html
+getMembersR = do
+    MembersPage {..} <- apiRequest True ()
+    defaultLayout $ do
+        setTitle "Jäsenet"
+        let memberNickname member = let MembersPageUsers {..} = member in nickname
+            memberName member = let MembersPageUsers {..} = member in name
+            memberHomeplace member = let MembersPageUsers {..} = member in homeplace
+            memberId member = let MembersPageUsers {..} = member in id
+        [whamlet|
+        <h1>
+          Jäsenet
+        $if null users
+          <p>
+            Ei jäseniä.
+        $else
+          <table>
+            <thead>
+              <tr>
+                <th scope="col">
+                  Nimi
+                <th scope="col">
+                  Kutsumanimi
+                <th scope="col">
+                  Kotipaikka
+            <tbody>
+            $forall member <- users
+              <tr>
+                <td>
+                  #{memberName member}
+                <td>
+                  #{memberNickname member}
+                <td>
+                  #{memberHomeplace member}
+|]

frontend/src/Datarekisteri/Frontend/Handlers/Profile.hs

@@ -0,0 +1,161 @@
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE DuplicateRecordFields #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE QuasiQuotes #-}
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE TypeFamilies #-}
+
+{-# LANGUAGE NoImplicitPrelude #-}
+
+module Datarekisteri.Frontend.Handlers.Profile where
+
+import Relude hiding (id)
+
+import Data.Morpheus.Client (raw, declareLocalTypesInline)
+
+import Yesod hiding (emailField)
+import Yesod.Auth
+
+import Datarekisteri.Core.Types
+import Datarekisteri.Frontend.ApiRequests
+import Datarekisteri.Frontend.Types
+import Datarekisteri.Frontend.FormFields
+import Datarekisteri.Frontend.Widgets
+
+declareLocalTypesInline "schema.gql" [raw|
+query ProfilePage($id: UserID) {
+  user(id: $id) {
+    id
+    name
+    nickname
+    email
+    pendingEmail
+    homeplace
+    birthdate
+    phoneNumber
+    isMember
+    application
+  }
+  permissions
+}
+|]
+
+declareLocalTypesInline "schema.gql" [raw|
+mutation UpdateProfile($user: UserID, $name: String, $homeplace: String, $nickname: String, $email: Email, $phoneNumber: PhoneNumber, $application: String) {
+  update(user: $user, name: $name, homeplace: $homeplace, nickname: $nickname, email: $email, phoneNumber: $phoneNumber, application: $application) {
+    id
+  }
+}
+|]
+
+declareLocalTypesInline "schema.gql" [raw|
+mutation UpdatePassword($user: UserID, $password: String!) {
+  update(user: $user, password: $password) {
+    id
+  }
+}
+|]
+
+passwordForm :: Form Text
+passwordForm = renderDivs $ areq verifiedPasswordField "Uusi salasana" Nothing
+
+profileForm :: ProfilePageUser -> Form UpdateProfileArgs
+profileForm ProfilePageUser {..} extraHtml = do
+    (nameRes, nameView) <- mopt textField "Nimi" (Just $ Just name)
+    (homeRes, homeView) <- mopt textField "Kotipaikka" (Just $ Just homeplace)
+    (nicknameRes, nicknameView) <- mopt textField "Kutsumanimi" (Just $ Just nickname)
+    (emailRes, emailView) <- mopt emailField "Sähköposti" (Just email)
+    (phoneNumberRes, phoneNumberView) <- mopt telephoneField "Puhelinnumero" (Just $ Just phoneNumber)
+    (applicationRes, applicationView) <- mopt textareaField' "Jäsenhakemus" (Just $ Just application)
+    let profileUpdateRes = UpdateProfileArgs (Just id) <$>
+            nameRes <*> homeRes <*> nicknameRes <*> emailRes <*> phoneNumberRes <*> applicationRes
+        inputField FieldView {..} = [whamlet|
+            <label for="#{fvId}">
+                ^{fvLabel}
+                ^{fvInput}
+                $maybe err <- fvErrors
+                    <div class=".errors">#{err}
+            |]
+        widget = [whamlet|
+            #{extraHtml}
+            ^{inputField nameView}
+            ^{inputField homeView}
+            ^{inputField nicknameView}
+            ^{inputField phoneNumberView}
+            ^{inputField emailView}
+            $maybe pending <- pendingEmail
+                <p>Päivitys osoitteeseen #
+                    <a href="mailto:#{renderEmail pending}">#{renderEmail pending}
+                    odottaa vahvistusta. #
+                    <a href="@{VerifyEmailR}">Siirry vahvistamaan
+            $if not isMember
+                ^{inputField applicationView}
+            |]
+    return (profileUpdateRes, widget)
+
+profile :: ProfilePageUser -> (Widget, Enctype) -> (Widget, Enctype) -> Widget
+profile user (profileWidget, profileEnctype) (passwordWidget, passwordEnctype) = do
+    setTitle "Muokkaa profiilia"
+    let userID = let ProfilePageUser {..} = user in id
+    passwordRoute <- handlerToWidget $ maybeAuthorized (UpdatePasswordR userID) True
+    let profileFormContent = [whamlet|
+            ^{profileWidget}
+            ^{submitButton "Päivitä tiedot"}
+            |]
+        passwordFormContent = [whamlet|
+            ^{passwordWidget}
+            ^{submitButton "Vaihda salasana"}
+            |]
+    [whamlet|
+        <h1>
+            $if isMember user
+                Jäsentiedot
+            $else
+                Jäsenhakemuksen tiedot
+        ^{form (ProfileR userID) profileEnctype profileFormContent}
+        $maybe route <- passwordRoute
+            ^{form route passwordEnctype passwordFormContent}
+    |]
+
+getProfile :: (YesodAuth DataIdClient, AuthId DataIdClient ~ Text) => (Maybe UserID) -> Handler Html
+getProfile userID = do
+    ProfilePage {..} <- apiRequest True (ProfilePageArgs {id = userID})
+    passwordForm <- liftHandler $ generateFormPost passwordForm
+    profileForm <- liftHandler $ generateFormPost $
+        profileForm (fromJust user)
+    defaultLayout $ profile (fromJust user)
+        profileForm passwordForm
+
+fromJust = fromMaybe $ error "Tried to access the profile of an inexistent user"
+
+getOwnProfileR :: (YesodAuth DataIdClient, AuthId DataIdClient ~ Text) => Handler Html
+getOwnProfileR = getProfile Nothing
+
+getProfileR :: (YesodAuth DataIdClient, AuthId DataIdClient ~ Text) => UserID -> Handler Html
+getProfileR = getProfile . Just
+
+postProfileR :: (YesodAuth DataIdClient, AuthId DataIdClient ~ Text) => UserID -> Handler Html
+postProfileR userID = do
+    ProfilePage {..} <- apiRequest True (ProfilePageArgs {id = Just userID})
+    ((result, widget), enctype) <- runFormPost $ profileForm (fromJust user)
+    case result of
+      FormSuccess update -> apiRequest @UpdateProfile True update >> redirect (ProfileR userID)
+      _ -> do
+          passwordForm <- liftHandler $ generateFormPost passwordForm
+          defaultLayout $ profile (fromJust user) (widget, enctype) passwordForm
+          --- XXX fromJust explodes if the user no longer exists
+
+postUpdatePasswordR :: (YesodAuth DataIdClient, AuthId DataIdClient ~ Text) => UserID -> Handler Html
+postUpdatePasswordR userID = do
+    ((result, widget), enctype) <- runFormPost passwordForm
+    case result of
+      FormSuccess new ->
+          apiRequest @UpdatePassword True (UpdatePasswordArgs {password = new, user = Just userID}) >> redirect (ProfileR userID)
+      _ -> do
+          ProfilePage {..} <- apiRequest True (ProfilePageArgs {id = Just userID})
+          profileForm <- liftHandler $ generateFormPost $ profileForm (fromJust user)
+          defaultLayout $ profile (fromJust user) profileForm (widget, enctype)
+          --- XXX fromJust explodes if the user no longer exists

frontend/src/Datarekisteri/Frontend/Handlers/VerifyEmail.hs

@@ -0,0 +1,59 @@
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE DuplicateRecordFields #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE QuasiQuotes #-}
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE TypeFamilies #-}
+
+{-# LANGUAGE NoImplicitPrelude #-}
+
+module Datarekisteri.Frontend.Handlers.VerifyEmail where
+
+import Relude
+
+import Data.Morpheus.Client (raw, declareLocalTypesInline)
+
+import Yesod
+import Yesod.Auth
+
+import Datarekisteri.Frontend.ApiRequests
+import Datarekisteri.Frontend.Types
+import Datarekisteri.Frontend.Widgets
+import Datarekisteri.Core.Types
+
+declareLocalTypesInline "schema.gql" [raw|
+mutation VerifyEmail($secret: String!) {
+  verifyEmail(secret: $secret)
+}
+|]
+
+getVerifyEmailR = do
+    codeForm <- generateFormPost verifyForm
+    defaultLayout $ verifyEmailW codeForm
+
+postVerifyEmailR :: (YesodAuth DataIdClient, AuthId DataIdClient ~ Text) => Handler Html
+postVerifyEmailR = do
+    ((result, widget), enctype) <- runFormPost verifyForm
+    case result of
+      FormSuccess verify -> do
+          success <- apiRequest @VerifyEmail False verify
+          case success of
+            VerifyEmail True -> setMessage "Sähköpostiosoite vahvistettu" >> redirect OwnProfileR
+            VerifyEmail False -> setMessage "Virheellinen vahvistuskoodi" >> redirect VerifyEmailR
+      _ -> defaultLayout $ verifyEmailW (widget, enctype)
+
+verifyEmailW (codeWidget, codeEnctype) = do
+    setTitle "Vahvista sähköpostiosoite"
+    let formContent = [whamlet|
+            ^{codeWidget}
+            ^{submitButton "Vahvista"}
+            |]
+    [whamlet|
+<h1>
+    Vahvista sähköpostiosoite
+^{form VerifyEmailR codeEnctype formContent}
+|]
+
+verifyForm = renderDivs $ VerifyEmailArgs <$> areq textField "Vahvistuskoodi" Nothing

frontend/src/Datarekisteri/Frontend/Types.hs

@@ -0,0 +1,309 @@
+{-# LANGUAGE DeriveAnyClass #-}
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE QuasiQuotes #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE ViewPatterns #-}
+
+{-# LANGUAGE NoImplicitPrelude #-}
+
+module Datarekisteri.Frontend.Types where
+
+import Relude hiding (id)
+
+import Data.Map (findWithDefault)
+import Data.Morpheus.Client (raw, declareLocalTypesInline)
+import Data.Time (getCurrentTime)
+import Data.Time.Format.ISO8601 (iso8601Show)
+import Relude.Extra.Foldable1 (maximum1)
+import Yesod.Core.Handler (getCurrentRoute)
+import Yesod.Default.Util (addStaticContentExternal)
+
+import Yesod
+import Yesod.Auth
+import Yesod.Static
+
+import Datarekisteri.Core.Types (UserID(..), Scope(..), Permission(..), readPermission)
+import Datarekisteri.Frontend.ApiRequests
+import Datarekisteri.Frontend.Auth
+
+data DataIdClient = DataIdClient
+    { getStatic :: Static
+    , getConfig :: Config
+    }
+
+data Config = Config
+    { configPort :: Int
+    , configApproot :: Text
+    , configServerUrl :: Text
+    }
+
+instance PathPiece UserID where
+    toPathPiece (UserID id) = show id
+    fromPathPiece s = UserID <$> readMaybe (toString s)
+
+mkYesodData "DataIdClient" [parseRoutes|
+/ HomeR GET
+
+/profile OwnProfileR GET
+/profile/#UserID ProfileR GET POST
+/update-password/#UserID UpdatePasswordR POST
+/verify-email VerifyEmailR GET POST
+
+/members MembersR GET
+
+/applications ApplicationsR GET
+/accept AcceptR POST
+/reject RejectR POST
+
+/apply ApplyR GET POST
+
+/auth AuthR Auth getAuth
+/static StaticR Static getStatic
+|]
+
+declareLocalTypesInline "schema.gql" [raw|
+query GetPermissions {
+  permissions
+  user {
+    id
+  }
+}
+|]
+
+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 getToken]
+        where getToken auth = (>>= fmap (tokenData . newToken) . rightToMaybe) <$>
+                      apiRequestAuth @GetWebUIToken [] (Just auth) ()
+    authenticate = pure . Authenticated . credsIdent
+
+withAuthenticated :: (AuthId DataIdClient -> Handler AuthResult) -> Handler AuthResult
+withAuthenticated m = maybeAuthId >>= maybe (pure AuthenticationRequired) m
+
+hasPermission :: Scope -> Permission -> Handler Bool
+hasPermission scope permission = do
+    GetPermissions {..} <- apiRequest @GetPermissions False ()
+    let permissionMap = fromMaybe mempty $ readPermission permissions
+        findPermission scope = findWithDefault None scope permissionMap
+        userID = (\x -> id (x :: GetPermissionsUser)) <$> user
+        scopes = scope :| case scope of
+            Tokens uid | Just uid == userID -> [OwnTokens]
+            Profile uid | Just uid == userID -> [OwnProfile]
+            _ -> []
+            -- TODO add Members and Applications to Profile Scopes if profile owner is member/applicant
+    pure $ (>= permission) $ maximum1 $ findPermission <$> scopes
+
+requirePermission :: Scope -> Permission -> Handler AuthResult
+requirePermission scope permission = ifM (hasPermission scope permission)
+    (pure Authorized)
+    (pure $ Unauthorized $ "Toiminto vaatii " <> renderPermission permission <> " " <> renderScope scope)
+        where renderPermission ReadWrite = "kirjoitusoikeuden"
+              renderPermission ReadOnly = "lukuoikeuden"
+              renderPermission None = "nollaoikeuden"
+              renderScope OwnProfile = "omaan profiliin"
+              renderScope (Profile _) = "käyttäjän profiliin"
+              renderScope OwnTokens = "omiin tokeneihin" -- TODO kunnon suomennos
+              renderScope (Tokens _) = "käyttäjän tokeneihin" -- TODO kunnon suomennos
+              renderScope Members = "kaikkiin jäseniin"
+              renderScope Applications = "jäsenhakemuksiin"
+
+authorizedHelper :: Scope -> Bool -> Handler AuthResult
+authorizedHelper scope True = requirePermission scope ReadWrite
+authorizedHelper scope False = requirePermission scope ReadOnly
+
+instance Yesod DataIdClient where
+    authRoute = const $ Just $ AuthR LoginR
+    approot = ApprootMaster $ configApproot . getConfig
+    makeSessionBackend = const $ sslOnlySessions $ laxSameSiteSessions $
+        Just <$> defaultClientSessionBackend (60*24*7) "client_session_key.aes"
+    isAuthorized (AuthR _) _ = pure Authorized
+    isAuthorized (StaticR _) _ = pure Authorized
+    isAuthorized HomeR _ = pure Authorized
+    isAuthorized ApplyR _ = pure Authorized
+    isAuthorized VerifyEmailR _ = pure Authorized
+    isAuthorized OwnProfileR isWrite = withAuthenticated $ const $ authorizedHelper OwnProfile isWrite
+    isAuthorized (ProfileR user) isWrite = withAuthenticated $ const $ authorizedHelper (Profile user) isWrite
+    isAuthorized (UpdatePasswordR user) isWrite =
+        withAuthenticated $ const $ authorizedHelper (Profile user) isWrite
+    isAuthorized MembersR isWrite = withAuthenticated $ const $ authorizedHelper Members isWrite
+    isAuthorized ApplicationsR isWrite = withAuthenticated $ const $ authorizedHelper Applications isWrite
+    isAuthorized AcceptR isWrite = withAuthenticated $ const $ authorizedHelper Applications isWrite
+    isAuthorized RejectR isWrite = withAuthenticated $ const $ authorizedHelper Applications isWrite
+    errorHandler NotFound = fmap toTypedContent $ defaultLayout $ defaultMessageWidget "Sivua ei löytynyt" $
+        [hamlet|<p>Pyytämästäsi osoitteesta ei löytynyt sivua|]
+    errorHandler (InternalError e) = do
+        $logErrorS "yesod-core" e
+        selectRep $ do
+            provideRep $ defaultLayout $ do
+                currentTime <- liftIO getCurrentTime
+                defaultMessageWidget "Palvelinvirhe" [hamlet|
+<p>
+    Pyynnön käsittelyssä tapahtui virhe. #
+    Ole yhteydessä ylläpitäjiin ja kerro heille palvelimen kellonaika virheen tapahtuessa #
+    #{iso8601Show currentTime}
+|]
+    errorHandler x = defaultErrorHandler x
+    addStaticContent = addStaticContentExternal Right base64md5 "/tmp/data-id" (StaticR . flip StaticRoute [])
+    defaultLayout widget = do
+        let messages :: Widget
+            messages = do
+                msgs <- getMessages
+                messagesClass <- newIdent
+                messageClass <- newIdent
+                toWidget [hamlet|
+                    $if not $ null msgs
+                        <aside class="#{messagesClass}">
+                          <ul>
+                            $forall (_, msg) <- msgs
+                              <li class="#{messageClass}">#{msg}
+                |]
+                toWidget [lucius|
+                    aside.#{messagesClass} > ul {
+                      list-style: none;
+                      padding: 0;
+                      margin: 0;
+                      li.#{messageClass} {
+                        display: block;
+                        padding: 0.7em;
+                        background-color: #3b4553;
+                        color: white;
+                        border-radius: 0.3em;
+                      }
+                    }
+                |]
+            navigationBar :: Widget
+            navigationBar = do
+                applicationsRoute <- handlerToWidget $ maybeAuthorized ApplicationsR False
+                profileRoute <- handlerToWidget $ maybeAuthorized OwnProfileR False
+                membersRoute <- handlerToWidget $ maybeAuthorized MembersR False
+                currentRoute <- getCurrentRoute
+                loggedIn <- isJust <$> maybeAuthId
+                navClass <- newIdent
+                activeClass <- newIdent
+                rightClass <- newIdent
+                let navItem :: Bool -> Maybe (Route DataIdClient) -> Text -> HtmlUrl (Route DataIdClient)
+                    navItem alignRight maybeRoute name = [hamlet|
+                        $maybe route <- maybeRoute
+                            <li :Just route == currentRoute:class="#{activeClass}" :alignRight:class="#{rightClass}">
+                                <a href="@{route}">#{name}
+                        |]
+                    rightNavItem = navItem True
+                    leftNavItem = navItem False
+                toWidget [hamlet|
+                    <nav .#{navClass}>
+                      <ul>
+                        ^{leftNavItem profileRoute "Profiili"}
+                        ^{leftNavItem membersRoute "Jäsenet"}
+                        ^{leftNavItem applicationsRoute "Hakemukset"}
+                        $if loggedIn
+                          ^{rightNavItem (Just (AuthR LogoutR)) "Kirjaudu ulos"}
+                        $else
+                          ^{rightNavItem (Just (AuthR LoginR)) "Kirjaudu sisään"}
+                          ^{rightNavItem (Just ApplyR) "Hae jäseneksi"}
+                |]
+                toWidget [lucius|
+                    .#{navClass} {
+                      display: block;
+                      position: fixed;
+                      top: 0;
+                      width: 100%;
+                      padding: 0;
+                      background-color: #{fgColor};
+                      ul {
+                        list-style-type: none;
+                        margin: 0;
+                        padding: 0;
+                      }
+                      li {
+                        display: block;
+                        float: left;
+                        padding: 0;
+                        margin: 0;
+                        a {
+                          color: #{bgColor};
+                          text-decoration: none;
+                          display: inline-block;
+                          padding: 0.7em 1em;
+                        }
+                        a:hover {
+                          background-color: #00838a;
+                          color: #ffffff;
+                        }
+                      }
+                      .#{activeClass} { font-weight: 500; }
+                      .#{rightClass} { float: right; }
+                    }
+                |]
+
+        p <- widgetToPageContent $ do
+            [whamlet|
+                <header>
+                  ^{navigationBar}
+                <main>
+                  ^{messages}
+                  ^{widget}
+            |] :: Widget
+            toWidget $ [lucius|
+                * {
+                  box-sizing: border-box;
+                }
+                html {
+                  font-family: "Fira Sans", sans-serif;
+                  height: 100%;
+                }
+                body {
+                  background-color: #e8eaef;
+                  color: #{fgColor};
+                  margin: 0;
+                  height: 100%;
+                }
+                main {
+                  margin: 0 auto;
+                  max-width: 50em;
+                  padding: 5em 1em 3em 1em;
+                  background-color: #{bgColor};
+                  min-height: 100%;
+                  box-sizing: border-box;
+                }
+                |]
+        withUrlRenderer [hamlet|
+            $doctype 5
+            <html>
+              <head>
+                <meta name="viewport" content="width=device-width,initial-scale=1"/>
+                <title>#{pageTitle p}
+                ^{pageHead p}
+              <body>
+                ^{pageBody p}
+            |]
+
+bgColor, fgColor :: Text
+bgColor = "#ffffff"
+fgColor = "#181c22"
+
+instance ApiRequest DataIdClient where
+    getApiUrl = configServerUrl . getConfig <$> getYesod
+    authIdToAuthorization = flip const
+
+instance RenderMessage DataIdClient FormMessage where
+    renderMessage _ _ = defaultFormMessage
+
+type Form a = Html -> MForm Handler (FormResult a, Widget)

frontend/src/Datarekisteri/Frontend/Widgets.hs

@@ -0,0 +1,124 @@
+{-# LANGUAGE ConstraintKinds #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE QuasiQuotes #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+
+module Datarekisteri.Frontend.Widgets where
+
+import Data.Text (Text)
+
+import Yesod
+
+type Widget' a = WidgetFor a ()
+
+submitButton :: Text -> Widget' a
+submitButton text = do
+    toWidget [hamlet|<input type="submit" value="#{text}">|]
+
+submitButtonBad :: Text -> Widget' a
+submitButtonBad text = do
+    buttonId <- newIdent
+    toWidget [hamlet|<input id="#{buttonId}" type="submit" value="#{text}">|]
+    toWidget [lucius|
+        input[type="submit"]##{buttonId} {
+            background-color: #8a003a;
+        }
+        input[type="submit"]##{buttonId}:hover {
+            background-color: #aa3968;
+        }
+    |]
+
+keyValueTable :: (ToWidget site a, ToWidget site b) => [(a, b)] -> Widget' site
+keyValueTable rows = do
+    tableClass <- newIdent
+    [whamlet|
+        <table .#{tableClass}>
+            $forall row <- rows
+                <tr>
+                    <th scope="row">^{fst row}
+                    <td>^{snd row}
+    |]
+    toWidget [lucius|
+        .#{tableClass} {
+            th { text-align: right; }
+            td { text-align: left; }
+        }
+    |]
+
+form :: Route a -> Enctype -> Widget' a -> Widget' a
+form route enctype content = do
+    formClass <- newIdent
+    [whamlet|
+        <form .#{formClass} action="@{route}" method="post" enctype="#{enctype}">
+            ^{content}
+    |]
+    toWidget [lucius|
+        form.#{formClass} {
+          max-width: min(30em,100%);
+          label {
+            display: block;
+            padding-top: 0.3em;
+            padding-bottom: 0.3em;
+          }
+          textarea {
+            width: 100%;
+            padding: 0.4em;
+            margin-top: 0.3em;
+            margin-bottom: 0.3em;
+          }
+          input {
+            width: 100%;
+            padding: 0.4em;
+            margin-top: 0.3em;
+            margin-bottom: 0.3em;
+            border-radius: 0.25em;
+          }
+          input:invalid {
+            border-color: #8a003a;
+          }
+          input[type="submit"] {
+            background-color: #00838a;
+            color: #ffffff;
+            padding: 0.5em 1em;
+            border: 0;
+            cursor: pointer;
+            font-weight: bold;
+          }
+          input[type="submit"]:hover {
+            background-color: #339ca1;
+          }
+        }
+    |]
+
+table' :: [Widget' a] -> [[Widget' a]] -> Widget' a
+table' header rows = do
+    tableClass <- newIdent
+    thClass <- newIdent
+    [whamlet|
+      <table .#{tableClass}>
+        <thead>
+          <tr>
+            $forall cell <- header
+              <th .#{thClass} scope="col">
+                ^{cell}
+      $forall row <- rows
+        <tr>
+          $forall cell <- row
+            <td>
+              ^{cell}
+    |]
+    toWidget [lucius|
+        table.#{tableClass} {
+          th[scope="col"].#{thClass} {
+            text-align: center;
+          }
+        }
+    |]
+
+table :: forall a site. ToTableRow site a => [a] -> Widget' site
+table rows = table' (tableHeader (undefined :: a)) (toCells <$> rows)
+
+class ToTableRow site a where
+    tableHeader :: a -> [Widget' site]
+    toCells :: a -> [Widget' site]

guix.scm

@@ -0,0 +1 @@
+.guix/modules/datarekisteri-package.scm

saku-laesvuori.key

@@ -1,52 +0,0 @@
------BEGIN PGP PUBLIC KEY BLOCK-----
-
-mQINBGCJJvcBEADEsx42OdBcdslRop/VYmEe/KMAEo5zN7mKapZeS8ZeR3dvgxUh
-3c4uIv8LoWHPbBdnslL8FhSzjxn7L11QOfLwzgdzoMqjVUJJaggvukhkjJXl5mja
-Yzta5/zmUGVgruHlsqFcJcnICnOgCCZDAVjSw/rTbkd2RN1oVte0b3MCZUv7A3Xi
-Z6yCrWL0yQikGIQi1CBvdTbca1aUMuhgpyaq1SCUfbe+oq4jc2mvnVsIZucDs48U
-ofayLDye0GsjOo2vyPRalBq1XhA1hoQYtfdqcENyiMAumfnzJ24ou+YRd2RXPKcc
-dy9FQrhL7hLwp+bewPXbrObgCiV2NyussShFe/m6C0A6RFBLSfG+dTFt4F/joWei
-yJmjt6FIRpHvTEjluvpn3ApO4JmlxBlTIUBcgJJp/UQ+IUSYEOAdoOw9RGn1sNG8
-uN++AvQXZZyFCMFrd1amJd6rjqVvIyc7DGyilmBF7os2p/iss+sQWdlAKuZQU6Zv
-xFR3Ltl+qhYNATSuKh9z7VdSiBLCJEHam4htdduwRroh5gXjQjAaLNPDihBLV46Q
-Oz3iI6gZbF3+QQy03hqXXc9W98tfd/nXgepD2S8SZPCmY3SY7JI9E98HGH7JiHeg
-cpOfK9Knn5NGfH92PyOjRnowvsNHLsR1VsmlNovk5wkNfRRPg5TBRDXcMQARAQAB
-tCJTYWt1IExhZXN2dW9yaSA8c2FrdUBsYWVzdnVvcmkuZmk+iQJXBBMBCgBBAhsD
-BQsJCAcCBhUKCQgLAgQWAgMBAh4BAheAAhkBFiEEoMkZR3NPB29fCOn/JX0oSiod
-OjIFAmJqq4oFCQUJZikACgkQJX0oSiodOjKG4hAAmhJK5M8BeSsV4lFWdps7xAwd
-jKiTJ+cYSsxK830J6XRrZsVMQ7hy8fHZmQ53maF8ZJS2EnA88vL9K/PiynjKoFA6
-1dRKBjFPP9/+zTUd5vAJ4bXN2YH666AXq+XKjHboS3gKbD4hT0RtlTe/kfXUP51g
-6UQgvyqM6vDuJBKJWez0dF98iB2RmU90GVVfLebZaSc1WDbiMKShgggtorGzmpj9
-GHuLyBYZX529vvG2K05bwJwtLajnD9oybOAhva/KSL0/Se6lCShlMekD4dvkBDrW
-/pYSpRY2lDgFZC1D3StiLIA1lRFgGkNyAD7fg5Bvme18tI9ywBQuWuZYkELPt7ns
-qgFw8GnKWo1SIPL1c6u/zTYCeyYtxdN0gLa4/dJOHeCwK4sA+FcJ1zd+WbWK1+LK
-4Zvf8r2+eo8NJCy0lWh+0ZdOAxkgDpxCGBOKTivvBI3p9rIPQYovP/xYongtmTKH
-vdwftOf3QIRbq2dD8EYCk06PCndUsVIqIUl9ilpfMxUVQoACLc8WxVm+bEStkWkK
-roXmsXiIBHZ6hRaxwY/CmG2rKUaFi8/o8E46COJpTNwaAbjX9Qd9e8NTtr+qooBN
-q08z0i0KHRbDdVmBIV8+VV++omB0RfFFCKXqKrA8jeXJVwzvWikcp6Im/rCD39JS
-4FtzEuqmi6IoXBhs3+u5Ag0EYIkm9wEQAL3qGd774FTzLFqjJICQWYisCBst07Tf
-4aVKRJEQZkKnWNOQzQltSa5nHRLVtdEvvbejK+Ci8/l2yI58PkqkbKlL9K/IRgHn
-8xqxWVcirbDZq32g5SI0zSa1B296o12TJrKGBSGBcAI0NRUaSUJmGy4HvIGdf8oV
-xqvNDKL4I2igf5Kj3mMOZzFjbOr17SUetF72W1w5BAqLWX32YVXnC/RHP7WRuFv7
-LLpsAHOgnInQ44BF8WQdxnliJr18Pz/kyW/otMsVq4OxNMwYTiRDqBmDNPZmLHTd
-thXvb41pI95Opk/th/8xc3+w1wAfcrx/vRccvfgr0nN4q4mqKAZSp4qJQocGF8xf
-JGc0CurTdQwQT2yWEmoVIqoQLTJOhX8NuC9JI/U8b2riRMcAVU37pzHWxUepsbH/
-rEVYbVSaSRLVKTNCOmDSvOtQ7LZBHvAoVGG7Zzoluqg0X2GqrdCyCaBdFBgWOlw8
-/2q+dR6JxMXcmSDxAJuZgI2oR4bTSXPbQT5ezqSq/71g2+CKw5me4KEOoZiuAVOS
-vMv05wU3/s3yJpCYK5OMsBgRaSWE7+QIQjr4+467/Bxo3mP5eIgKA6M67qT89TIK
-VSALA14mCnc991fW67ib9Y4Sx9ZtHvaYL5i6tZ143ShTfsfifpyoZt0LhA8CL3Ac
-W6wpqdgcIoWPABEBAAGJAjwEGAEKACYCGwwWIQSgyRlHc08Hb18I6f8lfShKKh06
-MgUCYmrqzQUJBQlmLAAKCRAlfShKKh06MuTGD/4/eMW3lg87nN1lJoQQgJExpbrU
-ulmyKpBhULh1cWVh1VmzLZVswZzh4qrNbd5rCNimKwL402ovvUEYGfup+YVvwtWb
-VmTvf4yc1R3LUP6pc0CofZGwkw/B4WOcQF/XkrNJELFmYkiYwAGvr25KDryv2MkS
-Y2NzkGppcSSu0xBYsRMb1OQyb7kExp3sYdzCVBdDn+mz5haAdYGHTCjvED71dYx4
-kMdy6bZwREctnjJ8JAW/WfySlmBysZ5ipcTjBF1MripGfbMOykNVm/c11gTD3ARd
-B4uFColsM4f2cihJxjFiQG4DjepC1prsMA2v0tIQ6/K4DTd0GOj2GMtbfjZqKCxE
-yhpXf7lSfi/YGxA9K2XscZZGJjrNA1Bm+JE4JxjGJb8tYarpOrRLLHByT0TmEjGa
-QvHZ3dNs1yMouH0vkwuAyf2bMKwI/dPqv4QwO5ICVJaiwClTSND8c2y8o3yUA6yy
-s6r7ku6/Yi185mmQqOjpNUJ/iJXPlGmh3VDxn54HNL7dbjjVhGQGbGDZfCy63VOH
-oO5BBurTYOXjvW0zxVBfjNoySF1Sk3gXeOI2hls+19lVRQwgOo1BrKamkVQ5D6Lr
-2qGpUBmeqo9xrONheCtJd+eZ4ml+2ILUjp8aD5NXI2Pb5nouU30NhsUmXDn7ehek
-+pSGh/BzjJxtn1qefg==
-=wMFC
------END PGP PUBLIC KEY BLOCK-----