├── .gitignore ├── .gitmodules ├── .travis.yml ├── .travis ├── build-cache.sh └── script.sh ├── FUTUREWORK.md ├── LICENSE ├── Makefile ├── README.md ├── docs ├── concepts │ ├── AcidPoly.lhs │ └── Exceptions.hs ├── dev-howtos.md ├── load_testing.md ├── messaging.md ├── release_management.md ├── styleguide.md ├── sybil.md ├── terminology.md └── thentos-captcha-README.md ├── misc ├── build-docs │ └── Doc.hs ├── bump-version.sh ├── release │ └── thentos-captcha-release.sh ├── selenium │ └── Makefile └── thentos-install.hs ├── refresh-i18n ├── LICENSE ├── Setup.hs ├── refresh-i18n.cabal └── src │ └── Main.hs ├── services └── helloworld │ ├── .ghci │ ├── .gitignore │ ├── devel.config │ ├── helloworld.cabal │ ├── src │ ├── Main.hs │ └── Site.hs │ └── static │ └── screen.css ├── stack.yaml ├── thentos-adhocracy ├── .gitignore ├── HLint.hs ├── LICENSE ├── Makefile ├── Setup.hs ├── devel.config ├── exec │ └── Main.hs ├── log │ └── .phony ├── src │ ├── Paths_thentos_adhocracy__.hs │ └── Thentos │ │ ├── Adhocracy3.hs │ │ └── Adhocracy3 │ │ ├── Action.hs │ │ ├── Action │ │ ├── Types.hs │ │ └── Unsafe.hs │ │ └── Backend │ │ ├── Api │ │ └── Simple.hs │ │ └── Core.hs ├── tests │ ├── Spec.hs │ └── Thentos │ │ └── Adhocracy3 │ │ └── Backend │ │ └── Api │ │ ├── ProxySpec.hs │ │ └── SimpleSpec.hs └── thentos-adhocracy.cabal ├── thentos-cookie-session ├── .gitignore ├── HLint.hs ├── LICENSE ├── LICENSE-AGPLv3 ├── Setup.hs ├── src │ ├── Control │ │ └── Monad │ │ │ └── Except │ │ │ └── Missing.hs │ ├── Servant │ │ └── Missing.hs │ └── Thentos │ │ ├── CookieSession.hs │ │ └── CookieSession │ │ ├── CSRF.hs │ │ └── Types.hs ├── test │ ├── Spec.hs │ └── Thentos │ │ └── CookieSessionSpec.hs └── thentos-cookie-session.cabal ├── thentos-core ├── .gitignore ├── HLint.hs ├── LICENSE ├── LICENSE-AGPLv3 ├── Makefile ├── Setup.hs ├── devel.config ├── exec │ ├── Captcha.hs │ ├── ImportA3Users.hs │ └── Main.hs ├── frontend │ └── static │ │ └── screen.css ├── log │ └── .phony ├── resources │ └── fonts │ │ ├── Courier_Prime.ttf │ │ ├── Courier_Prime_Bold.ttf │ │ ├── Courier_Prime_Bold_Italic.ttf │ │ ├── Courier_Prime_Italic.ttf │ │ └── LICENSE_INFO ├── schema │ ├── schema.sql │ └── wipe.sql ├── src │ ├── Database │ │ └── PostgreSQL │ │ │ └── Simple │ │ │ └── Missing.hs │ ├── LIO │ │ └── Missing.hs │ ├── Network │ │ └── HostAddr.hs │ ├── Paths │ │ └── TH.hs │ ├── Paths_thentos_core__.hs │ ├── System │ │ └── Log │ │ │ └── Missing.hs │ ├── Thentos.hs │ └── Thentos │ │ ├── Action.hs │ │ ├── Action │ │ ├── Core.hs │ │ ├── SimpleAuth.hs │ │ ├── TCB.hs │ │ ├── Types.hs │ │ └── Unsafe.hs │ │ ├── Backend │ │ ├── Api │ │ │ ├── Auth.hs │ │ │ ├── Auth │ │ │ │ └── Types.hs │ │ │ ├── Captcha.hs │ │ │ ├── Docs │ │ │ │ ├── Common.hs │ │ │ │ └── Proxy.hs │ │ │ ├── Proxy.hs │ │ │ ├── PureScript.hs │ │ │ └── Simple.hs │ │ └── Core.hs │ │ ├── Config.hs │ │ ├── Config │ │ └── Reader.hs │ │ ├── Ends │ │ └── Types.hs │ │ ├── Frontend.hs │ │ ├── Frontend │ │ ├── Handlers.hs │ │ ├── Handlers │ │ │ └── Combinators.hs │ │ ├── Pages.hs │ │ ├── Pages │ │ │ └── Core.hs │ │ ├── State.hs │ │ ├── TH.hs │ │ └── Types.hs │ │ ├── Prelude.hs │ │ ├── Smtp.hs │ │ ├── Sybil.hs │ │ ├── Sybil │ │ ├── AudioCaptcha.hs │ │ └── GraphicCaptcha.hs │ │ ├── Transaction.hs │ │ ├── Transaction │ │ └── Core.hs │ │ ├── Types.hs │ │ └── Util.hs └── thentos-core.cabal ├── thentos-purescript ├── bower.json ├── build.sh ├── gulpfile.js ├── package.json ├── src │ ├── Counter.purs │ ├── Error.js │ ├── Error.purs │ ├── I18n.js │ ├── I18n.purs │ ├── I18n │ │ └── Lang.purs │ ├── IFramesDemo.js │ ├── IFramesDemo.purs │ ├── LoginIndicator.purs │ ├── Main.js │ ├── Main.purs │ ├── Register.js │ ├── Register.purs │ ├── Servant │ │ └── Simple.purs │ ├── Util.js │ └── Util.purs └── static │ ├── a3.css │ ├── a3.css.map │ ├── app.js │ ├── frames.html │ ├── frames.js │ ├── frames1.html │ ├── frames2.html │ ├── index.html │ ├── register.html │ ├── register.js │ └── thentos.css └── thentos-tests ├── .gitignore ├── HLint.hs ├── LICENSE ├── Makefile ├── Setup.hs ├── bench └── Main.hs ├── src └── Thentos │ └── Test │ ├── Arbitrary.hs │ ├── Config.hs │ ├── Core.hs │ ├── DefaultSpec.hs │ ├── Network.hs │ ├── Transaction.hs │ └── WebDriver │ └── Missing.hs ├── tests ├── Network │ └── HostAddrSpec.hs ├── Spec.hs └── Thentos │ ├── Action │ └── SimpleAuthSpec.hs │ ├── ActionSpec.hs │ ├── Backend │ └── Api │ │ ├── CaptchaSpec.hs │ │ ├── PureScriptSpec.hs │ │ └── SimpleSpec.hs │ ├── Frontend │ ├── Handlers │ │ └── CombinatorsSpec.hs │ └── StateSpec.hs │ ├── FrontendSpec.hs │ ├── Sybil │ └── CaptchaSpec.hs │ ├── TransactionSpec.hs │ ├── TypesSpec.hs │ └── UtilSpec.hs └── thentos-tests.cabal /.gitignore: -------------------------------------------------------------------------------- 1 | *~ 2 | *.o 3 | *.hi 4 | *.dyn_o 5 | *.dyn_hi 6 | *.swp 7 | *.tix 8 | .cabal-sandbox/ 9 | cabal.sandbox.config 10 | *packages.conf.d/ 11 | packages/ 12 | .stack-work 13 | add-source-timestamps 14 | misc/selenium/log 15 | misc/selenium/*.jar 16 | misc/selenium/C:* 17 | .vim.custom 18 | bower_components/ 19 | node_modules/ 20 | output/ 21 | .psci* 22 | log/*.log 23 | thentos-purescript/.browserify-cache.json 24 | thentos-purescript/static/thentos.js 25 | -------------------------------------------------------------------------------- /.gitmodules: -------------------------------------------------------------------------------- 1 | [submodule "submodules/pronk"] 2 | path = submodules/pronk 3 | url = https://github.com/liqd/pronk.git 4 | branch = thentos-patches 5 | ignore = dirty 6 | -------------------------------------------------------------------------------- /.travis.yml: -------------------------------------------------------------------------------- 1 | # We use --force-reinstalls to allow caching. If this causes problems, go to 2 | # https://travis-ci.org/liqd/thentos/caches to invalidate the cache. 3 | 4 | language: c 5 | 6 | sudo: false 7 | 8 | cache: 9 | directories: 10 | - $HOME/build/liqd/thentos/.cabal-sandbox 11 | - $HOME/.cabal 12 | - $HOME/.nvm 13 | - $HOME/.th-psc-cache 14 | 15 | addons: 16 | apt: 17 | sources: 18 | - hvr-ghc 19 | packages: 20 | - ghc-7.10.2 21 | - happy-1.19.3 22 | - alex-3.1.4 23 | - cabal-install-1.22 24 | - xvfb 25 | - espeak 26 | - sox 27 | - hlint 28 | 29 | before_install: 30 | - grep '\(MemTotal\|SwapTotal\)' /proc/meminfo 31 | - git show | head -1 # (for matching against commit hash given on the travis log web page) 32 | - export PATH=/opt/ghc/7.10.2/bin:/opt/alex/3.1.4/bin:/opt/happy/1.19.3/bin:/opt/cabal/1.22/bin:$PATH 33 | - export PATH=~/.cabal/bin:$PATH 34 | - cd misc/selenium 35 | - "export DISPLAY=:1" 36 | - make init xvfb start 37 | - cd ../.. 38 | 39 | script: 40 | - ./.travis/script.sh 41 | -------------------------------------------------------------------------------- /.travis/build-cache.sh: -------------------------------------------------------------------------------- 1 | #!/bin/bash 2 | 3 | test "`pwd`" == "/home/travis/build/liqd/thentos" || exit 2 4 | 5 | # clone this repo to /home/travis/build/liqd/thentos, and run this script 6 | # from there like this: 7 | # 8 | # ./.travis/build-cache.sh 9 | # 10 | # WARNING: THIS SCRIPT IS NOT TESTED VERY THOROUGHLY! 11 | 12 | cabal update 13 | cabal sandbox delete 14 | cabal sandbox init 15 | time cabal install \ 16 | --dependencies-only --enable-tests --disable-documentation \ 17 | || exit 1 18 | 19 | time cabal install hlint || exit 1 20 | 21 | time tar cvpJf new-cache.tar.xz .cabal-sandbox || exit 1 22 | 23 | echo 'now move /home/travis/build/liqd/thentos/new-cache.tar.xz to where travis can find it.' 24 | -------------------------------------------------------------------------------- /.travis/script.sh: -------------------------------------------------------------------------------- 1 | #!/bin/bash 2 | 3 | # terminate this script after $TIMEOUT minutes so that travis updates 4 | # the cache before failing. 5 | TIMEOUT=$[2*60-5] 6 | THIS_PID=$$ 7 | ( sleep $[$TIMEOUT*60] ; kill $THIS_PID ) & 8 | 9 | # The container reports 16 cores (when it only has 1.5), and a higher 10 | # number may result in slower builds. So we comment out the relevant line 11 | # the config file 12 | sed -i 's/^jobs:/-- jobs:/' ${HOME}/.cabal/config 13 | 14 | cabal update 15 | ./misc/thentos-install.hs -c "--force-reinstalls" -t -p 16 | -------------------------------------------------------------------------------- /FUTUREWORK.md: -------------------------------------------------------------------------------- 1 | # Intro 2 | 3 | This file collects feature plans and half-done or un-done code 4 | fragments to be kept out of master (as well as the issue tracker) 5 | because there is no requirement for them yet. Hopefully, this will be 6 | useful as reference in the future. 7 | 8 | 9 | # List ot things 10 | 11 | - github single-sign-on (sso) 12 | git checkout 2015-09-28-github-sso 13 | 14 | - a system for public-key certification. this could be used by 15 | services that aim at full, server-less distribution with 16 | pseudonymous identities. the identities could be sybil attack 17 | proof, because you can only get exactly one for every qualified 18 | thentos user you control. and they could be highly anonymous if we 19 | manage to weave in blind signature schemes intelligently. 20 | 21 | - https://hacks.mozilla.org/2015/09/subresource-integrity-in-firefox-43/ 22 | 23 | - https://github.com/bitc/purescript-bundle-fast (better compilation 24 | time for purescript?) 25 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Thentos: A tool for privacy-preserving identity management 2 | Copyright (C) 2015-2019 liquid democracy e.V. 3 | 4 | This program is free software: you can redistribute it and/or modify 5 | it under the terms of the GNU Affero General Public License as 6 | published by the Free Software Foundation, either version 3 of the 7 | License, or (at your option) any later version. 8 | 9 | This program is distributed in the hope that it will be useful, 10 | but WITHOUT ANY WARRANTY; without even the implied warranty of 11 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 12 | GNU Affero General Public License for more details. 13 | 14 | You should have received a copy of the GNU Affero General Public License 15 | along with this program. If not, see . 16 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | SHELL=/bin/bash 2 | 3 | .phony: 4 | 5 | wc: .phony 6 | find thentos-core/{src,exec} -name '*.hs' | xargs wc 7 | find thentos-tests/{tests,bench} -name '*.hs' | xargs wc 8 | find thentos-adhocracy/{src,exec,tests} -name '*.hs' | xargs wc 9 | find services/helloworld/src -name '*.hs' | xargs wc 10 | 11 | clean: .phony 12 | find thentos-*/ -name '*~' -exec rm -f {} \; 13 | find thentos-*/ -name '*.o' -exec rm -f {} \; 14 | find thentos-*/ -name '*.hi' -exec rm -f {} \; 15 | find thentos-*/ -name '*.dyn_o' -exec rm -f {} \; 16 | find thentos-*/ -name '*.dyn_hi' -exec rm -f {} \; 17 | 18 | 19 | # weed out dead library dependencies. 20 | 21 | build-packunused: .phony 22 | cabal get packunused || (echo "rm stale copy of packunused?"; false) 23 | cd packunused-* && \ 24 | cabal sandbox init --sandbox=../.cabal-sandbox && \ 25 | cabal install packunused --constraint="Cabal==`cabal --version | perl -ne '/using version (.*) of the Cabal library/ && print $$1'`" 26 | 27 | %.packunused: .phony 28 | @echo 29 | @echo '| make build-packunused first to ensure freshness of executable.' 30 | @echo '| (See https://github.com/hvr/packunused/issues/5.)' 31 | @echo '|' 32 | @echo '| WARNING: packunused on hspec-discover tests cannot see Spec modules' 33 | @echo '| and will issue spurious warnings about unused libs!' 34 | @echo 35 | 36 | cd $* && \ 37 | ../.cabal-sandbox/bin/packunused --help >/dev/null && \ 38 | cabal clean && \ 39 | rm -f *.imports && \ 40 | cabal configure -O0 --disable-library-profiling --enable-test --enable-bench && \ 41 | cabal build --ghc-option=-ddump-minimal-imports && \ 42 | ../.cabal-sandbox/bin/packunused 43 | 44 | packunused: .phony thentos-core.packunused thentos-tests.packunused thentos-adhocracy.packunused 45 | 46 | 47 | # hlint 48 | 49 | hlint: .phony thentos-core.hlint thentos-tests.hlint thentos-adhocracy.hlint 50 | 51 | %.hlint: .phony 52 | cd $* && make hlint 53 | 54 | 55 | # sensei / seito 56 | 57 | # ABSTRACT: a ghcid-based method for running the test suite blindingly 58 | # fast rather than just the type checker painfully slowly. 59 | # 60 | # QUICK INTRO: you need to install https://github.com/hspec/sensei 61 | # first. run 'make sensei' in a new terminal at the beginning of your 62 | # session and keep it running. it will re-run the test suite every 63 | # time something changes, or if you hit 'return'. you can also run 64 | # 'make seito' to print the last test run to stdout. (this is most 65 | # useful if you want to integrate sensei into your editor/ide.) 66 | # 67 | # OTHER PACKAGES: sensei does not watch other packages (for deeper 68 | # reasons). in order to be able to react to changes to the core from 69 | # the test suite, these make rules drop thentos-core and thentos-test 70 | # from the package database and add their source trees to the list of 71 | # watched files. 72 | # 73 | # NOTE: if you want to work with package thentos-adhocracy, these 74 | # rules need to be updated! 75 | # 76 | # OPTIMIZATION: for optimal results, you will want to invoke sensei 77 | # with the '--match' argument. hspec arguments can be passed to 'make 78 | # sensei' via the SENSEI_ARGS shell variable. see sensei and hspec 79 | # docs for details. 80 | 81 | prepare-repl: .phony 82 | @echo $(SENSEI_ARGS) 83 | cabal sandbox hc-pkg -- unregister --force thentos-adhocracy || true 84 | cabal sandbox hc-pkg -- unregister --force thentos-tests || true 85 | cabal sandbox hc-pkg -- unregister --force thentos-core || true 86 | cd thentos-adhocracy && cabal clean 87 | cd thentos-tests && cabal clean 88 | cd thentos-core && cabal clean 89 | 90 | SOURCE_PATHS=-i./thentos-core/src/ -i./thentos-tests/src/ -i./thentos-tests/tests/ -i./thentos-adhocracy/src/ -i./thentos-adhocracy/tests/ 91 | 92 | sensei: sensei-tests 93 | sensei-tests: ./thentos-tests/tests/Spec.hs.sensei 94 | sensei-adhocracy: ./thentos-adhocracy/tests/Spec.hs.sensei 95 | 96 | %.sensei: .phony prepare-repl 97 | cabal exec -- sensei $(SOURCE_PATHS) -optP-DDEVELOPMENT -ignore-dot-ghci $* $(SENSEI_ARGS) 98 | 99 | seito: .phony 100 | sleep 0.2 && seito 101 | 102 | repl: ./thentos-core/src/Thentos.hs.repl 103 | 104 | %.repl: .phony prepare-repl 105 | cabal exec -- ghci $(SOURCE_PATHS) -optP-DDEVELOPMENT -ignore-dot-ghci $* 106 | -------------------------------------------------------------------------------- /docs/concepts/Exceptions.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts #-} 2 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 3 | {-# LANGUAGE DeriveFunctor #-} 4 | 5 | module Main where 6 | 7 | import Control.Applicative 8 | import Control.Monad.Except 9 | import Control.Monad.Identity 10 | import Control.Monad.State 11 | 12 | throwError' :: (MonadState s m, MonadError (s, e) m) => e -> m a 13 | throwError' e = do 14 | s <- get 15 | throwError (s, e) 16 | 17 | -- s -> Either String (a, s) 18 | newtype SE a = SE (StateT Int (ExceptT String Identity) a) 19 | deriving (Functor, Applicative, Monad, MonadState Int, MonadError String) 20 | 21 | -- s -> (Either String a, s) 22 | newtype ES a = ES (ExceptT String (StateT Int Identity) a) 23 | deriving (Functor, Applicative, Monad, MonadState Int, MonadError String) 24 | 25 | sample :: (MonadState Int m, MonadError String m) => m Int 26 | sample = do 27 | put 42 28 | catchError (modify (+1) >> throwError "Foo") (const $ modify (*2)) 29 | get 30 | 31 | runSE :: SE a -> Either String a 32 | runSE (SE m) = runIdentity (runExceptT (flip evalStateT 0 m)) 33 | 34 | runES :: ES a -> Either String a 35 | runES (ES m) = runIdentity (flip evalStateT 0 (runExceptT m)) 36 | 37 | -- What is the value of "runSE sample" and "runES sample", resp.? 38 | 39 | -- runSE sample == Right 84 40 | -- runES sample == Right 86 41 | 42 | -- In the first line, the state is "reset", but not to 0, but to the value before 'catchError' was 43 | -- entered. 44 | -------------------------------------------------------------------------------- /docs/load_testing.md: -------------------------------------------------------------------------------- 1 | # Load Testing 2 | 3 | You can find a working version of the pronk load testing tool at 4 | 5 | https://github.com/liqd/pronk/tree/thentos-patches 6 | 7 | Example usage: 8 | 9 | ```bash 10 | pronk "http://localhost:7002/login" -n 10000 -c 300 11 | ``` 12 | 13 | 10000 is the total number of requests and 300 is the number of concurrent 14 | requests. 15 | 16 | -------------------------------------------------------------------------------- /docs/messaging.md: -------------------------------------------------------------------------------- 1 | # Messaging API 2 | 3 | See also issue #472. 4 | 5 | ## Messaging Request 6 | 7 | Services (such as A3) can use Thentos to send messages to users or arbitrary 8 | email addresses. To send a message, the service sends a POST request with 9 | JSON payload to the `THENTOS_URL/email` endpoint. The payload must be a 10 | JSON object with the following required fields: 11 | 12 | * subject: the subject of the message 13 | * body: the plain-text body of the message 14 | * recipient: a JSON object described thereafter 15 | 16 | The following field is optional: 17 | 18 | * html: the HTML-formatted body of the message 19 | 20 | The recipient is a JSON object with the following optional fields: 21 | 22 | * personas: a list of strings where each string is the user 23 | path of a user. The message will be sent to each of these users. 24 | Implementation note: *users* in a service (such as A3) are *personas* in 25 | Thentos. In Thentos, a service's notation of a user path is stored as 26 | *ExternalUrl* of the persona. 27 | * emails: a list of strings where each string is an email address. 28 | The message will be sent to each of these addresses. A single 29 | string value containing one email address is also accepted. 30 | * groups: a list of strings where each string is a group of personas 31 | (called *ServiceGroup* in Thentos). The message will be sent to 32 | every member of the group, including the members of the sub-groups 33 | and so recursively. 34 | 35 | ## Messaging Reply 36 | 37 | If Thentos could successfully send all emails, it replies with status 38 | 204 OK and thus no payload. 39 | 40 | If the request was malformed, it replies with status 400 Bad Request and an 41 | error description in JSON format. FIXME Document the typical/expected cases. 42 | 43 | Services need to run on a privileged IP in order to be able to send 44 | messages. By default, only localhost is privileged, but that can be changed 45 | by modifying the Thentos config setting called `allow_ips`. If 46 | somebody from a non-privileged IP address sends a POST request to the `message` 47 | endpoint, Thentos replies with 401 Unauthorized. 48 | 49 | If the messages could not be sent due to some internal problem not caused 50 | by the sender, Thentos replies with 500 Internal Server Error. 51 | 52 | FIXME: if the error lies beyond thentos in the smtp world, i'm not 53 | sure 500 is the right one. perhaps then it depends on the smtp error? 54 | 55 | ## Duplicate Handling 56 | 57 | Thentos makes sure that a message is sent at most once to each user. 58 | 59 | If one recipient is listed more than once (either directly or via 60 | different personas belonging to the same user, or groups that the same 61 | user is a member of), the email is only sent once. This behavior 62 | guarantees that the service does not learn about which personas belong 63 | to the same user. 64 | -------------------------------------------------------------------------------- /docs/release_management.md: -------------------------------------------------------------------------------- 1 | # Release Strategy 2 | 3 | This document is most relevant for maintainers. 4 | 5 | 6 | ## Versioning 7 | 8 | Update versions with `./misc/bump-version.sh`. The script makes sure 9 | that cabal files (package versions and dependencies) and git tags are 10 | all in sync. It also prints information on how to publish a new 11 | release. 12 | 13 | The version name must obey these rules: 14 | 15 | 1. Follow the [Haskell 16 | PVP](https://wiki.haskell.org/Package_versioning_policy). 17 | 18 | 2. All release versions have the form `A.B.C`; new B-level or A-level 19 | releases start with zeroz (2.8.0, 3.0.0). 20 | 21 | 3. Every release is tagged in git like this: `git tag v0.0.1`. 22 | 23 | 4. If version `1.8.1` has been released, and then `1.7.3` needs a 24 | bugfix release `1.7.4`: start a git branch named `v1.7.3`, 25 | add commits until satisfied, tag the release commit, and leave it 26 | on that branch. 27 | 28 | 29 | ## Binary release distribution 30 | 31 | `./misc/release/` contains scripts for building release tar balls from 32 | tagged and uploaded releases. See shell code for the specifics. 33 | 34 | We use github for distributing binary release tarballs once created. 35 | To be specific: 36 | 37 | 1. Push the new release commit and tag as instructed in the output of 38 | `./misc/bump-version.sh`. 39 | 40 | 2. Visit https://github.com/liqd/thentos/releases/ 41 | 42 | 3. Click on `Draft new release`. 43 | 44 | 4. Name tag of new release in the corresponding field; fill in the 45 | details. 46 | 47 | 5. Attach tar.xz and hash files. 48 | 49 | 6. Click on `Publish release`. 50 | 51 | See https://help.github.com/articles/about-releases/ for further info. 52 | -------------------------------------------------------------------------------- /docs/styleguide.md: -------------------------------------------------------------------------------- 1 | # List of programming style rules 2 | 3 | where no other rules apply, https://github.com/tibbe/haskell-style-guide/blob/master/haskell-style.md holds. 4 | 5 | (Will be re-structured as it grows.) 6 | 7 | 8 | ## Changing the rules 9 | 10 | If you are contributing to the code under this policy document, or 11 | plan to contribute, but don't like any of the rules, you please send 12 | us a pull request with a change. The pull request can then be 13 | discussed, and if an agreement can be reached, the change will come 14 | into effect. 15 | 16 | 17 | ## Source comment keywords 18 | 19 | We use the following greppable keywords in the source code with the 20 | resp. specific meaning: 21 | 22 | - *TODO*: note to self to developer currently working on this piece of 23 | code. to be fixed before merge. should never appear in master. 24 | - *FIXME*: this code is not elegant, but it is believed to work. 25 | FIXME comments may appear on master and can be fixed, removed, or 26 | ignored indefinitely without causing production issues. 27 | - *FUTUREWORK*: a less urgent sibling of *FIXME*. 28 | - *UPSTREAM*: could benefit from some work on the libraries we depend 29 | on. one common example for this are: `*.Missing` modules. 30 | 31 | 32 | ## Testing 33 | 34 | ### HLint 35 | 36 | There is an hlint rule in the Makefile, and an associated customization 37 | file HLint.hs. This implements some elements of the automatable part of 38 | the coding policy. 39 | 40 | 41 | ### hspec module names 42 | 43 | For each file of the form `src/*.hs`, there may be a file called 44 | `tests/*Spec.hs` that contains tests for the code in this file. These 45 | are automatically collected by hspec-discover. 46 | 47 | Other test modules, or tests for code from unassociated production 48 | modules, are only allowed if there are good reasons. These reasons 49 | must be documented in the module's haddock comment. 50 | 51 | 52 | ## Imports 53 | 54 | Import statements are sorted in up to four groups. Imports within each 55 | group should be sorted alphabetically and groups should be separated by a 56 | single line. 57 | 58 | 1. Explicit unqualified imports from third-party modules (including the 59 | base library). Imported functions and types **must** be listed 60 | explicitly. 61 | 2. Qualified imports from third-party modules. Rename them using, 62 | preferably, the name of the module (without path). If that would result 63 | in a non-descriptive name such as `Strict`, use an earlier part of the 64 | full name (see the `Map` and `URI` samples below). Import Text and 65 | ByteString modules using the names defined in the string-conversions 66 | package (`SBS, LBS, ST, LT`). It's OK to rename several related modules 67 | to the same name if their definitions don't overlap (see the `Aeson` 68 | example below). Other abbreviations should generally be avoided. 69 | 3. Unqualified imports from Thentos. It's OK to omit the explicit import 70 | list in this case. 71 | 4. Qualified imports from Thentos. Here it's acceptable to use 72 | abbreviations (typically one or two letters) when renaming them. 73 | 74 | ```haskell 75 | import Control.Monad (unless) 76 | import Data.String.Conversions (SBS, ST, cs) 77 | import Text.Show.Pretty (ppShow) 78 | 79 | import qualified Data.Aeson as Aeson 80 | import qualified Data.Aeson.Types as Aeson 81 | import qualified Data.ByteString as SBS 82 | import qualified Data.Map.Strict as Map 83 | import qualified Data.Text as ST 84 | import qualified Data.Thyme as Thyme 85 | import qualified URI.ByteString as URI 86 | 87 | import Thentos.Action.Core 88 | import Thentos.Config 89 | import Thentos.Types 90 | 91 | import qualified Thentos.Frontend.Handlers as H 92 | import qualified Thentos.Frontend.Pages as P 93 | ``` 94 | 95 | 96 | ## Naming 97 | 98 | Acronyms in names are camelized. For instance: `ThreadId`, not 99 | `ThreadID`; `Thentos.Db` and `Thentos.Smtp`, not `DB` or `SMTP`. 100 | 101 | Names for `Either` values start with an `e` (example: `eSession`). 102 | Analogously, `Maybe` value names start with an `m`. 103 | 104 | 105 | ## String types 106 | 107 | Type synonyms SBS, LBS, ST, LT from string-conversions are used in type 108 | signatures (even if no strings are converted). 109 | 110 | 111 | ### Rationale 112 | 113 | Commonly used types like `Text` and `ByteString` are ambiguous (strict 114 | or lazy). Also, these short cuts follow a logical pattern, are very 115 | compact, and occur often enough in this code base (and in every other 116 | that makes use of `string-conversions`, such as e.g. `servant`) for 117 | even occasional readers to get used to them. Also, these type 118 | synonyms match the module names that they are from. 119 | 120 | 121 | ## Layout 122 | 123 | Maximum line length is 100 chars. 124 | 125 | Precede haddock section headings with two empty lines. Succeed with 126 | one empty line. 127 | 128 | Spacing in lambda: `\x -> ...`; NOT: `\ x -> ...`. 129 | -------------------------------------------------------------------------------- /docs/sybil.md: -------------------------------------------------------------------------------- 1 | 2 | 3 | # STATUS OF THIS DOCUMENT 4 | 5 | DRAFT. NOT ALL FEATURES MENTIONED ARE FULLY IMPLEMENTED. 6 | 7 | 8 | # Sybil attack countermeasures 9 | 10 | A Sybil attack is an attempt of a user to appear as more than one 11 | physical person. This document explains how you can use thentos to 12 | counter such attacks. 13 | 14 | 15 | ## Captchas 16 | 17 | Captchas are a tool for a web server to distinguish an algorithm from 18 | a human. This is not directly a sybil attack countermeasure (the same 19 | human will still be a human if she registers twice), but some sybil 20 | attacks are launched by bot nets. 21 | 22 | Even when facing a botnet, captchas are only a weak protection, 23 | though. First of all, there is an arms race for algorithms that 24 | create challenges that humans are better at solving than machines on 25 | the one hand, and algorithms that solve these challenges better than 26 | humans in the end. 27 | 28 | But worse, there is a market for the service of solving captchas for 29 | 10ct each or less (example: www.deathbycaptcha.com/). Companies that 30 | operate in this market can operate seemingly unrelated web sites on 31 | which they present the captchas they receive to their unsuspecting 32 | users. So the solutions offered by these services are both 33 | indistinguishable in principle from those offered by honest users, and 34 | not more expensive (as the users often do not have to be paid). 35 | 36 | Captchas are weak beyond rescue against even moderatly sophisticated 37 | attackers. The hope is that many attackers in the wild still fall 38 | short of that threshold. (Traffic analysis should help you to draw 39 | your own conclusions there.) 40 | 41 | We have deliberately chosen to not rely on google's recaptcha. It 42 | collects IP addresses of all your users, and the javascript code that 43 | it loads into your browser is obfuscated and may generate additional 44 | data traces now or in the future. Furthermore, even though it is 45 | probably slightly harder to crack than our built-in solution, there is 46 | no price difference for those who decide to counter Captcha security 47 | between the two. 48 | 49 | 50 | ## Looking for patterns in registration traffic and blacklists 51 | 52 | If, say, there are hundreds of emails creating accounts on the same 53 | afternoon, and they all have the form `anon@yahoo.com`, 54 | then something is probably going wrong. 55 | 56 | Thentos allows to download tables of the following form via rest 57 | (end-point /analytics/sybil), filtered by time windows: 58 | 59 | 1. given user name 60 | 2. email 61 | 3. timestamp 62 | 63 | The end-point supports content types text/csv and application/json; 64 | the analysis happens off-line with either office or scripting tools of 65 | your choice. 66 | 67 | If the analyst decides that there is a sybil attack, there two 68 | countermeasures are supported: 69 | 70 | 1. you can upload a blacklist of email addresses that are not 71 | accepted for user registration. registration attempts from 72 | addresses on any list are silently dropped on the floor. (this 73 | comes at the risk of fending off legitimate users, with all the 74 | usual implications of bad PR, smaller user base, and higher 75 | support costs. use this tool carefully!) 76 | blacklists can be csv or json. in the latter case, they 77 | consist of only one row per email address. `*` means *any 78 | sequence of characters or nothing*. if two blacklists are 79 | uploaded, the second one deletes the first one; to remove any 80 | blacklists, upload an empty blacklist. *end-point: 81 | /blacklist/register* 82 | 2. registration can be disallowed completely; either indefinitely 83 | (to be manually re-enabled), or for a pre-set time interval in 84 | hours or minutes. *end-point: /blacklist/register/global* 85 | 86 | A web UI for managing analytics and blacklists is intended, but not 87 | scheduled for implementation yet. 88 | 89 | 90 | ## Other approaches (future work) 91 | 92 | - bitcoin-style proof of work (could be done in browser; bad UX) 93 | - sms/tan authentication 94 | - paper letter with tan to residential address 95 | - post-ident 96 | - leveraging payment systems for proof of identity 97 | -------------------------------------------------------------------------------- /docs/thentos-captcha-README.md: -------------------------------------------------------------------------------- 1 | # Thentos Captcha 2 | 3 | Web service that serves captcha images and sounds and verifies captcha solutions. 4 | 5 | ## Install 6 | 7 | apt-get install postgresql-client espeak libgmp10 8 | 9 | ## Configure 10 | 11 | The relavent sections in `thentos-captcha.config` are: `frontend`, `backend`, `log`, and `database`. 12 | 13 | ## Run 14 | 15 | ./thentos-captcha --config path/to/thentos-captcha.config 16 | -------------------------------------------------------------------------------- /misc/build-docs/Doc.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | {-# LANGUAGE ScopedTypeVariables #-} 4 | {-# LANGUAGE ViewPatterns #-} 5 | 6 | -- | To generate and publish new docs, make sure your working copy is clean, chdir to the root of 7 | -- the git repo, and do this: 8 | -- 9 | -- >>> ./misc/thentos-install.hs 10 | -- >>> cabal exec -- ghc --make -main-is Doc misc/build-docs/Doc.hs 11 | -- >>> git checkout gh-pages 12 | -- >>> misc/build-docs/Doc 13 | -- 14 | -- Then inspect the diff, and add/commit in order to publish if happy. 15 | module Doc 16 | where 17 | 18 | import Control.Monad (void) 19 | import Data.Char (toUpper) 20 | import Data.Proxy (Proxy(Proxy)) 21 | import Data.String.Conversions (ST, (<>), cs) 22 | import Servant.Docs (markdown) 23 | import System.Directory (createDirectoryIfMissing) 24 | import System.FilePath ((), (<.>)) 25 | import System.IO (hGetContents) 26 | import System.Process (runInteractiveCommand, system) 27 | 28 | import qualified Data.Text as ST 29 | import qualified Data.Text.IO as ST 30 | import qualified Thentos.Adhocracy3.Backend.Api.Simple as A 31 | import qualified Thentos.Backend.Api.Docs.Common as TD 32 | import qualified Thentos.Backend.Api.Simple as S 33 | 34 | 35 | main :: IO () 36 | main = 37 | do 38 | assertGitBranch "gh-pages" 39 | putStrLn "Generating documentation and client code..." 40 | 41 | writeDocs "core" (Proxy :: Proxy (TD.RestDocs S.Api)) 42 | writeDocs "adhocracy3" (Proxy :: Proxy (TD.RestDocs A.Api)) 43 | 44 | 45 | writeDocs :: forall api. TD.HasFullDocExtras api => FilePath -> Proxy (TD.RestDocs api) -> IO () 46 | writeDocs stem proxy = do 47 | let path = "./gh-pages/servant-docs" 48 | 49 | createDirectoryIfMissing True path 50 | writeFile (path stem <.> "md") . markdown $ TD.restDocsMd proxy 51 | void . system $ "pandoc " ++ (path stem <.> "md") ++ " -o " ++ (path stem <.> "html") 52 | void . system $ "pandoc " ++ (path stem <.> "md") ++ " -o " ++ (path stem <.> "docx") 53 | 54 | let path' = path "client-code" 55 | proxy' :: Proxy api = Proxy 56 | 57 | createDirectoryIfMissing True path' 58 | let fp = path' stem <> "_vanilla" <.> "js" 59 | in ST.writeFile fp $ TD.restDocsJs proxy 60 | let fp = path' stem <> "_ng" <.> "js" 61 | in ST.writeFile fp $ TD.restDocsNg proxy 62 | 63 | let fp :: FilePath = path' cs moduleName <.> "purs" 64 | moduleName :: ST = capitalise $ cs stem 65 | in ST.writeFile fp $ TD.restDocsPurs proxy moduleName 66 | 67 | 68 | -- | this is defined in servant-foreign, but not exported as of today. watch 69 | -- https://github.com/haskell-servant/servant/pull/265. 70 | capitalise :: ST -> ST 71 | capitalise "" = "" 72 | capitalise name = toUpper (ST.head name) `ST.cons` ST.tail name 73 | 74 | 75 | assertGitBranch :: String -> IO () 76 | assertGitBranch branch = isCurrentGitBranch branch >>= \b -> if b 77 | then return () 78 | else error $ "assertGitBranch: not on " ++ show branch 79 | 80 | isCurrentGitBranch :: String -> IO Bool 81 | isCurrentGitBranch (("On branch " <>) -> pattern) = do 82 | (_, o, _, _) <- runInteractiveCommand "git status" 83 | ((pattern `elem`) . lines) <$> hGetContents o 84 | -------------------------------------------------------------------------------- /misc/bump-version.sh: -------------------------------------------------------------------------------- 1 | #!/bin/bash 2 | 3 | set -e 4 | cd `dirname $0`/.. 5 | export NEW_VERSION="$1" 6 | 7 | test -z "$NEW_VERSION" && ( echo "Please provide a version number to move to."; exit 1 ) 8 | git tag -l | grep -q v$NEW_VERSION && ( echo "git tag for $NEW_VERSION already exists."; exit 1 ) 9 | 10 | for f in thentos-{cookie-session,core,tests,adhocracy}/thentos-*.cabal; do 11 | perl -i -pe 's/^(version:\s*).*$/${1}'"$NEW_VERSION"'/' $f 12 | perl -i -pe 's/^(\s*, thentos-[-a-z]+ ).*$/${1}=='"$NEW_VERSION"'/' $f 13 | git add $f 14 | done 15 | 16 | git commit -m 'Release '"$NEW_VERSION"'.' 17 | git tag v$NEW_VERSION 18 | 19 | echo "created new commit and tag." 20 | echo "to inspect: git show; git tag -l" 21 | echo "to push: git push; git push --tags" 22 | -------------------------------------------------------------------------------- /misc/release/thentos-captcha-release.sh: -------------------------------------------------------------------------------- 1 | #!/bin/bash 2 | 3 | # release.sh 4 | # 5 | # Build a Thentos binary release. 6 | # 7 | # Command line arguments: 8 | # 9 | # [git ref name to release] 10 | # 11 | 12 | 13 | set -e 14 | 15 | if [ -z "$1" ]; then 16 | echo "Please provide a git reference name for release" 17 | exit 1 18 | fi 19 | 20 | cd `dirname $0`/../.. 21 | 22 | if ! git show-ref $1 >> /dev/null; then 23 | echo "\"$1\" is not a valid git reference" 24 | exit 1 25 | fi 26 | 27 | if [ ! -f cabal.sandbox.config ]; then 28 | echo "cabal.sandbox.config not found" 29 | exit 1 30 | fi 31 | 32 | relname=thentos-captcha-$1 33 | tarxz=$relname.`uname -m`.tar.xz 34 | tmpdir=`mktemp -d` 35 | gitdir=`pwd` 36 | cabal_sandbox=`cat cabal.sandbox.config | grep '^ *prefix' | awk -F ' ' '{print $2}'` 37 | 38 | echo -e "\n\n\n" 39 | echo "git ref: $1" 40 | echo "release file: $tarxz" 41 | echo "build path: `pwd`" 42 | echo -e "\n\n\n" 43 | 44 | pushd $tmpdir 45 | 46 | # clone and build 47 | git clone --reference $gitdir --branch $1 $gitdir 48 | cd thentos 49 | cabal sandbox init --sandbox=$cabal_sandbox 50 | ./misc/thentos-install.hs -p 51 | cd .. 52 | 53 | # collect files 54 | mkdir $relname 55 | cd $relname 56 | cp $cabal_sandbox/bin/thentos-captcha . 57 | cp -r ../thentos/thentos-core/schema . 58 | cp -r ../thentos/thentos-core/resources . 59 | cp ../thentos/docs/thentos-captcha-README.md README.md 60 | cp ../thentos/thentos-core/devel.config thentos-captcha.config 61 | cd .. 62 | 63 | # build package, cleanup, report 64 | tar cJf $tarxz $relname 65 | popd 66 | mkdir -p "output/releases" 67 | mv $tmpdir/$tarxz* output/releases/ 68 | rm -rf $tmpdir 69 | echo "Created release tarball in output/releases/$tarxz" 70 | cd ./output/releases 71 | for hash in sha256 sha1 md5; do 72 | echo -n "${hash}: " 73 | ${hash}sum $tarxz | awk -F ' ' '{print $1}' | tee $tarxz.$hash 74 | done 75 | cd - 76 | -------------------------------------------------------------------------------- /misc/selenium/Makefile: -------------------------------------------------------------------------------- 1 | # This Makefile may help you figure out how to run the selenium grid 2 | # service required for the webdriver frontend tests to work. It is in 3 | # no way well-written or stable, and you should only run it after you 4 | # have read it. 5 | # 6 | # Some more pointers: 7 | # 8 | # Download the standalone grid server from here: 9 | # 10 | # http://selenium-release.storage.googleapis.com/index.html 11 | # 12 | # Run like this: 13 | # 14 | # $ java -jar selenium-server-standalone-2.45.0.jar -role hub 15 | # $ java -jar selenium-server-standalone-2.45.0.jar -role node -hub http://localhost:4444/grid/register 16 | # 17 | # (You may have to change the version number to what you downloaded.) 18 | # 19 | # Here is a slightly outdated tutorial with partially helpful further 20 | # instructions: https://code.google.com/p/selenium/wiki/Grid2. 21 | 22 | 23 | SELENIUM_HOST=localhost 24 | 25 | SELENIUM_HUB_PORT=4451 26 | # (default: 4444) 27 | 28 | SELENIUM_NODE_PORT=4452 29 | # (default: 5555) 30 | 31 | SELENIUM_ARGS=-jar selenium-server-standalone-2.45.0.jar -host $(SELENIUM_HOST) 32 | 33 | default: 34 | cat Makefile 35 | make kill start watch 36 | 37 | init: 38 | curl https://selenium-release.storage.googleapis.com/2.45/selenium-server-standalone-2.45.0.jar > selenium-server-standalone-2.45.0.jar 39 | mkdir -p log 40 | 41 | kill: 42 | killall java > /dev/null 2>&1 || true 43 | killall tail > /dev/null 2>&1 || true 44 | 45 | start: 46 | nohup java $(SELENIUM_ARGS) -port $(SELENIUM_HUB_PORT) -role hub > log/hub 2>&1 & 47 | sleep 3 48 | nohup java $(SELENIUM_ARGS) -port $(SELENIUM_NODE_PORT) -role node -hub http://$(SELENIUM_HOST):$(SELENIUM_HUB_PORT)/grid/register > log/node 2>&1 & 49 | 50 | watch: 51 | ( sleep 1; tail -f log/hub ) & 52 | ( sleep 1; tail -f log/node ) & 53 | @echo "\n\npress ^D to shut down selenium.\n\n\n" 54 | cat > /dev/null 55 | make kill 56 | 57 | # (on debian: apt-get install xvfb) 58 | # after you run this, set DISPLAY=:1 and restart selenium. 59 | xvfb: 60 | killall Xvfb || true 61 | sleep 0.3 62 | killall -9 Xvfb || true 63 | sleep 0.2 64 | nohup Xvfb :1 > log/Xvfb 2>&1 & 65 | -------------------------------------------------------------------------------- /refresh-i18n/Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /refresh-i18n/refresh-i18n.cabal: -------------------------------------------------------------------------------- 1 | name: refresh-i18n 2 | version: 0.1 3 | synopsis: Keep translation tables in web apps up to date 4 | description: Script for refreshing translation tables in thentos-purescript. Shouldn't be hard to generalise. 5 | license: AGPL 6 | license-file: LICENSE 7 | author: Matthias Fischmann 8 | maintainer: mf@zerobuzz.net 9 | copyright: liquid democracy e.V., 2015-2017 10 | category: Language 11 | build-type: Simple 12 | cabal-version: >=1.10 13 | 14 | executable refresh-i18n 15 | main-is: 16 | Main.hs 17 | build-depends: 18 | base >=4.8 && <4.9 19 | , containers 20 | , directory 21 | , filepath 22 | , functor-infix 23 | , process 24 | , string-conversions 25 | , text 26 | hs-source-dirs: 27 | src 28 | default-language: 29 | Haskell2010 30 | -------------------------------------------------------------------------------- /refresh-i18n/src/Main.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE BangPatterns #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | {-# LANGUAGE ScopedTypeVariables #-} 4 | {-# LANGUAGE ViewPatterns #-} 5 | 6 | -- | usage: "$0 [target_path]" 7 | -- 8 | -- (I tried to use packages purescript, language-javascript, and language-purescript, but it was a 9 | -- lot easier to do just stupid pattern matching on the source files without any parsing.) 10 | module Main 11 | where 12 | 13 | import Control.Exception (assert) 14 | import Control.Monad (void) 15 | import Data.Function (on) 16 | import Data.Functor.Infix ((<$$>)) 17 | import Data.List (sort, groupBy) 18 | import Data.Maybe (listToMaybe, catMaybes) 19 | import Data.Monoid ((<>)) 20 | import Data.String.Conversions (ST, cs) 21 | import System.Directory (doesDirectoryExist, setCurrentDirectory, getDirectoryContents) 22 | import System.Environment (lookupEnv, getArgs) 23 | import System.FilePath ((), (<.>), takeExtension) 24 | import System.IO (hPutStrLn, stderr) 25 | import System.Process (system) 26 | 27 | import qualified Data.Set as Set 28 | import qualified Data.Text as ST 29 | import qualified Data.Text.IO as ST 30 | 31 | 32 | i18nModule :: FilePath 33 | i18nModule = "I18n" 34 | 35 | main :: IO () 36 | main = do 37 | setCurrentDirectoryToTarget 38 | purss :: [FilePath] <- getTranslateableFiles "." 39 | transKeys :: Set.Set ST <- Set.unions . Set.fromList <$$> mapM translationKeys purss 40 | !(tablesModule :: ST) <- ST.readFile (i18nModule <.> "js") 41 | ST.writeFile (i18nModule <.> "js-") $ updateKeys transKeys tablesModule 42 | void $ system ("mv " ++ (i18nModule <.> "js-") ++ " " ++ (i18nModule <.> "js")) 43 | 44 | 45 | setCurrentDirectoryToTarget :: IO () 46 | setCurrentDirectoryToTarget = do 47 | mEnvVar <- ( "thentos-purescript" "src") <$$> lookupEnv "THENTOS_DEV_ROOT" 48 | mArgPath <- do 49 | args <- getArgs 50 | case args of 51 | [fp] -> (\yes -> if yes then Just fp else Nothing) <$> doesDirectoryExist fp 52 | [] -> pure Nothing 53 | 54 | let Just target = listToMaybe . catMaybes $ [mArgPath, mEnvVar, Just "."] 55 | hPutStrLn stderr $ "target directory: " ++ show target 56 | setCurrentDirectory target 57 | 58 | 59 | getTranslateableFiles :: FilePath -> IO [FilePath] 60 | getTranslateableFiles = (filter f <$>) . getDirectoryContents 61 | where 62 | f fp = (fp /= i18nModule <.> "purs") && takeExtension fp == ".purs" 63 | 64 | 65 | -- | Load a text file and collect all text literals of the form "TR__...". Return a sorted, nubbed 66 | -- list of all those texts. 67 | -- 68 | -- Translation keys must occur as intact string literals (@"TR__" <$> ["A", "B"]@ is not allowed). 69 | -- They must only consist of capitals and underscores (in particular, double quotes won't work.) 70 | translationKeys :: FilePath -> IO [ST] 71 | translationKeys purs = f <$> ST.readFile purs 72 | where 73 | f raw = case ST.breakOn "\"TR__" raw of 74 | (_, "") -> [] 75 | (_, next) -> g $ ST.tail next 76 | 77 | g hit = case ST.breakOn "\"" hit of 78 | (key, rest) -> key : f (ST.tail rest) 79 | 80 | 81 | -- | Remove all inactive entires in dict; add missing entires into dict with "TODO" as translation. 82 | -- (FUTUREWORK: this function could benefit from heavier use of "Data.Set".) 83 | updateKeys :: Set.Set ST -> ST -> ST 84 | updateKeys (Set.toList -> activeKeys) = unGrp . (checkGrp <$>) . grp 85 | where 86 | grp :: ST -> [[ST]] 87 | grp = groupBy ((==) `on` ("\"TR__" `ST.isInfixOf`)) . ST.lines 88 | 89 | unGrp :: [[ST]] -> ST 90 | unGrp = ST.unlines . concat 91 | 92 | checkGrp :: [ST] -> [ST] 93 | checkGrp [] = [] 94 | checkGrp noise@(h:_) | not ("\"TR__" `ST.isInfixOf` h) = noise 95 | checkGrp table = (renderLine <$>) . refreshGrp . (parseLine <$>) $ table 96 | 97 | refreshGrp :: [(ST, ST, ST)] -> [(ST, ST, ST)] 98 | refreshGrp orig = sort completed 99 | where 100 | fst3 (k, _, _) = k 101 | pruned = filter ((`elem` activeKeys) . fst3) orig 102 | completed = pruned ++ 103 | [ (key, " ", ": @@@") | key <- activeKeys, not (key `elem` (fst3 <$> pruned)) ] 104 | 105 | parseLine :: ST -> (ST, ST, ST) 106 | parseLine l = case ST.breakOn "\"TR__" l of 107 | (pre, ST.tail -> rest) -> case ST.findIndex (== '"') rest of 108 | Nothing -> assert False $ error "updateKeys: parse error in translation rule" 109 | Just i -> case ST.splitAt i rest of 110 | (key, ST.tail -> post) -> (key, pre, post) 111 | 112 | renderLine :: (ST, ST, ST) -> ST 113 | renderLine (key, pre, post) = pre <> cs (show key) <> post 114 | -------------------------------------------------------------------------------- /services/helloworld/.ghci: -------------------------------------------------------------------------------- 1 | :set -isrc 2 | :set -hide-package MonadCatchIO-mtl 3 | :set -hide-package monads-fd 4 | :set -XOverloadedStrings 5 | -------------------------------------------------------------------------------- /services/helloworld/.gitignore: -------------------------------------------------------------------------------- 1 | /dist 2 | /log/*.log 3 | /site_key.txt 4 | /TAGS 5 | -------------------------------------------------------------------------------- /services/helloworld/devel.config: -------------------------------------------------------------------------------- 1 | service_id = "you have not configured a service id" 2 | service_key = "you have not configured a service key" 3 | 4 | thentos_backend_url = "http://localhost:7001" 5 | thentos_frontend_url = "http://localhost:7002" 6 | hello_world_url = "http://localhost:8000" 7 | -------------------------------------------------------------------------------- /services/helloworld/helloworld.cabal: -------------------------------------------------------------------------------- 1 | Name: helloworld 2 | Version: 0.1 3 | Synopsis: Project Synopsis Here 4 | Description: Project Description Here 5 | License: AllRightsReserved 6 | Author: Author 7 | Maintainer: maintainer@example.com 8 | Stability: Experimental 9 | Category: Web 10 | Build-type: Simple 11 | Cabal-version: >=1.2 12 | 13 | Flag development 14 | Description: Whether to build the server in development (interpreted) mode 15 | Default: False 16 | 17 | Flag old-base 18 | default: False 19 | manual: False 20 | 21 | Executable helloworld 22 | hs-source-dirs: src 23 | main-is: Main.hs 24 | 25 | Build-depends: 26 | base >= 4.4 27 | , aeson 28 | , blaze-html 29 | , blaze-markup >= 0.6.3 30 | , bytestring >= 0.9.1 31 | , case-insensitive 32 | , configurator >= 0.3.0.0 33 | , heist >= 0.14 34 | , http-client >= 0.4.7 35 | , http-conduit >= 2.1.5 36 | , http-types 37 | , lens >= 3.7.6 38 | , MonadCatchIO-transformers >= 0.2.1 39 | , mtl >= 2 40 | , snap >= 0.13 41 | , snap-blaze 42 | , snap-core >= 0.9 43 | , snap-loader-static >= 0.9 44 | , snap-server >= 0.9 45 | , string-conversions 46 | , transformers 47 | , text >= 0.11 48 | , time >= 1.1 49 | , unordered-containers 50 | , xmlhtml >= 0.1 51 | , pretty-show 52 | 53 | if flag(development) 54 | build-depends: 55 | snap-loader-dynamic == 0.10.* 56 | cpp-options: -DDEVELOPMENT 57 | -- In development mode, speed is already going to suffer, so skip 58 | -- the fancy optimization flags. Additionally, disable all 59 | -- warnings. The hint library doesn't give an option to execute 60 | -- compiled code when there were also warnings, so disabling 61 | -- warnings allows quicker workflow. 62 | ghc-options: -threaded -w 63 | else 64 | if impl(ghc >= 6.12.0) 65 | ghc-options: -threaded -Wall -fwarn-tabs -funbox-strict-fields -O2 66 | -fno-warn-orphans -fno-warn-unused-do-bind 67 | else 68 | ghc-options: -threaded -Wall -fwarn-tabs -funbox-strict-fields -O2 69 | -fno-warn-orphans 70 | -------------------------------------------------------------------------------- /services/helloworld/static/screen.css: -------------------------------------------------------------------------------- 1 | html { 2 | background-color: #c0c0ff; 3 | font-family: Verdana, Helvetica, sans-serif; 4 | } 5 | 6 | body { 7 | } 8 | 9 | a { 10 | text-decoration: underline; 11 | } 12 | 13 | a :hover { 14 | cursor: pointer; 15 | text-decoration: underline; 16 | } 17 | 18 | img { 19 | border: none; 20 | } 21 | 22 | .logged_in { 23 | background-color: #c0ffc0; 24 | } 25 | 26 | .logged_out { 27 | background-color: #ffc0c0; 28 | } 29 | -------------------------------------------------------------------------------- /stack.yaml: -------------------------------------------------------------------------------- 1 | # For more information, see: https://github.com/commercialhaskell/stack/blob/release/doc/yaml_configuration.md 2 | 3 | # Specifies the GHC version and set of packages available (e.g., lts-3.5, nightly-2015-09-21, ghc-7.10.2) 4 | resolver: lts-6.3 5 | 6 | # Local packages, usually specified by relative directory name 7 | packages: 8 | - submodules/pronk/ 9 | - thentos-cookie-session/ 10 | - thentos-core/ 11 | #- thentos-adhocracy/ 12 | - thentos-tests/ 13 | 14 | # Packages to be pulled from upstream that are not in the resolver (e.g., acme-missiles-0.3) 15 | extra-deps: 16 | - cond-0.4.1.1 17 | - configifier-0.1.1 18 | - elocrypt-0.4.1 19 | - functor-infix-0.0.3 20 | - lio-0.11.5.0 21 | - wai-digestive-functors-0.3 22 | - uri-bytestring-0.1.9.2 23 | - xml-html-conduit-lens-0.3.2.1 24 | - meldable-heap-2.0.3 25 | 26 | # Override default flag values for local packages and extra-deps 27 | flags: {} 28 | 29 | # Extra package databases containing global packages 30 | extra-package-dbs: [] 31 | 32 | # Control whether we use the GHC we find on the path 33 | # system-ghc: true 34 | 35 | # Require a specific version of stack, using version ranges 36 | # require-stack-version: -any # Default 37 | # require-stack-version: >= 0.1.4.0 38 | 39 | # Override the architecture used by stack, especially useful on Windows 40 | # arch: i386 41 | # arch: x86_64 42 | 43 | # Extra directories used by stack for building 44 | # extra-include-dirs: [/path/to/dir] 45 | # extra-lib-dirs: [/path/to/dir] 46 | 47 | nix: 48 | enable: false 49 | packages: [gcc,icu,zlib,postgresql,espeak] 50 | -------------------------------------------------------------------------------- /thentos-adhocracy/.gitignore: -------------------------------------------------------------------------------- 1 | /dist 2 | /docs 3 | /log/*.log 4 | /site_key.txt 5 | /TAGS 6 | -------------------------------------------------------------------------------- /thentos-adhocracy/HLint.hs: -------------------------------------------------------------------------------- 1 | import "hint" HLint.Default 2 | import "hint" HLint.Dollar 3 | import "hint" HLint.Generalise 4 | import "hint" HLint.HLint 5 | 6 | -- some rules are disabled universally; some are ignored in some modules. syntax: 7 | -- 8 | -- >>> rule ::= 'ignore' pattern [= module] 9 | -- >>> module ::= 'Thentos.Backend.Api.Adhocracy3' 10 | -- >>> pattern ::= '"' string '"' 11 | 12 | ignore "Redundant $" 13 | ignore "Redundant do" 14 | ignore "Use ." 15 | ignore "Use camelCase" 16 | ignore "Use const" 17 | ignore "Use fmap" 18 | ignore "Use head" 19 | ignore "Use list literal" 20 | ignore "Use mappend" 21 | ignore "Use record patterns" 22 | ignore "Parse error" 23 | 24 | -- FIXME: missing checks: 25 | -- 26 | -- - can i find / write a lint rule that disallows -fdefer-type-errors in OPTIONS pragmas? 27 | -- - check all modules for ghc options and move things to cabal file if appropriate. 28 | -- - language extensions enabled in cabal file should not be re-enabled in modules. 29 | -------------------------------------------------------------------------------- /thentos-adhocracy/LICENSE: -------------------------------------------------------------------------------- 1 | Thentos: A tool for privacy-preserving identity management 2 | Copyright (C) 2015-2019 liquid democracy e.V. 3 | 4 | This program is free software: you can redistribute it and/or modify 5 | it under the terms of the GNU Affero General Public License as 6 | published by the Free Software Foundation, either version 3 of the 7 | License, or (at your option) any later version. 8 | 9 | This program is distributed in the hope that it will be useful, 10 | but WITHOUT ANY WARRANTY; without even the implied warranty of 11 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 12 | GNU Affero General Public License for more details. 13 | 14 | You should have received a copy of the GNU Affero General Public License 15 | along with this program. If not, see . 16 | -------------------------------------------------------------------------------- /thentos-adhocracy/Makefile: -------------------------------------------------------------------------------- 1 | SHELL=/bin/bash 2 | HLINT=hlint 3 | 4 | hlint: 5 | $(HLINT) --version 6 | find src exec tests -name '*.hs' | xargs $(HLINT) 7 | -------------------------------------------------------------------------------- /thentos-adhocracy/Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /thentos-adhocracy/devel.config: -------------------------------------------------------------------------------- 1 | # Sample config for running A3 with Thentos in proxy mode. 2 | # Used ports: A3 frontend on 6551, Thentos proxy on 6546, A3 backend on 6541. 3 | # Required changes in the A3 config: 4 | # 5 | # * Change the following line in etc/frontend_development.ini.in: 6 | # 7 | # adhocracy.frontend.rest_url = http://localhost:6546 8 | # 9 | # * Change the following lines in etc/development.ini.in: 10 | # 11 | # adhocracy.skip_registration_mail = true 12 | # adhocracy.validate_user_token = false 13 | # 14 | # * Call bin/buildout 15 | 16 | command: "run" 17 | root_path: "../thentos-core" 18 | 19 | backend: 20 | bind_port: 6546 21 | bind_host: localhost 22 | 23 | frontend: 24 | bind_port: 6551 25 | bind_host: localhost 26 | 27 | purescript: 28 | "./thentos-purescript/static/" 29 | 30 | proxy: 31 | service_id: qlX4MP7xEgtRng+8iNvMIcSo 32 | endpoint: http://localhost:6541 33 | 34 | smtp: 35 | sender_name: "Thentos" 36 | sender_address: "thentos@thentos.org" 37 | sendmail_path: "/usr/sbin/sendmail" # (built-in default) 38 | sendmail_args: ["-t"] # (built-in default) 39 | 40 | default_user: 41 | name: "god" 42 | password: "god" 43 | email: "postmaster@localhost" 44 | groups: ["groupAdmin", "groupUser", "groupServiceAdmin", "groupUserAdmin"] 45 | 46 | user_reg_expiration: 1d 47 | pw_reset_expiration: 1d 48 | email_change_expiration: 1d 49 | captcha_expiration: 1h 50 | gc_interval: 30m 51 | 52 | log: 53 | path: ./log/thentos.log 54 | level: DEBUG 55 | stdout: True 56 | 57 | database: 58 | name: "thentosdev" 59 | 60 | email_templates: 61 | account_verification: 62 | subject: "Thentos: Aktivierung Ihres Nutzerkontos" 63 | # Supported variables: {{user_name}}, {{activation_url}} 64 | body: | 65 | Hallo {{user_name}}, 66 | 67 | vielen Dank für Ihre Registrierung bei Thentos. 68 | 69 | Diese E-Mail dient der Validierung Ihrer Identität. Bitte 70 | nutzen Sie den folgenden Link um das Nutzerkonto zu aktivieren. 71 | 72 | {{activation_url}} 73 | 74 | Wir wünschen Ihnen viel Spaß und Inspiration! 75 | 76 | Das Thentos-Team 77 | user_exists: 78 | subject: "Thentos: Attempted Signup" 79 | body: | 80 | Someone tried to sign up to Thentos with your email address. 81 | 82 | This is a reminder that you already have a Thentos account. If you 83 | haven't tried to sign up to Thentos, you can just ignore this email. 84 | If you have, you are hereby reminded that you already have an account. 85 | password_reset: 86 | subject: "Thentos: Reset Password" 87 | # Supported variables: {{user_name}}, {{reset_url}} 88 | body: | 89 | Dear {{user_name}}, 90 | 91 | please use the link below to reset your password. 92 | 93 | {{reset_url}} 94 | 95 | Your Thentos Team 96 | -------------------------------------------------------------------------------- /thentos-adhocracy/exec/Main.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE NoImplicitPrelude #-} 2 | 3 | module Main where 4 | 5 | import Prelude (IO) 6 | 7 | import qualified Thentos.Adhocracy3 8 | 9 | main :: IO () 10 | main = Thentos.Adhocracy3.main 11 | -------------------------------------------------------------------------------- /thentos-adhocracy/log/.phony: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/liqd/thentos/f7d53d8e9d11956d2cc83efb5f5149876109b098/thentos-adhocracy/log/.phony -------------------------------------------------------------------------------- /thentos-adhocracy/src/Paths_thentos_adhocracy__.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | #if DEVELOPMENT 3 | {-# LANGUAGE TemplateHaskell #-} 4 | #endif 5 | 6 | -- | Custom modifications to the cabal-generated "Paths_thentos_adhocracy". See analogous module in 7 | -- thentos-core package for more information. 8 | module Paths_thentos_adhocracy__ (getDataFileName, version) where 9 | 10 | #if !DEVELOPMENT 11 | import Paths_thentos_adhocracy 12 | 13 | #else 14 | import Distribution.Version (Version(Version)) 15 | import System.FilePath (()) 16 | 17 | import Paths.TH (getPackageSourceRoot) 18 | 19 | getDataFileName :: FilePath -> IO FilePath 20 | getDataFileName = return . ($(getPackageSourceRoot "thentos-core") ) 21 | 22 | version :: Version 23 | version = Version [] [] 24 | 25 | #endif 26 | -------------------------------------------------------------------------------- /thentos-adhocracy/src/Thentos/Adhocracy3.hs: -------------------------------------------------------------------------------- 1 | module Thentos.Adhocracy3 (main) where 2 | 3 | import Thentos (makeMain) 4 | 5 | import qualified Thentos.Adhocracy3.Backend.Api.Simple as Simple (runBackend) 6 | 7 | 8 | -- * main 9 | 10 | main :: IO () 11 | main = makeMain $ \actionEnv mBeConfig _ -> do 12 | maybe (error "command `run` requires backend") 13 | (`Simple.runBackend` actionEnv) 14 | mBeConfig 15 | -------------------------------------------------------------------------------- /thentos-adhocracy/src/Thentos/Adhocracy3/Action/Unsafe.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE FlexibleContexts #-} 3 | {-# LANGUAGE OverloadedStrings #-} 4 | 5 | module Thentos.Adhocracy3.Action.Unsafe 6 | ( createUserInA3 7 | ) where 8 | 9 | import Control.Monad.Except (throwError) 10 | import Control.Monad (when) 11 | import Data.Aeson (ToJSON) 12 | import Data.Configifier ((>>.), Tagged(Tagged)) 13 | import Data.Maybe (fromMaybe) 14 | import Data.Monoid ((<>)) 15 | import Data.Proxy (Proxy(Proxy)) 16 | import Data.String.Conversions (LBS, cs) 17 | import LIO.Core (liftLIO) 18 | 19 | import LIO.TCB (ioTCB) 20 | import qualified Data.Aeson as Aeson 21 | import qualified Network.HTTP.Client as Client 22 | import qualified Network.HTTP.Types.Status as Status 23 | 24 | import Thentos.Action.TCB 25 | import Thentos.Adhocracy3.Action.Types 26 | import Thentos.Config 27 | import Thentos.Types 28 | import Thentos.Util 29 | 30 | 31 | -- | Create a user in A3 from a persona name and return the user path. 32 | createUserInA3 :: PersonaName -> A3Action Path 33 | createUserInA3 persName = do 34 | config <- getConfig 35 | let a3req = fromMaybe 36 | (error "createUserInA3: mkUserCreationRequestForA3 failed, check config!") $ 37 | mkUserCreationRequestForA3 config persName 38 | a3resp <- liftLIO . ioTCB . sendRequest $ a3req 39 | when (responseCode a3resp >= 400) $ do 40 | throwError . OtherError . A3BackendErrorResponse (responseCode a3resp) $ 41 | Client.responseBody a3resp 42 | extractUserPath a3resp 43 | where 44 | responseCode = Status.statusCode . Client.responseStatus 45 | 46 | -- | Convert a persona name into a user creation request to be sent to the A3 backend. 47 | -- The persona name is used as user name. The email address is set to a unique dummy value 48 | -- and the password is set to a dummy value. 49 | mkUserCreationRequestForA3 :: ThentosConfig -> PersonaName -> Maybe Client.Request 50 | mkUserCreationRequestForA3 config persName = do 51 | let user = UserFormData { udName = UserName $ fromPersonaName persName, 52 | udEmail = email, 53 | udPassword = "dummypass" } 54 | mkRequestForA3 config "/principals/users" $ A3UserWithPass user 55 | where 56 | rawEmail = cs (mailEncode $ fromPersonaName persName) <> "@example.org" 57 | email = fromMaybe (error $ "mkUserCreationRequestForA3: couldn't create dummy email") $ 58 | parseUserEmail rawEmail 59 | 60 | -- | Make a POST request to be sent to the A3 backend. Returns 'Nothing' if the 'ThentosConfig' 61 | -- lacks a correctly configured proxy. 62 | -- 63 | -- Note that the request is configured to NOT thrown an exception even if the response status code 64 | -- indicates an error (400 or higher). Properly dealing with error replies is left to the caller. 65 | -- 66 | -- Since the A3 frontend doesn't know about different services (i.e. never sends a 67 | -- @X-Thentos-Service@ header), we send the request to the default proxy which should be the A3 68 | -- backend. 69 | mkRequestForA3 :: ToJSON a => ThentosConfig -> String -> a -> Maybe Client.Request 70 | mkRequestForA3 config route dat = do 71 | defaultProxy <- Tagged <$> config >>. (Proxy :: Proxy '["proxy"]) 72 | let target = extractTargetUrl defaultProxy 73 | initReq <- Client.parseUrl $ cs $ show target route 74 | return initReq { Client.method = "POST" 75 | , Client.requestHeaders = [("Content-Type", "application/json")] 76 | , Client.requestBody = Client.RequestBodyLBS . Aeson.encode $ dat 77 | , Client.checkStatus = \_ _ _ -> Nothing 78 | } 79 | 80 | -- | Extract the user path from an A3 response received for a user creation request. 81 | -- FIXME: make use of servant-client for all rest communication with A3 backend! 82 | extractUserPath :: MonadThentosError ThentosA3Error m => Client.Response LBS -> m Path 83 | extractUserPath resp = do 84 | resource <- either (throwError . OtherError . A3BackendInvalidJson) return $ 85 | (Aeson.eitherDecode . Client.responseBody $ resp :: Either String TypedPath) 86 | pure $ tpPath resource 87 | 88 | sendRequest :: Client.Request -> IO (Client.Response LBS) 89 | sendRequest req = Client.newManager Client.defaultManagerSettings >>= Client.httpLbs req 90 | -------------------------------------------------------------------------------- /thentos-adhocracy/src/Thentos/Adhocracy3/Backend/Core.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | module Thentos.Adhocracy3.Backend.Core 4 | ( mkSimpleA3Error 5 | , a3ActionErrorToServantErr 6 | ) 7 | where 8 | 9 | import Data.Aeson (encode) 10 | import Data.Function (on) 11 | import Data.List (nubBy) 12 | import Data.String.Conversions (ST) 13 | import Servant.Server.Internal.ServantErr (err400, err401, err500, errBody, errHeaders) 14 | import Servant.Server (ServantErr) 15 | import System.Log.Logger (Priority(DEBUG, ERROR, CRITICAL)) 16 | import Text.Show.Pretty (ppShow) 17 | 18 | import qualified Thentos.Action.Types as AC 19 | 20 | import Thentos.Adhocracy3.Action.Types 21 | import Thentos.Backend.Core 22 | import Thentos.Types 23 | 24 | 25 | a3ActionErrorToServantErr :: AC.ActionError ThentosA3Error -> IO ServantErr 26 | a3ActionErrorToServantErr = errorInfoToServantErr mkA3StyleServantErr . actionErrorA3Info a3Info 27 | 28 | -- | Construct a simple A3-style error wrapping a single error. 'aeName' is set to @thentos@ and 29 | -- 'aeLocation' to @body@. Useful for cases where all we really have is a description. 30 | mkSimpleA3Error :: ST -> A3Error 31 | mkSimpleA3Error desc = A3Error {aeName = "thentos", aeLocation = "body", aeDescription = desc} 32 | 33 | -- | Construct a ServantErr that looks like those reported by the A3 backend. 34 | -- The backend returns a list of errors but we always use a single-element list, as Thentos 35 | -- aborts at the first detected error. 36 | mkA3StyleServantErr :: ServantErr -> A3ErrorMessage -> ServantErr 37 | mkA3StyleServantErr baseErr err = baseErr 38 | { errBody = encode $ err 39 | , errHeaders = nubBy ((==) `on` fst) $ contentTypeJsonHeader : errHeaders baseErr 40 | } 41 | 42 | mkA3 :: ErrorInfo ST -> ErrorInfo A3ErrorMessage 43 | mkA3 (p, se, msg) = (p, se, A3ErrorMessage [mkSimpleA3Error msg]) 44 | 45 | actionErrorA3Info :: Show e 46 | => (e -> ErrorInfo A3ErrorMessage) -> AC.ActionError e -> ErrorInfo A3ErrorMessage 47 | actionErrorA3Info other = f 48 | where 49 | a3Error a b c = A3ErrorMessage [A3Error a b c] 50 | 51 | f e = case e of 52 | (AC.ActionErrorThentos te) -> g te 53 | (AC.ActionErrorAnyLabel _) -> mkA3 (Just (DEBUG, ppShow e), err401, "unauthorized") 54 | (AC.ActionErrorUnknown _) -> mkA3 (Just (CRITICAL, ppShow e), err500, "internal error") 55 | 56 | -- For errors specifically relevant to the A3 frontend we mirror the A3 backend errors 57 | -- exactly so that the frontend recognizes them 58 | g e = case e of 59 | OtherError ae -> other ae 60 | BadCredentials -> (Nothing, err400, a3Error 61 | "password" 62 | "body" 63 | "User doesn't exist or password is wrong") 64 | UserEmailAlreadyExists -> (Nothing, err400, a3Error 65 | "data.adhocracy_core.sheets.principal.IUserExtended.email" 66 | "body" 67 | "The user login email is not unique") 68 | UserNameAlreadyExists -> (Nothing, err400, a3Error 69 | "data.adhocracy_core.sheets.principal.IUserBasic.name" 70 | "body" 71 | "The user login name is not unique") 72 | NoSuchPendingUserConfirmation -> (Nothing, err400, a3Error 73 | "path" 74 | "body" 75 | "Unknown or expired activation path") 76 | NoSuchThentosSession -> (Nothing, err400, a3Error 77 | "X-User-Token" 78 | "header" 79 | "Invalid user token") 80 | _ -> mkA3 $ thentosErrorInfo (impossible "other error handled above") e 81 | 82 | a3Info :: ThentosA3Error -> ErrorInfo A3ErrorMessage 83 | a3Info ae = case ae of 84 | GenericA3Error errMsg -> (Nothing, err400, errMsg) 85 | _ -> mkA3 $ f ae 86 | where 87 | f (GenericA3Error _) = impossible "generic error handled above" 88 | f e@(A3BackendErrorResponse _ _) = 89 | (Just (ERROR, show e), err500, "exception in a3 backend") 90 | f e@(A3BackendInvalidJson _) = 91 | (Just (ERROR, show e), err500, "exception in a3 backend: received bad json") 92 | f e@(A3UriParseError _) = 93 | (Just (ERROR, show e), err500, "exception in a3 backend: received unparsable URL") 94 | f e@(A3NoDefaultPersona _ _) = 95 | (Just (ERROR, show e), err500, "no default persona found for user") 96 | f e@A3PersonaLacksExternalUrl = 97 | (Just (ERROR, show e), err500, "no external URL stored for persona") 98 | 99 | impossible :: String -> a 100 | impossible = error 101 | -------------------------------------------------------------------------------- /thentos-adhocracy/tests/Spec.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -F -pgmF hspec-discover #-} 2 | -------------------------------------------------------------------------------- /thentos-adhocracy/thentos-adhocracy.cabal: -------------------------------------------------------------------------------- 1 | name: thentos-adhocracy 2 | version: 0.9.0 3 | synopsis: Thentos-binding for the adhocracy participation platform 4 | description: 5 | See https://github.com/liqd/adhocracy3.mercator and https://github.com/liqd/thentos. 6 | license: AGPL 7 | license-file: LICENSE 8 | homepage: https://github.com/liqd/thentos 9 | author: Matthias Fischmann, Florian Hartwig, Christian Siefkes 10 | maintainer: mf@zerobuzz.net, florian.hartwig@liqd.de, christian@siefkes.net 11 | copyright: liquid democracy e.V. (https://liqd.net/) 12 | category: Authentication 13 | build-type: Simple 14 | cabal-version: >= 1.18 15 | 16 | Source-Repository head 17 | type: git 18 | location: https://github.com/liqd/thentos 19 | 20 | flag profiling 21 | default: False 22 | 23 | flag with-thentos-executable 24 | default: True 25 | 26 | library 27 | default-language: 28 | Haskell2010 29 | hs-source-dirs: 30 | src 31 | ghc-options: 32 | -Wall -j1 33 | if flag(profiling) 34 | ghc-options: 35 | -auto-all -caf-all -fforce-recomp 36 | exposed-modules: 37 | Thentos.Adhocracy3 38 | , Thentos.Adhocracy3.Action 39 | , Thentos.Adhocracy3.Action.Types 40 | , Thentos.Adhocracy3.Action.Unsafe 41 | , Thentos.Adhocracy3.Backend.Api.Simple 42 | , Thentos.Adhocracy3.Backend.Core 43 | other-modules: 44 | Paths_thentos_adhocracy 45 | build-depends: 46 | -- losely based on: https://www.stackage.org/lts-3.5/cabal.config 47 | aeson >=0.8.0.2 && <0.9 48 | , aeson-pretty >=0.7.2 && <0.8 49 | , base >=4.8.1.0 && <5 50 | , case-insensitive >=1.2.0.4 && <1.3 51 | , configifier >=0.1.0 && <0.2 52 | , functor-infix >=0.0.3 && <0.1 53 | , hslogger >=1.2.9 && <1.3 54 | , http-client >=0.4.22 && <0.5 55 | , http-conduit >=2.1.8 && <2.2 56 | , http-types >=0.8.6 && <0.9 57 | , lens >=4.12.3 && <4.13 58 | , lio >=0.11.5.0 && <0.12 59 | , mtl >=2.2.1 && <2.3 60 | , network >=2.6.2.1 && <2.7 61 | , network-uri >=2.6 && <2.7 62 | , pretty-show >=1.6.8.2 && <1.7 63 | , safe >=0.3.9 && <0.4 64 | , servant >=0.5 65 | , servant-docs >=0.5 66 | , servant-server >=0.5 67 | , string-conversions >=0.4 && <0.5 68 | , text >=1.2.1.3 && <1.3 69 | , thentos-core ==0.9.0 70 | , thyme >=0.3.5.5 && <0.4 71 | , unordered-containers >=0.2.5.1 && <0.3 72 | , uri-bytestring >=0.1.8 && <0.2 73 | , wai >=3.0.3.0 && <3.1 74 | 75 | executable thentos-adhocracy 76 | if flag(with-thentos-executable) 77 | Buildable: True 78 | else 79 | Buildable: False 80 | 81 | default-language: 82 | Haskell2010 83 | hs-source-dirs: 84 | exec 85 | main-is: 86 | Main.hs 87 | ghc-options: 88 | -Wall -j1 -threaded -rtsopts -with-rtsopts=-N 89 | if flag(profiling) 90 | ghc-options: 91 | -auto-all -caf-all -fforce-recomp 92 | build-depends: 93 | base 94 | , thentos-adhocracy 95 | 96 | test-suite tests 97 | default-language: 98 | Haskell2010 99 | type: 100 | exitcode-stdio-1.0 101 | hs-source-dirs: 102 | tests 103 | main-is: 104 | Spec.hs 105 | other-modules: 106 | -- (modules to be collected by hspec-discover are not to be mentioned here.) 107 | ghc-options: 108 | -Wall -j1 -threaded -rtsopts -with-rtsopts=-N 109 | cpp-options: 110 | -DGHC_GENERICS 111 | build-depends: 112 | aeson >=0.8.0.2 && <0.9 113 | , aeson-pretty >=0.7.2 && <0.8 114 | , async >=2.0.2 && <2.1 115 | , base >=4.8.1.0 && <5 116 | , bytestring >=0.10.6.0 && <0.11 117 | , case-insensitive >=1.2.0.4 && <1.3 118 | , configifier 119 | , containers >=0.5.6.2 && <0.6 120 | , filepath >=1.4.0.0 && <1.5 121 | , hspec >=2.1.10 && <2.3 122 | , hspec-wai >=0.6.3 && <0.7 123 | , HTTP >=4000.2.20 && <4000.3 124 | , http-client >=0.4.22 && <0.5 125 | , http-types >=0.8.6 && <0.9 126 | , lens >=4.12.3 && <4.13 127 | , lens-aeson >=1.0.0.4 && <1.1 128 | , lio >=0.11.5.0 && <0.12 129 | , network >=2.6.2.1 && <2.7 130 | , process >=1.2.3.0 && <1.3 131 | , QuickCheck >=2.8.1 && <2.9 132 | , resource-pool >=0.2.3.2 && <0.3 133 | , string-conversions >=0.4 && <0.5 134 | , text >=1.2.1.3 && <1.3 135 | , thentos-adhocracy ==0.9.0 136 | , thentos-core ==0.9.0 137 | , thentos-tests ==0.9.0 138 | , transformers >=0.4.2.0 && <0.5 139 | , wai >=3.0.3.0 && <3.1 140 | , wai-extra >=3.0.10 && <3.1 141 | , warp >=3.1.3 && <3.2 142 | , wreq >=0.4.0.0 && <0.5 143 | -------------------------------------------------------------------------------- /thentos-cookie-session/.gitignore: -------------------------------------------------------------------------------- 1 | /dist 2 | /docs 3 | /log/*.log 4 | /site_key.txt 5 | /TAGS 6 | -------------------------------------------------------------------------------- /thentos-cookie-session/HLint.hs: -------------------------------------------------------------------------------- 1 | import "hint" HLint.Default 2 | import "hint" HLint.Dollar 3 | import "hint" HLint.Generalise 4 | import "hint" HLint.HLint 5 | 6 | -- how to tweak the rules: http://community.haskell.org/~ndm/darcs/hlint/hlint.htm 7 | 8 | ignore "Redundant lambda" = Thentos.Backend.Api.Simple 9 | ignore "Redundant bracket" = Thentos.Backend.Api.Simple 10 | ignore "Redundant $" 11 | ignore "Redundant do" 12 | ignore "Use ." 13 | ignore "Use camelCase" 14 | ignore "Use const" 15 | ignore "Use fmap" 16 | ignore "Use head" 17 | ignore "Use list literal" 18 | ignore "Use mappend" 19 | ignore "Use record patterns" 20 | ignore "Parse error" 21 | -------------------------------------------------------------------------------- /thentos-cookie-session/LICENSE: -------------------------------------------------------------------------------- 1 | Thentos: A tool for privacy-preserving identity management 2 | Copyright (C) 2015-2019 liquid democracy e.V. 3 | 4 | This program is free software: you can redistribute it and/or modify 5 | it under the terms of the GNU Affero General Public License as 6 | published by the Free Software Foundation, either version 3 of the 7 | License, or (at your option) any later version. 8 | 9 | This program is distributed in the hope that it will be useful, 10 | but WITHOUT ANY WARRANTY; without even the implied warranty of 11 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 12 | GNU Affero General Public License for more details. 13 | 14 | You should have received a copy of the GNU Affero General Public License 15 | along with this program. If not, see . 16 | -------------------------------------------------------------------------------- /thentos-cookie-session/Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /thentos-cookie-session/src/Control/Monad/Except/Missing.hs: -------------------------------------------------------------------------------- 1 | module Control.Monad.Except.Missing where 2 | 3 | import Control.Monad.Except (MonadError(catchError, throwError)) 4 | import Data.Functor (($>)) 5 | 6 | finally :: MonadError e m => m a -> m b -> m a 7 | finally action finalizer = do 8 | a <- action `catchError` \e -> finalizer >> throwError e 9 | finalizer $> a 10 | -------------------------------------------------------------------------------- /thentos-cookie-session/src/Thentos/CookieSession/Types.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ConstraintKinds #-} 2 | {-# LANGUAGE DeriveGeneric #-} 3 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 4 | {-# LANGUAGE OverloadedStrings #-} 5 | {-# LANGUAGE PackageImports #-} 6 | 7 | module Thentos.CookieSession.Types where 8 | 9 | import Control.Lens (Getter) 10 | import Control.Monad.State.Class (MonadState) 11 | import "cryptonite" Crypto.Random (MonadRandom, getRandomBytes) 12 | import Data.Aeson (FromJSON, ToJSON) 13 | import Data.String.Conversions 14 | import Data.String (IsString) 15 | import Data.Typeable (Typeable) 16 | import GHC.Generics (Generic) 17 | import Servant.API (FromHttpApiData) 18 | import qualified Codec.Binary.Base64 as Base64 19 | import qualified Data.Text as ST 20 | 21 | newtype ThentosSessionToken = ThentosSessionToken { fromThentosSessionToken :: ST } 22 | deriving ( Eq, Ord, Show, Read, Typeable, Generic, IsString 23 | , FromHttpApiData, FromJSON, ToJSON 24 | ) 25 | 26 | class GetThentosSessionToken a where 27 | getThentosSessionToken :: Getter a (Maybe ThentosSessionToken) 28 | 29 | type MonadUseThentosSessionToken s m = (MonadState s m, GetThentosSessionToken s) 30 | 31 | -- | Return a base64 encoded random string of length 24 (18 bytes of entropy). 32 | -- We use @_@ instead of @/@ as last letter of the base64 alphabet since it allows using names 33 | -- within URLs without percent-encoding. Our Base64 alphabet thus consists of ASCII letters + 34 | -- digits as well as @+@ and @_@. All of these are reliably recognized in URLs, even if they occur 35 | -- at the end. 36 | -- 37 | -- RFC 4648 also has a "URL Safe Alphabet" which additionally replaces @+@ by @-@. But that's 38 | -- problematic, since @-@ at the end of URLs is not recognized as part of the URL by some programs 39 | -- such as Thunderbird. 40 | freshRandomName :: MonadRandom m => m ST 41 | freshRandomName = ST.replace "/" "_" . cs . Base64.encode <$> getRandomBytes 18 42 | 43 | freshSessionToken :: MonadRandom m => m ThentosSessionToken 44 | freshSessionToken = ThentosSessionToken <$> freshRandomName 45 | -------------------------------------------------------------------------------- /thentos-cookie-session/test/Spec.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -F -pgmF hspec-discover #-} 2 | -------------------------------------------------------------------------------- /thentos-cookie-session/test/Thentos/CookieSessionSpec.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE FlexibleInstances #-} 3 | {-# LANGUAGE MultiParamTypeClasses #-} 4 | {-# LANGUAGE OverloadedStrings #-} 5 | {-# LANGUAGE ScopedTypeVariables #-} 6 | {-# LANGUAGE TypeOperators #-} 7 | 8 | {-# OPTIONS -fno-warn-incomplete-patterns #-} 9 | 10 | module Thentos.CookieSessionSpec (spec) where 11 | 12 | import Control.Monad (replicateM_) 13 | import Control.Monad.Trans.Except (ExceptT) 14 | import qualified Data.Vault.Lazy as Vault 15 | import Network.HTTP.Types (methodGet) 16 | import Network.Wai (Middleware, Application) 17 | import Network.Wai.Session (SessionStore, Session, withSession) 18 | import Network.Wai.Session.Map (mapStore) 19 | import Network.Wai.Test (simpleBody, simpleHeaders) 20 | import Servant (Proxy(Proxy), ServantErr, Get, JSON, (:>), serve) 21 | import Test.Hspec (Spec, context, describe, it, shouldBe, shouldSatisfy) 22 | import Test.Hspec.Wai (with, request, liftIO) 23 | import Web.Cookie (SetCookie, def, parseSetCookie, 24 | setCookieName, setCookieValue, setCookieMaxAge) 25 | 26 | import Thentos.CookieSession 27 | 28 | 29 | spec :: Spec 30 | spec = describe "Thentos.CookieSession" . with server $ do 31 | 32 | context "the cookie is set" $ do 33 | 34 | it "has read and write access to the cookie" $ do 35 | replicateM_ 5 $ request methodGet "" [("Cookie", "test=const")] "" 36 | x <- request methodGet "" [("Cookie", "test=const")] "" 37 | liftIO $ simpleBody x `shouldSatisfy` (== "\"4\"") 38 | 39 | 40 | context "no cookie is set" $ do 41 | 42 | it "one will be in the Set-Cookie header of the response" $ do 43 | resp <- request methodGet "" [] "" 44 | let Just c = parseSetCookie <$> lookup "Set-Cookie" (simpleHeaders resp) 45 | liftIO $ setCookieName c `shouldBe` setCookieName setCookieOpts 46 | liftIO $ setCookieValue c `shouldBe` "const" 47 | 48 | it "adds SetCookie params" $ do 49 | resp <- request methodGet "" [] "" 50 | let Just c = parseSetCookie <$> lookup "Set-Cookie" (simpleHeaders resp) 51 | liftIO $ setCookieMaxAge c `shouldBe` setCookieMaxAge setCookieOpts 52 | 53 | 54 | type API = SSession IO Int Int :> Get '[JSON] String 55 | 56 | setCookieOpts :: SetCookie 57 | setCookieOpts = def { setCookieName = "test", setCookieMaxAge = Just 300 } 58 | 59 | sessionMiddleware :: SessionStore IO Int a -> Vault.Key (Session IO Int a) -> Middleware 60 | sessionMiddleware s = withSession s "test" setCookieOpts 61 | 62 | server :: IO Application 63 | server = do 64 | ref <- mapStore (return "const") 65 | key <- Vault.newKey 66 | return $ sessionMiddleware ref key 67 | $ serve (Proxy :: Proxy API) (handler key) 68 | 69 | handler :: Vault.Key (Session IO Int Int) 70 | -> (Vault.Key (Session IO Int Int) -> Maybe (Session IO Int Int)) 71 | -> ExceptT ServantErr IO String 72 | handler key smap = do 73 | x <- liftIO $ lkup 1 74 | case x of 75 | Nothing -> liftIO (ins 1 0) >> return "Nothing" 76 | Just y -> liftIO (ins 1 $ succ y) >> return (show y) 77 | where 78 | Just (lkup, ins) = smap key 79 | -------------------------------------------------------------------------------- /thentos-cookie-session/thentos-cookie-session.cabal: -------------------------------------------------------------------------------- 1 | name: thentos-cookie-session 2 | version: 0.9.1 3 | synopsis: All-in-one session handling for servant-based frontends 4 | description: 5 | Uses cookies to store session keys. 6 | . 7 | Offers CSRF protection. 8 | . 9 | Designed with HTML frontends in mind, but Suitable for any HTTP service. 10 | license: AGPL 11 | license-file: LICENSE 12 | homepage: https://github.com/liqd/thentos 13 | author: Matthias Fischmann, Florian Hartwig, Christian Siefkes, Nicolas Pouillard 14 | maintainer: mf@zerobuzz.net, np@nicolaspouillard.fr 15 | copyright: liquid democracy e.V. (https://liqd.net/) 16 | category: Web, Authentication 17 | build-type: Simple 18 | cabal-version: >= 1.18 19 | 20 | Source-Repository head 21 | type: git 22 | location: https://github.com/liqd/thentos 23 | 24 | flag profiling 25 | default: False 26 | 27 | library 28 | default-language: 29 | Haskell2010 30 | hs-source-dirs: 31 | src 32 | ghc-options: 33 | -Wall -j1 34 | if flag(profiling) 35 | ghc-options: 36 | -auto-all -caf-all -fforce-recomp 37 | exposed-modules: 38 | Thentos.CookieSession 39 | , Thentos.CookieSession.CSRF 40 | , Thentos.CookieSession.Types 41 | , Control.Monad.Except.Missing 42 | , Servant.Missing 43 | build-depends: 44 | aeson >=0.11 && <0.12 45 | , base >=4.8 && <4.9 46 | , bytestring >=0.10 && <0.11 47 | , cookie >=0.4 && <0.5 48 | , cryptonite >=0.15 && <0.16 49 | , digestive-functors >=0.8 && <0.9 50 | , lens >=4.13 && <4.14 51 | , memory >=0.13 && <0.14 52 | , mtl >=2.2 && <2.3 53 | , resourcet >=1.1 && <1.2 54 | , sandi >=0.3.5 && <0.4 55 | , servant >=0.7 && <0.8 56 | , servant-server >=0.7 && <0.8 57 | , string-conversions >=0.4 && <0.5 58 | , text >=1.2 && <1.3 59 | , transformers >=0.4 && <0.5 60 | , vault >=0.3 && <0.4 61 | , wai >=3.2 && <3.3 62 | , wai-extra >=3.0 && <3.1 63 | , wai-session >=0.3 && <0.4 64 | 65 | test-suite spec 66 | type: exitcode-stdio-1.0 67 | ghc-options: 68 | -Wall -fno-warn-name-shadowing 69 | default-language: Haskell2010 70 | hs-source-dirs: test 71 | main-is: Spec.hs 72 | other-modules: 73 | Thentos.CookieSessionSpec 74 | build-depends: 75 | base == 4.* 76 | , cookie 77 | , hspec == 2.* 78 | , hspec-wai 79 | , http-types 80 | , servant-server 81 | , thentos-cookie-session 82 | , wai 83 | , wai-extra 84 | , wai-session 85 | , transformers 86 | , vault 87 | -------------------------------------------------------------------------------- /thentos-core/.gitignore: -------------------------------------------------------------------------------- 1 | /dist 2 | /docs 3 | /log/*.log 4 | /site_key.txt 5 | /TAGS 6 | -------------------------------------------------------------------------------- /thentos-core/HLint.hs: -------------------------------------------------------------------------------- 1 | import "hint" HLint.Default 2 | import "hint" HLint.Dollar 3 | import "hint" HLint.Generalise 4 | import "hint" HLint.HLint 5 | 6 | -- some rules are disabled universally; some are ignored in some modules. syntax: 7 | -- 8 | -- >>> rule ::= 'ignore' pattern [= module] 9 | -- >>> module ::= 'Thentos.Backend.Api.Adhocracy3' 10 | -- >>> pattern ::= '"' string '"' 11 | 12 | ignore "Redundant lambda" = Thentos.Backend.Api.Simple 13 | ignore "Redundant bracket" = Thentos.Backend.Api.Simple 14 | ignore "Redundant $" 15 | ignore "Redundant do" 16 | ignore "Use ." 17 | ignore "Use camelCase" 18 | ignore "Use const" 19 | ignore "Use fmap" 20 | ignore "Use head" 21 | ignore "Use list literal" 22 | ignore "Use mappend" 23 | ignore "Use record patterns" 24 | ignore "Parse error" 25 | 26 | -- FIXME: missing checks: 27 | -- 28 | -- - can i find / write a lint rule that disallows -fdefer-type-errors in OPTIONS pragmas? 29 | -- - check all modules for ghc options and move things to cabal file if appropriate. 30 | -- - language extensions enabled in cabal file should not be re-enabled in modules. 31 | -------------------------------------------------------------------------------- /thentos-core/LICENSE: -------------------------------------------------------------------------------- 1 | Thentos: A tool for privacy-preserving identity management 2 | Copyright (C) 2015-2019 liquid democracy e.V. 3 | 4 | This program is free software: you can redistribute it and/or modify 5 | it under the terms of the GNU Affero General Public License as 6 | published by the Free Software Foundation, either version 3 of the 7 | License, or (at your option) any later version. 8 | 9 | This program is distributed in the hope that it will be useful, 10 | but WITHOUT ANY WARRANTY; without even the implied warranty of 11 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 12 | GNU Affero General Public License for more details. 13 | 14 | You should have received a copy of the GNU Affero General Public License 15 | along with this program. If not, see . 16 | -------------------------------------------------------------------------------- /thentos-core/Makefile: -------------------------------------------------------------------------------- 1 | SHELL=/bin/bash 2 | HLINT=hlint 3 | 4 | hlint: 5 | $(HLINT) --version 6 | find src exec -name '*.hs' | xargs $(HLINT) 7 | 8 | wc: 9 | make -C .. wc 10 | 11 | clean: 12 | make -C .. clean 13 | 14 | dist-clean: clean 15 | cabal clean 16 | 17 | show-splices: 18 | cabal install -j1 --ghc-options="-fforce-recomp -ddump-splices" 19 | 20 | freeze: 21 | @cabal freeze --shadow-installed-packages --enable-test --enable-bench\ 22 | || ( echo -e "\n\nthere is a neat trick that may help you here:"\ 23 | ; echo -e "cut&paste cabal.config to the existing dependencies"\ 24 | ; echo -e "in lib target in thentos.cabal, then try again."\ 25 | ; echo -e "this may not yield the most up-to-date solution, but"\ 26 | ; echo -e "it is an easy way to get all dependencies of new libs"\ 27 | ; echo -e "listed in cabal.config.") 28 | -------------------------------------------------------------------------------- /thentos-core/Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /thentos-core/devel.config: -------------------------------------------------------------------------------- 1 | # This "secret" is hardcoded and public. 2 | # If you remove it, thentos will generate a new one for you. 3 | csrf_secret: 1daf3741e8a9ae1b39fd7e9cc7bab44ee31b6c3119ab5c3b05ac33cbb543289c 4 | 5 | backend: 6 | bind_port: 7001 7 | bind_host: "127.0.0.1" 8 | 9 | frontend: 10 | bind_port: 7002 11 | bind_host: "127.0.0.1" 12 | 13 | allow_ips: 14 | - 127.0.0.1 15 | 16 | smtp: 17 | sender_name: "Thentos" 18 | sender_address: "thentos@thentos.org" 19 | sendmail_path: "/usr/sbin/sendmail" # (built-in default) 20 | sendmail_args: ["-t"] # (built-in default) 21 | 22 | default_user: 23 | name: "god" 24 | password: "god" 25 | email: "postmaster@localhost" 26 | groups: ["groupAdmin", "groupUser", "groupServiceAdmin", "groupUserAdmin"] 27 | 28 | user_reg_expiration: 1d 29 | pw_reset_expiration: 1d 30 | email_change_expiration: 1d 31 | captcha_expiration: 1h 32 | gc_interval: 30m 33 | 34 | log: 35 | path: ./log/thentos.log 36 | level: DEBUG 37 | stdout: True 38 | 39 | database: 40 | name: "thentosdev" 41 | 42 | purescript: 43 | "./thentos-purescript/static/" 44 | 45 | email_templates: 46 | account_verification: 47 | subject: "Thentos: Aktivierung Ihres Nutzerkontos" 48 | # Supported variables: {{user_name}}, {{activation_url}} 49 | body: | 50 | Hallo {{user_name}}, 51 | 52 | vielen Dank für Ihre Registrierung bei Thentos. 53 | 54 | Diese E-Mail dient der Validierung Ihrer Identität. Bitte 55 | nutzen Sie den folgenden Link um das Nutzerkonto zu aktivieren. 56 | 57 | {{activation_url}} 58 | 59 | Wir wünschen Ihnen viel Spaß und Inspiration! 60 | 61 | Das Thentos-Team 62 | user_exists: 63 | subject: "Thentos: Attempted Signup" 64 | body: | 65 | Someone tried to sign up to Thentos with your email address. 66 | 67 | This is a reminder that you already have a Thentos account. If you 68 | haven't tried to sign up to Thentos, you can just ignore this email. 69 | If you have, you are hereby reminded that you already have an account. 70 | password_reset: 71 | subject: "Thentos: Reset Password" 72 | # Supported variables: {{user_name}}, {{reset_url}} 73 | body: | 74 | Dear {{user_name}}, 75 | 76 | please use the link below to reset your password. 77 | 78 | {{reset_url}} 79 | 80 | Your Thentos Team 81 | -------------------------------------------------------------------------------- /thentos-core/exec/Captcha.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | {-# LANGUAGE ScopedTypeVariables #-} 4 | 5 | module Main (main) where 6 | 7 | import Control.Concurrent.Async (concurrently) 8 | import Control.Exception (finally) 9 | import Data.Configifier ((>>.), Tagged(Tagged)) 10 | 11 | import Thentos (createConnPoolAndInitDb, runGcLoop) 12 | import Thentos.Action.Types (ActionEnv(ActionEnv)) 13 | import Thentos.Prelude 14 | import Thentos.Config 15 | import Thentos.Config.Reader 16 | import Thentos.Sybil.AudioCaptcha (checkEspeak) 17 | 18 | import qualified Thentos.Backend.Api.Captcha as Captcha 19 | 20 | 21 | main :: IO () 22 | main = do 23 | config :: ThentosConfig <- readConfig "devel.config" 24 | checkEspeak -- Make sure that we can successfully generate audio captchas 25 | connPool <- createConnPoolAndInitDb config 26 | let actionEnv = ActionEnv config connPool 27 | _ <- runGcLoop actionEnv $ config >>. (Proxy :: Proxy '["gc_interval"]) 28 | 29 | let backendCfg = forceCfg "backend" $ Tagged <$> config >>. (Proxy :: Proxy '["backend"]) 30 | backend = Captcha.runBackendApi backendCfg actionEnv 31 | frontendCfg = forceCfg "frontend" $ Tagged <$> config >>. (Proxy :: Proxy '["frontend"]) 32 | frontend = Captcha.runFrontendApi frontendCfg actionEnv 33 | run = void $ concurrently backend frontend 34 | finalize = announceAction "shutting down hslogger" removeAllHandlers 35 | 36 | logger INFO "Press ^C to abort." 37 | run `finally` finalize 38 | where 39 | forceCfg name = fromMaybe . error $ name ++ " not configured" 40 | -------------------------------------------------------------------------------- /thentos-core/exec/Main.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE NoImplicitPrelude #-} 2 | 3 | module Main where 4 | 5 | import Prelude (IO) 6 | 7 | import qualified Thentos 8 | 9 | main :: IO () 10 | main = Thentos.main 11 | -------------------------------------------------------------------------------- /thentos-core/frontend/static/screen.css: -------------------------------------------------------------------------------- 1 | html { 2 | background-color: #ffffa0; 3 | font-family: Verdana, Helvetica, sans-serif; 4 | } 5 | 6 | body { 7 | } 8 | 9 | table { 10 | } 11 | 12 | td { 13 | border: solid black; 14 | padding: 5px; 15 | } 16 | 17 | a { 18 | text-decoration: underline; 19 | } 20 | 21 | a :hover { 22 | cursor: pointer; 23 | text-decoration: underline; 24 | } 25 | 26 | img { 27 | border: none; 28 | } 29 | 30 | .logged_in { 31 | background-color: #c0ffc0; 32 | } 33 | 34 | .logged_out { 35 | background-color: #ffc0c0; 36 | } 37 | 38 | .dashboard_body { 39 | background-color: #ffffc3; 40 | border: dashed orange; 41 | } 42 | 43 | ul.digestive-functors-error-list { 44 | color: red; 45 | } 46 | 47 | .active_tab_header { 48 | background-color: #83ff89; 49 | font-weight: bold; 50 | } 51 | 52 | .inactive_tab_header { 53 | } -------------------------------------------------------------------------------- /thentos-core/log/.phony: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/liqd/thentos/f7d53d8e9d11956d2cc83efb5f5149876109b098/thentos-core/log/.phony -------------------------------------------------------------------------------- /thentos-core/resources/fonts/Courier_Prime.ttf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/liqd/thentos/f7d53d8e9d11956d2cc83efb5f5149876109b098/thentos-core/resources/fonts/Courier_Prime.ttf -------------------------------------------------------------------------------- /thentos-core/resources/fonts/Courier_Prime_Bold.ttf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/liqd/thentos/f7d53d8e9d11956d2cc83efb5f5149876109b098/thentos-core/resources/fonts/Courier_Prime_Bold.ttf -------------------------------------------------------------------------------- /thentos-core/resources/fonts/Courier_Prime_Bold_Italic.ttf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/liqd/thentos/f7d53d8e9d11956d2cc83efb5f5149876109b098/thentos-core/resources/fonts/Courier_Prime_Bold_Italic.ttf -------------------------------------------------------------------------------- /thentos-core/resources/fonts/Courier_Prime_Italic.ttf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/liqd/thentos/f7d53d8e9d11956d2cc83efb5f5149876109b098/thentos-core/resources/fonts/Courier_Prime_Italic.ttf -------------------------------------------------------------------------------- /thentos-core/resources/fonts/LICENSE_INFO: -------------------------------------------------------------------------------- 1 | http://quoteunquoteapps.com/courierprime/ 2 | http://scripts.sil.org/OFL 3 | 4 | -------------------------------------------------------------------------------- /thentos-core/schema/schema.sql: -------------------------------------------------------------------------------- 1 | -- All statements in this file must be idempotent (it is called at start time, every time). 2 | CREATE TABLE IF NOT EXISTS users ( 3 | id bigserial PRIMARY KEY, 4 | name text NOT NULL UNIQUE, 5 | password text NOT NULL, 6 | email text NOT NULL UNIQUE, 7 | confirmed bool NOT NULL, 8 | created timestamptz NOT NULL DEFAULT now() 9 | ); 10 | 11 | CREATE TABLE IF NOT EXISTS user_confirmation_tokens ( 12 | id bigint NOT NULL REFERENCES users (id) ON DELETE CASCADE, 13 | token text NOT NULL UNIQUE, 14 | timestamp timestamptz NOT NULL DEFAULT now() 15 | ); 16 | 17 | CREATE TABLE IF NOT EXISTS password_reset_tokens ( 18 | token text PRIMARY KEY, 19 | uid bigint NOT NULL REFERENCES users (id) ON DELETE CASCADE, 20 | timestamp timestamptz NOT NULL DEFAULT now() 21 | ); 22 | 23 | CREATE TABLE IF NOT EXISTS email_change_tokens ( 24 | token text PRIMARY KEY, 25 | uid bigint NOT NULL REFERENCES users (id) ON DELETE CASCADE, 26 | timestamp timestamptz NOT NULL DEFAULT now(), 27 | new_email text NOT NULL 28 | ); 29 | 30 | CREATE TABLE IF NOT EXISTS user_groups ( 31 | uid bigint NOT NULL REFERENCES users (id) ON DELETE CASCADE, 32 | grp text NOT NULL, 33 | UNIQUE (uid, grp) 34 | ); 35 | 36 | CREATE TABLE IF NOT EXISTS services ( 37 | id text PRIMARY KEY, 38 | owner_user bigint NOT NULL REFERENCES users (id), 39 | name text NOT NULL, 40 | description text NOT NULL, 41 | key text NOT NULL 42 | ); 43 | 44 | CREATE TABLE IF NOT EXISTS service_groups ( 45 | sid text REFERENCES services (id) ON DELETE CASCADE, 46 | grp text NOT NULL, 47 | UNIQUE (sid, grp) 48 | ); 49 | 50 | CREATE TABLE IF NOT EXISTS user_services ( 51 | uid bigint NOT NULL REFERENCES users (id) ON DELETE CASCADE, 52 | sid text NOT NULL REFERENCES services (id) ON DELETE CASCADE, 53 | anonymous bool NOT NULL, 54 | UNIQUE (uid, sid) 55 | ); 56 | 57 | CREATE TABLE IF NOT EXISTS personas ( 58 | id bigserial PRIMARY KEY, 59 | name text NOT NULL UNIQUE, 60 | uid bigint NOT NULL REFERENCES users (id) ON DELETE CASCADE, 61 | external_url text UNIQUE, -- e.g. A3 user path 62 | created timestamptz NOT NULL DEFAULT now() 63 | ); 64 | 65 | CREATE TABLE IF NOT EXISTS contexts ( 66 | id serial PRIMARY KEY, 67 | name text NOT NULL, 68 | owner_service text NOT NULL REFERENCES services (id), 69 | description text NOT NULL, 70 | url text, 71 | UNIQUE (owner_service, name), 72 | UNIQUE (owner_service, url) 73 | ); 74 | 75 | -- Which persona should be used for which context? 76 | CREATE TABLE IF NOT EXISTS personas_per_context ( 77 | id serial PRIMARY KEY, 78 | persona_id bigint NOT NULL REFERENCES personas (id) ON DELETE CASCADE, 79 | context_id bigint NOT NULL REFERENCES contexts (id) ON DELETE CASCADE, 80 | UNIQUE (persona_id, context_id) 81 | ); 82 | 83 | CREATE TABLE IF NOT EXISTS thentos_sessions ( 84 | token text PRIMARY KEY, 85 | uid bigint REFERENCES users (id) ON DELETE CASCADE, 86 | sid text REFERENCES services (id) ON DELETE CASCADE, 87 | start timestamptz NOT NULL, 88 | end_ timestamptz NOT NULL, 89 | period interval NOT NULL, 90 | CHECK ((uid IS NULL) <> (sid IS NULL)) 91 | ); 92 | 93 | CREATE TABLE IF NOT EXISTS service_sessions ( 94 | token text PRIMARY KEY, 95 | service text NOT NULL REFERENCES services (id) ON DELETE CASCADE, 96 | start timestamptz NOT NULL, 97 | end_ timestamptz NOT NULL, 98 | period interval NOT NULL, 99 | thentos_session_token text NOT NULL REFERENCES thentos_sessions (token) ON DELETE CASCADE, 100 | meta text NOT NULL 101 | ); 102 | 103 | -- A persona can be a member of any number of groups 104 | CREATE TABLE IF NOT EXISTS persona_groups ( 105 | pid bigint NOT NULL REFERENCES personas (id) ON DELETE CASCADE, 106 | grp text NOT NULL, 107 | UNIQUE (pid, grp) 108 | ); 109 | 110 | -- Groups can be members of other groups (any member of subgroup is also a member of supergroup) 111 | CREATE TABLE IF NOT EXISTS group_tree ( 112 | supergroup text NOT NULL, 113 | subgroup text NOT NULL, 114 | UNIQUE (supergroup, subgroup) 115 | ); 116 | 117 | CREATE TABLE IF NOT EXISTS captchas ( 118 | id text PRIMARY KEY, 119 | solution text NOT NULL, 120 | timestamp timestamptz NOT NULL DEFAULT now() 121 | ); 122 | -------------------------------------------------------------------------------- /thentos-core/schema/wipe.sql: -------------------------------------------------------------------------------- 1 | DROP SCHEMA public CASCADE; 2 | CREATE SCHEMA public; 3 | GRANT ALL ON SCHEMA public TO public; 4 | COMMENT ON SCHEMA public IS 'standard public schema'; 5 | -------------------------------------------------------------------------------- /thentos-core/src/Database/PostgreSQL/Simple/Missing.hs: -------------------------------------------------------------------------------- 1 | module Database.PostgreSQL.Simple.Missing where 2 | 3 | import Data.Attoparsec.ByteString.Char8 (Parser, anyChar, char, decimal, digit, isDigit, peekChar, signed, takeWhile1) 4 | import Data.Bits ((.&.)) 5 | import qualified Data.ByteString.Char8 as B8 6 | import Data.Char (ord) 7 | import Data.Fixed (Pico, Fixed(MkFixed)) 8 | import Data.Int (Int64) 9 | 10 | intervalSeconds :: Parser Pico 11 | intervalSeconds = do 12 | (h, m, s) <- interval 13 | return $ s + 60 * fromIntegral m + 60 * 60 * fromIntegral h 14 | 15 | -- | Parse a limited postgres interval of the form [-]HHH:MM:SS.[SSSS] (no larger units than hours). 16 | interval :: Parser (Int, Int, Pico) 17 | interval = do 18 | h <- signed decimal <* char ':' 19 | m <- twoDigits <* char ':' 20 | s <- seconds 21 | if m < 60 && s <= 60 22 | then return (h, m, s) 23 | else fail "invalid interval" 24 | 25 | -- helpers seconds and twoDigits below are lifted from postgresql-simple 26 | 27 | data T = T {-# UNPACK #-} !Int {-# UNPACK #-} !Int64 28 | 29 | -- | Parse a count of seconds, with the integer part being two digits 30 | -- long. 31 | seconds :: Parser Pico 32 | seconds = do 33 | real <- twoDigits 34 | mc <- peekChar 35 | case mc of 36 | Just '.' -> do 37 | t <- anyChar *> takeWhile1 isDigit 38 | return $! parsePicos real t 39 | _ -> return $! fromIntegral real 40 | where 41 | parsePicos a0 t = MkFixed (fromIntegral (t' * 10^n)) 42 | where 43 | T n t' = B8.foldl' step (T 12 (fromIntegral a0)) t 44 | step ma@(T m a) c 45 | | m <= 0 = ma 46 | | otherwise = T (m-1) (10 * a + fromIntegral (ord c) .&. 15) 47 | 48 | -- | Parse a two-digit integer (e.g. day of month, hour). 49 | twoDigits :: Parser Int 50 | twoDigits = do 51 | a <- digit 52 | b <- digit 53 | let c2d c = ord c .&. 15 54 | return $! c2d a * 10 + c2d b 55 | -------------------------------------------------------------------------------- /thentos-core/src/LIO/Missing.hs: -------------------------------------------------------------------------------- 1 | module LIO.Missing 2 | where 3 | 4 | import LIO.Core (MonadLIO, liftLIO, taint, guardWrite) 5 | import LIO.Error (AnyLabelError) 6 | import LIO.Label (Label) 7 | import LIO.DCLabel (DCLabel, (%%)) 8 | 9 | import qualified LIO.Exception as LE 10 | 11 | 12 | tryTaint :: (MonadLIO l m, Label l) => l -> m r -> (AnyLabelError -> m r) -> m r 13 | tryTaint label onSuccess onFailure = do 14 | result <- liftLIO $ LE.try (taint label) 15 | case result of 16 | Left e -> onFailure e 17 | Right () -> onSuccess 18 | 19 | tryGuardWrite :: (MonadLIO l m, Label l) => l -> m r -> (AnyLabelError -> m r) -> m r 20 | tryGuardWrite label onSuccess onFailure = do 21 | result <- liftLIO $ LE.try (guardWrite label) 22 | case result of 23 | Left e -> onFailure e 24 | Right () -> onSuccess 25 | 26 | -- | Test whether guard-write against a given label violates current clearance. In other words: 27 | -- whether given label can flow to clearance. 28 | guardWriteOk :: MonadLIO l m => l -> m Bool 29 | guardWriteOk l = tryGuardWrite l (pure True) (\_ -> pure False) 30 | 31 | dcBottom :: DCLabel 32 | dcBottom = True %% False 33 | 34 | dcTop :: DCLabel 35 | dcTop = False %% True 36 | -------------------------------------------------------------------------------- /thentos-core/src/Network/HostAddr.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE LambdaCase #-} 2 | 3 | module Network.HostAddr 4 | where 5 | 6 | import Data.Int (Int32) 7 | import Network.Socket 8 | (SockAddr(SockAddrInet, SockAddrInet6, SockAddrUnix, SockAddrCan), 9 | HostAddress, HostAddress6, SocketType(Stream), AddrInfoFlag(AI_NUMERICHOST), 10 | addrAddress, getAddrInfo, addrFlags, addrSocketType, defaultHints) 11 | 12 | data HostAddr 13 | = HostAddress HostAddress 14 | | HostAddress6 HostAddress6 15 | | UnixAddress String 16 | | CanAddress Int32 17 | deriving (Eq, Read, Show) 18 | 19 | hostAddr :: SockAddr -> HostAddr 20 | hostAddr = \case 21 | SockAddrInet _ ip -> HostAddress ip 22 | SockAddrInet6 _ _ ip _ -> HostAddress6 ip 23 | SockAddrUnix fp -> UnixAddress fp 24 | SockAddrCan i -> CanAddress i 25 | 26 | getHostAddr :: String -> IO HostAddr 27 | getHostAddr name = hostAddr . addrAddress . single <$> getAddrInfo (Just hints) (Just name) Nothing 28 | where 29 | hints = defaultHints { addrFlags = [AI_NUMERICHOST], addrSocketType = Stream } 30 | 31 | single [x] = x 32 | single [] = error "Impossible error: numeric addresses should always resolve" 33 | single _ = error "Impossible error: too many results from getAddrInfo should have been ruled out by our `hints`" 34 | -------------------------------------------------------------------------------- /thentos-core/src/Paths/TH.hs: -------------------------------------------------------------------------------- 1 | module Paths.TH (getPackageSourceRoot) where 2 | 3 | import Control.Exception (SomeException(SomeException), catch) 4 | import Data.Char (toUpper) 5 | import Data.Maybe (catMaybes) 6 | import Language.Haskell.TH (Q, Exp, runIO) 7 | import Language.Haskell.TH.Quote (dataToExpQ) 8 | import System.Directory (getCurrentDirectory, canonicalizePath) 9 | import System.Environment (lookupEnv) 10 | import System.FilePath (()) 11 | 12 | -- | Takes a package name and returns a directory 'FilePath' at compile time. The file path is 13 | -- determined as follows (first working method wins): 14 | -- 15 | -- 1. Shell variable. Example: CABAL_PACKAGE_SOURCE_ROOT_THENTOS_CORE for package thentos-core. 16 | -- 2. If current directory contains a directory with the same name as the package, take that. 17 | -- 3. Like 2., but on *parent* directory. 18 | -- 4. Take current directory. 19 | -- 20 | -- WARNING: use this only for testing or build-time effects! 21 | getPackageSourceRoot :: FilePath -> Q Exp 22 | getPackageSourceRoot fp = 23 | runIO (head . catMaybes <$> sequence 24 | [ lookupEnv (toShellVarName fp) 25 | , perhaps fp 26 | , perhaps $ ".." fp 27 | , Just <$> getCurrentDirectory 28 | ]) 29 | >>= dataToExpQ (const Nothing) 30 | 31 | perhaps :: FilePath -> IO (Maybe FilePath) 32 | perhaps fp = exceptToMaybe $ getCurrentDirectory >>= canonicalizePath . ( fp) 33 | 34 | exceptToMaybe :: IO a -> IO (Maybe a) 35 | exceptToMaybe a = (Just <$> a) `catch` \(SomeException _) -> return Nothing 36 | 37 | toShellVarName :: FilePath -> FilePath 38 | toShellVarName fp = "CABAL_PACKAGE_SOURCE_ROOT_" ++ (f <$> fp) 39 | where 40 | f '-' = '_' 41 | f c = toUpper c 42 | -------------------------------------------------------------------------------- /thentos-core/src/Paths_thentos_core__.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | #if DEVELOPMENT 3 | -- #warning "building in development mode (-fdevelopment)" 4 | {-# LANGUAGE TemplateHaskell #-} 5 | #else 6 | -- #warning "building in production mode: (-f-development)" 7 | #endif 8 | 9 | -- | Custom modifications to the cabal-generated "Paths_thentos_core". 10 | -- 11 | -- Quick motivation: we run code in at least the following different ways: 12 | -- 13 | -- - the deployed binary. 14 | -- - with hspec's sensei (via the `Makefile` rules in the git repo root). 15 | -- - interactively (via the repl rules, same `Makefile`). 16 | -- - the test suite (cabal `cabal test` or `./misc/thentos-install.hs`). 17 | -- - via TH splices that run during compile time (e.g., to compile css source files as byte 18 | -- strings into the executable) 19 | -- 20 | -- In order to make sure the code will find places in the file system in all these contexts, the 21 | -- cabal built-in functionality is almost enough, but not quite. This file adds two little quirks. 22 | -- 23 | -- 1. In development mode (cabal flag `development`), 'getDataFileName' returns the path into the 24 | -- package root (it just calls 'getPackageSourceRoot'). 25 | -- 2. 'getPackageSourceRoot' is exported both from here and from "Paths.TH" for use in sibling 26 | -- packages. 27 | -- 28 | -- Related info: http://neilmitchell.blogspot.de/2008/02/adding-data-files-using-cabal.html 29 | module Paths_thentos_core__ (getDataFileName, getPackageSourceRoot, version) where 30 | 31 | import Paths.TH (getPackageSourceRoot) 32 | 33 | #if !DEVELOPMENT 34 | import Paths_thentos_core 35 | 36 | #else 37 | import Distribution.Version (Version(Version)) 38 | import System.FilePath (()) 39 | 40 | getDataFileName :: FilePath -> IO FilePath 41 | getDataFileName = return . ($(getPackageSourceRoot "thentos-core") ) 42 | 43 | version :: Version 44 | version = Version [] [] 45 | 46 | #endif 47 | -------------------------------------------------------------------------------- /thentos-core/src/System/Log/Missing.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveDataTypeable #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | {-# LANGUAGE StandaloneDeriving #-} 4 | 5 | 6 | module System.Log.Missing 7 | ( logger 8 | , loggerName 9 | , announceAction 10 | , Prio(..) 11 | ) 12 | where 13 | 14 | import Control.Exception (bracket_) 15 | import Control.Monad.IO.Class (MonadIO, liftIO) 16 | import Data.Aeson (FromJSON(parseJSON), ToJSON(toJSON), Value(String)) 17 | import Data.Data (Typeable) 18 | import Data.String.Conversions (cs) 19 | import Data.Text (toUpper, pack) 20 | import Safe (readMay) 21 | 22 | import System.Log.Logger 23 | 24 | -- | 'logM' has two drawbacks: (1) It asks for a hierarchical logger 25 | -- (aka component or module) name, but we don't want to bother with 26 | -- that; (2) it lives in 'IO', not 'MonadIO m => m'. 'log' is defined 27 | -- in "Prelude", that's why the slightly different name. 28 | 29 | newtype Prio = Prio { fromPrio :: Priority } 30 | deriving (Show, Eq) 31 | 32 | logger :: MonadIO m => Priority -> String -> m () 33 | logger prio msg = liftIO $ logM loggerName prio msg 34 | 35 | loggerName :: String 36 | loggerName = "Thentos" 37 | 38 | announceAction :: String -> IO a -> IO a 39 | announceAction msg = bracket_ (logger INFO msg) (logger INFO $ msg ++ ": [ok]") 40 | 41 | deriving instance Typeable Prio 42 | 43 | instance FromJSON Prio where 44 | parseJSON (String s) = Prio <$> maybe (fail $ "not a valid log priority: " ++ cs s) return 45 | (readMay . cs . toUpper $ s) 46 | parseJSON _ = fail "expected a string representing log priority" 47 | 48 | instance ToJSON Prio where 49 | toJSON = String . pack . show . fromPrio 50 | -------------------------------------------------------------------------------- /thentos-core/src/Thentos/Action/SimpleAuth.hs: -------------------------------------------------------------------------------- 1 | {- Safe -} 2 | 3 | {-# LANGUAGE FlexibleContexts #-} 4 | {-# LANGUAGE FlexibleInstances #-} 5 | {-# LANGUAGE MultiParamTypeClasses #-} 6 | 7 | -- | Simplified access to 'Action' with guarded exits. 8 | module Thentos.Action.SimpleAuth 9 | ( assertAuth 10 | , hasAgent 11 | , hasUserId 12 | , hasServiceId 13 | , hasGroup 14 | , hasPrivilegedIP 15 | ) where 16 | 17 | import Control.Conditional (ifM) 18 | import LIO.Core (liftLIO, taint) 19 | import LIO.DCLabel ((%%)) 20 | 21 | import LIO.Missing 22 | import Thentos.Backend.Api.Auth.Types 23 | import Thentos.Types 24 | 25 | 26 | -- | Run boolean authorization predicate. Throw 'ActionErrorAnyLabel' if the result is 'False'. 27 | assertAuth :: MonadThentosIO m => m Bool -> m () 28 | assertAuth utest = ifM utest (pure ()) (liftLIO $ taint dcTop) 29 | 30 | hasAgent :: MonadThentosIO m => Agent -> m Bool 31 | hasAgent (UserA u) = hasUserId u 32 | hasAgent (ServiceA s) = hasServiceId s 33 | 34 | hasUserId :: MonadThentosIO m => UserId -> m Bool 35 | hasUserId uid = guardWriteOk (UserA uid %% UserA uid) 36 | 37 | hasServiceId :: MonadThentosIO m => ServiceId -> m Bool 38 | hasServiceId sid = guardWriteOk (ServiceA sid %% ServiceA sid) 39 | 40 | hasGroup :: MonadThentosIO m => Group -> m Bool 41 | hasGroup g = guardWriteOk (g %% g) 42 | 43 | hasPrivilegedIP :: MonadThentosIO m => m Bool 44 | hasPrivilegedIP = guardWriteOk (PrivilegedIP %% PrivilegedIP) 45 | -------------------------------------------------------------------------------- /thentos-core/src/Thentos/Action/Types.hs: -------------------------------------------------------------------------------- 1 | {- Safe -} 2 | 3 | {-# LANGUAGE ConstraintKinds #-} 4 | {-# LANGUAGE DataKinds #-} 5 | {-# LANGUAGE DeriveFunctor #-} 6 | {-# LANGUAGE DeriveGeneric #-} 7 | {-# LANGUAGE FlexibleContexts #-} 8 | {-# LANGUAGE FlexibleInstances #-} 9 | {-# LANGUAGE MultiParamTypeClasses #-} 10 | {-# LANGUAGE TemplateHaskell #-} 11 | 12 | module Thentos.Action.Types where 13 | 14 | import Control.Exception (SomeException) 15 | import Control.Monad.Reader (ReaderT(ReaderT)) 16 | import Control.Monad.State (StateT) 17 | import Control.Monad.Trans.Class (lift) 18 | import Control.Monad.Trans.Either (EitherT(EitherT)) 19 | import Data.Configifier ((>>.)) 20 | import Database.PostgreSQL.Simple (Connection) 21 | import Data.Pool (Pool) 22 | import LIO.Core (LIO) 23 | import LIO.TCB (ioTCB) 24 | 25 | import Thentos.Types 26 | import Thentos.Config 27 | import Thentos.Prelude 28 | import Thentos.CookieSession.CSRF 29 | 30 | 31 | data ActionEnv = 32 | ActionEnv 33 | { _aStConfig :: ThentosConfig 34 | , _aStDb :: Pool Connection 35 | } 36 | deriving (Generic) 37 | 38 | makeLenses ''ActionEnv 39 | 40 | class GetThentosDb a where 41 | getThentosDb :: Getter a (Pool Connection) 42 | 43 | instance GetThentosDb ActionEnv where 44 | getThentosDb = aStDb 45 | 46 | class GetThentosConfig a where 47 | getThentosConfig :: Getter a ThentosConfig 48 | 49 | instance GetThentosConfig ActionEnv where 50 | getThentosConfig = aStConfig 51 | 52 | type MonadThentosConfig v m = (MonadReader v m, GetThentosConfig v) 53 | 54 | instance GetCsrfSecret ActionEnv where 55 | csrfSecret = pre $ aStConfig . to (>>. (Proxy :: Proxy '["csrf_secret"])) . _Just . csrfSecret . _Just 56 | 57 | 58 | -- | The 'Action' monad transformer stack. It contains: 59 | -- 60 | -- - 'LIO' as a base monad. 61 | -- - A state of polymorphic type (for use e.g. by the frontend handlers to store cookies etc.) 62 | -- - The option of throwing @ThentosError e@. (Not 'ActionError e', which contains 63 | -- authorization errors that must not be catchable from inside an 'Action'.) 64 | -- - An 'ActionEnv' in a reader. The state can be used by actions for calls to 'LIO', which 65 | -- will have authorized effect. Since it is contained in a reader, actions do not have the 66 | -- power to corrupt it. 67 | newtype ActionStack e s a = 68 | ActionStack 69 | { fromAction :: ReaderT ActionEnv 70 | (EitherT (ThentosError e) 71 | (StateT s 72 | (LIO DCLabel))) a 73 | } 74 | deriving (Functor, Generic) 75 | 76 | instance Applicative (ActionStack e s) where 77 | pure = ActionStack . pure 78 | (ActionStack ua) <*> (ActionStack ua') = ActionStack $ ua <*> ua' 79 | 80 | instance Monad (ActionStack e s) where 81 | return = pure 82 | (ActionStack ua) >>= f = ActionStack $ ua >>= fromAction . f 83 | 84 | instance MonadReader ActionEnv (ActionStack e s) where 85 | ask = ActionStack ask 86 | local f = ActionStack . local f . fromAction 87 | 88 | instance MonadError (ThentosError e) (ActionStack e s) where 89 | throwError = ActionStack . throwError 90 | catchError (ActionStack ua) h = ActionStack $ catchError ua (fromAction . h) 91 | 92 | instance MonadState s (ActionStack e s) where 93 | state = ActionStack . state 94 | 95 | instance MonadLIO DCLabel (ActionStack e s) where 96 | liftLIO lio = ActionStack . ReaderT $ \_ -> EitherT (Right <$> lift lio) 97 | 98 | instance MonadRandom (ActionStack e s) where 99 | getRandomBytes = liftLIO . ioTCB . getRandomBytes 100 | 101 | type MonadQuery e v m = 102 | (GetThentosDb v, 103 | GetThentosConfig v, 104 | MonadReader v m, 105 | MonadThentosError e m, 106 | MonadThentosIO m) 107 | 108 | type MonadAction e v m = (MonadQuery e v m, MonadRandom m) 109 | 110 | -- | Errors known by 'runActionE', 'runAction', .... 111 | -- 112 | -- FIXME DOC 113 | -- The 'MonadError' instance of newtype 'Action' lets you throw and catch errors from *within* the 114 | -- 'Action', i.e., at construction time). These are errors are handled in the 'ActionErrorThentos' 115 | -- constructor. Label errors and other (possibly async) exceptions are caught (if possible) in 116 | -- 'runActionE' and its friends and maintained in other 'ActionError' constructors. 117 | data ActionError e = 118 | ActionErrorThentos (ThentosError e) 119 | | ActionErrorAnyLabel AnyLabelError 120 | | ActionErrorUnknown SomeException 121 | deriving (Show) 122 | 123 | instance (Show e, Typeable e) => Exception (ActionError e) 124 | -------------------------------------------------------------------------------- /thentos-core/src/Thentos/Action/Unsafe.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE Unsafe #-} 2 | 3 | {-# LANGUAGE DataKinds #-} 4 | {-# LANGUAGE FlexibleContexts #-} 5 | {-# LANGUAGE ScopedTypeVariables #-} 6 | 7 | module Thentos.Action.Unsafe 8 | where 9 | 10 | import LIO.Core (setClearanceP) 11 | import LIO.TCB (Priv(PrivTCB), ioTCB) 12 | 13 | import Thentos.Action.Types 14 | import Thentos.Prelude 15 | import Thentos.Transaction.Core (ThentosQuery, runThentosQuery) 16 | import Thentos.Types 17 | 18 | import qualified Thentos.Transaction as T 19 | 20 | 21 | -- * making unsafe actions safe 22 | 23 | unsafeLiftIO :: MonadThentosIO m => IO a -> m a 24 | unsafeLiftIO = liftLIO . ioTCB 25 | 26 | -- * queries 27 | 28 | query :: MonadQuery e v m => ThentosQuery e a -> m a 29 | query u = do 30 | connPool <- view getThentosDb 31 | unsafeLiftIO (runThentosQuery connPool u) >>= either throwError return 32 | 33 | 34 | -- * labels, privileges and access rights. 35 | 36 | extendClearanceOnLabel :: MonadThentosIO m => DCLabel -> m () 37 | extendClearanceOnLabel label = liftLIO $ do 38 | getClearance >>= setClearanceP (PrivTCB cFalse) . (`lub` label) 39 | 40 | extendClearanceOnPrincipals :: MonadThentosIO m => ToCNF cnf => [cnf] -> m () 41 | extendClearanceOnPrincipals principals = mapM_ extendClearanceOnLabel $ [ p %% p | p <- principals ] 42 | 43 | extendClearanceOnAgent :: MonadQuery e v m => Agent -> m () 44 | extendClearanceOnAgent agent = do 45 | extendClearanceOnPrincipals [agent] 46 | query (T.agentGroups agent) >>= extendClearanceOnPrincipals 47 | -------------------------------------------------------------------------------- /thentos-core/src/Thentos/Backend/Api/Auth.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts #-} 2 | {-# LANGUAGE FlexibleInstances #-} 3 | {-# LANGUAGE MultiParamTypeClasses #-} 4 | {-# LANGUAGE ScopedTypeVariables #-} 5 | {-# LANGUAGE TypeFamilies #-} 6 | {-# LANGUAGE TypeOperators #-} 7 | 8 | {-# OPTIONS_GHC -fno-warn-orphans #-} 9 | 10 | -- | Authentication via 'ThentosSessionToken'. 11 | -- 12 | -- A LESS RELEVANT OBSERVATION: It would be nice if we could provide this function: 13 | -- 14 | -- >>> thentosAuth :: ActionEnv 15 | -- >>> -> ServerT api (Action) 16 | -- >>> -> Maybe ThentosSessionToken 17 | -- >>> -> Server api 18 | -- >>> thentosAuth actionEnv api mTok = enter (enterAction actionEnv mTok) api 19 | -- 20 | -- because then here we could write: 21 | -- 22 | -- >>> api :: ActionEnv -> Server (ThentosAuth :> MyApi) 23 | -- >>> api = (`thentosAuth` myApi) 24 | -- 25 | -- But the signature of `thentosAuth` requires injectivity of `ServerT` (`api` needs to be inferred 26 | -- from `ServerT api (Action)`). ghc-7.12 may help (see 27 | -- https://ghc.haskell.org/trac/ghc/wiki/InjectiveTypeFamilies), or it may not: Even if injective 28 | -- type families are supported, `ServerT` may not be injective in some particular type that this 29 | -- function is called with. 30 | -- 31 | -- So instead, you will have to write something like this: 32 | -- 33 | -- >>> api :: ActionEnv -> Server (ThentosAuth :> MyApi) 34 | -- >>> api actionEnv mTok = enter (enterAction actionEnv mTok) myApi 35 | module Thentos.Backend.Api.Auth (module Thentos.Backend.Api.Auth.Types) where 36 | 37 | import Control.Lens ((&), (<>~)) 38 | import Data.CaseInsensitive (foldedCase) 39 | import Data.Proxy (Proxy(Proxy)) 40 | import Data.String.Conversions (cs) 41 | import Network.Wai (remoteHost) 42 | import Network.Socket (SockAddr) 43 | import Servant.API ((:>)) 44 | import Servant.Server (HasServer, ServerT, route) 45 | import Servant.Server.Internal (passToServer) 46 | import Servant.Utils.Links (HasLink(MkLink, toLink)) 47 | 48 | import qualified Servant.Foreign as F 49 | 50 | import Thentos.Backend.Api.Auth.Types 51 | import Thentos.Backend.Core 52 | 53 | 54 | instance HasServer sub context => HasServer (ThentosAuth :> sub) context where 55 | type ServerT (ThentosAuth :> sub) m = ThentosAuthCredentials -> ServerT sub m 56 | route Proxy context sub = route (Proxy :: Proxy sub) context $ passToServer sub go 57 | where 58 | go request = 59 | let mTok = lookupThentosHeaderSession renderThentosHeaderName request in 60 | let origin :: SockAddr = remoteHost request in 61 | ThentosAuthCredentials mTok origin 62 | 63 | instance HasLink sub => HasLink (ThentosAuth :> sub) where 64 | type MkLink (ThentosAuth :> sub) = MkLink sub 65 | toLink _ = toLink (Proxy :: Proxy sub) 66 | 67 | instance F.HasForeign F.NoTypes () sub => F.HasForeign F.NoTypes () (ThentosAuth :> sub) where 68 | type Foreign () (ThentosAuth :> sub) = F.Foreign () sub 69 | foreignFor plang Proxy Proxy req = F.foreignFor plang Proxy (Proxy :: Proxy sub) $ req 70 | & F.reqHeaders <>~ [F.HeaderArg (F.Arg headerName ())] 71 | where 72 | headerName = F.PathSegment . cs . foldedCase $ renderThentosHeaderName ThentosHeaderSession 73 | -------------------------------------------------------------------------------- /thentos-core/src/Thentos/Backend/Api/Auth/Types.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveGeneric #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | 4 | module Thentos.Backend.Api.Auth.Types 5 | where 6 | 7 | import GHC.Generics (Generic) 8 | import LIO.DCLabel (ToCNF, toCNF) 9 | import Network.Socket (SockAddr) 10 | 11 | import Thentos.Types (ThentosSessionToken) 12 | 13 | 14 | data ThentosAuth 15 | 16 | data ThentosAuthCredentials = 17 | ThentosAuthCredentials 18 | { thentosAuthSessionToken :: Maybe ThentosSessionToken 19 | , thentosAuthOrigin :: SockAddr 20 | } 21 | 22 | -- | Principal for lio 'CNF' expressions that is present iff request's IP address is privileged. 23 | data PrivilegedIP = PrivilegedIP 24 | deriving (Eq, Ord, Show, Read, Enum, Bounded, Generic) 25 | 26 | instance ToCNF PrivilegedIP where toCNF = toCNF . show 27 | -------------------------------------------------------------------------------- /thentos-core/src/Thentos/Backend/Api/Docs/Proxy.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE FlexibleContexts #-} 3 | {-# LANGUAGE FlexibleInstances #-} 4 | {-# LANGUAGE MultiParamTypeClasses #-} 5 | {-# LANGUAGE OverloadedStrings #-} 6 | {-# LANGUAGE ScopedTypeVariables #-} 7 | {-# LANGUAGE TypeFamilies #-} 8 | {-# LANGUAGE TypeOperators #-} 9 | 10 | {-# OPTIONS -fno-warn-orphans #-} 11 | 12 | module Thentos.Backend.Api.Docs.Proxy where 13 | 14 | import Control.Lens ((&), (%~)) 15 | import Data.Proxy (Proxy(Proxy)) 16 | import Servant.API ((:<|>)) 17 | import Servant.Docs (HasDocs(..)) 18 | 19 | import qualified Servant.Docs as Docs 20 | import qualified Servant.Foreign as F 21 | import qualified Servant.Foreign.Internal as F 22 | 23 | import Thentos.Backend.Api.Docs.Common () 24 | import Thentos.Backend.Api.Proxy (ServiceProxy) 25 | 26 | 27 | instance HasDocs sublayout => HasDocs (sublayout :<|> ServiceProxy) where 28 | docsFor _ dat opt = docsFor (Proxy :: Proxy sublayout) dat opt 29 | & Docs.apiIntros %~ (++ intros) 30 | where 31 | intros = [Docs.DocIntro "@@1.3@@Authenticating Proxy" [unlines desc]] 32 | desc = [ "All requests that are not handled by the endpoints listed" 33 | , "below are handled as follows:" 34 | , "We extract the Thentos Session Token (X-Thentos-Session) from" 35 | , "the request headers and forward the request to the service, adding" 36 | , "X-Thentos-User and X-Thentos-Groups with the appropriate" 37 | , "data to the request headers. If the request does not include" 38 | , "a valid session token, it is rejected. Responses from the" 39 | , "service are returned unmodified." 40 | ] 41 | 42 | instance F.HasForeign F.NoTypes () ServiceProxy where 43 | type Foreign () ServiceProxy = F.Req () 44 | foreignFor Proxy Proxy Proxy req = 45 | req & F.reqFuncName . F._FunctionName %~ ("ServiceProxy" :) 46 | -------------------------------------------------------------------------------- /thentos-core/src/Thentos/Backend/Api/PureScript.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | 4 | module Thentos.Backend.Api.PureScript where 5 | 6 | import Data.Configifier ((>>.)) 7 | import Data.Proxy (Proxy(Proxy)) 8 | import Data.String.Conversions (cs) 9 | import Servant.API (Raw) 10 | import Servant.Server.Internal.RoutingApplication (toApplication, RouteResult(Fail)) 11 | import Servant.Server.Internal.ServantErr (err404, errBody) 12 | import Servant.Server (Server) 13 | import Servant.Utils.StaticFiles (serveDirectory) 14 | 15 | import Thentos.Config (ThentosConfig) 16 | 17 | 18 | type Api = Raw 19 | 20 | api :: ThentosConfig -> Server Api 21 | api cfg = api' $ cs <$> cfg >>. (Proxy :: Proxy '["purescript"]) 22 | 23 | api' :: Maybe FilePath -> Server Api 24 | api' (Just fp) = serveDirectory fp 25 | api' Nothing = toApplication $ 26 | \_ cont -> cont $ Fail err404 { errBody = "purescript frontend not configured." } 27 | -------------------------------------------------------------------------------- /thentos-core/src/Thentos/Config/Reader.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE ScopedTypeVariables #-} 3 | {-# LANGUAGE ViewPatterns #-} 4 | 5 | {-# OPTIONS_GHC -O0 #-} 6 | module Thentos.Config.Reader where 7 | 8 | import Data.Configifier 9 | import System.Log.Logger 10 | import System.Directory (createDirectoryIfMissing, setCurrentDirectory, canonicalizePath) 11 | import System.FilePath (takeDirectory) 12 | import System.IO (stdout) 13 | import System.Log.Formatter (simpleLogFormatter, nullFormatter) 14 | import System.Log.Handler.Simple (formatter, fileHandler, streamHandler) 15 | 16 | import Thentos.Config 17 | 18 | import qualified Data.Text as ST 19 | import qualified Data.Text.IO as ST 20 | 21 | import Thentos.Prelude 22 | 23 | readConfig :: FilePath -> IO ThentosConfig 24 | readConfig configFile = defaultSources' "THENTOS_" [configFile] >>= readConfigWithSources 25 | 26 | readConfigWithSources :: [Source] -> IO ThentosConfig 27 | readConfigWithSources sources = do 28 | logger DEBUG $ "config sources:\n" ++ ppShow sources 29 | 30 | result <- try $ configifyWithDefault (TaggedM defaultThentosConfig) sources 31 | case result of 32 | Left (e :: Error) -> do 33 | logger CRITICAL $ "error parsing config: " ++ ppShow e 34 | printConfigUsage 35 | throwIO e 36 | Right cfg -> do 37 | logger DEBUG $ "parsed config (yaml):\n" ++ cs (renderConfigFile cfg) 38 | logger DEBUG $ "parsed config (raw):\n" ++ ppShow cfg 39 | configLogger (Tagged $ cfg >>. (Proxy :: Proxy '["log"])) 40 | configSignupLogger (cfg >>. (Proxy :: Proxy '["signup_log"])) 41 | setRootPath (cfg >>. (Proxy :: Proxy '["root_path"])) 42 | return cfg 43 | 44 | 45 | -- ** helpers 46 | 47 | printConfigUsage :: IO () 48 | printConfigUsage = do 49 | ST.putStrLn $ docs (Proxy :: Proxy (ToConfigCode ThentosConfig')) 50 | 51 | setRootPath :: ST -> IO () 52 | setRootPath (cs -> path) = do 53 | canonicalizePath path >>= logger INFO . ("Current working directory: " ++) . show 54 | setCurrentDirectory path 55 | 56 | 57 | -- * logging 58 | 59 | -- | Note: logging to stderr does not work very well together with multiple threads. stdout is 60 | -- line-buffered and works better that way. 61 | -- 62 | -- FIXME: there should be a way to override an already-set log file with 'no log file' on e.g. the 63 | -- command line. (difficult with the current 'Maybe' solution; this may be a configifier patch.) 64 | configLogger :: LogConfig -> IO () 65 | configLogger config = do 66 | let logfile = ST.unpack $ config >>. (Proxy :: Proxy '["path"]) 67 | loglevel = fromPrio $ config >>. (Proxy :: Proxy '["level"]) 68 | logstdout :: Bool = config >>. (Proxy :: Proxy '["stdout"]) 69 | removeAllHandlers 70 | createDirectoryIfMissing True $ takeDirectory logfile 71 | 72 | let fmt = simpleLogFormatter "$utcTime *$prio* [$pid][$tid] -- $msg" 73 | mkHandler f = (\h -> h { formatter = fmt }) <$> f loglevel 74 | 75 | handlers <- sequence $ mkHandler <$> fileHandler logfile : [streamHandler stdout | logstdout] 76 | 77 | updateGlobalLogger loggerName $ 78 | setLevel loglevel . 79 | setHandlers handlers 80 | 81 | configSignupLogger :: Maybe ST -> IO () 82 | configSignupLogger Nothing = return () 83 | configSignupLogger (Just path) = do 84 | let logfile = ST.unpack path 85 | createDirectoryIfMissing True $ takeDirectory logfile 86 | handler <- fileHandler logfile DEBUG 87 | let handler' = handler { formatter = nullFormatter } 88 | updateGlobalLogger signupLogger (setHandlers [handler']) 89 | -------------------------------------------------------------------------------- /thentos-core/src/Thentos/Ends/Types.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE FlexibleInstances #-} 3 | {-# LANGUAGE MultiParamTypeClasses #-} 4 | {-# LANGUAGE OverloadedStrings #-} 5 | {-# LANGUAGE ScopedTypeVariables #-} 6 | {-# LANGUAGE TypeFamilies #-} 7 | 8 | -- | Types required by both backend and frontend. 9 | module Thentos.Ends.Types 10 | ( HTM 11 | , renderHTM 12 | , PrettyHTML 13 | , TextCss 14 | , PNG 15 | , WAV 16 | ) 17 | where 18 | 19 | import Control.Lens ((&), (%~), (.~)) 20 | import Data.Proxy (Proxy(Proxy)) 21 | import Data.String.Conversions (ST, LT, SBS, LBS, cs) 22 | import Network.HTTP.Media ((//), (/:)) 23 | import Servant.API (Accept (..), MimeRender (..)) 24 | import Servant.HTML.Blaze (HTML) 25 | import Text.Blaze.Html (Html, ToMarkup, toHtml) 26 | import Text.Blaze.Html.Renderer.Pretty (renderHtml) 27 | 28 | import qualified Servant.Foreign as F 29 | import qualified Servant.Foreign.Internal as F 30 | 31 | import Thentos.Types 32 | 33 | 34 | -- * content types 35 | 36 | -- FUTUREWORK: we will need more of http://www.iana.org/assignments/media-types/media-types.xhtml, 37 | -- and we should probably add all of them either to the servant package or to a new package 38 | -- servant-content-types rather than here. 39 | 40 | -- | Html content type with pretty printing. (See also: package servant-blaze.) 41 | type HTM = PrettyHTML 42 | 43 | renderHTM :: Html -> LBS 44 | renderHTM = cs . renderHtml 45 | 46 | data PrettyHTML 47 | 48 | instance Accept PrettyHTML where 49 | contentType _ = contentType (Proxy :: Proxy HTML) 50 | 51 | instance {-# OVERLAPPABLE #-} ToMarkup a => MimeRender PrettyHTML a where 52 | mimeRender _ = renderHTM . toHtml 53 | 54 | instance {-# OVERLAPPING #-} MimeRender PrettyHTML Html where 55 | mimeRender _ = renderHTM 56 | 57 | 58 | data TextCss 59 | 60 | instance Accept TextCss where 61 | contentType _ = "text" // "css" /: ("charset", "utf-8") 62 | 63 | instance MimeRender TextCss LBS where mimeRender _ = id 64 | instance MimeRender TextCss SBS where mimeRender _ = cs 65 | instance MimeRender TextCss ST where mimeRender _ = cs 66 | instance MimeRender TextCss LT where mimeRender _ = cs 67 | instance MimeRender TextCss String where mimeRender _ = cs 68 | 69 | 70 | data PNG 71 | 72 | instance Accept PNG where 73 | contentType _ = "image" // "png" 74 | 75 | instance MimeRender PNG ImageData where 76 | mimeRender _ = cs . fromImageData 77 | 78 | 79 | data WAV 80 | 81 | instance Accept WAV where 82 | contentType _ = "audio" // "l16" 83 | 84 | instance MimeRender WAV SBS where 85 | mimeRender _ = cs 86 | 87 | 88 | -- * servant foreign 89 | 90 | -- See https://github.com/haskell-servant/servant/issues/509 91 | -- See https://github.com/haskell-servant/servant/issues/290 92 | {- 93 | More generic instances for PNG and WAV would be better but this fails with the following 94 | error in Captcha.hs: `No instance for Foreign.NotFound arising from a use of `restDocs'`. 95 | 96 | instance {-# OVERLAPPING #-} (F.Elem PNG list, F.HasForeignType lang ftype a, F.ReflectMethod method) 97 | => F.HasForeign lang ftype (F.Verb method status list a) where 98 | type Foreign ftype (F.Verb method status list a) = F.Req ftype 99 | 100 | foreignFor lang Proxy Proxy req = 101 | req & F.reqFuncName . F._FunctionName %~ (methodLC :) 102 | & F.reqMethod .~ method 103 | & F.reqReturnType .~ Just retType 104 | where 105 | retType = F.typeFor lang (Proxy :: Proxy ftype) (Proxy :: Proxy a) 106 | method = F.reflectMethod (Proxy :: Proxy method) 107 | methodLC = ST.toLower $ cs method 108 | -} 109 | instance {-# OVERLAPPING #-} F.HasForeignType lang ftype a 110 | => F.HasForeign lang ftype (F.Verb 'F.POST status '[PNG] a) where 111 | type Foreign ftype (F.Verb 'F.POST status '[PNG] a) = F.Req ftype 112 | 113 | foreignFor lang Proxy Proxy req = 114 | req & F.reqFuncName . F._FunctionName %~ ("post" :) 115 | & F.reqMethod .~ "POST" 116 | & F.reqReturnType .~ Just retType 117 | where 118 | retType = F.typeFor lang (Proxy :: Proxy ftype) (Proxy :: Proxy a) 119 | 120 | instance {-# OVERLAPPING #-} F.HasForeignType lang ftype a 121 | => F.HasForeign lang ftype (F.Verb 'F.POST status '[WAV] a) where 122 | type Foreign ftype (F.Verb 'F.POST status '[WAV] a) = F.Req ftype 123 | 124 | foreignFor lang Proxy Proxy req = 125 | req & F.reqFuncName . F._FunctionName %~ ("post" :) 126 | & F.reqMethod .~ "POST" 127 | & F.reqReturnType .~ Just retType 128 | where 129 | retType = F.typeFor lang (Proxy :: Proxy ftype) (Proxy :: Proxy a) 130 | -------------------------------------------------------------------------------- /thentos-core/src/Thentos/Frontend.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE FlexibleContexts #-} 3 | {-# LANGUAGE OverloadedStrings #-} 4 | {-# LANGUAGE TemplateHaskell #-} 5 | {-# LANGUAGE TypeOperators #-} 6 | 7 | module Thentos.Frontend (runFrontend) where 8 | 9 | import Data.String.Conversions (LBS) 10 | import Servant hiding (serveDirectory) 11 | import System.Log.Logger (Priority(INFO)) 12 | 13 | import qualified Data.ByteString.Lazy.Char8 as LBS 14 | import qualified Network.Wai as Wai 15 | 16 | import System.Log.Missing (logger) 17 | import Thentos.Action.Types (ActionEnv) 18 | import Thentos.Backend.Core (addHeadersToResponse, runWarpWithCfg) 19 | import Thentos.Config 20 | import Thentos.Ends.Types 21 | import Thentos.Frontend.Handlers 22 | import Thentos.Frontend.Handlers.Combinators 23 | import Thentos.Frontend.State 24 | import Thentos.Frontend.TH 25 | import Thentos.Frontend.Types 26 | 27 | 28 | -- * driver 29 | 30 | runFrontend :: HttpConfig -> ActionEnv -> IO () 31 | runFrontend config aState = do 32 | logger INFO $ "running frontend on " ++ show (bindUrl config) ++ "." 33 | serveFActionStack (Proxy :: Proxy FrontendH) frontendH aState >>= runWarpWithCfg config . disableCaching 34 | 35 | type FrontendH = 36 | GetH 37 | :<|> "user" :> UserH 38 | :<|> "service" :> ServiceH 39 | :<|> "dashboard" :> DashboardH 40 | :<|> StaticContent 41 | 42 | frontendH :: FormHandler (ServerT FrontendH) 43 | frontendH = 44 | redirect' "/dashboard" 45 | :<|> userH 46 | :<|> serviceH 47 | :<|> dashboardH 48 | :<|> staticContent 49 | 50 | 51 | -- * static content 52 | 53 | -- | Instead of ServeDirectory, we bake all static content into the executable. This helps to 54 | -- minimize the number of moving parts in the deployment. 55 | type StaticContent = 56 | "screen.css" :> Get '[TextCss] LBS 57 | 58 | staticContent :: Applicative m => ServerT StaticContent m 59 | staticContent = 60 | l $(loadStaticContent "screen.css") 61 | where 62 | l = pure . LBS.pack 63 | 64 | 65 | -- * /user 66 | 67 | type UserH = 68 | UserRegisterH 69 | :<|> UserRegisterConfirmH 70 | :<|> UserLoginH 71 | :<|> ResetPasswordRequestH 72 | :<|> ResetPasswordH 73 | :<|> UserLogoutH 74 | :<|> EmailUpdateH 75 | :<|> EmailUpdateConfirmH 76 | :<|> PasswordUpdateH 77 | 78 | userH :: FormHandler (ServerT UserH) 79 | userH = 80 | userRegisterH 81 | :<|> userRegisterConfirmH 82 | :<|> userLoginH 83 | :<|> resetPasswordRequestH 84 | :<|> resetPasswordH 85 | :<|> userLogoutH 86 | :<|> emailUpdateH 87 | :<|> emailUpdateConfirmH 88 | :<|> passwordUpdateH 89 | 90 | 91 | -- * service 92 | 93 | type ServiceH = 94 | ServiceLoginH 95 | :<|> ServiceRegisterH 96 | :<|> ServiceCreateH 97 | 98 | serviceH :: FormHandler (ServerT ServiceH) 99 | serviceH = 100 | serviceLoginH 101 | :<|> serviceRegisterH 102 | :<|> serviceCreateH 103 | 104 | 105 | -- * Cache control 106 | 107 | -- | Disable response caching. The wrapped handler can overwrite this by 108 | -- setting its own cache control headers. 109 | -- 110 | -- Cache-control headers are only added to GET and HEAD responses since other request methods 111 | -- are considered uncachable by default. 112 | -- 113 | -- According to the HTTP 1.1 Spec, GET/HEAD responses with the following error codes (>= 400) may 114 | -- be cached unless forbidded by cache-control headers: 115 | -- 116 | -- * 404 Not Found 117 | -- * 405 Method Not Allowed 118 | -- * 410 Gone 119 | -- * 414 Request-URI Too Long 120 | -- * 501 Not Implemented 121 | disableCaching :: Wai.Middleware 122 | disableCaching app req cont = app req $ 123 | cont . (if relevantMeth then addHeadersToResponse cacheHeaders else id) 124 | where 125 | cacheHeaders = 126 | [ ("Cache-Control", "no-cache, no-store, must-revalidate") 127 | , ("Expires", "0") 128 | ] 129 | 130 | relevantMeth :: Bool 131 | relevantMeth = Wai.requestMethod req `elem` ["GET", "HEAD"] 132 | -------------------------------------------------------------------------------- /thentos-core/src/Thentos/Frontend/Pages/Core.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | module Thentos.Frontend.Pages.Core where 3 | 4 | import Text.Blaze.Html (Html, (!)) 5 | import Text.Digestive.Blaze.Html5 (form, childErrorList) 6 | import Text.Digestive.Form (Form, check, validate) 7 | import Text.Digestive.Types (Result(Success, Error)) 8 | import Text.Digestive.View (View, absoluteRef) 9 | 10 | import qualified Data.Text as ST 11 | import qualified Text.Blaze.Html5 as H 12 | import qualified Text.Blaze.Html5.Attributes as A 13 | 14 | import Thentos.Frontend.Types 15 | import Thentos.Prelude 16 | import Thentos.Types 17 | 18 | -- * base layout 19 | 20 | -- | Call 'basePagelet'' without optional headings. 21 | basePagelet :: FrontendSessionData -> ST -> Html -> Html 22 | basePagelet fsd title = basePagelet' fsd title Nothing 23 | 24 | -- | Create an html document with default headings from title, 25 | -- optional headings, and body. 26 | basePagelet' :: FrontendSessionData -> ST -> Maybe Html -> Html -> Html 27 | basePagelet' fsd title mHeadings body = H.docTypeHtml $ do 28 | H.head $ do 29 | H.title $ H.text title 30 | H.link ! A.rel "stylesheet" ! A.href "/screen.css" 31 | sequence_ mHeadings 32 | H.body $ do 33 | H.div . H.ul $ for_ (fsd ^. fsdMessages) (H.li . H.string . show) 34 | H.h1 $ H.text title 35 | body 36 | 37 | 38 | -- * forms 39 | 40 | -- | Protect a form from CSRF attacks by including a secret token as a hidden field. 41 | csrfProofForm :: FrontendSessionData -> View Html -> ST -> Html -> Html 42 | csrfProofForm fsd v action f = do 43 | childErrorList "" v 44 | form v action $ f <> csrfField 45 | where 46 | csrfField 47 | | Just csrfToken <- fsd ^. fsdCsrfToken = 48 | let name = H.toValue (absoluteRef "_csrf" v) in 49 | H.input ! A.type_ "hidden" 50 | ! A.id name 51 | ! A.name name 52 | ! A.value (H.toValue (fromCsrfToken csrfToken)) 53 | | otherwise = 54 | mempty 55 | 56 | 57 | -- * error / status reports to the user 58 | 59 | errorPage :: String -> Html 60 | errorPage = basePagelet fsd "Error" . errorHtml 61 | where 62 | fsd = emptyFrontendSessionData 63 | 64 | errorPagelet :: u -> rs -> String -> Html 65 | errorPagelet _ _ = errorHtml 66 | 67 | errorHtml :: String -> Html 68 | errorHtml = H.string . ("*** error: " ++) . show 69 | 70 | permissionDeniedPage :: Html 71 | permissionDeniedPage = basePagelet' fsd "Permission Denied" Nothing 72 | (H.a ! A.href "/dashboard" $ "Back to dashboard") 73 | where 74 | fsd = emptyFrontendSessionData 75 | 76 | notFoundPage :: Html 77 | notFoundPage = basePagelet fsd "Not Found" $ H.p "The requested page does not exist." 78 | where 79 | fsd = emptyFrontendSessionData 80 | 81 | confirmationMailSentPage :: FrontendSessionData -> ST -> ST -> ST -> Html 82 | confirmationMailSentPage fsd title msg1 msg2 = 83 | basePagelet fsd title $ confirmationMailSentBody msg1 msg2 84 | 85 | confirmationMailSentSnippet :: ST -> ST -> u -> rs -> Html 86 | confirmationMailSentSnippet msg1 msg2 _ _ = confirmationMailSentBody msg1 msg2 87 | 88 | confirmationMailSentBody :: ST -> ST -> Html 89 | confirmationMailSentBody msg1 msg2 = H.p . H.text . ST.unlines $ 90 | msg1 : 91 | "Please check your email (don't forget the spam folder)" : 92 | "and complete " <> msg2 <> " by following the link we sent you." : 93 | [] 94 | 95 | 96 | -- * form field validation 97 | 98 | validateNonEmpty :: (Monoid v, IsString v, Monad m) => v -> Form v m ST -> Form v m ST 99 | validateNonEmpty fieldName = check (fieldName <> " must not be empty") (not . ST.null) 100 | 101 | validateEmail :: (Monoid v, IsString v, Monad m) => Form v m ST -> Form v m UserEmail 102 | validateEmail = validate $ maybe (Error "email address invalid") Success . parseUserEmail 103 | 104 | validatePass :: (UserPass, UserPass) -> Result Html UserPass 105 | validatePass (p1, p2) 106 | | p1 == p2 = Success p1 107 | | otherwise = Error "passwords don't match" 108 | 109 | validatePassChange :: (UserPass, UserPass, UserPass) -> Result Html (UserPass, UserPass) 110 | validatePassChange (old, new1, new2) 111 | | new1 == new2 = Success (old, new1) 112 | | otherwise = Error "passwords don't match" 113 | -------------------------------------------------------------------------------- /thentos-core/src/Thentos/Frontend/State.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE FlexibleContexts #-} 3 | {-# LANGUAGE OverloadedStrings #-} 4 | {-# LANGUAGE RankNTypes #-} 5 | {-# LANGUAGE ScopedTypeVariables #-} 6 | {-# LANGUAGE TypeOperators #-} 7 | 8 | module Thentos.Frontend.State 9 | ( serveFActionStack 10 | , serveFAction 11 | , enterFAction 12 | , getFrontendCfg 13 | , fActionServantErr 14 | ) 15 | where 16 | 17 | import Control.Monad.Trans.Except (ExceptT(ExceptT)) 18 | import Data.Configifier (Tagged(Tagged)) 19 | import LIO.TCB (ioTCB) 20 | import Network.Wai (Application) 21 | import Servant (ServantErr, HasServer, ServerT, Server, (:~>)(Nat)) 22 | import Servant.Server (errHTTPCode, errHeaders, errBody, err303, err404, err400, err500) 23 | import Servant.Utils.Enter (Enter) 24 | import Text.Blaze.Html (Html) 25 | import Text.Blaze.Html.Renderer.Pretty (renderHtml) 26 | import Web.Cookie (SetCookie, def, setCookieName, setCookiePath) 27 | 28 | import Thentos.Prelude 29 | import Thentos.Action.Core 30 | import Thentos.Action.Types 31 | import Thentos.Action.TCB 32 | import Thentos.Backend.Core 33 | import Thentos.Config 34 | import Thentos.Frontend.Types 35 | import Thentos.CookieSession 36 | 37 | import qualified Thentos.Frontend.Pages.Core as Pages 38 | 39 | 40 | -- BUG #406: EU-required user notifications about cookies 41 | -- FUTUREWORK: more efficient refresh (only if changed or after 20% of the age has been passed) 42 | 43 | 44 | -- * errors 45 | 46 | fActionServantErr :: ActionError FActionError -> IO ServantErr 47 | fActionServantErr = errorInfoToServantErr mkServErr . 48 | actionErrorInfo (thentosErrorInfo f) 49 | where 50 | f :: FActionError -> (Maybe (Priority, String), ServantErr, ST) 51 | f (FActionError303 uri) = 52 | (Nothing, err303 { errHeaders = [("Location", uri)] }, "redirect: " <> cs uri) 53 | f FActionError404 = 54 | (Nothing, err404, "page not found.") 55 | f e@FActionErrorNoToken = 56 | (Just (DEBUG, show e), err400, "email confirmation url broken: no token.") 57 | f e@FActionErrorCreateService = 58 | (Just (DEBUG, show e), err400, "could not create service.") 59 | f e@FActionErrorServiceLoginNoCbUrl = 60 | (Just (DEBUG, show e), err400, "no or broken callback url.") 61 | f e@(FActionError500 _) = 62 | (Just (ERROR, show e), err500, "we are very sorry.") 63 | 64 | mkServErr :: ServantErr -> ST -> ServantErr 65 | mkServErr baseErr msg = baseErr 66 | { errBody = cs . renderHtml $ makeErrorPage (errHTTPCode baseErr) msg 67 | , errHeaders = ("Content-Type", "text/html; charset=utf-8") : errHeaders baseErr 68 | } 69 | 70 | makeErrorPage :: Int -> ST -> Html 71 | makeErrorPage 403 = const Pages.permissionDeniedPage 72 | makeErrorPage 404 = const Pages.notFoundPage 73 | makeErrorPage _ = Pages.errorPage . cs 74 | 75 | 76 | -- * middleware 77 | 78 | -- We set the path to "/" to keep the browser from setting the current path for the cookie and hence 79 | -- storing many cookies instead of only one. 80 | -- 81 | -- FIXME: make 'SetCookie' configurable with configifier. 82 | -- At least some configuration is possible now, see the SetCookie parameter to serveFAction. 83 | thentosSetCookie :: SetCookie 84 | thentosSetCookie = def { setCookieName = "thentos", setCookiePath = Just "/" } 85 | 86 | 87 | -- * frontend action monad 88 | 89 | type FActionStack = ActionStack FActionError FrontendSessionData 90 | 91 | serveFActionStack :: forall api. 92 | ( HasServer api '[] 93 | , Enter (ServerT api FActionStack) (FActionStack :~> ExceptT ServantErr IO) (Server api) 94 | ) 95 | => Proxy api -> ServerT api FActionStack -> ActionEnv -> IO Application 96 | serveFActionStack proxy fServer aState = 97 | serveFAction proxy (Proxy :: Proxy FrontendSessionData) thentosSetCookie 98 | extendClearanceOnThentosSession (Nat (liftLIO . ioTCB)) (Nat run) fServer 99 | where 100 | run :: FActionStack a -> ExceptT ServantErr IO a 101 | run = ExceptT . (>>= _Left fActionServantErr) . (fst <$>) 102 | . runActionE emptyFrontendSessionData aState 103 | 104 | getFrontendCfg :: MonadThentosConfig e m => m HttpConfig 105 | getFrontendCfg = do 106 | Just (feConfig :: HttpConfig) <- (Tagged <$>) <$> getConfigField (Proxy :: Proxy '["frontend"]) 107 | return feConfig 108 | -------------------------------------------------------------------------------- /thentos-core/src/Thentos/Frontend/TH.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TemplateHaskell #-} 2 | 3 | module Thentos.Frontend.TH where 4 | 5 | import Language.Haskell.TH (Q, Exp, runIO) 6 | import Language.Haskell.TH.Quote (dataToExpQ) 7 | import System.FilePath (()) 8 | 9 | import Paths_thentos_core__ (getPackageSourceRoot) 10 | 11 | loadStaticContent :: FilePath -> Q Exp 12 | loadStaticContent filePath = 13 | runIO (readFile ($(getPackageSourceRoot "thentos-core") "frontend/static/" filePath)) 14 | >>= dataToExpQ (const Nothing) 15 | -------------------------------------------------------------------------------- /thentos-core/src/Thentos/Prelude.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE PackageImports #-} 2 | module Thentos.Prelude (module X) where 3 | 4 | import Control.Applicative as X 5 | import Control.Conditional as X hiding ((<|), (??), (|>)) 6 | import Control.Exception as X (ErrorCall (..), Exception, IOException) 7 | import Control.Exception.Lifted as X (catch, throwIO, try) 8 | import Control.Lens as X hiding (Bifunctor, Context, bimap, contexts) 9 | import Control.Monad as X hiding (guard, unless, when) 10 | import Data.Char as X (isAlpha, ord, toUpper) 11 | {- FIXME: using monad-base might help working with MonadIO and MonadLIO 12 | import Control.Monad.Base as X (MonadBase (liftBase), liftBaseDefault) 13 | -} 14 | import Control.Monad.Error.Class as X (MonadError, catchError, throwError) 15 | import Control.Monad.IO.Class as X (MonadIO (liftIO)) 16 | import Control.Monad.Reader.Class as X (MonadReader (ask, local, reader), asks) 17 | import Control.Monad.State.Class as X (MonadState (put, get, state), gets, modify, modify') 18 | import Control.Monad.Trans.Control as X (MonadBaseControl) 19 | import "cryptonite" Crypto.Random as X (MonadRandom(getRandomBytes)) 20 | import Data.Bifunctor as X (Bifunctor, bimap, first, second) 21 | import Data.Either as X (isLeft, isRight) 22 | import Data.Foldable as X 23 | import Data.Function as X (on) 24 | import Data.Functor as X (($>)) 25 | import Data.Functor.Infix as X ((<$$>)) 26 | import Data.Int as X (Int64) 27 | import Data.List as X (groupBy, intercalate, isPrefixOf, nub, nubBy, sort, 28 | unfoldr, (\\)) 29 | import Data.Maybe as X (catMaybes, fromJust, fromMaybe, isJust, isNothing, 30 | listToMaybe, maybeToList) 31 | import Data.Monoid as X 32 | import Data.Proxy as X (Proxy (Proxy)) 33 | import Data.String as X (IsString (fromString)) 34 | import Data.String.Conversions as X (ConvertibleStrings, LBS, LT, SBS, ST, cs) 35 | import Data.Traversable as X 36 | import Data.Typeable as X (Typeable) 37 | import Data.Void as X (Void, absurd) 38 | import GHC.Generics as X (Generic) 39 | import LIO.Core as X (LIOState (LIOState), MonadLIO (liftLIO), evalLIO, 40 | getClearance, guardWrite, setClearance, taint) 41 | import LIO.DCLabel as X (CNF, DCLabel (DCLabel), ToCNF (toCNF), cFalse, (%%), (/\), 42 | (\/)) 43 | import LIO.Error as X (AnyLabelError (AnyLabelError)) 44 | import LIO.Label as X (Label, lub) 45 | import LIO.Missing as X (dcBottom, dcTop, guardWriteOk, tryGuardWrite, tryTaint) 46 | import Safe as X (fromJustNote, readMay) 47 | import System.Log as X (Priority (..)) 48 | import System.Log.Logger as X (removeAllHandlers, setHandlers, setLevel, 49 | updateGlobalLogger) 50 | import System.Log.Missing as X (Prio (fromPrio), announceAction, logger, loggerName) 51 | import System.Random as X (Random) 52 | import Text.Show.Pretty as X (ppShow) 53 | -------------------------------------------------------------------------------- /thentos-core/src/Thentos/Smtp.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | {-# LANGUAGE ScopedTypeVariables #-} 4 | 5 | module Thentos.Smtp (sendMail, SendmailError(..), checkSendmail) 6 | where 7 | 8 | import Thentos.Prelude 9 | import Data.Configifier ((>>.)) 10 | import Network.Mail.Mime (Mail, Address(Address), sendmailCustomCaptureOutput, 11 | simpleMail', renderMail') 12 | 13 | import qualified Data.ByteString as SB 14 | 15 | import Thentos.Config 16 | import Thentos.Types 17 | 18 | data SendmailError = SendmailError String 19 | 20 | sendMail :: SmtpConfig -> Maybe UserName -> UserEmail -> ST -> ST -> Maybe ST -> IO (Either SendmailError ()) 21 | sendMail config mName address subject message html = do 22 | logger DEBUG $ "sending email: " ++ ppShow (address, subject, message) 23 | when (isJust html) . logger WARNING $ "No support for the optional HTML part" 24 | renderedMail <- renderMail' mail 25 | r <- try $ sendmailCustomCaptureOutput sendmailPath sendmailArgs renderedMail 26 | case r of 27 | Right (out, err) -> do 28 | unless (SB.null out) . 29 | logger WARNING $ "sendmail produced output on stdout: " ++ cs out 30 | unless (SB.null err) . 31 | logger WARNING $ "sendmail produced output on stderr: " ++ cs err 32 | return $ Right () 33 | Left (e :: IOException) -> 34 | return . Left . SendmailError $ "IO error running sendmail: " ++ show e 35 | where 36 | receiverAddress = Address (fromUserName <$> mName) (fromUserEmail $ address) 37 | sentFromAddress = buildEmailAddress config 38 | 39 | mail :: Mail 40 | mail = simpleMail' receiverAddress sentFromAddress subject (cs message) 41 | 42 | sendmailPath :: String = cs $ config >>. (Proxy :: Proxy '["sendmail_path"]) 43 | sendmailArgs :: [String] = cs <$> config >>. (Proxy :: Proxy '["sendmail_args"]) 44 | 45 | -- | Run sendMail to check that we can send emails. Throw an error if sendmail 46 | -- is not available or doesn't work. 47 | checkSendmail :: SmtpConfig -> IO () 48 | checkSendmail cfg = do 49 | let address = fromJust $ parseUserEmail "user@example.com" 50 | result <- sendMail cfg Nothing address "Test Mail" "This is a test" Nothing 51 | case result of 52 | Left _ -> throwIO $ ErrorCall "sendmail seems to not work.\ 53 | \ Maybe the sendmail path is misconfigured?" 54 | Right () -> return () 55 | -------------------------------------------------------------------------------- /thentos-core/src/Thentos/Sybil.hs: -------------------------------------------------------------------------------- 1 | module Thentos.Sybil 2 | ( generateCaptcha 3 | , generateAudioCaptcha 4 | ) where 5 | 6 | import Thentos.Sybil.AudioCaptcha 7 | import Thentos.Sybil.GraphicCaptcha 8 | -------------------------------------------------------------------------------- /thentos-core/src/Thentos/Sybil/AudioCaptcha.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | {-# LANGUAGE ViewPatterns #-} 4 | 5 | -- FIXME: use 'Audio Word16' from package HCodecs instead of SBS. 6 | -- FIXME: provide start-time check (`init` function) for existence 7 | -- of executables. use it in main. 8 | 9 | module Thentos.Sybil.AudioCaptcha (checkEspeak, generateAudioCaptcha) where 10 | 11 | import System.Exit (ExitCode(ExitSuccess)) 12 | import System.FilePath (()) 13 | import System.IO.Temp (withSystemTempDirectory) 14 | import System.Process (readProcess, runInteractiveProcess, waitForProcess) 15 | 16 | import qualified Data.Text as ST 17 | import qualified Data.ByteString as SBS 18 | 19 | import Thentos.Prelude 20 | import Thentos.Types 21 | import Thentos.Action.Unsafe (unsafeLiftIO) 22 | 23 | -- | Test whether espeak is available on this system, throwing an error if it isn't. 24 | -- In that case, generating audio captchas won't work. 25 | checkEspeak :: IO () 26 | checkEspeak = void $ readProcess "espeak" ["--version"] "" 27 | 28 | -- | Generate a captcha. Returns a pair of the binary audio data in WAV format and the correct 29 | -- solution to the captcha. (Return value is wrapped in 'Action' for access to 'IO' and for 30 | -- throwing 'ThentosError'.) 31 | generateAudioCaptcha :: (MonadThentosIO m, MonadThentosError e m) => String -> Random20 -> m (SBS, ST) 32 | generateAudioCaptcha eSpeakVoice rnd = do 33 | let solution = mkAudioSolution rnd 34 | challenge <- mkAudioChallenge eSpeakVoice solution 35 | return (challenge, solution) 36 | 37 | -- | Returns 6 digits of randomness. (This loses a lot of the input randomness, but captchas are a 38 | -- low-threshold counter-measure, so they should be at least reasonably convenient to use.) 39 | mkAudioSolution :: Random20 -> ST 40 | mkAudioSolution = ST.intercalate " " 41 | . (cs . show . (`mod` 10) <$>) 42 | . take 6 . SBS.unpack . fromRandom20 43 | 44 | mkAudioChallenge :: (MonadThentosIO m, MonadThentosError e m) => String -> ST -> m SBS 45 | mkAudioChallenge eSpeakVoice solution = do 46 | unless (validateLangCode eSpeakVoice) $ do 47 | throwError $ AudioCaptchaVoiceNotFound eSpeakVoice 48 | 49 | eResult <- unsafeLiftIO . withSystemTempDirectory "thentosAudioCaptcha" $ 50 | \(( "captcha.wav") -> tempFile) -> do 51 | let args :: [String] 52 | args = [ "-w", tempFile 53 | -- FIXME: use "--stdout" (when I tried, I had truncation issues) 54 | , "-s", "100" 55 | , "-v", eSpeakVoice 56 | , cs $ ST.intersperse ' ' solution 57 | ] 58 | (_, outH, errH, procH) <- runInteractiveProcess "espeak" args Nothing Nothing 59 | outS <- SBS.hGetContents outH 60 | errS <- SBS.hGetContents errH 61 | exitCode <- waitForProcess procH 62 | 63 | if "Failed to read voice" `SBS.isInfixOf` errS 64 | then return . Left $ AudioCaptchaVoiceNotFound eSpeakVoice 65 | else if not ((exitCode == ExitSuccess) && SBS.null outS && SBS.null errS) 66 | then return . Left $ AudioCaptchaInternal exitCode outS errS 67 | else Right <$> SBS.readFile tempFile 68 | 69 | case eResult of 70 | Left e -> throwError e 71 | Right v -> return v 72 | 73 | validateLangCode :: String -> Bool 74 | validateLangCode (cs -> s) = 75 | not (ST.null s || ST.isPrefixOf "-" s || ST.isSuffixOf "-" s) 76 | && ST.all (`elem` '-':['a'..'z']) s 77 | -------------------------------------------------------------------------------- /thentos-core/src/Thentos/Sybil/GraphicCaptcha.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | {-# LANGUAGE ScopedTypeVariables #-} 3 | 4 | module Thentos.Sybil.GraphicCaptcha (generateCaptcha) where 5 | 6 | import Data.Elocrypt (mkPassword) 7 | 8 | import Codec.Picture (PixelRGBA8(PixelRGBA8), encodePng) 9 | import Control.Monad.Random.Class (MonadRandom, getRandomR) 10 | import Control.Monad.Random (evalRand, mkStdGen) 11 | import Graphics.Rasterific 12 | ( Drawing, PointSize(PointSize), Point 13 | , withTransformation, withTexture, printTextAt, rectangle, renderDrawing, fill 14 | ) 15 | import Graphics.Rasterific.Linear (V2(V2), (^*)) 16 | import Graphics.Rasterific.Texture (uniformTexture, patternTexture, transformTexture) 17 | import Graphics.Rasterific.Transformations (translate) 18 | import Graphics.Text.TrueType (Font, loadFontFile) 19 | 20 | import Thentos.Prelude hiding (MonadRandom) 21 | import Thentos.Types 22 | 23 | 24 | -- | Generate a captcha. Returns a pair of the binary image data in PNG format and the correct 25 | -- solution to the captcha. 26 | generateCaptcha :: Random20 -> IO (ImageData, ST) 27 | generateCaptcha rnd = do 28 | let fontPath = "./resources/fonts/Courier_Prime_Bold.ttf" 29 | font <- loadFontFile fontPath >>= either (throwIO . ErrorCall) return 30 | let random20ToStdGen = mkStdGen . sum . map ord . cs . fromRandom20 31 | return $ flip evalRand (random20ToStdGen rnd) $ do 32 | solution <- mkSolution 33 | challenge <- mkChallenge font solution 34 | return (challenge, cs solution) 35 | 36 | mkSolution :: MonadRandom m => m String 37 | mkSolution = unwords <$> replicateM 2 (mkPassword 3) 38 | 39 | 40 | mkChallenge :: forall m. MonadRandom m => Font -> String -> m ImageData 41 | mkChallenge font solution = 42 | let width = 300 43 | height = 100 44 | offsets = [30,65..] 45 | yOffset = 30 46 | textPx = 40 47 | render = renderDrawing width height (PixelRGBA8 255 255 255 255) 48 | letterParams = zip offsets solution 49 | 50 | fuzz :: Float -> m Float 51 | fuzz i = getRandomR (i * (1-a) + b, i * (1+a) - b) 52 | where 53 | a = 0.3 54 | b = 0.2 55 | 56 | holeOffsetParam = 10 57 | chunkOffsetParam = 2 58 | 59 | action :: m (Drawing PixelRGBA8 ()) 60 | action = do 61 | offsetParams <- forM solution $ \_ -> do 62 | holeOffset@(V2 x y) <- V2 <$> fuzz holeOffsetParam <*> fuzz 0 63 | chunkOffset <- V2 <$> fuzz (-x) <*> fuzz (-chunkOffsetParam-y) 64 | return (holeOffset, chunkOffset) 65 | 66 | let allParams = zip letterParams offsetParams 67 | 68 | return $ forM_ allParams $ \((offset, char), (holeOffset, chunkOffset)) -> do 69 | withTransformation (translate $ V2 offset yOffset) $ 70 | biteLetter holeOffset chunkOffset font textPx char 71 | 72 | in ImageData . cs . encodePng . render <$> action 73 | 74 | 75 | -- | Render a letter with a chunk displaced. 76 | biteLetter :: Point -> Point -> Font -> Float -> Char -> Drawing PixelRGBA8 () 77 | biteLetter _ _ _ _ ' ' = return () 78 | biteLetter holeOffset chunkOffset font size char = do 79 | withTexture texLetter $ fill rect 80 | withTexture texWhite $ fill hole 81 | withTexture texChunk $ fill chunk 82 | where 83 | -- Render letter to texture 84 | black = PixelRGBA8 0 0 0 255 85 | white = PixelRGBA8 255 255 255 255 86 | transparent = PixelRGBA8 255 255 255 0 87 | texBlack = uniformTexture black 88 | texWhite = uniformTexture white 89 | printText = printTextAt font (PointSize size) (V2 0 size) [char] 90 | letter = withTexture texBlack printText 91 | texLetter = patternTexture 100 100 96 transparent letter 92 | rect = rectangle (V2 0 0) size 50 93 | -- Take a chunk of the letter and displace it randomly 94 | hole = rectangle holeOffset 30 30 95 | chunk = rectangle chunkOffset 30 30 96 | texChunk = transformTexture (translate $ chunkOffset ^* (-1)) texLetter 97 | -------------------------------------------------------------------------------- /thentos-core/src/Thentos/Util.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts #-} 2 | {-# LANGUAGE ScopedTypeVariables #-} 3 | {-# LANGUAGE TupleSections #-} 4 | {-# LANGUAGE OverloadedStrings #-} 5 | 6 | module Thentos.Util 7 | ( hashUserPass 8 | , makeUserFromFormData 9 | , verifyUserPass 10 | , hashServiceKey 11 | , verifyServiceKey 12 | , hashSecret 13 | , hashSecretWith 14 | , mailEncode 15 | , cshow 16 | , readsPrecEnumBoundedShow 17 | ) where 18 | 19 | import Data.Text.Encoding (encodeUtf8) 20 | import Network.HTTP.Types (urlEncode) 21 | 22 | import qualified Crypto.BCrypt as BCrypt 23 | import qualified Crypto.Scrypt as Scrypt 24 | import qualified Data.Text as ST 25 | 26 | import Thentos.Prelude 27 | import Thentos.Types 28 | 29 | 30 | -- * crypto 31 | 32 | hashUserPass :: (Functor m, MonadIO m) => UserPass -> m (HashedSecret UserPass) 33 | hashUserPass = hashSecret fromUserPass 34 | 35 | makeUserFromFormData :: (Functor m, MonadIO m) => UserFormData -> m User 36 | makeUserFromFormData userData = do 37 | hashedPassword <- hashUserPass $ udPassword userData 38 | return $ User (udName userData) 39 | hashedPassword 40 | (udEmail userData) 41 | 42 | verifyUserPass :: UserPass -> User -> Bool 43 | verifyUserPass pass user = secretMatches (fromUserPass pass) (user ^. userPassword) 44 | 45 | hashServiceKey :: (Functor m, MonadIO m) => ServiceKey -> m (HashedSecret ServiceKey) 46 | hashServiceKey = hashSecret fromServiceKey 47 | 48 | verifyServiceKey :: ServiceKey -> Service -> Bool 49 | verifyServiceKey key service = secretMatches (fromServiceKey key) (service ^. serviceKey) 50 | 51 | 52 | -- | Call 'hasSecretWith' with fresh salt and default params. 53 | hashSecret :: (Functor m, MonadIO m) => (a -> ST) -> a -> m (HashedSecret a) 54 | hashSecret a s = (\salt -> hashSecretWith Scrypt.defaultParams salt a s) <$> liftIO Scrypt.newSalt 55 | 56 | hashSecretWith :: Scrypt.ScryptParams -> Scrypt.Salt -> (a -> ST) -> a -> HashedSecret a 57 | hashSecretWith params salt a = 58 | SCryptHash . Scrypt.getEncryptedPass . 59 | Scrypt.encryptPass params salt . Scrypt.Pass . encodeUtf8 . a 60 | 61 | secretMatches :: ST -> HashedSecret a -> Bool 62 | secretMatches t s = case s of 63 | SCryptHash hash -> Scrypt.verifyPass' (Scrypt.Pass $ encodeUtf8 t) (Scrypt.EncryptedPass hash) 64 | BCryptHash hash -> BCrypt.validatePassword hash (encodeUtf8 t) 65 | 66 | 67 | -- * networking 68 | 69 | -- | Encode a bytestring in such a way that it can be used as local part in an email address. 70 | -- This is done by percent-encoding the input in such a way that it could be used in a query string 71 | -- and additionally replacing every "." by "+", since the local address part cannot contain 72 | -- multiple subsequent dots or start or end with a dot. 73 | mailEncode :: ConvertibleStrings s SBS => s -> ST 74 | mailEncode = ST.replace "." "+" . cs . urlEncode True . cs 75 | 76 | 77 | -- * misc 78 | 79 | -- | Convertible show. 80 | cshow :: (Show a, ConvertibleStrings String b) => a -> b 81 | cshow = cs . show 82 | 83 | 84 | -- | Generic 'readsPrec' for enumerable types. 85 | readsPrecEnumBoundedShow :: (Enum a, Bounded a, Show a) => Int -> String -> [(a, String)] 86 | readsPrecEnumBoundedShow _ s = f [minBound..] 87 | where 88 | f [] = [] 89 | f (x:xs) = case splitAt (length s') s of 90 | (s0, s1) -> if s0 == s' then [(x, s1)] else f xs 91 | where 92 | s' = show x 93 | -------------------------------------------------------------------------------- /thentos-purescript/bower.json: -------------------------------------------------------------------------------- 1 | { 2 | "name": "thentos-purescript", 3 | "version": "1.0.0", 4 | "moduleType": [ 5 | "node" 6 | ], 7 | "ignore": [ 8 | "**/.*", 9 | "node_modules", 10 | "bower_components", 11 | "output" 12 | ], 13 | "dependencies": { 14 | "purescript-affjax": "0.10.0", 15 | "purescript-console": "0.1.1", 16 | "purescript-exceptions": "0.3.0", 17 | "purescript-generics": "0.7.0", 18 | "purescript-globals": "0.2.2", 19 | "purescript-halogen": "https://github.com/slamdata/purescript-halogen.git#64478fa", 20 | "purescript-lists": "0.7.7", 21 | "purescript-random": "0.2.0", 22 | "purescript-uri": "0.2.0" 23 | } 24 | } 25 | -------------------------------------------------------------------------------- /thentos-purescript/build.sh: -------------------------------------------------------------------------------- 1 | #!/bin/bash 2 | 3 | set -o errexit 4 | cd "$( dirname "${BASH_SOURCE[0]}" )" 5 | 6 | export PATH=`pwd`/node_modules/.bin/:$PATH 7 | 8 | case "$1" in 9 | "dep") 10 | echo -n 'node: '; node --version 11 | echo -n 'npm: '; npm --version 12 | time npm install 13 | echo -n 'bower: '; bower --version 14 | echo -n 'gulp: '; gulp --version 15 | echo -n 'psc: '; psc --version 16 | time bower install 17 | ;; 18 | "it") 19 | time gulp bundle 20 | ;; 21 | "watch") 22 | gulp watch 23 | ;; 24 | "generate-translation-tables") 25 | test -e ../.cabal-sandbox/bin/refresh-i18n \ 26 | || echo "refresh-i18n not found. install cabal package?" 27 | ../.cabal-sandbox/bin/refresh-i18n 28 | ;; 29 | "clean") 30 | rm -rf ./.tmp ./output ./dist ./static/thentos.js 31 | ;; 32 | "distclean") 33 | $0 clean 34 | rm -rf ./bower_components ./node_modules 35 | ;; 36 | "pull-cache") 37 | test "$2" == "" && ( echo "$0: please specify cache path."; exit 1 ) 38 | echo "pulling build cache from $2..." 39 | rsync -a --delete "$2"/bower_components . || true 40 | rsync -a --delete "$2"/node_modules . || true 41 | ;; 42 | "push-cache") 43 | test "$2" == "" && ( echo "$0: please specify cache path."; exit 1 ) 44 | echo "pushing build cache to $2..." 45 | mkdir -p "$2" 46 | rsync -a --delete bower_components "$2" 47 | rsync -a --delete node_modules "$2" 48 | ;; 49 | *) 50 | echo "usage: $0 [dep|it|watch|generate-translation-tables|clean|distclean|pull-cache|push-cache]" >&2 51 | exit 1 52 | ;; 53 | esac 54 | -------------------------------------------------------------------------------- /thentos-purescript/gulpfile.js: -------------------------------------------------------------------------------- 1 | /* jshint node: true */ 2 | "use strict"; 3 | 4 | var gulp = require("gulp"); 5 | var minify = require('gulp-minify'); 6 | var purescript = require("gulp-purescript"); 7 | var webpack = require("webpack-stream"); 8 | 9 | var sources = [ 10 | "src/**/*.purs", 11 | "bower_components/purescript-*/src/**/*.purs" 12 | ]; 13 | 14 | var foreigns = [ 15 | "src/**/*.js", 16 | "bower_components/purescript-*/src/**/*.js" 17 | ]; 18 | 19 | gulp.task("make", function() { 20 | return purescript.psc({ src: sources, ffi: foreigns }); 21 | }); 22 | 23 | gulp.task("prebundle", ["make"], function() { 24 | return purescript.pscBundle({ 25 | src: "output/**/*.js", 26 | output: "dist/thentos.js", 27 | module: "Main", 28 | main: "Main" 29 | }); 30 | }); 31 | 32 | gulp.task("bundle", ["prebundle"], function () { 33 | return gulp.src("dist/thentos.js") 34 | .pipe(webpack({ 35 | resolve: { modulesDirectories: ["node_modules"] }, 36 | output: { filename: "thentos.js" } 37 | })) 38 | .pipe(gulp.dest("static")); 39 | }); 40 | 41 | gulp.task("watch", function () { 42 | return gulp.watch(sources.concat(foreigns), ["bundle"]); 43 | }); 44 | 45 | gulp.task('minify', function() { 46 | gulp.src('./static/thentos.js') 47 | .pipe(minify({ 48 | exclude: [], 49 | ignoreFiles: [] 50 | })) 51 | .pipe(gulp.dest('./static')) 52 | }); 53 | 54 | gulp.task("default", ["bundle"]); 55 | -------------------------------------------------------------------------------- /thentos-purescript/package.json: -------------------------------------------------------------------------------- 1 | { 2 | "name": "thentos-purescript", 3 | "version": "0.0.1", 4 | "description": "Frontend code for the thentos PPIM system.", 5 | "readme": "see README.md", 6 | "keywords": [ 7 | "identity management", 8 | "security", 9 | "user data" 10 | ], 11 | "license": "AGPL", 12 | "author": { 13 | "name": "Matthias Fischmann", 14 | "email": "matthias.fischmann@liqd.net" 15 | }, 16 | 17 | "homepage": "https://github.com/liqd/thentos", 18 | "bugs": { 19 | "url": "https://github.com/liqd/thentos/issues", 20 | "email": "matthias.fischmann@liqd.net" 21 | }, 22 | "repository": { 23 | "type": "git", 24 | "url": "git://github.com/liqd/thentos.git" 25 | }, 26 | 27 | "dependencies": { 28 | "virtual-dom": "2.1.1" 29 | }, 30 | "devDependencies": { 31 | "bower": "1.7.1", 32 | "gulp": "3.9.0", 33 | "gulp-minify": "0.0.5", 34 | "gulp-purescript": "0.8.0", 35 | "purescript": "0.7.6", 36 | "webpack-stream": "3.1.0" 37 | }, 38 | 39 | "main": "static/thentos.js", 40 | "scripts": { 41 | "test": "echo \"Error: no test specified\" && exit 1" 42 | } 43 | } 44 | -------------------------------------------------------------------------------- /thentos-purescript/src/Counter.purs: -------------------------------------------------------------------------------- 1 | module Counter where 2 | 3 | import Control.Monad.Aff (Aff(), Canceler(), runAff, forkAff, later') 4 | import Control.Monad.Aff.Class (MonadAff) 5 | import Control.Monad.Aff.Console (log) 6 | import Control.Monad.Eff.Class (liftEff) 7 | import Control.Monad.Eff.Console (CONSOLE()) 8 | import Control.Monad.Eff (Eff()) 9 | import Control.Monad.Eff.Exception (throwException) 10 | import Control.Monad.Eff.Random (RANDOM(), randomInt) 11 | import Data.Tuple (Tuple(Tuple)) 12 | import Halogen (Component(), ComponentHTML(), ComponentDSL(), HalogenEffects(), Natural(), Driver(), 13 | component, modify, get, runUI, action) 14 | import Halogen.Query (liftAff') 15 | import Halogen.Util (appendTo) 16 | import Prelude (Show, Functor, Unit(), show, pure, const, void, bind, unit, (+), ($), (>>=), (++)) 17 | import Prim (Boolean(), Int(), String()) 18 | 19 | import qualified Halogen.HTML.Indexed as H 20 | 21 | 22 | -- counter 23 | 24 | data CounterState eff = CounterState Int (Aff (CounterEffects eff) Unit) 25 | 26 | initialCounterState :: forall eff. Aff (CounterEffects eff) Unit -> CounterState eff 27 | initialCounterState = CounterState 0 28 | 29 | data CounterQuery a = Tick a | Clear a 30 | 31 | counterUI :: forall eff g. (Functor g, MonadAff (CounterEffects eff) g) 32 | => Component (CounterState eff) CounterQuery g 33 | counterUI = component render eval 34 | where 35 | render :: CounterState eff -> ComponentHTML CounterQuery 36 | render (CounterState n _) = H.div_ [H.text ("[counter=" ++ show n ++ "]")] 37 | 38 | eval :: Natural CounterQuery (ComponentDSL (CounterState eff) CounterQuery g) 39 | eval (Tick next) = do 40 | modify (\(CounterState n h) -> CounterState (n + 1) h) 41 | CounterState _ tickHandler <- get 42 | liftAff' $ forkAff tickHandler 43 | pure next 44 | eval (Clear next) = do 45 | modify (\(CounterState _ h) -> CounterState 0 h) 46 | pure next 47 | 48 | verbose :: Boolean 49 | verbose = true 50 | 51 | type CounterEffects eff = HalogenEffects (console :: CONSOLE, random :: RANDOM | eff) 52 | type CounterDriver eff = Driver CounterQuery (console :: CONSOLE, random :: RANDOM | eff) 53 | 54 | counterRunner :: forall eff b. 55 | String -> 56 | Aff (CounterEffects eff) b -> 57 | Aff (CounterEffects eff) (Tuple (Canceler (CounterEffects eff)) (CounterDriver eff)) 58 | counterRunner selector callback = do 59 | { node: node, driver: driver } <- runUI counterUI (initialCounterState (void callback)) 60 | appendTo selector node 61 | i <- liftEff $ randomInt 100 700 62 | canceler <- forkAff $ setInterval i $ driver (action Tick) 63 | pure (Tuple canceler driver) 64 | where 65 | _log :: String -> Aff (console :: CONSOLE | eff) Unit 66 | _log s = if verbose then log s >>= \_ -> pure unit else pure unit 67 | 68 | setInterval :: forall a. 69 | Int -> 70 | Aff (CounterEffects eff) a -> 71 | Aff (CounterEffects eff) Unit 72 | setInterval ms action = later' ms $ do 73 | action 74 | setInterval ms action 75 | 76 | counterMain :: forall eff a. 77 | String -> 78 | Aff (CounterEffects eff) a -> 79 | Eff (CounterEffects eff) Unit 80 | counterMain selector callback = runAff throwException (const (pure unit)) 81 | (counterRunner selector callback) 82 | -------------------------------------------------------------------------------- /thentos-purescript/src/Error.js: -------------------------------------------------------------------------------- 1 | /* global exports */ 2 | "use strict"; 3 | 4 | // module Error 5 | exports.throwJS = function(e) { console.log("*** " + e); throw e; }; 6 | exports.warnJS = function(e) { console.log(">>> " + e); return function(v) { return v; }; }; 7 | exports.stringify = function(o) { return JSON.stringify(o, null, 2); }; 8 | -------------------------------------------------------------------------------- /thentos-purescript/src/Error.purs: -------------------------------------------------------------------------------- 1 | module Error where 2 | 3 | foreign import throwJS :: forall e a. e -> a 4 | foreign import warnJS :: forall e a. e -> a -> a 5 | foreign import stringify :: forall a. a -> String 6 | -------------------------------------------------------------------------------- /thentos-purescript/src/I18n.js: -------------------------------------------------------------------------------- 1 | /* global exports */ 2 | "use strict"; 3 | 4 | // module I18n 5 | exports.trF = function(lang) { 6 | return function(key) { 7 | try { 8 | return table[lang][key]; 9 | } catch (e) { 10 | console.log(e); 11 | console.log("I18n: lookup error in translation table: " + lang + "/" + key); 12 | return "***"; 13 | } 14 | }; 15 | }; 16 | 17 | var table = {}; 18 | 19 | table.EN = { 20 | "TR__CANCEL": "cancel", 21 | "TR__EMAIL": "email", 22 | "TR__ERROR_FORMAT_EMAIL": "Email format is incorrect.", 23 | "TR__ERROR_MATCH_PASSWORD": "Passwords do not match.", 24 | "TR__ERROR_REQUIRED_CAPTCHA_SOLUTION": "Please enter the keywords displayed above", 25 | "TR__ERROR_REQUIRED_EMAIL": "Email is required.", 26 | "TR__ERROR_REQUIRED_PASSWORD": "Password is required.", 27 | "TR__ERROR_REQUIRED_TERMS_AND_CONDITIONS": "You must agree to terms and conditions", 28 | "TR__ERROR_REQUIRED_USERNAME": "Username is required", 29 | "TR__ERROR_TOO_SHORT_PASSWORD": "Password is too short.", 30 | "TR__I_ACCEPT_THE_TERMS_AND_CONDITIONS": "I accept the [[link:terms and conditions]].", 31 | "TR__PASSWORD": "password", 32 | "TR__PASSWORD_REPEAT": "password repeat", 33 | "TR__REGISTER": "register", 34 | "TR__REGISTER_SUCCESS": "Thank you for your registration. We sent you an email with an activation link. In case you do not recieve that email, please also check your spam folder.", 35 | "TR__REGISTRATION_CALL_FOR_ACTIVATION": "Once you have clicked on the activation link you can proceed using {{siteName}}.", 36 | "TR__REGISTRATION_LOGIN_INSTEAD": "I already have an account. Log in [[link:here]].", 37 | "TR__REGISTRATION_PROCEED": "Proceed back to [[link:{{siteName}}]].", 38 | "TR__REGISTRATION_SUPPORT": "Having trouble with the registration?", 39 | "TR__REGISTRATION_THANKS_FOR_REGISTERING": "Hi, {{userName}}! Thanks for registering with {{siteName}}.", 40 | "TR__USERNAME": "username", 41 | }; 42 | 43 | table.DE = { 44 | "TR__CANCEL": "abbrechen", 45 | "TR__EMAIL": "E-Mail", 46 | "TR__ERROR_FORMAT_EMAIL": "E-Mail-Format ist ungültig.", 47 | "TR__ERROR_MATCH_PASSWORD": "Passwörter stimmen nicht überein", 48 | "TR__ERROR_REQUIRED_CAPTCHA_SOLUTION": "Bitte die Schlüsselwörter eingeben", 49 | "TR__ERROR_REQUIRED_EMAIL": "E-Mail erforderlich", 50 | "TR__ERROR_REQUIRED_PASSWORD": "Passwort erforderlich", 51 | "TR__ERROR_REQUIRED_TERMS_AND_CONDITIONS": "Bitte stimme den Nutzungsbedingungen zu.", 52 | "TR__ERROR_REQUIRED_USERNAME": "Nutzername erforderlich", 53 | "TR__ERROR_TOO_SHORT_PASSWORD": "Das Passwort ist zu kurz.", 54 | "TR__I_ACCEPT_THE_TERMS_AND_CONDITIONS": "Ich akzeptiere die [[link:Nutzungsbedingungen]].", 55 | "TR__PASSWORD": "Passwort", 56 | "TR__PASSWORD_REPEAT": "Passwort Wiederholung", 57 | "TR__REGISTER": "registrieren", 58 | "TR__REGISTER_SUCCESS": "Danke für Deine Registrierung. Wir haben Dir eine E-Mail mit einem Aktivierungslink gesendet. Falls Du diese E-Mail nicht erhältst, überprüfe bitte auch Deinen Spamordner.", 59 | "TR__REGISTRATION_CALL_FOR_ACTIVATION": "Sobald Du auf den Aktivierungslink geklickt hast, kannst Du {{siteName}} benutzen.", 60 | "TR__REGISTRATION_LOGIN_INSTEAD": "Ich habe bereits einen Account. [[link:Hier]] anmelden.", 61 | "TR__REGISTRATION_PROCEED": "Gehe zurück zu [[link:{{siteName}}]].", 62 | "TR__REGISTRATION_SUPPORT": "Probleme mit der Registrierung?", 63 | "TR__REGISTRATION_THANKS_FOR_REGISTERING": "Hi, {{userName}}! Danke für Deine Anmeldung bei {{siteName}}.", 64 | "TR__USERNAME": "Nutzername", 65 | }; 66 | -------------------------------------------------------------------------------- /thentos-purescript/src/I18n.purs: -------------------------------------------------------------------------------- 1 | -- | Pure translation functions. The function `trH` can be called once after the entire HTML tree 2 | -- has been constructed. The language key always needs to be passed as explicit function argument. 3 | -- Properties may not contain translation keys; only elements are translated by `trH`. If you need 4 | -- to pass translated texts to properties, call `trS` directly on the translation key. 5 | -- 6 | -- For making sure the translation tables in `I18n.js` are all up to date (i.e., are not missing any 7 | -- translations and contain no unused ones), check out `$THENTOS_DEV_ROOT/refresh-i18n/`. 8 | -- 9 | -- NOTE: We could set the language by passing a function like `function () { return 'EN' }` into the 10 | -- component via the config. This function would be called every time a translation key is looked 11 | -- up. This makes sense if you look at it with an angular-js mindset, but there are two 12 | -- disadvantages to this approach: 13 | -- 1. performance, especially if the function has non-trivial run time; 14 | -- 2. it is brittle and error-prone. Language change is an event, and the component needs a chance 15 | -- to react to this event. If the function does a look-up into a global variable maintained in 16 | -- another web framework and that global variable changes, we have no way of knowing that we need 17 | -- to re-render. 18 | -- 19 | -- FUTUREWORK: 20 | -- 21 | -- - translate strings in element Properties (see 0ec877a4 for a first try). something like neil 22 | -- mitchell's uniplate may come in handy there. 23 | -- 24 | -- - consider transformer on CompontentHTML that carries the language / state. make it a fixme or 25 | -- implement it, or explain why we don't do it. 26 | -- 27 | -- - offer a language key "debug" that translates everything to "*****". this can be used to 28 | -- navigate the app and hunt down untranslated text fragments. hm. something more automatic 29 | -- would be nice, but it's hard. 30 | module I18n (trH, trS) where 31 | 32 | import Data.String (take, length) 33 | import Halogen.Component (ComponentHTML()) 34 | import Halogen.HTML.Indexed (HTML(Slot, Element, Text)) 35 | import Prelude (show, otherwise, (==), (<$>), ($)) 36 | 37 | import Error 38 | import qualified I18n.Lang as Lang 39 | 40 | trH :: forall f. Lang.Lang -> ComponentHTML f -> ComponentHTML f 41 | trH lang (Text txt) = Text $ trSLenient lang txt 42 | trH lang (Element ns tagn attrs chs) = Element ns tagn attrs $ trH lang <$> chs 43 | trH lang (Slot p) = throwJS "I18n.trH: cannot translate Slots!" -- FIXME: can I? 44 | 45 | trS :: Lang.Lang -> String -> String 46 | trS lang txt = trF (show lang) txt 47 | 48 | trSLenient :: Lang.Lang -> String -> String 49 | trSLenient lang txt 50 | | "TR__" `isPrefixOf` txt = trF (show lang) txt 51 | | otherwise = txt 52 | 53 | foreign import trF :: String -> String -> String 54 | 55 | -- | FIXME: write PR for package purescript-strings; also include isSuffixOf, isInfixOf. 56 | isPrefixOf :: String -> String -> Boolean 57 | isPrefixOf prefix s = take (length prefix) s == prefix 58 | -------------------------------------------------------------------------------- /thentos-purescript/src/I18n/Lang.purs: -------------------------------------------------------------------------------- 1 | module I18n.Lang 2 | where 3 | 4 | import Data.Generic 5 | import Data.Maybe 6 | import Data.String 7 | import Prelude 8 | 9 | -- FUTURE WORK: use ISO639, but make sure that lib user can select a subset of languages that will 10 | -- allow for static translation coverage checks. 11 | -- 12 | -- see also: https://github.com/zerobuzz/multi-language/blob/master/src/MuLa/ISO639.hs 13 | 14 | data Lang = EN | DE 15 | 16 | derive instance genericLang :: Generic Lang 17 | instance eqLang :: Eq Lang where eq = gEq 18 | instance showLang :: Show Lang where show = dropQualification <<< gShow 19 | 20 | dropQualification :: String -> String 21 | dropQualification s = case lastIndexOf "." s of 22 | Nothing -> s 23 | Just i -> drop (i+1) s 24 | -------------------------------------------------------------------------------- /thentos-purescript/src/IFramesDemo.js: -------------------------------------------------------------------------------- 1 | /* global exports */ 2 | "use strict"; 3 | 4 | // module IFramesDemo 5 | exports.onChangeValue = function(ev) { 6 | return ev.target.value; 7 | }; 8 | -------------------------------------------------------------------------------- /thentos-purescript/src/IFramesDemo.purs: -------------------------------------------------------------------------------- 1 | module IFramesDemo where 2 | 3 | import Prelude 4 | 5 | import Control.Monad.Aff (Aff(), Canceler(), runAff, forkAff) 6 | import Control.Monad.Aff.Class (MonadAff) 7 | import Control.Monad.Eff (Eff()) 8 | import Control.Monad.Eff.Exception (throwException) 9 | import Data.Array (replicate) 10 | import Halogen (Component(), ComponentHTML(), ComponentDSL(), HalogenEffects(), Natural(), 11 | component, modify, runUI) 12 | import Halogen.Util (appendToBody) 13 | import Prim (Boolean(), Int(), Number(), String(), Array()) 14 | 15 | import qualified Halogen.HTML.Events.Indexed as E 16 | import qualified Halogen.HTML.Indexed as H 17 | import qualified Halogen.HTML.Properties.Indexed as P 18 | 19 | import Data.Maybe 20 | import Unsafe.Coerce (unsafeCoerce) 21 | import Halogen.HTML.Core (IsProp, prop, propName, attrName) 22 | 23 | 24 | data IFDState = IFDState Int Int Int 25 | 26 | initialIFDState :: IFDState 27 | initialIFDState = IFDState 30 20 1 28 | 29 | data IFDQuery a = UpdX Int a | UpdY Int a | UpdZ Int a 30 | 31 | foreign import onChangeValue :: forall a. a -> Int 32 | 33 | slideHandler :: forall eff. (Int -> Unit -> IFDQuery Unit) -> P.IProp (onInput :: P.I | eff) (IFDQuery Unit) 34 | slideHandler mkQuery = E.onInput $ E.input $ \domEv -> mkQuery (onChangeValue domEv) 35 | 36 | ui :: forall g. (Functor g) => Component IFDState IFDQuery g 37 | ui = component render eval 38 | where 39 | render :: IFDState -> ComponentHTML IFDQuery 40 | render state@(IFDState x y z) = H.div_ 41 | [ H.p_ [ H.input [ slideHandler UpdX 42 | , P.inputType P.InputRange 43 | , P.value (show x), min_ 1, max_ 90 44 | ] 45 | , H.text $ "x=" ++ show x 46 | ] 47 | , H.p_ [ H.input [ slideHandler UpdY 48 | , P.inputType P.InputRange 49 | , P.value (show y), min_ 1, max_ 90 50 | ] 51 | , H.text $ "y=" ++ show y 52 | ] 53 | , H.p_ [ H.input [ slideHandler UpdZ 54 | , P.inputType P.InputRange 55 | , P.value (show z), min_ 1, max_ 30 56 | ] 57 | , H.text $ "z=" ++ show z 58 | ] 59 | , H.div_ [renderXY] 60 | ] 61 | where 62 | min_ = unsafeCoerce <<< prop (propName "min") (Just $ attrName "min") 63 | max_ = unsafeCoerce <<< prop (propName "max") (Just $ attrName "max") 64 | 65 | wh_ :: forall p. Int -> Array (P.IProp (width :: P.I, height :: P.I | p) (IFDQuery Unit)) 66 | wh_ i = [P.width (P.Pixels i), P.height (P.Pixels i)] -- FIXME: this becomes `width="[object Object]"` 67 | 68 | renderXY :: ComponentHTML IFDQuery 69 | renderXY = H.table_ <<< replicate (y / 10) <<< H.tr_ <<< replicate (x / 10) $ H.td_ [renderZ] 70 | 71 | renderZ :: ComponentHTML IFDQuery 72 | renderZ = case (z / 10) of 73 | 0 -> H.iframe [P.src "/js/index.html"] 74 | 1 -> H.iframe $ [P.src "/js/frames1.html"] ++ wh_ 50 75 | _ -> H.iframe $ [P.src "/js/frames2.html"] ++ wh_ 100 76 | 77 | eval :: Natural IFDQuery (ComponentDSL IFDState IFDQuery g) 78 | eval (UpdX x next) = do 79 | modify (\(IFDState _ y z) -> IFDState x y z) 80 | pure next 81 | eval (UpdY y next) = do 82 | modify (\(IFDState x _ z) -> IFDState x y z) 83 | pure next 84 | eval (UpdZ z next) = do 85 | modify (\(IFDState x y _) -> IFDState x y z) 86 | pure next 87 | 88 | type IFDEffects eff = HalogenEffects eff 89 | 90 | runner :: forall eff. Aff (IFDEffects eff) (Canceler (IFDEffects eff)) 91 | runner = do 92 | { node: node, driver: driver } <- runUI ui initialIFDState 93 | appendToBody node 94 | forkAff $ pure unit 95 | 96 | main :: forall eff. Eff (IFDEffects eff) Unit 97 | main = runAff throwException (const (pure unit)) runner 98 | -------------------------------------------------------------------------------- /thentos-purescript/src/Main.js: -------------------------------------------------------------------------------- 1 | /* global exports */ 2 | "use strict"; 3 | 4 | // module Main 5 | exports.publish = function(moduleName) { 6 | // (this can most likely be implemented with DOM.HTML.window in purs.) 7 | return function(valueName) { 8 | return function(value) { 9 | return function __do() { 10 | if (!window.PS) { 11 | window.PS = {}; 12 | } 13 | if (!window.PS[moduleName]) { 14 | window.PS[moduleName] = {}; 15 | } 16 | window.PS[moduleName][valueName] = value; 17 | console.log("registered: PS['" + moduleName + "]." + valueName); 18 | } 19 | } 20 | } 21 | } 22 | -------------------------------------------------------------------------------- /thentos-purescript/src/Main.purs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import Control.Monad.Eff 4 | import Control.Monad.Eff.Console (CONSOLE(), log) 5 | import Prelude 6 | 7 | import qualified Register as Register 8 | import qualified Data.Maybe as Data.Maybe 9 | 10 | 11 | foreign import publish :: forall a. String -> String -> a -> forall eff. Eff eff Unit 12 | 13 | main :: forall eff. Eff (console :: CONSOLE | eff) Unit 14 | main = do 15 | log "initializing thentos-purescript..." 16 | 17 | {- 18 | publish "Main" "counter" Counter.counterMain 19 | publish "Main" "counter_" Counter.counterRunner 20 | publish "Main" "tick" (action Counter.Tick) 21 | publish "Main" "clear" (action Counter.Clear) 22 | publish "Main" "indicator" LoginIndicator.main 23 | publish "IFrames" "main" IFramesDemo.main 24 | -} 25 | publish "Register" "main" Register.main 26 | publish "Register" "mainEl" Register.mainEl 27 | publish "Data.Maybe" "Just" Data.Maybe.Just 28 | publish "Data.Maybe" "Nothing" Data.Maybe.Nothing 29 | 30 | log "initialization of thentos-purescript complete!" 31 | -------------------------------------------------------------------------------- /thentos-purescript/src/Register.js: -------------------------------------------------------------------------------- 1 | /* global exports */ 2 | "use strict"; 3 | 4 | // module Register 5 | exports.eventInputValue = function(ev) { 6 | return { value: ev.target.value, 7 | validity: marshal(ev.target.validity) }; 8 | 9 | }; 10 | 11 | // ev.target.validity is an rich object, not just a json dictionary. 12 | // i think. anyway, this function turns it into something that can be 13 | // passed into purescript via the foreign function binding. 14 | var marshal = function(v) { 15 | return { 16 | valueMissing: v.valueMissing 17 | , typeMismatch: v.typeMismatch 18 | , patternMismatch: v.patternMismatch 19 | , tooLong: v.tooLong 20 | , rangeUnderflow: v.rangeUnderflow 21 | , rangeOverflow: v.rangeOverflow 22 | , stepMismatch: v.stepMismatch 23 | , badInput: v.badInput 24 | , customError: v.customError 25 | , valid: v.valid 26 | }; 27 | }; 28 | 29 | exports.arrayBufferToBase64 = function(b) { 30 | return btoa(String.fromCharCode.apply(null, new Uint8Array(b))); 31 | }; 32 | -------------------------------------------------------------------------------- /thentos-purescript/src/Util.js: -------------------------------------------------------------------------------- 1 | // 2 | // DO NOT EDIT! THIS IS GENERATED REST API CLIENT CODE! 3 | // 4 | // source package: thentos-core 5 | // source package version: Version {versionBranch = [], versionTags = []} 6 | // 7 | "use strict"; 8 | // module Util 9 | exports.encodeURIComponent = encodeURIComponent; 10 | -------------------------------------------------------------------------------- /thentos-purescript/src/Util.purs: -------------------------------------------------------------------------------- 1 | -- 2 | -- DO NOT EDIT! THIS IS GENERATED REST API CLIENT CODE! 3 | -- 4 | -- source package: thentos-core 5 | -- source package version: Version {versionBranch = [], versionTags = []} 6 | -- 7 | module Util where 8 | foreign import encodeURIComponent :: String -> String 9 | -------------------------------------------------------------------------------- /thentos-purescript/static/app.js: -------------------------------------------------------------------------------- 1 | window.state = {}; 2 | 3 | window.onload = function () { 4 | console.log('initializing some app...'); 5 | 6 | PS['Main'].indicator("#id1")(); 7 | 8 | var counterSync = PS['Main'].counter("#id2")(function () { 9 | console.log('tyck!'); 10 | }); 11 | var counterAsync = PS['Main'].counter_("#id3")(function () { 12 | console.log('tack!'); 13 | }); 14 | 15 | counterSync(); 16 | 17 | counterAsync( 18 | function (handle) { 19 | window.state['canceler'] = function() { 20 | handle.value0(function (x) {})(function (x) {}); return true; 21 | }; 22 | 23 | window.state['driver'] = function (signal) { 24 | handle.value1(signal)(function (e) { }, function(e) { }); 25 | }; 26 | } 27 | ); 28 | 29 | console.log('initialization of some app complete!'); 30 | }; 31 | 32 | var _tick = function(e) { 33 | // console.log(e); 34 | // e.stopPropagation(); 35 | window.state.driver(PS['Main'].tick); 36 | } 37 | 38 | var _clear = function(e) { 39 | window.state.driver(PS['Main'].clear); 40 | } 41 | var _kill = function(e) { 42 | window.state.canceler(); 43 | } 44 | -------------------------------------------------------------------------------- /thentos-purescript/static/frames.html: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 | 6 | 7 | 8 | 9 | 10 | 11 | -------------------------------------------------------------------------------- /thentos-purescript/static/frames.js: -------------------------------------------------------------------------------- 1 | window.onload = function () { 2 | console.log('initializing frames demo...'); 3 | PS['IFrames'].main(); 4 | console.log('initialization of frames demo complete!'); 5 | }; 6 | -------------------------------------------------------------------------------- /thentos-purescript/static/frames1.html: -------------------------------------------------------------------------------- 1 |