├── .HTF └── spec.history ├── .gitignore ├── LICENSE ├── LICENSE.md ├── Makefile ├── README.md ├── Setup.hs ├── app └── main.hs ├── bin ├── GetWords.hs ├── InsertWords.hs ├── add_word.sh ├── db-create-database.sh ├── db-drop-database.sh ├── db-recreate-database.sh ├── db_dump.sh ├── edit_word.sh ├── insert_test_data.sh ├── question.sh ├── remove_word.sh ├── setup_database.sh └── tests.sh ├── config.yml.example ├── db_restore_data.sh ├── deploy ├── 0001-words.sql ├── 0002-users.sql ├── 0003-tokens.sql ├── 0004-session.sql ├── 0005-scoring.sql └── 0006-update-user.sql ├── deploysetup └── deploysetup.sh ├── drop-ddl.sql ├── front ├── .babelrc ├── FlashCardEdit.js ├── FullscreenNavigation.jsx ├── Makefile ├── TopNavigation.jsx ├── main.js ├── package-lock.json ├── package.json ├── utils.js └── webpack.config.js ├── izidict.cabal ├── package.yaml ├── queries.sql ├── questionary.py ├── revert ├── 0001-words.sql ├── 0002-users.sql ├── 0003-tokens.sql ├── 0004-session.sql ├── 0005-scoring.sql └── 0006-update-user.sql ├── sqitch.conf ├── sqitch.plan ├── sql.load ├── sql ├── addFlashCard.sql ├── checkPassword.sql ├── decreaseBucketFlashCard.sql ├── deleteFlashCard.sql ├── getFlashCard.sql ├── getFlashCards.sql ├── getNewRandomSession.sql ├── getNewRandomSessionWithoutPasswordCheck.sql ├── getQuizzFlashCard.sql ├── increaseBucketFlashCard.sql ├── insertDefaultFlashCards.sql ├── insertUser.sql ├── insert_word.sql ├── registerUser.sql ├── searchFlashCards.sql ├── test_data.sql ├── updateFlashCard.sql ├── updatePassword.sql ├── verifyFlashCardRectoAnswer.sql └── verifyFlashCardVersoAnswer.sql ├── src ├── API │ └── Facebook.hs ├── Auth.hs ├── Cache.hs ├── Css.hs ├── Data.hs ├── Data │ ├── APIFacebook.hs │ ├── Exception.hs │ ├── FlashCard.hs │ ├── GrantUser.hs │ ├── Message.hs │ ├── NewUser.hs │ ├── Session.hs │ ├── Settings.hs │ ├── User.hs │ └── Word.hs ├── Database.hs ├── Database │ ├── Queries.hs │ ├── SqlRow.hs │ └── Types.hs ├── Form.hs ├── HandlerM.hs ├── Mustache.hs ├── Queries.sql ├── Server.hs ├── SharedEnv.hs ├── Template.hs ├── Utils.hs └── templates │ ├── account.html │ ├── dashboard.html │ ├── flashcard.add.html │ ├── flashcard.edit.html │ ├── footer.html │ ├── head.html │ ├── header-logo.html │ ├── home.html │ ├── login.html │ ├── nav.fullscreen.html │ ├── nav.login.html │ ├── quizz.answer.html │ ├── quizz.finish.html │ ├── quizz.html │ ├── register.html │ ├── robots.txt │ └── sitemap.xml ├── stack.yaml ├── static ├── css │ └── bootstrap.css ├── fonts │ ├── glyphicons-halflings-regular.eot │ ├── glyphicons-halflings-regular.svg │ ├── glyphicons-halflings-regular.ttf │ └── glyphicons-halflings-regular.woff └── tmp │ ├── autogen-FQn2C_-6.js │ ├── autogen-PE46a7-4.css │ ├── autogen-dAT6QVJx.js │ └── autogen-f9mZBX8C.js ├── templates ├── default-layout-wrapper.hamlet ├── default-layout.hamlet ├── default-layout.lucius ├── homepage.hamlet ├── homepage.julius └── homepage.lucius ├── test ├── Spec.hs ├── index.html └── tests.sh ├── verify ├── 0001-words.sql ├── 0002-users.sql ├── 0003-tokens.sql ├── 0004-session.sql ├── 0005-scoring.sql └── 0006-update-user.sql └── www ├── favico.png ├── favicon.ico ├── fonts ├── Roboto-Black.ttf ├── Roboto-BlackItalic.ttf ├── Roboto-Bold.ttf ├── Roboto-BoldItalic.ttf ├── Roboto-Italic.ttf ├── Roboto-Light.ttf ├── Roboto-LightItalic.ttf ├── Roboto-Medium.ttf ├── Roboto-MediumItalic.ttf ├── Roboto-Regular.ttf ├── Roboto-Thin.ttf ├── Roboto-ThinItalic.ttf ├── RobotoSlab-Bold.ttf ├── RobotoSlab-Light.ttf ├── RobotoSlab-Regular.ttf ├── RobotoSlab-Thin.ttf └── SansForgetica-Regular.otf ├── home.html ├── images ├── dictionnary.logo.png ├── icons.png ├── icons.xcf ├── idea.1.jpg ├── memory.1.jpg ├── memory.2.jpg └── memory.3.jpg ├── index.html ├── js └── izidict.js ├── login.html ├── normalize.css ├── profile.html └── register.html /.HTF/spec.history: -------------------------------------------------------------------------------- 1 | {"version":0,"runs":[{"startTime":"2018-08-23T15:52:05.234146905Z","tests":[{"testId":"Main:nonEmpty","result":"fail","timedOut":false,"timeMs":0},{"testId":"Main:empty","result":"pass","timedOut":false,"timeMs":0},{"testId":"Main:reverse","result":"fail","timedOut":false,"timeMs":0},{"testId":"Main:reverseReplay","result":"fail","timedOut":false,"timeMs":0}]},{"startTime":"2018-08-23T15:48:56.338142376Z","tests":[{"testId":"Main:nonEmpty","result":"fail","timedOut":false,"timeMs":0},{"testId":"Main:empty","result":"pass","timedOut":false,"timeMs":0},{"testId":"Main:reverse","result":"fail","timedOut":false,"timeMs":0}]}]} -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | .stack-work/ 2 | .tags 3 | front/node_modules/* 4 | config.yml 5 | cubes/* 6 | backup.sql 7 | debian/* 8 | *.env 9 | words.csv 10 | words.sql 11 | db_dump.sql 12 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright aRkadeFR (c) 2018 2 | 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions are met: 7 | 8 | * Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | 11 | * Redistributions in binary form must reproduce the above 12 | copyright notice, this list of conditions and the following 13 | disclaimer in the documentation and/or other materials provided 14 | with the distribution. 15 | 16 | * Neither the name of aRkadeFR nor the names of other 17 | contributors may be used to endorse or promote products derived 18 | from this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -------------------------------------------------------------------------------- /LICENSE.md: -------------------------------------------------------------------------------- 1 | Web Server for Words 2 | Copyright (C) 2018 aRkadeFR 3 | 4 | This program is free software: you can redistribute it and/or modify 5 | it under the terms of the GNU General Public License as published by 6 | the Free Software Foundation, either version 3 of the License, or 7 | (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 General Public License for more details. 13 | 14 | You should have received a copy of the GNU General Public License 15 | along with this program. If not, see . 16 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | POSIXCUBE_BIN ?= ~/Projects/posixcube/posixcube.sh 2 | 3 | .PHONY: ghcid 4 | ghcid: 5 | # http://www.parsonsmatt.org/2018/05/19/ghcid_for_the_win.html 6 | ghcid --command "cabal new-repl backend-exe" --test "main" 7 | 8 | .PHONY: test 9 | test: 10 | pg_virtualenv -s $(MAKE) fulltest 11 | 12 | .PHONY: fulltest 13 | fulltest: 14 | ./bin/setup_database.sh 15 | stack test 16 | 17 | .PHONY: clean 18 | clean: 19 | cabal new-clean 20 | 21 | .PHONY: deb 22 | deb: build clean 23 | dpkg-buildpackage -us -uc 24 | 25 | .PHONY: build 26 | build: clean 27 | cabal new-build 28 | 29 | .PHONY: serve 30 | serve: 31 | stack exec backend-exe 32 | 33 | .PHONY: deploybaseconfiguration 34 | deploybaseconfiguration: 35 | ${POSIXCUBE_BIN} -u root -h izidict.com -c ./cubes/base_configuration 36 | 37 | .PHONY: deploydehydrated 38 | deploydehydrated: 39 | ${POSIXCUBE_BIN} -u root -h izidict.com -e ./production.env -c ./cubes/dehydrated 40 | 41 | .PHONY: deployprimarydb 42 | deployprimarydb: 43 | ${POSIXCUBE_BIN} -u flog -h izidict.com -c ./cubes/postgresql 44 | 45 | .PHONY: deploynginx 46 | deploynginx: 47 | ${POSIXCUBE_BIN} -u flog -h izidict.com -e ./production.env -c ./cubes/nginx 48 | 49 | BACKEND_BIN=$(stack exec -- which backend-exe) 50 | 51 | .PHONY: deploy 52 | deploy: 53 | scp ../izidict_0.1_all.deb root@izidict.com:~/ 54 | ssh root@izidict.com -- dpkg -i izidict_0.1_amd64.deb do 20 | 21 | _ <- waitAny [asyncThreadApp] 22 | 23 | return () 24 | -------------------------------------------------------------------------------- /bin/GetWords.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE QuasiQuotes #-} 2 | 3 | import System.IO 4 | import Database.HDBC.PostgreSQL (withPostgreSQL) 5 | import Database.HDBC 6 | import Database.YeshQL 7 | import Options.Applicative 8 | import Data.Semigroup ((<>)) 9 | 10 | 11 | [yesh| 12 | -- name:getWords :: (Int, String, String, String, String, Int) 13 | SELECT 14 | * 15 | FROM 16 | words 17 | ORDER BY 18 | random() 19 | LIMIT 5 20 | |] 21 | 22 | printWords :: IO () 23 | printWords = withPostgreSQL "service = words" $ \conn -> do 24 | putStrLn "It works! I have a connection to get the words" 25 | maybeWord <- getWords conn 26 | commit conn 27 | disconnect conn 28 | -- apply a the printStrLn to each row of maybeWord that are encapsulated into maybes 29 | putStrLn $ "these are my 5 words: " ++ show maybeWord 30 | return () 31 | 32 | main :: IO () 33 | main = printWords 34 | -------------------------------------------------------------------------------- /bin/InsertWords.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE QuasiQuotes #-} 2 | 3 | import System.IO 4 | import Database.HDBC.PostgreSQL (withPostgreSQL) 5 | import Database.HDBC 6 | import Database.YeshQL 7 | import Options.Applicative 8 | import Data.Semigroup ((<>)) 9 | 10 | data WordAdded = WordAdded 11 | { language :: String 12 | , word :: String 13 | , definition :: String } 14 | 15 | wordAdded :: Parser WordAdded 16 | wordAdded = WordAdded 17 | <$> strOption 18 | ( long "language" 19 | <> short 'l' 20 | <> help "Language of this word" ) 21 | <*> strOption 22 | ( long "word" 23 | <> short 'w' 24 | <> help "Word to be added" ) 25 | <*> strOption 26 | ( long "definition" 27 | <> short 'd' 28 | <> help "Definition of the word" ) 29 | 30 | [yesh| 31 | -- name:insertWord 32 | -- :wordLanguage :: String 33 | -- :wordWord :: String 34 | -- :wordDefinition :: String 35 | INSERT INTO 36 | words (language, word, definition) 37 | VALUES 38 | (:wordLanguage, :wordWord, :wordDefinition) 39 | |] 40 | 41 | addWord :: WordAdded -> IO () 42 | addWord (WordAdded language word definition) = withPostgreSQL "service = words" $ \conn -> do 43 | putStrLn "It works! I have a connection add a word" 44 | wordId <- insertWord language word definition conn 45 | commit conn 46 | disconnect conn 47 | putStrLn "and we're good!" 48 | return () 49 | addWord _ = return () 50 | 51 | main :: IO () 52 | main = addWord =<< execParser opts 53 | where 54 | opts = info (wordAdded <**> helper) 55 | ( fullDesc 56 | <> progDesc "Add a new word into the database" 57 | <> header "insert-words - add a new word into your custom database" ) 58 | -------------------------------------------------------------------------------- /bin/add_word.sh: -------------------------------------------------------------------------------- 1 | #!/bin/bash 2 | 3 | ./bin/add_word.sh 4 | 5 | echo "Add a word" 6 | -------------------------------------------------------------------------------- /bin/db-create-database.sh: -------------------------------------------------------------------------------- 1 | #!/bin/bash 2 | 3 | echo "CREATE DATABASE words WITH OWNER = 'arkadefr';" | psql postgres 4 | -------------------------------------------------------------------------------- /bin/db-drop-database.sh: -------------------------------------------------------------------------------- 1 | #!/bin/bash 2 | 3 | echo 'DROP DATABASE words;' | psql postgres 4 | -------------------------------------------------------------------------------- /bin/db-recreate-database.sh: -------------------------------------------------------------------------------- 1 | #!/bin/bash 2 | 3 | export PGSERVICE="words" 4 | 5 | ./drop-database.sh 6 | 7 | ./create-database.sh 8 | 9 | psql -f create-schema-ddl.sql 10 | -------------------------------------------------------------------------------- /bin/db_dump.sh: -------------------------------------------------------------------------------- 1 | #!/bin/bash -e 2 | 3 | . ./env 4 | 5 | pg_dump --data-only --format plain -f db_dump.sql words 6 | -------------------------------------------------------------------------------- /bin/edit_word.sh: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/FlogFr/FlashCard/17029f9b84f23c43f67702b77bd7418cdf0a9d28/bin/edit_word.sh -------------------------------------------------------------------------------- /bin/insert_test_data.sh: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/FlogFr/FlashCard/17029f9b84f23c43f67702b77bd7418cdf0a9d28/bin/insert_test_data.sh -------------------------------------------------------------------------------- /bin/question.sh: -------------------------------------------------------------------------------- 1 | #!/bin/bash 2 | 3 | function syntax { 4 | echo "Syntax:" 5 | echo " $0 #SUBJECT#" 6 | } 7 | 8 | if [[ $# != 1 ]]; then 9 | echo "Wrong number of parameters" 10 | syntax 11 | fi 12 | 13 | SUBJECT=$1 14 | 15 | echo "Question on subject $SUBJECT" 16 | -------------------------------------------------------------------------------- /bin/remove_word.sh: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/FlogFr/FlashCard/17029f9b84f23c43f67702b77bd7418cdf0a9d28/bin/remove_word.sh -------------------------------------------------------------------------------- /bin/setup_database.sh: -------------------------------------------------------------------------------- 1 | #!/bin/bash -e 2 | 3 | psql -c 'CREATE DATABASE words;' 4 | psql -c 'CREATE EXTENSION pg_trgm;' words 5 | psql -c 'CREATE EXTENSION pgcrypto;' words 6 | psql -c 'CREATE EXTENSION IF NOT EXISTS "uuid-ossp";' words 7 | 8 | sqitch deploy 9 | 10 | # test user username: testusername 11 | # test user password: testpassword 12 | # test user languages: testpassword 13 | 14 | INSERT INTO users (email, username, passpass, languages) VALUES ('donald.duck@brazaville.com', 'passpass', 'donald.duck', '{}'); 15 | INSERT INTO users (email, username, passpass, languages) VALUES ('daisy.duck@brazaville.com', 'passpass', 'daisy.duck', '{"FR"}'); 16 | INSERT INTO users (email, username, passpass, languages) VALUES ('huey.duck@brazaville.com', 'passpass', 'huey.duck', '{}'); 17 | INSERT INTO users (email, username, passpass, languages) VALUES ('dewey.duck@brazaville.com', 'passpass', 'dewey.duck', '{}'); 18 | INSERT INTO users (email, username, passpass, languages) VALUES ('louie.duck@brazaville.com', 'passpass', 'louie.duck', '{}'); 19 | INSERT INTO users (email, username, passpass, languages) VALUES ('scrooge.mcduck@brazaville.com', 'passpass', 'scrooge.mcduck', '{"PL", "EN"}'); 20 | 21 | 22 | insertUser dbconnection "donald.duck@brazaville.com" "passpass" 23 | insertUser dbconnection "daisy.duck@brazaville.com" "passpass" 24 | insertUser dbconnection "huey.duck@brazaville.com" "passpass" 25 | insertUser dbconnection "dewey.duck@brazaville.com" "passpass" 26 | insertUser dbconnection "louie.duck@brazaville.com" "passpass" 27 | insertUser dbconnection "scrooge.mcduck@brazaville.com" "passpass" 28 | -------------------------------------------------------------------------------- /bin/tests.sh: -------------------------------------------------------------------------------- 1 | #!/bin/bash -e 2 | 3 | echo "test my yesod application" 4 | echo "please run yesod devel" 5 | curl http://127.0.0.1:3000/api/ 6 | -------------------------------------------------------------------------------- /config.yml.example: -------------------------------------------------------------------------------- 1 | --- 2 | base_url: "http://localhost:9000" 3 | production: False 4 | app_port: 9000 5 | pgservice: "flashcard" 6 | facebook_appid: "" 7 | facebook_appsecret: "" 8 | facebook_apptoken: "" 9 | ... 10 | -------------------------------------------------------------------------------- /db_restore_data.sh: -------------------------------------------------------------------------------- 1 | #!/bin/bash -e 2 | 3 | . ./env 4 | 5 | psql -f db_dump.sql 6 | -------------------------------------------------------------------------------- /deploy/0001-words.sql: -------------------------------------------------------------------------------- 1 | -- Deploy words:0001-words to pg 2 | BEGIN; 3 | 4 | -- Create Schema Words 5 | CREATE SEQUENCE words_id_seq; 6 | 7 | CREATE TABLE IF NOT EXISTS words ( 8 | id BIGINT NOT NULL PRIMARY KEY DEFAULT nextval('words_id_seq'), 9 | last_query_at TIMESTAMPTZ NOT NULL default(now()), 10 | inserted_at TIMESTAMPTZ NOT NULL default(now()), 11 | language CHARACTER(2) NOT NULL, 12 | word VARCHAR(128) NOT NULL, 13 | keywords TEXT[] NOT NULL DEFAULT '{}', 14 | definition TEXT NOT NULL, 15 | difficulty INTEGER DEFAULT 1 NOT NULL, 16 | score FLOAT DEFAULT 0.5 17 | ); 18 | 19 | ALTER SEQUENCE words_id_seq OWNED BY words.id; 20 | 21 | CREATE INDEX words_trgm ON words USING GIN(word gin_trgm_ops); 22 | 23 | COMMIT; 24 | -------------------------------------------------------------------------------- /deploy/0002-users.sql: -------------------------------------------------------------------------------- 1 | -- Deploy users:0002-users to pg 2 | 3 | BEGIN; 4 | 5 | -- Create Users 6 | CREATE SEQUENCE users_id_seq; 7 | 8 | CREATE TABLE IF NOT EXISTS users ( 9 | "id" BIGINT NOT NULL PRIMARY KEY DEFAULT nextval('users_id_seq'), 10 | "username" TEXT NOT NULL, 11 | "email" TEXT NULL, 12 | "passpass" TEXT NOT NULL, 13 | "languages" CHAR(2)[] 14 | ); 15 | 16 | ALTER SEQUENCE users_id_seq OWNED BY users.id; 17 | 18 | CREATE UNIQUE INDEX users_username_index on users (lower(username)); 19 | 20 | ALTER TABLE users ADD CONSTRAINT users_username_check CHECK (username <> ''::text); 21 | 22 | ALTER TABLE words ADD COLUMN userid BIGINT NOT NULL; 23 | 24 | ALTER TABLE words ADD CONSTRAINT userid_fk FOREIGN KEY (userid) REFERENCES users ON DELETE CASCADE; 25 | 26 | CREATE OR REPLACE FUNCTION user_hash_password () 27 | RETURNS trigger 28 | AS $$ 29 | BEGIN 30 | IF TG_OP = 'INSERT' OR (OLD.passpass != NEW.passpass) THEN 31 | -- Insert new user or Update password of the user, please encrypt it 32 | NEW.passpass := crypt(NEW.passpass, gen_salt('bf', 8)); 33 | END IF; 34 | 35 | RETURN NEW; 36 | END 37 | $$ LANGUAGE plpgsql; 38 | 39 | CREATE TRIGGER tr_user_hash_password BEFORE INSERT OR UPDATE ON users 40 | FOR EACH ROW 41 | EXECUTE PROCEDURE user_hash_password(); 42 | 43 | COMMIT; 44 | -------------------------------------------------------------------------------- /deploy/0003-tokens.sql: -------------------------------------------------------------------------------- 1 | -- Deploy words:0003-tokens to pg 2 | 3 | BEGIN; 4 | 5 | -- Create token table 6 | CREATE SEQUENCE IF NOT EXISTS token_id_seq; 7 | 8 | CREATE TABLE IF NOT EXISTS token ( 9 | "id" BIGINT NOT NULL PRIMARY KEY DEFAULT nextval('users_id_seq'), 10 | "token" UUID NOT NULL, 11 | "created_at" TIMESTAMPTZ NOT NULL DEFAULT now() 12 | ); 13 | 14 | ALTER SEQUENCE token_id_seq OWNED BY token.id; 15 | 16 | COMMIT; 17 | -------------------------------------------------------------------------------- /deploy/0004-session.sql: -------------------------------------------------------------------------------- 1 | -- Deploy words:0004-session to pg 2 | 3 | BEGIN; 4 | 5 | -- Create Users 6 | CREATE SEQUENCE IF NOT EXISTS sessions_id_seq; 7 | 8 | CREATE UNLOGGED TABLE IF NOT EXISTS sessions ( 9 | "id" BIGINT NOT NULL PRIMARY KEY DEFAULT nextval('sessions_id_seq'), 10 | "userid" BIGINT NOT NULL UNIQUE REFERENCES users (id) ON DELETE CASCADE, 11 | "secret" TEXT NOT NULL 12 | ); 13 | 14 | 15 | ALTER SEQUENCE sessions_id_seq OWNED BY sessions.id; 16 | 17 | CREATE OR REPLACE FUNCTION auth_check_password (username TEXT, pass TEXT) 18 | RETURNS BOOLEAN AS $$ 19 | DECLARE passed BOOLEAN; 20 | BEGIN 21 | SELECT (crypt($2, u.passpass) = u.passpass) INTO passed 22 | FROM users u 23 | WHERE u.username = $1; 24 | 25 | RETURN passed; 26 | END 27 | $$ LANGUAGE plpgsql 28 | SECURITY DEFINER; 29 | 30 | CREATE OR REPLACE FUNCTION auth_jwt_header () 31 | RETURNS JSON AS $$ 32 | BEGIN 33 | RETURN '{"alg": "HS256", "typ": "JWT"}'::json; 34 | END 35 | $$ LANGUAGE plpgsql; 36 | 37 | CREATE OR REPLACE FUNCTION auth_jwt_payload (user_id BIGINT) 38 | RETURNS JSON AS $$ 39 | SELECT json_build_object( 40 | 'username', u.username, 41 | 'email', u.email 42 | ) 43 | FROM users u 44 | WHERE u.id = $1 45 | LIMIT 1; 46 | $$ LANGUAGE sql; 47 | 48 | CREATE OR REPLACE FUNCTION auth_jwt_signature (header JSON, payload JSON, secret TEXT) 49 | RETURNS bytea AS $$ 50 | SELECT hmac( 51 | ENCODE(CONVERT_TO(header::text, 'UTF-8'), 'base64') || '.' || 52 | ENCODE(CONVERT_TO(payload::text, 'UTF-8'), 'base64'), 53 | secret, 54 | 'sha256'); 55 | $$ LANGUAGE sql; 56 | 57 | CREATE OR REPLACE FUNCTION auth_jwt_new (user_id BIGINT) 58 | RETURNS TEXT AS $$ 59 | DECLARE 60 | jwt_header JSON; 61 | jwt_payload JSON; 62 | jwt_secret TEXT; 63 | BEGIN 64 | jwt_header := auth_jwt_header(); 65 | RAISE NOTICE 'JWT new header: %', jwt_header; 66 | jwt_payload := auth_jwt_payload($1); 67 | RAISE NOTICE 'JWT new payload: %', jwt_payload; 68 | 69 | -- Creating a new secret 70 | WITH user_secret_information (secret) AS ( 71 | INSERT INTO 72 | sessions (userid, secret) 73 | VALUES 74 | (user_id, md5(random()::text)) 75 | ON CONFLICT (userid) DO UPDATE 76 | SET secret = md5(random()::text) 77 | RETURNING 78 | secret 79 | ) 80 | SELECT 81 | secret INTO jwt_secret 82 | FROM 83 | user_secret_information; 84 | 85 | -- Header (based 64 URL, and concat with the point) 86 | -- type of encryption ({"alg": "HS256", "typ": "JWT"}) 87 | RETURN regexp_replace( ENCODE(CONVERT_TO(jwt_header::text, 'UTF-8'), 'base64') || '.' || 88 | -- Payload (based 64 URL, and concat with the point) 89 | ENCODE(CONVERT_TO(jwt_payload::text, 'UTF-8'), 'base64') || '.' || 90 | -- Signature (already in base64 URL) 91 | ENCODE(CONVERT_TO(auth_jwt_signature(jwt_header, jwt_payload, jwt_secret)::text, 'UTF-8'), 'base64'), 92 | -- Remove the newline and tabulation characters, 93 | -- this comes from an old base64 RFC that lines should be no more than 76 chars 94 | E'[\\n\\r]', '', 'g'); 95 | END 96 | $$ LANGUAGE plpgsql; 97 | 98 | -- auth_jwt_decode 99 | -- decode a JWT token, and check the signature. 100 | -- If it match, then return the userid of the jwt 101 | CREATE OR REPLACE FUNCTION auth_jwt_decode (jwt TEXT) 102 | RETURNS BIGINT AS $$ 103 | DECLARE 104 | jwt_parts TEXT[]; 105 | jwt_header JSON; 106 | jwt_payload JSON; 107 | jwt_signature TEXT; 108 | jwt_username TEXT; 109 | jwt_user_id BIGINT; 110 | jwt_user_secret TEXT; 111 | jwt_signature_truth BYTEA; 112 | jwt_signature_to_be_verified BYTEA; 113 | BEGIN 114 | jwt_parts := regexp_split_to_array( jwt, '\.' ); 115 | IF array_length(jwt_parts, 1) != 3 THEN 116 | -- The JWT is wrong 117 | RAISE EXCEPTION 'JWT Malformed' USING ERRCODE = 'P1002'; 118 | ELSE 119 | jwt_header := CONVERT_FROM( DECODE( (jwt_parts)[1], 'base64') , 'UTF-8' )::JSON; 120 | jwt_payload := CONVERT_FROM( DECODE( (jwt_parts)[2], 'base64') , 'UTF-8' )::JSON; 121 | jwt_signature := (jwt_parts)[3]; 122 | 123 | jwt_username := jwt_payload->>'username'; 124 | SELECT u.id INTO jwt_user_id FROM users u WHERE u.username = jwt_username; 125 | 126 | SELECT secret INTO jwt_user_secret FROM users u join sessions s on u.id = s.userid WHERE u.username = jwt_username; 127 | 128 | SELECT DECODE(jwt_signature, 'base64') INTO jwt_signature_truth; 129 | SELECT auth_jwt_signature(jwt_header, jwt_payload, jwt_user_secret) INTO jwt_signature_to_be_verified; 130 | IF CONVERT_TO(jwt_signature_to_be_verified::text, 'UTF-8') = jwt_signature_truth THEN 131 | RAISE NOTICE 'JWT Signature recomputed and verified'; 132 | -- TODO: if we want to retrieve the jwt payload… 133 | -- jwt_payload := ('{"user_id": "' || jwt_user_id || '"}')::jsonb || jwt_payload::jsonb; 134 | RETURN jwt_user_id; 135 | ELSE 136 | -- The JWT is wrong 137 | RAISE EXCEPTION 'JWT Incorrect' USING ERRCODE = 'P1003'; 138 | RETURN 'f'; 139 | END IF; 140 | END IF; 141 | END 142 | $$ LANGUAGE plpgsql; 143 | 144 | CREATE OR REPLACE FUNCTION auth_login (username TEXT, pass TEXT) 145 | RETURNS TEXT AS $$ 146 | DECLARE 147 | auth_jwt TEXT; 148 | BEGIN 149 | IF auth_check_password(username, pass) THEN 150 | -- the credentials are correct, we can create JWT 151 | WITH user_info (id) AS ( 152 | SELECT id 153 | FROM users u 154 | WHERE u.username = $1 155 | LIMIT 1 156 | ) 157 | SELECT auth_jwt_new(user_info.id) INTO auth_jwt 158 | FROM user_info; 159 | 160 | RETURN auth_jwt; 161 | ELSE 162 | -- wrong credentials 163 | RAISE EXCEPTION 'Wrong credentials' USING ERRCODE = 'P1001'; 164 | END IF; 165 | END 166 | $$ LANGUAGE plpgsql; 167 | 168 | COMMIT; 169 | -------------------------------------------------------------------------------- /deploy/0005-scoring.sql: -------------------------------------------------------------------------------- 1 | -- Deploy words:0005-scoring to pg 2 | 3 | BEGIN; 4 | 5 | -- Create the word scoring system 6 | CREATE OR REPLACE FUNCTION get_word_score (last_query_at TIMESTAMPTZ, difficulty INT) 7 | RETURNS INT 8 | AS $$ 9 | BEGIN 10 | RETURN (difficulty * 100) + date_part('day', (now() - last_query_at)); 11 | END 12 | $$ LANGUAGE plpgsql; 13 | 14 | 15 | CREATE OR REPLACE FUNCTION verify_word_full(wordId INT, testDefinition TEXT) 16 | RETURNS BOOL 17 | AS $$ 18 | DECLARE 19 | verified BOOL; 20 | diff INT; 21 | BEGIN 22 | -- arbitrary 0.4 found by example 23 | SELECT verify_word(wordId, testDefinition, 0.4) INTO verified; 24 | SELECT difficulty INTO diff FROM words WHERE id = wordId; 25 | IF verified = 't' AND diff > 0 THEN 26 | diff := diff - 1; 27 | ELSE 28 | IF verified = 'f' THEN 29 | diff := diff + 1; 30 | END IF; 31 | END IF; 32 | UPDATE words SET last_query_at = now(), difficulty = diff WHERE id = wordId; 33 | return verified; 34 | END 35 | $$ LANGUAGE plpgsql; 36 | 37 | CREATE OR REPLACE FUNCTION verify_word(wordId INT, testDefinition TEXT, threshold REAL) 38 | RETURNS BOOL 39 | AS $$ 40 | DECLARE 41 | definition TEXT; 42 | def_curr TEXT; 43 | simi REAL; 44 | simi_max REAL; 45 | ind INT; 46 | nb_def INT; 47 | BEGIN 48 | SELECT w.definition INTO definition FROM words w WHERE id = wordId; 49 | RAISE NOTICE 'Definition to verify: %', testDefinition; 50 | RAISE NOTICE 'Against: %', definition; 51 | 52 | SELECT array_length(regexp_split_to_array(definition, ','), 1) INTO nb_def; 53 | 54 | ind := 1; 55 | simi_max := 0; 56 | LOOP 57 | SELECT split_part(definition, ',', ind) INTO def_curr; 58 | ind := ind + 1; 59 | 60 | SELECT similarity(unaccent(def_curr), unaccent(testDefinition)) INTO simi; 61 | IF simi > simi_max THEN 62 | simi_max := simi; 63 | END IF; 64 | EXIT WHEN ind > nb_def; 65 | END LOOP; 66 | 67 | RAISE NOTICE 'max similarity found to: %', simi_max; 68 | IF simi_max > threshold THEN 69 | return 't'; 70 | ELSE 71 | return 'f'; 72 | END IF; 73 | END 74 | $$ LANGUAGE plpgsql; 75 | 76 | 77 | COMMIT; 78 | -------------------------------------------------------------------------------- /deploy/0006-update-user.sql: -------------------------------------------------------------------------------- 1 | -- Deploy words:0006-update-user to pg 2 | 3 | BEGIN; 4 | 5 | -- Create extensions 6 | CREATE EXTENSION IF NOT EXISTS CITEXT; 7 | 8 | -- Create 9 | ALTER TABLE users RENAME TO user_account; 10 | 11 | -- Create Domain 12 | CREATE DOMAIN email_d AS CITEXT 13 | CHECK( 14 | value ~ '^[a-zA-Z0-9.!#$%&''*+/=?^_`{|}~-]+@[a-zA-Z0-9](?:[a-zA-Z0-9-]{0,61}[a-zA-Z0-9])?(?:\.[a-zA-Z0-9](?:[a-zA-Z0-9-]{0,61}[a-zA-Z0-9])?)*$' 15 | ); 16 | 17 | DELETE FROM 18 | user_account 19 | WHERE 20 | email !~ '^[a-zA-Z0-9.!#$%&''*+/=?^_`{|}~-]+@[a-zA-Z0-9](?:[a-zA-Z0-9-]{0,61}[a-zA-Z0-9])?(?:\.[a-zA-Z0-9](?:[a-zA-Z0-9-]{0,61}[a-zA-Z0-9])?)*$'; 21 | ALTER TABLE user_account ALTER COLUMN email TYPE email_d ; 22 | DELETE FROM 23 | user_account 24 | WHERE 25 | email is NULL; 26 | 27 | ALTER TABLE user_account ALTER COLUMN email SET NOT NULL; 28 | ALTER TABLE user_account DROP CONSTRAINT users_username_check; 29 | ALTER TABLE user_account ALTER COLUMN username DROP NOT NULL; 30 | ALTER TABLE user_account ADD COLUMN first_name TEXT NULL; 31 | ALTER TABLE user_account ADD COLUMN last_name TEXT NULL; 32 | ALTER TABLE user_account ADD COLUMN email_verified BOOL DEFAULT 'f' NOT NULL; 33 | ALTER TABLE user_account ADD CONSTRAINT unique_user_account_email UNIQUE (email); 34 | 35 | -- Now for the session 36 | ALTER TABLE sessions RENAME TO session; 37 | 38 | ALTER TABLE session ADD COLUMN created_at TIMESTAMPTZ NOT NULL default now(); 39 | 40 | -- Remove the unique constraint on the userid 41 | ALTER TABLE session DROP CONSTRAINT sessions_userid_key; 42 | 43 | -- Alter table words now 44 | DROP VIEW words_score; 45 | 46 | -- Alter table words to flashcard 47 | ALTER TABLE words RENAME TO flashcard; 48 | 49 | ALTER TABLE flashcard ALTER COLUMN word TYPE TEXT; 50 | ALTER TABLE flashcard RENAME word TO recto; 51 | ALTER TABLE flashcard RENAME definition TO verso; 52 | ALTER TABLE flashcard RENAME keywords TO tags; 53 | ALTER TABLE flashcard RENAME difficulty TO bucket; 54 | ALTER TABLE flashcard ALTER COLUMN bucket SET DEFAULT 0; 55 | ALTER TABLE flashcard DROP COLUMN language; 56 | ALTER TABLE flashcard ADD COLUMN side TEXT DEFAULT 'recto'; 57 | ALTER TABLE flashcard ADD COLUMN updated_at TIMESTAMPTZ NOT NULL DEFAULT now(); 58 | 59 | CREATE OR REPLACE FUNCTION update_flashcard_updated_at() 60 | RETURNS TRIGGER AS $$ 61 | BEGIN 62 | NEW.updated_at = now(); 63 | RETURN NEW; 64 | END; 65 | $$ language 'plpgsql'; 66 | 67 | CREATE TRIGGER flashcard_updated_at 68 | BEFORE UPDATE ON flashcard 69 | FOR EACH ROW 70 | EXECUTE PROCEDURE update_flashcard_updated_at(); 71 | 72 | COMMIT; 73 | -------------------------------------------------------------------------------- /deploysetup/deploysetup.sh: -------------------------------------------------------------------------------- 1 | #!/bin/bash -e 2 | 3 | 4 | -------------------------------------------------------------------------------- /drop-ddl.sql: -------------------------------------------------------------------------------- 1 | -- Drop Tables 2 | DROP TABLE words; 3 | -------------------------------------------------------------------------------- /front/.babelrc: -------------------------------------------------------------------------------- 1 | { 2 | "presets": ["@babel/preset-env", "@babel/preset-react", {'plugins': ['@babel/plugin-proposal-class-properties']}] 3 | } 4 | -------------------------------------------------------------------------------- /front/FlashCardEdit.js: -------------------------------------------------------------------------------- 1 | import React from 'react'; 2 | import ReactDOM from 'react-dom'; 3 | 4 | export function addTag(elt) { 5 | console.log('add tag'); 6 | console.log(elt); 7 | var newDiv = document.createElement("div"); 8 | elt.previousElementSibling.append( 9 | newDiv, 10 | ); 11 | ReactDOM.render( 12 | , 13 | newDiv 14 | ); 15 | } 16 | 17 | export function removeTag(elt) { 18 | elt.parentElement.remove(); 19 | } 20 | 21 | export class FlashCardTagInput extends React.Component { 22 | 23 | constructor(props) { 24 | super(props); 25 | 26 | this.state = { 27 | unmount: false, 28 | } 29 | 30 | this.onRemove = this.onRemove.bind(this); 31 | } 32 | 33 | onRemove = () => { 34 | this.setState({ 35 | unmount: true, 36 | }); 37 | } 38 | 39 | render() { 40 | const {unmount} = this.state; 41 | 42 | if (unmount) { 43 | return null; 44 | } else { 45 | return ( 46 |
47 | 48 | Delete tag 49 |
50 | ) 51 | } 52 | } 53 | } 54 | -------------------------------------------------------------------------------- /front/FullscreenNavigation.jsx: -------------------------------------------------------------------------------- 1 | import React, {Component} from 'react'; 2 | import { render } from 'react-dom'; 3 | import {closeFullScreenMenu} from './utils.js'; 4 | 5 | export class FullscreenNavigation extends Component { 6 | 7 | constructor(props) { 8 | super(props); 9 | 10 | this.hideFullscreenMenu = this.hideFullscreenMenu.bind(this); 11 | } 12 | 13 | hideFullscreenMenu(e) { 14 | e.preventDefault(); 15 | closeFullScreenMenu(); 16 | } 17 | 18 | render() { 19 | return ( 20 | 21 | 22 | 23 | 24 | 41 | 42 | ); 43 | } 44 | 45 | } 46 | -------------------------------------------------------------------------------- /front/Makefile: -------------------------------------------------------------------------------- 1 | .PHONY: build 2 | build: 3 | npm run build 4 | 5 | .PHONY: dev 6 | dev: 7 | npm run start 8 | -------------------------------------------------------------------------------- /front/TopNavigation.jsx: -------------------------------------------------------------------------------- 1 | import React, {Component} from 'react'; 2 | import ReactDOM, { render } from 'react-dom'; 3 | 4 | import { FullscreenNavigation } from './FullscreenNavigation.jsx'; 5 | 6 | export class TopNavigation extends Component { 7 | 8 | constructor(props) { 9 | super(props); 10 | 11 | this.onOpenFullscreenMenu = this.onOpenFullscreenMenu.bind(this); 12 | } 13 | 14 | componentDidMount() { 15 | } 16 | 17 | onOpenFullscreenMenu(e) { 18 | const {user} = this.props; 19 | 20 | e.preventDefault(); 21 | ReactDOM.render( 22 | , 23 | document.getElementById('fullscreen-menu') 24 | ); 25 | openFullScreenMenu(); 26 | } 27 | 28 | render() { 29 | return ( 30 | 37 | ); 38 | } 39 | 40 | } 41 | -------------------------------------------------------------------------------- /front/main.js: -------------------------------------------------------------------------------- 1 | import React from 'react'; 2 | import ReactDOM from 'react-dom'; 3 | 4 | import { TopNavigation } from "./TopNavigation.jsx"; 5 | 6 | import {openFullScreenMenu, closeFullScreenMenu, newQuizzTimeout} from './utils.js'; 7 | import {addTag, removeTag} from './FlashCardEdit.js'; 8 | 9 | window.onload = function() { 10 | if (window.location.pathname === "/") { 11 | // pathname 12 | } 13 | 14 | // Top Navigation for user 15 | if (typeof backendVariables !== 'undefined' && typeof backendVariables.session !== 'undefined' && typeof backendVariables.session.user.id !== 'undefined') { 16 | ReactDOM.render( 17 | , 18 | document.getElementById('top-navigation-user') 19 | ); 20 | } 21 | } 22 | 23 | 24 | // export global context / window context the function needed 25 | // by the attribute onclick= 26 | window.openFullScreenMenu = openFullScreenMenu; 27 | window.closeFullScreenMenu = closeFullScreenMenu; 28 | window.addTag = addTag; 29 | window.removeTag = removeTag; 30 | window.newQuizzTimeout = newQuizzTimeout; 31 | -------------------------------------------------------------------------------- /front/package.json: -------------------------------------------------------------------------------- 1 | { 2 | "name": "front", 3 | "version": "1.0.0", 4 | "description": "frontend for izidict", 5 | "main": "main.js", 6 | "scripts": { 7 | "start": "webpack --mode development --watch", 8 | "build": "webpack --mode production", 9 | "test": "echo \"Error: no test specified\" && exit 1" 10 | }, 11 | "author": "", 12 | "license": "ISC", 13 | "devDependencies": { 14 | "@babel/core": "^7.1.5", 15 | "@babel/plugin-proposal-class-properties": "^7.1.0", 16 | "@babel/preset-env": "^7.1.5", 17 | "@babel/preset-react": "^7.0.0", 18 | "babel-loader": "^8.0.4", 19 | "webpack": "^4.25.1", 20 | "webpack-cli": "^3.1.2" 21 | }, 22 | "dependencies": { 23 | "moment": "^2.22.2", 24 | "moment-timezone": "^0.5.23", 25 | "react": "^16.6.1", 26 | "react-dom": "^16.6.1" 27 | } 28 | } 29 | -------------------------------------------------------------------------------- /front/utils.js: -------------------------------------------------------------------------------- 1 | export function openFullScreenMenu() { 2 | document.getElementById('fullscreen-menu').style.visibility = "visible"; 3 | } 4 | 5 | export function closeFullScreenMenu() { 6 | document.getElementById('fullscreen-menu').style.visibility = "hidden"; 7 | } 8 | 9 | export function newQuizzTimeout() { 10 | setTimeout( 11 | () => { 12 | window.location = "/quizz"; 13 | }, 14 | 3000 15 | ); 16 | } 17 | -------------------------------------------------------------------------------- /front/webpack.config.js: -------------------------------------------------------------------------------- 1 | const path = require("path"); 2 | 3 | module.exports = { 4 | entry: "./main.js", 5 | output: { 6 | path: path.join(__dirname, "/dist"), 7 | filename: "izidict.js" 8 | }, 9 | module: { 10 | rules: [{ 11 | test: /\.jsx?$/, 12 | exclude: /node_modules/, 13 | use: [{ 14 | loader: "babel-loader" 15 | }] 16 | }] 17 | } 18 | }; 19 | -------------------------------------------------------------------------------- /izidict.cabal: -------------------------------------------------------------------------------- 1 | -- This file has been generated from package.yaml by hpack version 0.28.2. 2 | -- 3 | -- see: https://github.com/sol/hpack 4 | -- 5 | -- hash: 862007f62876066ccf6e24161edbdaf6ab1484c078e8b71963e2a05aee41c7d9 6 | 7 | name: izidict 8 | version: 0.1.0.0 9 | synopsis: IziDict HTTP backend server 10 | description: IziDict HTTP backend server 11 | category: Development 12 | homepage: https://github.com/aRkadeFR/izidict#readme 13 | bug-reports: https://github.com/aRkadeFR/izidict/issues 14 | maintainer: aRkadeFR 15 | license: MIT 16 | license-file: LICENSE 17 | build-type: Simple 18 | cabal-version: >= 1.10 19 | 20 | source-repository head 21 | type: git 22 | location: https://github.com/aRkadeFR/izidict 23 | 24 | executable backend-exe 25 | main-is: main.hs 26 | exposed-modules: 27 | API.Facebook 28 | Auth 29 | Cache 30 | Config 31 | Data 32 | Data.GrantUser 33 | Data.User 34 | Data.Message 35 | Data.Session 36 | Form 37 | HandlerM 38 | Mustache 39 | SharedEnv 40 | SQL 41 | Template 42 | User 43 | Word 44 | Paths_izidict 45 | hs-source-dirs: 46 | src 47 | app 48 | ghc-options: -Wall 49 | build-depends: 50 | base >=4.7 && <5 51 | , base64-bytestring 52 | , aeson 53 | , aeson-pretty 54 | , async 55 | , binary 56 | , binary-bits 57 | , blaze-html 58 | , blaze-markup 59 | , bytestring >=0.10.8.2 60 | , byteable 61 | , clay 62 | , cookie 63 | , containers 64 | , convertible 65 | , cryptohash 66 | , data-binary-ieee754 67 | , geojson 68 | , lens 69 | , lens-aeson 70 | , HaskellNet 71 | , HaskellNet-SSL 72 | , http-api-data 73 | , http-conduit 74 | , http-media 75 | , http-types 76 | , mtl 77 | , mime-mail 78 | , monad-logger 79 | , megaparsec 80 | , mustache 81 | , network 82 | , postgresql-libpq >= 0.9.4.2 83 | , protolude 84 | , random 85 | , resource-pool >=0.2.3.2 86 | , servant >=0.5 87 | , servant-blaze ==0.8 88 | , servant-multipart 89 | , servant-server ==0.14.1 90 | , scientific 91 | , semigroups 92 | , stm 93 | , swagger2 94 | , text 95 | , time 96 | , transformers 97 | , utf8-string 98 | , unordered-containers 99 | , uuid 100 | , vector 101 | , wai 102 | , wai-extra 103 | , warp 104 | , wkt-geom 105 | , yaml 106 | default-language: Haskell2010 107 | default-extensions: OverloadedStrings 108 | , DeriveGeneric 109 | , TemplateHaskell 110 | , TypeOperators 111 | , DataKinds 112 | , RankNTypes 113 | , GeneralizedNewtypeDeriving 114 | , QuasiQuotes 115 | , DeriveDataTypeable 116 | , FlexibleInstances 117 | , MultiParamTypeClasses 118 | , NoImplicitPrelude 119 | , InstanceSigs 120 | -------------------------------------------------------------------------------- /package.yaml: -------------------------------------------------------------------------------- 1 | name: izidict 2 | version: 0.1.0.0 3 | synopsis: IziDict HTTP backend server 4 | description: IziDict HTTP backend server 5 | maintainer: aRkadeFR 6 | license: MIT 7 | github: aRkadeFR/izidict 8 | category: Development 9 | 10 | dependencies: 11 | - base >= 4.7 && < 5 12 | - aeson 13 | - aeson-pretty 14 | - convertible 15 | - utf8-string 16 | - elm-export 17 | - servant >= 0.5 18 | - servant-server 19 | - servant-swagger 20 | - servant-swagger-ui 21 | - servant-elm 22 | - wai-extra 23 | - wai-cors >= 0.2.6 24 | - swagger2 25 | - lens 26 | - wai 27 | - warp 28 | - containers 29 | - mtl 30 | - resource-pool >= 0.2.3.2 31 | - bytestring >= 0.10.8.2 32 | - HDBC >= 2.4.0.2 33 | - HDBC-postgresql >= 2.3.2.5 34 | - yeshql-hdbc >= 4.1.0.1 35 | - yeshql >= 4.1.0.1 36 | - yaml == 0.8.32 37 | 38 | source-dirs: 39 | - src 40 | 41 | ghc-options: -Wall 42 | 43 | executables: 44 | backend-exe: 45 | main: main.hs 46 | source-dirs: app 47 | generate-elm-api: 48 | main: generateElmAPI.hs 49 | source-dirs: app 50 | 51 | tests: 52 | spec: 53 | main: Spec.hs 54 | source-dirs: test 55 | dependencies: 56 | - hspec == 2.* 57 | - hspec-wai == 0.9.0 58 | - hspec-wai-json == 0.9.0 59 | - mockery 60 | - QuickCheck 61 | -------------------------------------------------------------------------------- /queries.sql: -------------------------------------------------------------------------------- 1 | -- name: get-random-word 2 | -- Get random word from table 3 | WITH params AS ( 4 | SELECT count(*) AS nb_rows 5 | FROM words 6 | ) 7 | SELECT language, word, definition 8 | FROM words, params 9 | OFFSET floor(random() * (SELECT nb_rows FROM params)) 10 | LIMIT 1; 11 | 12 | -- name: get-n-random-words 13 | -- Get N random word from table 14 | SELECT language, word, definition 15 | FROM words 16 | ORDER BY random() 17 | LIMIT %(n)s; 18 | 19 | -- name: get-similarity-word 20 | -- Check similarity word 21 | SELECT similarity(%(word_try)s, %(word)s); 22 | 23 | -- name: get-similarity-definition 24 | -- Check similarity word 25 | SELECT similarity(%(word_try)s, definition) 26 | FROM words 27 | WHERE word = %(word)s; 28 | -------------------------------------------------------------------------------- /questionary.py: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env python3 2 | 3 | import psycopg2 4 | import anosql 5 | import random 6 | import time 7 | import os 8 | 9 | 10 | def main(): 11 | with psycopg2.connect('service=words') as db_conn: 12 | queries = anosql.load_queries('postgres', 'queries.sql') 13 | 14 | # Let's print 5 random words we want to work on, 15 | # with the definition 16 | random_words = queries.get_n_random_words(db_conn, n=5) 17 | print('Words to keep in mind are:') 18 | for random_word in random_words: 19 | print('{} "{}": {}'.format(random_word[0], random_word[1], random_word[2])) 20 | 21 | time.sleep(10) 22 | os.system('cls' if os.name == 'nt' else 'clear') 23 | 24 | # And now let's do a simple question 25 | random_word = random.choice(random_words) 26 | 27 | answer = input('Word in {} for {}:\n--> '.format(random_word[0], random_word[2])) 28 | similarity = queries.get_similarity_word(db_conn, word_try=answer, word=random_word[1])[0][0] 29 | if similarity > 0.05: 30 | print('Cool! Again?') 31 | else: 32 | print('Almost there… The good word was: {}\nKeep trying!'.format(random_word[1])) 33 | pass 34 | 35 | 36 | if __name__ == '__main__': 37 | main() 38 | -------------------------------------------------------------------------------- /revert/0001-words.sql: -------------------------------------------------------------------------------- 1 | -- Revert words:0001-words from pg 2 | 3 | BEGIN; 4 | 5 | DROP TABLE "words"; 6 | 7 | COMMIT; 8 | -------------------------------------------------------------------------------- /revert/0002-users.sql: -------------------------------------------------------------------------------- 1 | -- Revert words:0002-users from pg 2 | 3 | BEGIN; 4 | 5 | -- XXX Add DDLs here. 6 | 7 | COMMIT; 8 | -------------------------------------------------------------------------------- /revert/0003-tokens.sql: -------------------------------------------------------------------------------- 1 | -- Revert words:0003-tokens from pg 2 | 3 | BEGIN; 4 | 5 | -- XXX Add DDLs here. 6 | 7 | COMMIT; 8 | -------------------------------------------------------------------------------- /revert/0004-session.sql: -------------------------------------------------------------------------------- 1 | -- Revert words:0004-session from pg 2 | 3 | BEGIN; 4 | 5 | -- XXX Add DDLs here. 6 | 7 | COMMIT; 8 | -------------------------------------------------------------------------------- /revert/0005-scoring.sql: -------------------------------------------------------------------------------- 1 | -- Revert words:0005-scoring from pg 2 | 3 | BEGIN; 4 | 5 | -- XXX Add DDLs here. 6 | 7 | COMMIT; 8 | -------------------------------------------------------------------------------- /revert/0006-update-user.sql: -------------------------------------------------------------------------------- 1 | -- Revert words:0006-update-user from pg 2 | 3 | BEGIN; 4 | 5 | -- Session 6 | -- Remove the unique constraint on the userid 7 | ALTER TABLE session ADD CONSTRAINT sessions_userid_key UNIQUE (userid); 8 | -- 9 | ALTER TABLE session DROP COLUMN created_at; 10 | ALTER TABLE session RENAME TO sessions; 11 | 12 | -- Change the field email type back to text 13 | ALTER TABLE user_account ALTER COLUMN email TYPE TEXT ; 14 | 15 | -- Move the table back 16 | ALTER TABLE user_account RENAME TO users; 17 | 18 | -- Drop Domain 19 | DROP DOMAIN IF EXISTS email_d; 20 | 21 | -- Drop extension 22 | DROP EXTENSION IF EXISTS CITEXT; 23 | 24 | COMMIT; 25 | -------------------------------------------------------------------------------- /sqitch.conf: -------------------------------------------------------------------------------- 1 | [core] 2 | engine = pg 3 | plan_file = sqitch.plan 4 | top_dir = . 5 | [deploy] 6 | verify = true 7 | [rebase] 8 | verify = true 9 | [target "dev"] 10 | uri = db:pg:words 11 | [target "test"] 12 | uri = db:pg:words 13 | [engine "pg"] 14 | target = test 15 | -------------------------------------------------------------------------------- /sqitch.plan: -------------------------------------------------------------------------------- 1 | %syntax-version=1.0.0 2 | %project=words 3 | 4 | 0001-words 2018-02-05T21:59:14Z aRkadeFR # Schema for words 5 | 0002-users 2018-07-16T07:41:01Z aRkadeFR # Add 0002-users deploy change 6 | 0003-tokens 2018-08-03T07:06:48Z aRkadeFR # 0003-tokens temporary for authentication 7 | 0004-session 2018-08-05T09:57:37Z aRkadeFR # Add 0004-session handle / table 8 | 0005-scoring 2018-08-23T20:29:16Z aRkadeFR # Add 0005-scoring for words 9 | 0006-update-user 2019-01-05T06:09:38Z aRkadeFR # 0006-update-user 10 | -------------------------------------------------------------------------------- /sql.load: -------------------------------------------------------------------------------- 1 | LOAD CSV 2 | FROM '/home/arkadefr/Projects/words/words.csv' 3 | HAVING FIELDS ( 4 | language, word, definition 5 | ) 6 | INTO postgresql:///words?tablename=words 7 | TARGET COLUMNS ( 8 | language, word, definition 9 | ) 10 | 11 | WITH truncate, 12 | skip header = 1, 13 | fields optionally enclosed by '"', 14 | fields escaped by double-quote, 15 | fields terminated by ',' 16 | 17 | SET client_encoding to 'latin1', 18 | work_mem to '12MB', 19 | standard_conforming_strings to 'on' 20 | ; 21 | -------------------------------------------------------------------------------- /sql/addFlashCard.sql: -------------------------------------------------------------------------------- 1 | -- Add FlashCard 2 | WITH flashcard_inserted AS ( 3 | INSERT INTO 4 | flashcard 5 | (userid, recto, tags, verso, updated_at) 6 | VALUES 7 | (CAST($1 AS BIGINT), CAST($2 AS TEXT), CAST($3 AS TEXT[]), CAST($4 AS TEXT), now() - INTERVAL '1 day') 8 | RETURNING 9 | * 10 | ) 11 | SELECT 12 | COUNT(*) 13 | FROM 14 | flashcard_inserted 15 | ; 16 | -------------------------------------------------------------------------------- /sql/checkPassword.sql: -------------------------------------------------------------------------------- 1 | -- Password checked 2 | WITH user_checked AS ( 3 | SELECT 4 | id 5 | FROM 6 | user_account 7 | WHERE 8 | email = CAST($1 AS CITEXT) 9 | AND CRYPT($2, passpass) = passpass 10 | ) 11 | SELECT 12 | count(*) 13 | FROM 14 | user_checked 15 | ; 16 | -------------------------------------------------------------------------------- /sql/decreaseBucketFlashCard.sql: -------------------------------------------------------------------------------- 1 | -- Decrease bucket flashcard . 2 | -- Not less than 0 3 | WITH flashcard_updated AS ( 4 | UPDATE 5 | flashcard 6 | SET 7 | side = CASE WHEN side = 'recto' THEN 'verso' 8 | ELSE 'recto' END 9 | , bucket = CASE WHEN bucket = 6 THEN 5 10 | WHEN bucket = 5 THEN 4 11 | WHEN bucket = 4 THEN 3 12 | WHEN bucket = 3 THEN 2 13 | WHEN bucket = 2 THEN 1 14 | ELSE 0 END 15 | WHERE 16 | userid = CAST($1 AS BIGINT) 17 | AND id = CAST($2 AS BIGINT) 18 | RETURNING 19 | * 20 | ) 21 | SELECT 22 | COUNT(*) 23 | FROM 24 | flashcard_updated 25 | ; 26 | -------------------------------------------------------------------------------- /sql/deleteFlashCard.sql: -------------------------------------------------------------------------------- 1 | -- Delete FlashCard 2 | WITH flashcard_deleted AS ( 3 | DELETE 4 | FROM 5 | flashcard 6 | WHERE 7 | userid = CAST($1 AS BIGINT) 8 | AND id = CAST($2 AS BIGINT) 9 | RETURNING 10 | * 11 | ) 12 | SELECT 13 | COUNT(*) 14 | FROM 15 | flashcard_deleted 16 | ; 17 | -------------------------------------------------------------------------------- /sql/getFlashCard.sql: -------------------------------------------------------------------------------- 1 | -- Get my FlashCards 2 | SELECT 3 | id, 4 | recto, 5 | tags, 6 | verso, 7 | bucket, 8 | side 9 | FROM 10 | flashcard 11 | WHERE 12 | userid = CAST($1 AS BIGINT) 13 | AND id = CAST($2 AS BIGINT) 14 | ; 15 | -------------------------------------------------------------------------------- /sql/getFlashCards.sql: -------------------------------------------------------------------------------- 1 | -- Get my FlashCards 2 | SELECT 3 | id, 4 | recto, 5 | tags, 6 | verso, 7 | bucket, 8 | side 9 | FROM 10 | flashcard 11 | WHERE 12 | userid = CAST($1 AS BIGINT) 13 | ORDER BY 14 | inserted_at DESC 15 | LIMIT 50 16 | ; 17 | -------------------------------------------------------------------------------- /sql/getNewRandomSession.sql: -------------------------------------------------------------------------------- 1 | -- Get new random session for user email 2 | WITH user_id AS ( 3 | SELECT 4 | id 5 | FROM 6 | user_account 7 | WHERE 8 | email = CAST($1 AS CITEXT) 9 | AND CRYPT($2, passpass) = passpass 10 | ) 11 | INSERT INTO 12 | session 13 | (userid, secret) 14 | SELECT 15 | uid.id, md5(random()::TEXT) 16 | FROM 17 | user_id uid 18 | RETURNING 19 | secret 20 | ; 21 | -------------------------------------------------------------------------------- /sql/getNewRandomSessionWithoutPasswordCheck.sql: -------------------------------------------------------------------------------- 1 | -- Get new random session for user email 2 | WITH user_id AS ( 3 | SELECT 4 | id 5 | FROM 6 | user_account 7 | WHERE 8 | email = CAST($1 AS CITEXT) 9 | ) 10 | INSERT INTO 11 | session 12 | (userid, secret) 13 | SELECT 14 | uid.id, md5(random()::TEXT) 15 | FROM 16 | user_id uid 17 | RETURNING 18 | secret 19 | ; 20 | -------------------------------------------------------------------------------- /sql/getQuizzFlashCard.sql: -------------------------------------------------------------------------------- 1 | -- Get a FlashCard for the quizz 2 | -- The rule to get a FlashCard is this one: 3 | -- - Bucket 0: Pick the flash card every day 4 | -- - Bucket 1: Pick the flash card every 2 days 5 | -- - Bucket 2: Pick the flash card every week 6 | -- - Bucket 3: Pick the flash card every month 7 | -- - Bucket 4: Pick the flash card every 3 months 8 | -- - Bucket 5: Pick the flash card every 6 months 9 | -- - Bucket 6: Pick the flash card every year 10 | SELECT 11 | id, 12 | recto, 13 | tags, 14 | verso, 15 | bucket, 16 | side 17 | FROM 18 | flashcard 19 | WHERE 20 | userid = CAST($1 AS BIGINT) 21 | AND date_part('day', updated_at) != date_part('day', now()) -- we remove all the cards already asked today 22 | AND ( bucket = 0 23 | OR bucket = 1 AND EXTRACT(DAY FROM (now() - updated_at)) > 2 24 | OR bucket = 2 AND EXTRACT(DAY FROM (now() - updated_at)) > 7 25 | OR bucket = 3 AND EXTRACT(DAY FROM (now() - updated_at)) > 30 26 | OR bucket = 4 AND EXTRACT(DAY FROM (now() - updated_at)) > 90 27 | OR bucket = 5 AND EXTRACT(DAY FROM (now() - updated_at)) > 180 28 | OR bucket = 6 AND EXTRACT(DAY FROM (now() - updated_at)) > 365 29 | ) 30 | ORDER BY 31 | bucket DESC 32 | LIMIT 33 | 1 34 | ; 35 | -------------------------------------------------------------------------------- /sql/increaseBucketFlashCard.sql: -------------------------------------------------------------------------------- 1 | -- Increase bucket flashcard . 2 | -- Not more than 5 3 | WITH flashcard_updated AS ( 4 | UPDATE 5 | flashcard 6 | SET 7 | side = CASE WHEN side = 'recto' THEN 'verso' 8 | ELSE 'recto' END 9 | , bucket = CASE WHEN bucket = 0 THEN 1 10 | WHEN bucket = 1 THEN 2 11 | WHEN bucket = 2 THEN 3 12 | WHEN bucket = 3 THEN 4 13 | WHEN bucket = 4 THEN 5 14 | ELSE 6 END 15 | WHERE 16 | userid = CAST($1 AS BIGINT) 17 | AND id = CAST($2 AS BIGINT) 18 | RETURNING 19 | * 20 | ) 21 | SELECT 22 | COUNT(*) 23 | FROM 24 | flashcard_updated 25 | ; 26 | -------------------------------------------------------------------------------- /sql/insertDefaultFlashCards.sql: -------------------------------------------------------------------------------- 1 | -- Insert 10 Default FlashCards 2 | WITH flashcard_inserted AS ( 3 | INSERT INTO 4 | flashcard 5 | (recto, tags, verso, userid, updated_at) 6 | VALUES 7 | ('Gravity Apple', CAST('{general knowledge}' AS TEXT[]), 'Object inspired Isaac Newton s theory', CAST($1 AS BIGINT), now() - INTERVAL '1 day'), 8 | ('NYC Yellow', CAST('{general knowledge}' AS TEXT[]), 'Color of NYC Taxi', CAST($1 AS BIGINT), now() - INTERVAL '1 day'), 9 | ('J. K. Rowling', CAST('{general knowledge}' AS TEXT[]), 'Author of the books Harry Potter', CAST($1 AS BIGINT), now() - INTERVAL '1 day'), 10 | ('Percy Spencer', CAST('{general knowledge}' AS TEXT[]), 'Inventor of the microwave', CAST($1 AS BIGINT), now() - INTERVAL '1 day'), 11 | ('Merci', CAST('{general knowledge}' AS TEXT[]), 'Thank you', CAST($1 AS BIGINT), now() - INTERVAL '1 day'), 12 | ('Yawn and stretch at the same time', CAST('{general knowledge}' AS TEXT[]), 'Pandiculating', CAST($1 AS BIGINT), now() - INTERVAL '1 day'), 13 | ('Pteronophobia', CAST('{general knowledge}' AS TEXT[]), 'Fear of being tickled by a feather', CAST($1 AS BIGINT), now() - INTERVAL '1 day'), 14 | ('Country with 50 percent of the total round about in the world', CAST('{general knowledge}' AS TEXT[]), 'France has 50 percent of the total number of…', CAST($1 AS BIGINT), now() - INTERVAL '1 day'), 15 | ('Pluto is smaller than which country?', CAST('{general knowledge}' AS TEXT[]), 'Russia is bigger than which planet', CAST($1 AS BIGINT), now() - INTERVAL '1 day'), 16 | ('Animal sleeping up to three years', CAST('{general knowledge}' AS TEXT[]), 'Action a snail can do during three years', CAST($1 AS BIGINT), now() - INTERVAL '1 day'), 17 | ('Animal without a brain', CAST('{general knowledge}' AS TEXT[]), 'Body part missing for starfish', CAST($1 AS BIGINT), now() - INTERVAL '1 day'), 18 | ('Year of creation of the video game character Mario', CAST('{general knowledge}' AS TEXT[]), '1981 Video Game', CAST($1 AS BIGINT), now() - INTERVAL '1 day') 19 | RETURNING 20 | * 21 | ) 22 | SELECT 23 | COUNT(*) 24 | FROM 25 | flashcard_inserted 26 | ; 27 | -------------------------------------------------------------------------------- /sql/insertUser.sql: -------------------------------------------------------------------------------- 1 | -- Facebook insert user 2 | -- the email is verified. 3 | WITH user_inserted AS ( 4 | INSERT INTO 5 | user_account 6 | (username, email, passpass, email_verified) 7 | SELECT 8 | CAST($1 AS TEXT) || CAST($2 AS TEXT), CAST($3 AS TEXT), CAST($4 AS TEXT), 't' 9 | RETURNING 10 | * 11 | ) 12 | SELECT 13 | id, username, email, languages 14 | FROM 15 | user_inserted 16 | ; 17 | -------------------------------------------------------------------------------- /sql/insert_word.sql: -------------------------------------------------------------------------------- 1 | -- Insert sql word 2 | INSERT INTO 3 | words (language, word, definition) 4 | VALUES 5 | (:'language', :'word', :'definition') 6 | ; 7 | -------------------------------------------------------------------------------- /sql/registerUser.sql: -------------------------------------------------------------------------------- 1 | -- Register new user 2 | WITH user_inserted AS ( 3 | INSERT INTO 4 | user_account 5 | (email, passpass) 6 | SELECT 7 | CAST($1 AS email_d), CAST($2 AS TEXT) 8 | RETURNING 9 | * 10 | ) 11 | SELECT 12 | id, username, email, languages 13 | FROM 14 | user_inserted 15 | ; 16 | -------------------------------------------------------------------------------- /sql/searchFlashCards.sql: -------------------------------------------------------------------------------- 1 | -- Search my FlashCards 2 | SELECT 3 | id, 4 | recto, 5 | tags, 6 | verso, 7 | bucket, 8 | side 9 | FROM 10 | flashcard 11 | WHERE 12 | userid = CAST($1 AS BIGINT) 13 | AND to_tsvector('english', COALESCE(recto, '') || ' ' || COALESCE(verso, '')) @@ plainto_tsquery('english', CAST($2 AS TEXT)) 14 | ORDER BY 15 | inserted_at DESC 16 | LIMIT 50 17 | ; 18 | -------------------------------------------------------------------------------- /sql/test_data.sql: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/FlogFr/FlashCard/17029f9b84f23c43f67702b77bd7418cdf0a9d28/sql/test_data.sql -------------------------------------------------------------------------------- /sql/updateFlashCard.sql: -------------------------------------------------------------------------------- 1 | -- Update FlashCard 2 | WITH flashcard_updated AS ( 3 | UPDATE 4 | flashcard 5 | SET 6 | recto = CAST($3 AS TEXT) 7 | , tags = CAST($4 AS TEXT[]) 8 | , verso = CAST($5 AS TEXT) 9 | WHERE 10 | id = CAST($2 AS BIGINT) 11 | AND userid = CAST($1 AS BIGINT) 12 | RETURNING 13 | * 14 | ) 15 | SELECT 16 | count(*) 17 | FROM 18 | flashcard_updated 19 | ; 20 | -------------------------------------------------------------------------------- /sql/updatePassword.sql: -------------------------------------------------------------------------------- 1 | -- Update User Password 2 | WITH password_updated AS ( 3 | UPDATE 4 | user_account 5 | SET 6 | passpass = CAST($2 AS TEXT) 7 | WHERE 8 | email = CAST($1 AS email_d) 9 | RETURNING 10 | * 11 | ) 12 | SELECT 13 | count(*) 14 | FROM 15 | password_updated 16 | ; 17 | -------------------------------------------------------------------------------- /sql/verifyFlashCardRectoAnswer.sql: -------------------------------------------------------------------------------- 1 | -- Verify Recto FlashCard answer 2 | SELECT 3 | to_tsvector('english', recto) @@ plainto_tsquery('english', CAST($3 AS TEXT)) AS verified 4 | FROM 5 | flashcard 6 | WHERE 7 | userid = CAST($1 AS BIGINT) 8 | AND id = CAST($2 AS BIGINT) 9 | ; 10 | -------------------------------------------------------------------------------- /sql/verifyFlashCardVersoAnswer.sql: -------------------------------------------------------------------------------- 1 | -- Verify Verso FlashCard answer 2 | SELECT 3 | to_tsvector('english', verso) @@ plainto_tsquery('english', CAST($3 AS TEXT)) AS verified 4 | FROM 5 | flashcard 6 | WHERE 7 | userid = CAST($1 AS BIGINT) 8 | AND id = CAST($2 AS BIGINT) 9 | ; 10 | -------------------------------------------------------------------------------- /src/API/Facebook.hs: -------------------------------------------------------------------------------- 1 | module API.Facebook where 2 | 3 | import Protolude 4 | 5 | import Control.Monad.Logger 6 | import Control.Exception 7 | import Data.Aeson 8 | import Network.HTTP.Conduit 9 | 10 | import Data.Text (unpack) 11 | import HandlerM 12 | import Data.Exception 13 | import Data.APIFacebook 14 | 15 | 16 | getFacebookAccessToken :: FBAppID -> FBAppSecret -> FBRedirectURI -> Text -> HandlerM FBAccessToken 17 | getFacebookAccessToken fbAppId fbAppSecret fbRedirectURI code = do 18 | returnBS <- simpleHttp . unpack $ ("https://graph.facebook.com/v3.2/oauth/access_token?client_id=" <> fbAppId <> "&redirect_uri=" <> fbRedirectURI <> "&client_secret=" <> fbAppSecret <> "&code=" <> code :: Text) 19 | 20 | let mfbAccessToken = decode returnBS :: Maybe FBAccessToken 21 | case mfbAccessToken of 22 | Just fbAccessToken -> return fbAccessToken 23 | Nothing -> throw $ ExceptionText "Cant decode the FB Access Token" 24 | 25 | 26 | getFacebookToken :: FBAppToken -> FBAccessToken -> HandlerM FBToken 27 | getFacebookToken fbAppToken fbAccessToken = do 28 | -- GET graph.facebook.com/debug_token? 29 | -- input_token={token-to-inspect} 30 | -- &access_token={app-token-or-admin-token} 31 | returnBS <- simpleHttp . unpack $ ("https://graph.facebook.com/debug_token?input_token=" <> access_token fbAccessToken <> "&access_token=" <> fbAppToken :: Text) 32 | $(logInfo) ("result: " <> show returnBS :: Text) 33 | 34 | let mfbToken = decode returnBS :: Maybe FBToken 35 | case mfbToken of 36 | Just fbToken -> return fbToken 37 | Nothing -> throw $ ExceptionText "Cant decode the FB Token" 38 | 39 | getFacebookPermissionList :: FBAppToken -> Text -> HandlerM FBPermissionList 40 | getFacebookPermissionList fbAppToken userId = do 41 | -- yes, userId is a Text in Facebook DB… 42 | returnBS <- simpleHttp . unpack $ ("https://graph.facebook.com/v3.2/" <> userId <> "/permissions?access_token=" <> fbAppToken :: Text) 43 | 44 | let mFBPermissions = decode returnBS :: Maybe FBPermissionList 45 | 46 | case mFBPermissions of 47 | Just fbPermissions -> return fbPermissions 48 | Nothing -> throw $ ExceptionText "Cant decode the FB Permission List" 49 | 50 | getFacebookUser :: FBAccessToken -> Text -> HandlerM FBUser 51 | getFacebookUser fbAppToken userId = do 52 | returnBS <- simpleHttp . unpack $ ("https://graph.facebook.com/v3.2/" <> userId <> "?access_token=" <> access_token fbAppToken <> "&fields=first_name,last_name,email" :: Text) 53 | 54 | let mFBUser = decode returnBS :: Maybe FBUser 55 | 56 | case mFBUser of 57 | Just fbUser -> return fbUser 58 | Nothing -> throw $ ExceptionText "Cant decode the FB User information" 59 | -------------------------------------------------------------------------------- /src/Auth.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TypeFamilies #-} 2 | 3 | module Auth where 4 | 5 | import Protolude 6 | import Data.List 7 | import Data.String 8 | import Data.Pool 9 | import Data.Exception 10 | import Control.Lens hiding ( Context ) 11 | import Crypto.Hash hiding ( Context ) 12 | import Data.Byteable 13 | import Data.Aeson.Lens 14 | import Database.Queries 15 | import Database.PostgreSQL.LibPQ 16 | import Servant 17 | import Servant.Server ( Context((:.), EmptyContext) 18 | , Handler 19 | ) 20 | import Servant.API.Experimental.Auth ( AuthProtect ) 21 | import Servant.Server.Experimental.Auth 22 | ( AuthHandler 23 | , AuthServerData 24 | , mkAuthHandler 25 | ) 26 | import Network.Wai ( Request 27 | , requestHeaders 28 | ) 29 | import qualified Data.ByteString as BS 30 | import qualified Data.ByteString.Base64 as BS64 31 | import Web.Cookie ( parseCookies ) 32 | 33 | import Data.User 34 | import Data.Session 35 | 36 | -- | We need to specify the data returned after authentication 37 | type instance AuthServerData (AuthProtect "custom-auth") = Session 38 | 39 | 40 | -- | A method that, when given a JWT ByteString, will return a User 41 | -- This is our bespoke (and bad) authentication logic. 42 | sessionFromJWT :: Pool Connection -> ByteString -> Handler Session 43 | sessionFromJWT dbPool jwtPartsBS = do 44 | let jwtParts = BS.split 46 jwtPartsBS 45 | if length jwtParts /= 3 46 | then throwError $ err302 { 47 | errHeaders = [ 48 | ("Location", "/") 49 | , ("Set-Cookie", "jwt=deleted; path=/; expires=Thu, 01 Jan 1970 00:00:00 GMT") 50 | ] 51 | } 52 | else do 53 | let jwtHeader = jwtParts!!0 54 | let jwtPayload = jwtParts!!1 55 | let jwtSignature = jwtParts!!2 56 | 57 | let eJwtPayloadBS = BS64.decode jwtPayload 58 | case eJwtPayloadBS of 59 | Right jwtPayloadBS -> do 60 | let mUserEmail = jwtPayloadBS ^? key "email" 61 | . _String 62 | case mUserEmail of 63 | Just userEmail' -> do 64 | eitherSecrets <- withResource dbPool $ \conn -> liftIO $ (try $ do 65 | secrets' <- queryFromText conn "SELECT s.secret FROM user_account uc JOIN session s ON s.userid = uc.id WHERE s.created_at > now() - INTERVAL '14 days' AND uc.email = CAST($1 AS CITEXT) ;" 66 | [ Just (Oid 25, encodeUtf8 userEmail', Binary) ] :: IO [Text] 67 | return $ secrets') :: Handler (Either ExceptionPostgreSQL [Text]) 68 | case eitherSecrets of 69 | Right secretList -> do 70 | let signatureList = (\s -> BS64.encode $ toBytes $ hmacAlg SHA256 (encodeUtf8 $ s) (jwtHeader <> "." <> jwtPayload)) <$> secretList 71 | 72 | let signatureVerified = filter (\s -> s == jwtSignature) signatureList 73 | if length signatureVerified > 0 74 | then do 75 | -- the JWT has been verified at least against one 76 | -- secret. All good, we can retrieve and return the 77 | -- user 78 | eitherUserList <- withResource dbPool $ \conn -> liftIO $ (try $ do 79 | eitherUser' <- queryFromText conn ("SELECT uc.id , uc.username , uc.email , uc.languages " 80 | <> "FROM user_account uc " 81 | <> "WHERE uc.email = CAST($1 AS email_d) ;") 82 | [ Just (Oid 25, encodeUtf8 userEmail', Binary) ] :: IO [User] 83 | return $ eitherUser') :: Handler (Either ExceptionPostgreSQL [User]) 84 | case eitherUserList of 85 | Right userList -> do 86 | if length userList > 0 87 | then return $ Session (userList!!0) 88 | else return AnonymousSession 89 | Left _ -> return AnonymousSession 90 | else return AnonymousSession 91 | Left _ -> return AnonymousSession 92 | Nothing -> return AnonymousSession 93 | Left _ -> return AnonymousSession 94 | 95 | --- | The auth handler wraps a function from Request -> Handler Session. 96 | --- We look for a token in the request headers that we expect to be in the cookie. 97 | authHandler :: Pool Connection -> AuthHandler Request Session 98 | authHandler dbPool = mkAuthHandler handler 99 | where handler :: Request -> Handler Session 100 | handler req = either returnAnonymousSession (sessionFromJWT dbPool) $ do 101 | cookie <- maybeToEither "Missing cookie header" $ lookup "cookie" $ requestHeaders req 102 | maybeToEither "Missing JWT cookie" $ lookup "jwt" $ parseCookies cookie 103 | 104 | returnAnonymousSession :: String -> Handler Session 105 | returnAnonymousSession _ = return AnonymousSession 106 | 107 | contextProxy :: Proxy '[(Servant.Server.Experimental.Auth.AuthHandler Request Session)] 108 | contextProxy = Proxy 109 | 110 | -- | The context that will be made available to request handlers. We supply the 111 | -- "cookie-auth"-tagged request handler defined above, so that the 'HasServer' instance 112 | -- of 'AuthProtect' can extract the handler and run it on the request. 113 | authServerContext :: Pool Connection -> Context (AuthHandler Request Session ': '[]) 114 | authServerContext pool = (authHandler pool) :. EmptyContext 115 | -------------------------------------------------------------------------------- /src/Cache.hs: -------------------------------------------------------------------------------- 1 | module Cache where 2 | 3 | import Protolude 4 | 5 | import Data.Text (pack) 6 | import Control.Concurrent.STM.TMVar 7 | import Data.HashMap.Strict 8 | import SharedEnv 9 | import Data.Settings 10 | import qualified Data.ByteString as BS 11 | import HandlerM 12 | 13 | 14 | readCacheOrFile :: FilePath -> HandlerM Text 15 | readCacheOrFile filePath = do 16 | sharedEnv <- ask 17 | if production . settings $ sharedEnv 18 | then do 19 | let tCache = cache sharedEnv 20 | 21 | cache' <- liftIO $ atomically $ readTMVar tCache 22 | 23 | let cacheKey = "FILE-" <> pack filePath :: Text 24 | 25 | let mCacheValue = lookup cacheKey cache' 26 | 27 | case mCacheValue of 28 | -- if the key exists in the cache', return it 29 | Just cacheValue -> return $ decodeUtf8 cacheValue 30 | -- if the key doesnt exists, read the file, 31 | -- save it in the cache, and return the content 32 | Nothing -> do 33 | contentTxt <- liftIO $ readFile filePath 34 | let newCache = insert cacheKey (encodeUtf8 contentTxt) cache' 35 | _ <- liftIO $ atomically $ swapTMVar tCache newCache 36 | return $ contentTxt 37 | else liftIO $ readFile filePath 38 | 39 | 40 | readCacheOrFileBS :: FilePath -> HandlerM ByteString 41 | readCacheOrFileBS filePath = do 42 | sharedEnv <- ask 43 | if production . settings $ sharedEnv 44 | then do 45 | let tCache = cache sharedEnv 46 | 47 | cache' <- liftIO $ atomically $ readTMVar tCache 48 | 49 | let cacheKey = "FILE-" <> pack filePath :: Text 50 | 51 | let mCacheValue = lookup cacheKey cache' 52 | 53 | case mCacheValue of 54 | -- if the key exists in the cache', return it 55 | Just cacheValue -> return $ cacheValue 56 | -- if the key doesnt exists, read the file, 57 | -- save it in the cache, and return the content 58 | Nothing -> do 59 | contentBS <- liftIO $ BS.readFile filePath 60 | let newCache = insert cacheKey contentBS cache' 61 | _ <- liftIO $ atomically $ swapTMVar tCache newCache 62 | return $ contentBS 63 | else liftIO $ BS.readFile filePath 64 | -------------------------------------------------------------------------------- /src/Data.hs: -------------------------------------------------------------------------------- 1 | module Data 2 | ( module Data.APIFacebook 3 | , module Data.Exception 4 | , module Data.GrantUser 5 | , module Data.Message 6 | , module Data.Settings 7 | , module Data.Session 8 | , module Data.User 9 | , module Data.FlashCard 10 | ) where 11 | 12 | import Data.APIFacebook 13 | import Data.Exception 14 | import Data.GrantUser 15 | import Data.Message 16 | import Data.Settings 17 | import Data.Session 18 | import Data.User 19 | import Data.FlashCard 20 | -------------------------------------------------------------------------------- /src/Data/APIFacebook.hs: -------------------------------------------------------------------------------- 1 | module Data.APIFacebook where 2 | 3 | import Protolude 4 | import Data.Aeson 5 | 6 | 7 | type FBAppID = Text 8 | type FBAppToken = Text 9 | type FBAppSecret = Text 10 | type FBRedirectURI = Text 11 | 12 | 13 | data FBUser = FBUser { 14 | first_name :: Text 15 | , last_name :: Text 16 | , email :: Text 17 | } deriving (Generic, Show) 18 | 19 | instance FromJSON FBUser 20 | 21 | data FBToken = FBToken { 22 | app_id :: Text 23 | , user_id :: Text 24 | } deriving (Generic, Show) 25 | 26 | 27 | instance FromJSON FBToken where 28 | parseJSON (Object o) = FBToken <$> ((o .: "data") >>= (.: "app_id")) 29 | <*> ((o .: "data") >>= (.: "user_id")) 30 | parseJSON _ = mzero 31 | 32 | 33 | data FBAccessToken = FBAccessToken { 34 | access_token :: Text 35 | , token_type :: Text 36 | , expires_in :: Integer 37 | } deriving (Generic, Show) 38 | 39 | 40 | instance FromJSON FBAccessToken 41 | 42 | data FBPermission = FBPermission { 43 | permission :: Text 44 | , status :: Text 45 | } deriving (Generic, Show) 46 | 47 | instance FromJSON FBPermission where 48 | parseJSON (Object o) = 49 | FBPermission <$> (o .: "permission") 50 | <*> (o .: "status") 51 | parseJSON _ = mzero 52 | 53 | newtype FBPermissionList = FBPermissionList { fBPermissionList :: [FBPermission] } 54 | deriving (Show) 55 | 56 | instance FromJSON FBPermissionList where 57 | parseJSON (Object o) = FBPermissionList <$> o .: "data" 58 | parseJSON _ = mzero 59 | -------------------------------------------------------------------------------- /src/Data/Exception.hs: -------------------------------------------------------------------------------- 1 | module Data.Exception where 2 | 3 | import Protolude 4 | 5 | 6 | newtype ExceptionText = ExceptionText Text 7 | deriving (Show, Eq) 8 | instance Exception ExceptionText 9 | 10 | data ExceptionPostgreSQL = ExceptionPGUniqueViolation 11 | | ExceptionPGJWTMalformed 12 | | ExceptionPGJWTInvalid 13 | deriving (Show, Eq) 14 | instance Exception ExceptionPostgreSQL 15 | -------------------------------------------------------------------------------- /src/Data/FlashCard.hs: -------------------------------------------------------------------------------- 1 | module Data.FlashCard where 2 | 3 | import Protolude 4 | 5 | import Data.Aeson 6 | 7 | 8 | data FlashCard = FlashCard 9 | { flashCardId :: Integer 10 | , flashCardRecto :: Text 11 | , flashCardTags :: [Text] 12 | , flashCardVerso :: Text 13 | , flashCardBucket :: Int 14 | , flashCardSide :: Text 15 | } deriving (Eq, Generic, Show) 16 | 17 | 18 | instance ToJSON FlashCard 19 | instance FromJSON FlashCard 20 | -------------------------------------------------------------------------------- /src/Data/GrantUser.hs: -------------------------------------------------------------------------------- 1 | module Data.GrantUser where 2 | 3 | import Protolude 4 | 5 | import Data.Aeson 6 | 7 | data GrantUser = GrantUser 8 | { grantUsername :: Text 9 | , grantPassword :: Text 10 | } deriving (Eq, Generic, Show) 11 | 12 | instance ToJSON GrantUser 13 | instance FromJSON GrantUser 14 | -------------------------------------------------------------------------------- /src/Data/Message.hs: -------------------------------------------------------------------------------- 1 | module Data.Message where 2 | 3 | import Protolude 4 | 5 | data Message = Message { 6 | description :: Text 7 | } deriving (Eq, Show) 8 | -------------------------------------------------------------------------------- /src/Data/NewUser.hs: -------------------------------------------------------------------------------- 1 | module Data.NewUser 2 | ( NewUser(..) 3 | , newuserUsername 4 | , newuserPassword 5 | , newuserEmail 6 | , newuserLanguages 7 | ) 8 | where 9 | 10 | import Protolude 11 | 12 | import Data.Aeson 13 | 14 | 15 | data NewUser = NewUser 16 | { username :: String 17 | , password :: String 18 | , email :: MaybeString 19 | , languages :: StringArray 20 | } deriving (Eq, Generic, Show) 21 | 22 | 23 | newuserUsername :: NewUser -> String 24 | newuserUsername = username 25 | 26 | newuserPassword :: NewUser -> String 27 | newuserPassword = password 28 | 29 | newuserEmail :: NewUser -> MaybeString 30 | newuserEmail = email 31 | 32 | newuserLanguages :: NewUser -> StringArray 33 | newuserLanguages = languages 34 | 35 | instance ToSchema NewUser 36 | instance ToJSON NewUser 37 | instance FromJSON NewUser 38 | instance ElmType NewUser 39 | -------------------------------------------------------------------------------- /src/Data/Session.hs: -------------------------------------------------------------------------------- 1 | module Data.Session where 2 | 3 | import Protolude 4 | import Data.Aeson 5 | import Data.User 6 | 7 | data Session = Session 8 | { sessionUser :: User 9 | } | AnonymousSession 10 | deriving (Generic, Show) 11 | 12 | 13 | instance ToJSON Session where 14 | toJSON (Session u) = object ["user" .= u] 15 | toJSON AnonymousSession = object [] 16 | 17 | toEncoding (Session u) = pairs ("user" .= u) 18 | toEncoding AnonymousSession = genericToEncoding defaultOptions AnonymousSession 19 | 20 | 21 | data SessionSecret = SessionSecret 22 | { sessionSecret :: ByteString 23 | } deriving (Generic, Show) 24 | -------------------------------------------------------------------------------- /src/Data/Settings.hs: -------------------------------------------------------------------------------- 1 | module Data.Settings where 2 | 3 | 4 | import Protolude 5 | import Control.Monad 6 | import qualified Data.Text as T 7 | import qualified Data.Yaml as Y 8 | import Data.APIFacebook 9 | 10 | data Settings = Settings 11 | { base_url :: T.Text 12 | , production :: Bool 13 | , app_port :: Int 14 | , pgservice :: T.Text 15 | , facebook_appid :: FBAppID 16 | , facebook_appsecret :: FBAppSecret 17 | , facebook_apptoken :: FBAppToken 18 | } deriving (Show, Generic, Eq) 19 | 20 | instance Y.ToJSON Settings 21 | instance Y.FromJSON Settings 22 | 23 | loadSettings :: T.Text -> IO (Settings) 24 | loadSettings pathFileCfg = do 25 | maybeSettings <- Y.decodeFileEither . T.unpack $ pathFileCfg 26 | case maybeSettings of 27 | Right config -> return config 28 | Left err -> fail ("impossible to load the config.yml file" ++ show err) 29 | -------------------------------------------------------------------------------- /src/Data/User.hs: -------------------------------------------------------------------------------- 1 | module Data.User where 2 | 3 | import Protolude 4 | import Data.Aeson 5 | 6 | 7 | data User = User 8 | { userId :: Integer 9 | , userUsername :: Maybe Text 10 | , userEmail :: Text 11 | } deriving (Eq, Generic, Show) 12 | 13 | 14 | instance ToJSON User where 15 | toJSON (User id' username' email') = 16 | object [ 17 | "id" .= id' 18 | , "username" .= username' 19 | , "email" .= email' 20 | ] 21 | instance FromJSON User 22 | -------------------------------------------------------------------------------- /src/Data/Word.hs: -------------------------------------------------------------------------------- 1 | module Data.Word where 2 | 3 | import Protolude hiding (Word) 4 | 5 | import Data.Aeson 6 | 7 | 8 | data Word = Word 9 | { wordId :: Int 10 | , wordRecto :: Text 11 | , wordTags :: [Text] 12 | , wordVerso :: Text 13 | , wordBucket :: Integer 14 | } deriving (Eq, Generic, Show) 15 | 16 | instance ToJSON Word 17 | instance FromJSON Word 18 | -------------------------------------------------------------------------------- /src/Database.hs: -------------------------------------------------------------------------------- 1 | module Database 2 | ( DBConnectionString 3 | , initConnectionPool 4 | ) where 5 | 6 | import Protolude 7 | 8 | import Database.PostgreSQL.LibPQ (Connection, connectdb, finish) 9 | import Data.Pool ( Pool 10 | , createPool 11 | ) 12 | 13 | type DBConnectionString = Text 14 | 15 | initConnectionPool :: DBConnectionString -> IO (Pool Connection) 16 | initConnectionPool connTxt = 17 | createPool (connectdb . encodeUtf8 $ (connTxt)) 18 | finish 19 | 2 -- stripes 20 | 60 -- unused connection are kept open for a minute 21 | 10 -- max. 10 connections open per stripe 22 | -------------------------------------------------------------------------------- /src/Database/Queries.hs: -------------------------------------------------------------------------------- 1 | module Database.Queries where 2 | 3 | import Protolude hiding (FatalError) 4 | 5 | import Data.Pool 6 | 7 | import Database.PostgreSQL.LibPQ 8 | import qualified Data.ByteString.Internal as B 9 | ( ByteString(..) ) 10 | 11 | import Control.Exception 12 | import SharedEnv 13 | import Database.SqlRow 14 | import Data.Exception 15 | import Cache 16 | import HandlerM 17 | 18 | -- PG_TYPE_BOOL 16 19 | -- PG_TYPE_BYTEA 17 20 | -- PG_TYPE_CHAR 18 21 | -- PG_TYPE_NAME 19 22 | -- PG_TYPE_INT8 20 23 | -- PG_TYPE_INT2 21 24 | -- PG_TYPE_INT2VECTOR 22 25 | -- PG_TYPE_INT4 23 26 | -- PG_TYPE_REGPROC 24 27 | -- PG_TYPE_TEXT 25 28 | -- PG_TYPE_OID 26 29 | -- PG_TYPE_TID 27 30 | -- PG_TYPE_XID 28 31 | -- PG_TYPE_CID 29 32 | -- PG_TYPE_OIDVECTOR 30 33 | -- PG_TYPE_SET 32 34 | -- PG_TYPE_XML 142 35 | -- PG_TYPE_XMLARRAY 143 36 | -- PG_TYPE_CHAR2 409 37 | -- PG_TYPE_CHAR4 410 38 | -- PG_TYPE_CHAR8 411 39 | -- PG_TYPE_POINT 600 40 | -- PG_TYPE_LSEG 601 41 | -- PG_TYPE_PATH 602 42 | -- PG_TYPE_BOX 603 43 | -- PG_TYPE_POLYGON 604 44 | -- PG_TYPE_FILENAME 605 45 | -- PG_TYPE_CIDR 650 46 | -- PG_TYPE_FLOAT4 700 47 | -- PG_TYPE_FLOAT8 701 48 | -- PG_TYPE_ABSTIME 702 49 | -- PG_TYPE_RELTIME 703 50 | -- PG_TYPE_TINTERVAL 704 51 | -- PG_TYPE_UNKNOWN 705 52 | -- PG_TYPE_MONEY 790 53 | -- PG_TYPE_OIDINT2 810 54 | -- PG_TYPE_MACADDR 829 55 | -- PG_TYPE_INET 869 56 | -- PG_TYPE_OIDINT4 910 57 | -- PG_TYPE_OIDNAME 911 58 | -- PG_TYPE_TEXTARRAY 1009 59 | -- PG_TYPE_BPCHARARRAY 1014 60 | -- PG_TYPE_VARCHARARRAY 1015 61 | -- PG_TYPE_BPCHAR 1042 62 | -- PG_TYPE_VARCHAR 1043 63 | -- PG_TYPE_DATE 1082 64 | -- PG_TYPE_TIME 1083 65 | -- PG_TYPE_TIMESTAMP_NO_TMZONE 1114 /* since 7.2 */ 66 | -- PG_TYPE_DATETIME 1184 67 | -- PG_TYPE_TIME_WITH_TMZONE 1266 /* since 7.1 */ 68 | -- PG_TYPE_TIMESTAMP 1296 /* deprecated since 7.0 */ 69 | -- PG_TYPE_NUMERIC 1700 70 | -- PG_TYPE_RECORD 2249 71 | -- PG_TYPE_VOID 2278 72 | 73 | queryFromText :: (SqlRow a) => Connection -> Text -> [Maybe (Oid, B.ByteString, Format)] -> IO [a] 74 | queryFromText conn sqlQuery params = do 75 | mresult <- execParams conn (encodeUtf8 sqlQuery) params Binary 76 | case mresult of 77 | Just result -> do 78 | rStatus <- resultStatus result 79 | case rStatus of 80 | TuplesOk -> fromSqlResultRows result 81 | FatalError -> do 82 | diagSqlstate <- resultErrorField result DiagSqlstate 83 | 84 | diagSeverity <- resultErrorField result DiagSeverity 85 | putStrLn $ ("DiagSeverity : " <> (show diagSeverity) :: Text) 86 | diagMessagePrimary <- resultErrorField result DiagMessagePrimary 87 | putStrLn $ ("DiagMessagePrimary : " <> (show diagMessagePrimary) :: Text) 88 | diagMessageDetail <- resultErrorField result DiagMessageDetail 89 | putStrLn $ ("DiagMessageDetail : " <> (show diagMessageDetail) :: Text) 90 | diagMessageHint <- resultErrorField result DiagMessageHint 91 | putStrLn $ ("DiagMessageHint : " <> (show diagMessageHint) :: Text) 92 | diagStatementPosition <- resultErrorField result DiagStatementPosition 93 | putStrLn $ ("DiagStatementPosition : " <> (show diagStatementPosition) :: Text) 94 | diagInternalPosition <- resultErrorField result DiagInternalPosition 95 | putStrLn $ ("DiagInternalPosition : " <> (show diagInternalPosition) :: Text) 96 | diagInternalQuery <- resultErrorField result DiagInternalQuery 97 | putStrLn $ ("DiagInternalQuery : " <> (show diagInternalQuery) :: Text) 98 | diagContext <- resultErrorField result DiagContext 99 | putStrLn $ ("DiagContext : " <> (show diagContext) :: Text) 100 | diagSourceFile <- resultErrorField result DiagSourceFile 101 | putStrLn $ ("DiagSourceFile : " <> (show diagSourceFile) :: Text) 102 | diagSourceLine <- resultErrorField result DiagSourceLine 103 | putStrLn $ ("DiagSourceLine : " <> (show diagSourceLine) :: Text) 104 | diagSourceFunction <- resultErrorField result DiagSourceFunction 105 | putStrLn $ ("DiagSourceFunction : " <> (show diagSourceFunction) :: Text) 106 | putStrLn $ ("DiagSqlstate : " <> (show diagSqlstate) :: Text) 107 | 108 | case diagSqlstate of 109 | Just sqlStateBS -> do 110 | let sqlState = show sqlStateBS :: [Char] 111 | case sqlState of 112 | -- https://www.postgresql.org/docs/current/errcodes-appendix.html 113 | "\"23505\"" -> throw ExceptionPGUniqueViolation 114 | "\"P1002\"" -> throw ExceptionPGJWTMalformed 115 | "\"P1003\"" -> throw ExceptionPGJWTInvalid 116 | _ -> throw $ ExceptionText "Dont know this PG exception" 117 | Nothing -> throw $ ExceptionText "Cant retrieve the PostgreSQL error field SqlState" 118 | otherStatus -> do 119 | putStrLn $ ("PG Status : " <> (show otherStatus) :: Text) 120 | throw $ ExceptionText "Wrong PostgreSQL result status, please check" 121 | Nothing -> throw $ ExceptionText "Didnt receive a PostgreSQL result" 122 | 123 | runSqlFile :: (SqlRow a) => FilePath -> [Maybe (Oid, B.ByteString, Format)] -> HandlerM (Either ExceptionPostgreSQL [a]) 124 | runSqlFile sqlFilePath params = do 125 | -- fetch the events 126 | sharedEnv <- ask 127 | let dbPool = dbConnectionPool sharedEnv 128 | sqlQuery <- readCacheOrFile sqlFilePath 129 | withResource dbPool $ \conn -> liftIO $ try $ do 130 | queryFromText conn sqlQuery params 131 | 132 | runSqlFile' :: (SqlRow a) => FilePath -> [Maybe (Oid, B.ByteString, Format)] -> HandlerM [a] 133 | runSqlFile' sqlFilePath params = do 134 | -- Unsafe function that can throw exception 135 | eitherResult <- runSqlFile sqlFilePath params :: (SqlRow a) => HandlerM (Either ExceptionPostgreSQL [a]) 136 | case eitherResult of 137 | Right result -> return result 138 | Left err -> throw $ toException err 139 | -------------------------------------------------------------------------------- /src/Database/SqlRow.hs: -------------------------------------------------------------------------------- 1 | module Database.SqlRow where 2 | 3 | import Protolude hiding (Location, get) 4 | 5 | import Database.PostgreSQL.LibPQ 6 | import Foreign.C.Types 7 | 8 | import Database.Types 9 | 10 | import Data 11 | 12 | 13 | class SqlRow a where 14 | fromSqlResultRow :: Result -> CInt -> IO a 15 | 16 | fromSqlResultRows :: Result -> IO [a] 17 | fromSqlResultRows sqlResult = do 18 | nbRows <- ntuples sqlResult 19 | fromSqlResultRows' sqlResult 0 nbRows 20 | where fromSqlResultRows' res nRow (Row nbRows) = 21 | if nbRows == 0 22 | then return [] 23 | else 24 | if nRow >= (nbRows -1) 25 | then do 26 | -- last value to return 27 | rowValue <- fromSqlResultRow res nRow 28 | return $ [rowValue] 29 | else do 30 | rowValue <- fromSqlResultRow res nRow 31 | rowValues <- fromSqlResultRows' res (nRow+1) (Row nbRows) 32 | return $ rowValue:rowValues 33 | 34 | 35 | instance SqlRow Text where 36 | fromSqlResultRow :: Result -> CInt -> IO Text 37 | fromSqlResultRow res nRow = do 38 | getPGTypeValue res nRow 0 :: IO Text 39 | 40 | instance SqlRow Integer where 41 | fromSqlResultRow :: Result -> CInt -> IO Integer 42 | fromSqlResultRow res nRow = do 43 | getPGTypeValue res nRow 0 :: IO Integer 44 | 45 | instance SqlRow Bool where 46 | fromSqlResultRow :: Result -> CInt -> IO Bool 47 | fromSqlResultRow res nRow = do 48 | getPGTypeValue res nRow 0 :: IO Bool 49 | 50 | instance SqlRow User where 51 | fromSqlResultRow :: Result -> CInt -> IO User 52 | fromSqlResultRow res nRow = do 53 | User <$> (getPGTypeValue res nRow 0 :: IO Integer) 54 | <*> (getPGTypeValue res nRow 1 :: IO (Maybe Text)) 55 | <*> (getPGTypeValue res nRow 2 :: IO Text) 56 | 57 | instance SqlRow FlashCard where 58 | fromSqlResultRow :: Result -> CInt -> IO FlashCard 59 | fromSqlResultRow res nRow = do 60 | FlashCard <$> (getPGTypeValue res nRow 0 :: IO Integer) 61 | <*> (getPGTypeValue res nRow 1 :: IO Text) 62 | <*> (getPGTypeValue res nRow 2 :: IO [Text]) 63 | <*> (getPGTypeValue res nRow 3 :: IO Text) 64 | <*> (getPGTypeValue res nRow 4 :: IO Int) 65 | <*> (getPGTypeValue res nRow 5 :: IO Text) 66 | -------------------------------------------------------------------------------- /src/Database/Types.hs: -------------------------------------------------------------------------------- 1 | module Database.Types where 2 | 3 | import Protolude hiding (empty, Location, get) 4 | 5 | import Database.PostgreSQL.LibPQ 6 | import Foreign.C.Types 7 | import Control.Exception 8 | import System.IO.Error 9 | 10 | import Data.Binary 11 | import Data.Binary.Get 12 | import Data.Time 13 | import Data.UUID 14 | import qualified Data.ByteString.Lazy as BSL 15 | import qualified Data.ByteString as BS 16 | 17 | getPGBool :: Get Bool 18 | getPGBool = do 19 | w <- getWord8 20 | return $ (fromIntegral w :: Integer) /= 0 21 | 22 | getRemainingWord8 :: Get [Word8] 23 | getRemainingWord8 = do 24 | empty <- isEmpty 25 | if empty 26 | then return [] 27 | else do current <- getWord8 28 | remainingWords <- getRemainingWord8 29 | return (current:remainingWords) 30 | 31 | data PGRange = PGRange 32 | { pgH :: !Word8 33 | , pgLengthStart :: !Word32 34 | , pgRangeStartData :: ![Word8] 35 | , pgLengthStop :: !Word32 36 | , pgRangeStopData :: ![Word8] 37 | } deriving (Show) 38 | 39 | getPGRange :: Get PGRange 40 | getPGRange = do 41 | pgH' <- getWord8 -- get the first byte 42 | pgLengthStart' <- getWord32be 43 | pgRangeStartData' <- getNbPGArrayData pgLengthStart' 44 | pgLengthStop' <- getWord32be 45 | pgRangeStopData' <- getNbPGArrayData pgLengthStop' 46 | 47 | return $! PGRange pgH' pgLengthStart' pgRangeStartData' pgLengthStop' pgRangeStopData' 48 | 49 | -- Please refer to the documentation of array.h in postgresql repository 50 | -- https://doxygen.postgresql.org/array_8h_source.html 51 | -- * - standard varlena header word 52 | -- * - number of dimensions of the array 53 | -- * - offset to stored data, or 0 if no nulls bitmap 54 | -- * - element type OID 55 | -- * - length of each array axis (C array of int) 56 | -- * - lower boundary of each dimension (C array of int) 57 | -- * - bitmap showing locations of nulls (OPTIONAL) 58 | -- * - whatever is the stored data 59 | data PGArray = PGArray 60 | { pgArrayVl_len_ :: !Word32 61 | , pgArrayNbDim :: !(Maybe Word16) 62 | , pgArrayDataOffset :: !(Maybe Word32) 63 | , pgArrayElemType :: !(Maybe Word16) 64 | , pgArrayDimensions :: !(Maybe Word32) 65 | , pgArrayLowerBound :: !(Maybe Word32) 66 | , pgArrayData :: ![PGArrayData] 67 | } deriving (Show) 68 | 69 | data PGArrayData = PGArrayData 70 | { pgArrayDataLength :: !Word32 71 | , pgArrayDataData :: ![Word8] 72 | } deriving (Show) 73 | 74 | getNb16PGArrayData :: Word16 -> Get [Word8] 75 | getNb16PGArrayData 0 = return [] 76 | getNb16PGArrayData nbWords = do 77 | currentWord <- getWord8 78 | remainingWords <- getNb16PGArrayData (nbWords - 1) 79 | return (currentWord:remainingWords) 80 | 81 | getNbPGArrayData :: Word32 -> Get [Word8] 82 | getNbPGArrayData 0 = return [] 83 | getNbPGArrayData nbWords = do 84 | currentWord <- getWord8 85 | remainingWords <- getNbPGArrayData (nbWords - 1) 86 | return (currentWord:remainingWords) 87 | 88 | getPGArrayData :: Get PGArrayData 89 | getPGArrayData = do 90 | textLength <- getWord32be 91 | pgWord8' <- getNbPGArrayData textLength 92 | return $ PGArrayData textLength pgWord8' 93 | 94 | getPGArrayDataList :: Get [PGArrayData] 95 | getPGArrayDataList = do 96 | empty <- isEmpty 97 | if empty 98 | then return [] 99 | else do pgArrayData' <- getPGArrayData 100 | pgArrayDatas' <- getPGArrayDataList 101 | return (pgArrayData':pgArrayDatas') 102 | 103 | getPGArray :: Get PGArray 104 | getPGArray = do 105 | vl_len_' <- getWord32be 106 | if vl_len_' == 0 107 | then do 108 | return $! PGArray vl_len_' Nothing Nothing Nothing Nothing Nothing [] 109 | else do 110 | nbDim' <- getWord16be 111 | dataOffset' <- getWord32be 112 | elemType' <- getWord16be 113 | dimensions' <- getWord32be 114 | lowerBound' <- getWord32be 115 | 116 | -- A text is represented by the length of the next words 117 | -- then appended the text 118 | pgArrayData' <- getPGArrayDataList 119 | 120 | return $! PGArray vl_len_' (Just nbDim') (Just dataOffset') (Just elemType') (Just dimensions') (Just lowerBound') pgArrayData' 121 | 122 | class PGType a where 123 | decodePGType :: BSL.ByteString -> IO a 124 | 125 | getPGTypeValue :: Result -> CInt -> CInt -> IO a 126 | getPGTypeValue res nRow nCol = do 127 | mValueBS <- getvalue res (Row nRow) (Col nCol) 128 | case mValueBS of 129 | Just valueBS -> decodePGType . BSL.fromStrict $ valueBS 130 | Nothing -> throw $ userError "Impossible to get the value bytestring" 131 | 132 | 133 | instance PGType [Text] where 134 | decodePGType bs = do 135 | return $ (decodeUtf8 . BS.pack) <$> words8 136 | where words8 = fmap pgArrayDataData $ pgArrayData pgArray 137 | pgArray = runGet getPGArray bs 138 | 139 | 140 | instance PGType (Maybe Text) where 141 | decodePGType bs = return $ Just (decodeUtf8 . BSL.toStrict $ bs) 142 | getPGTypeValue res nRow nCol = do 143 | mValueBS <- getvalue res (Row nRow) (Col nCol) 144 | return $ decodeUtf8 <$> mValueBS 145 | 146 | instance PGType Text where 147 | decodePGType bs = return $ decodeUtf8 . BSL.toStrict $ bs 148 | 149 | instance PGType UUID where 150 | decodePGType bs = do 151 | let mValue = fromByteString bs 152 | case mValue of 153 | Just value' -> return value' 154 | Nothing -> throw $ userError "Impossible to decode expected UUID" 155 | 156 | instance PGType ByteString where 157 | decodePGType bs = return $ BSL.toStrict bs 158 | 159 | instance PGType BSL.ByteString where 160 | decodePGType bs = return $ bs 161 | 162 | instance PGType Bool where 163 | decodePGType bs = return $ runGet getPGBool bs 164 | 165 | instance PGType Double where 166 | decodePGType bs = return $ runGet getDoublebe bs 167 | 168 | instance PGType Int where 169 | decodePGType bs = return $ fromIntegral $ runGet getInt32be bs 170 | 171 | instance PGType Integer where 172 | decodePGType bs = return $ fromIntegral $ runGet getInt64be bs 173 | 174 | getTupleWord64 :: Get (Word64, Word64) 175 | getTupleWord64 = do 176 | firstWord64 <- getWord64be 177 | secondWord64 <- getWord64be 178 | _ <- getWord8 -- 1 byte unconsume for flag 179 | return (firstWord64,secondWord64) 180 | 181 | getDate :: Get (Integer, Integer) 182 | getDate = do 183 | totalSeconds <- get :: Get Int64 184 | let relDays = (totalSeconds `div` 86400000000) + 51544 185 | let relSeconds = (totalSeconds `mod` 86400000000) `div` 1000000 186 | return (fromIntegral relDays, fromIntegral relSeconds) 187 | 188 | 189 | instance PGType UTCTime where 190 | decodePGType bs = return $ UTCTime (ModifiedJulianDay relDays) (secondsToDiffTime relSeconds) 191 | where (relDays, relSeconds) = runGet getDate bs 192 | 193 | instance PGType Float where 194 | decodePGType bs = return $ runGet getFloatbe bs 195 | -------------------------------------------------------------------------------- /src/Form.hs: -------------------------------------------------------------------------------- 1 | module Form where 2 | 3 | import Protolude 4 | 5 | import Servant.Multipart 6 | 7 | 8 | -- | Lookup a textual input with the given @name@ attribute. 9 | lookupInputs :: Text -> MultipartData tag -> Maybe [Text] 10 | lookupInputs iname = Just . fmap iValue . filter ((==iname) . iName) . inputs 11 | 12 | 13 | data UserLoginForm = UserLoginForm { 14 | userLoginFormEmail :: Text 15 | , userLoginFormPassword :: Text 16 | } deriving (Show) 17 | instance FromMultipart Mem UserLoginForm where 18 | fromMultipart multipartData = 19 | UserLoginForm <$> lookupInput "email" multipartData 20 | <*> lookupInput "password" multipartData 21 | 22 | data RegisterForm = RegisterForm { 23 | registerFormEmail :: Text 24 | , registerFormPassword :: Text 25 | } deriving (Show) 26 | instance FromMultipart Mem RegisterForm where 27 | fromMultipart multipartData = 28 | RegisterForm <$> lookupInput "email" multipartData 29 | <*> lookupInput "password" multipartData 30 | 31 | data UserUpdateForm = UserUpdateForm { 32 | userUpdateFormEmail :: Text 33 | , userUpdateFormUsername :: Text 34 | , userUpdateFormPassword :: Text 35 | , userUpdateFormNewPassword :: Text 36 | } deriving (Show) 37 | instance FromMultipart Mem UserUpdateForm where 38 | fromMultipart multipartData = 39 | UserUpdateForm <$> lookupInput "email" multipartData 40 | <*> lookupInput "username" multipartData 41 | <*> lookupInput "password" multipartData 42 | <*> lookupInput "new-password" multipartData 43 | 44 | data FlashCardForm = FlashCardForm { 45 | flashCardFormId :: Text 46 | , flashCardFormRecto :: Text 47 | , flashCardFormTags :: [Text] 48 | , flashCardFormVerso :: Text 49 | } deriving (Show) 50 | instance FromMultipart Mem FlashCardForm where 51 | fromMultipart multipartData = 52 | FlashCardForm <$> lookupInput "id" multipartData 53 | <*> lookupInput "recto" multipartData 54 | <*> lookupInputs "tag" multipartData 55 | <*> lookupInput "verso" multipartData 56 | 57 | data SearchForm = SearchForm { 58 | searchFormText :: Text 59 | } deriving (Show) 60 | instance FromMultipart Mem SearchForm where 61 | fromMultipart multipartData = 62 | SearchForm <$> lookupInput "search-text" multipartData 63 | 64 | data QuizzForm = QuizzForm { 65 | quizzFormId :: Text 66 | , quizzFormRecto :: Maybe Text 67 | , quizzFormVerso :: Maybe Text 68 | } deriving (Show) 69 | instance FromMultipart Mem QuizzForm where 70 | fromMultipart multipartData = 71 | QuizzForm <$> lookupInput "id" multipartData 72 | <*> Just (lookupInput "recto" multipartData) 73 | <*> Just (lookupInput "verso" multipartData) 74 | -------------------------------------------------------------------------------- /src/HandlerM.hs: -------------------------------------------------------------------------------- 1 | module HandlerM where 2 | 3 | import Control.Monad.Trans.Reader (runReaderT, ReaderT) 4 | import Control.Monad.Logger 5 | import SharedEnv 6 | import Servant 7 | 8 | 9 | -- hoistServer :: HasServer api '[] => Proxy api -> (forall x. m x -> n x) -> ServerT api m -> ServerT api n 10 | -- ^^^^^^^^^^^^^^^^^^^^^^ 11 | nt :: SharedEnv -> HandlerM a -> Handler a 12 | -- runReaderT :: conf -> m a 13 | nt c x = runStderrLoggingT (runReaderT x c) 14 | 15 | -- newtype ReaderT conf m a 16 | type HandlerM = ReaderT SharedEnv (LoggingT Handler) 17 | -------------------------------------------------------------------------------- /src/Mustache.hs: -------------------------------------------------------------------------------- 1 | module Mustache where 2 | 3 | import Protolude 4 | 5 | import Text.Mustache 6 | import Text.Mustache.Types 7 | import qualified Data.Vector as V 8 | import Data 9 | 10 | 11 | 12 | newtype MessageMustache = MessageMustache Text 13 | instance ToMustache MessageMustache where 14 | toMustache (MessageMustache messageText) = object 15 | [ "message" ~> (String $ messageText) 16 | ] 17 | 18 | newtype FlashCardTagMustache = FlashCardTagMustache Text 19 | instance ToMustache FlashCardTagMustache where 20 | toMustache (FlashCardTagMustache tag) = object 21 | [ "tag" ~> (String tag) ] 22 | 23 | newtype FlashCardMustache = FlashCardMustache FlashCard 24 | instance ToMustache FlashCardMustache where 25 | toMustache (FlashCardMustache flashCard@FlashCard{}) = object 26 | [ "id" ~> (Number . fromInteger $ flashCardId flashCard) 27 | , "recto" ~> (String $ flashCardRecto flashCard) 28 | , "recto-value" ~> (String $ (if (flashCardSide flashCard) == "recto" then (flashCardRecto flashCard) else "")) 29 | , "recto-disabled" ~> (String $ (if (flashCardSide flashCard) == "recto" then "disabled" else "")) 30 | , "verso" ~> (String $ flashCardVerso flashCard) 31 | , "verso-value" ~> (String $ (if (flashCardSide flashCard) == "verso" then (flashCardVerso flashCard) else "")) 32 | , "verso-disabled" ~> (String $ (if (flashCardSide flashCard) == "verso" then "disabled" else "")) 33 | , "tags" ~> (V.fromList (toMustache . FlashCardTagMustache <$> flashCardTags flashCard)) 34 | ] 35 | 36 | newtype UserMustache = UserMustache User 37 | instance ToMustache UserMustache where 38 | toMustache (UserMustache user@User{}) = object 39 | [ "username" ~> (String $ fromMaybe "" (userUsername user)) 40 | , "email" ~> (String $ userEmail user) 41 | ] 42 | -------------------------------------------------------------------------------- /src/Queries.sql: -------------------------------------------------------------------------------- 1 | -- name:updateFullUser :: User 2 | -- :user :: User 3 | -- :fullUser :: FullUser 4 | UPDATE 5 | users 6 | SET 7 | email = :fullUser.fullUserEmail 8 | , languages = :fullUser.fullUserLanguages 9 | WHERE 10 | users.id = :user.userId 11 | RETURNING 12 | id 13 | , username 14 | , email 15 | , languages 16 | ;;; 17 | -- name:insertUser :: (String, String) 18 | -- :user :: NewUser 19 | INSERT INTO 20 | users 21 | (username, passpass, email, languages) 22 | VALUES 23 | (:user.newuserUsername, :user.newuserPassword, :user.newuserEmail, :user.newuserLanguages) 24 | RETURNING 25 | id 26 | , username 27 | ;;; 28 | -- name:getNewToken :: (String) 29 | INSERT INTO 30 | token 31 | (token) 32 | VALUES 33 | (uuid_generate_v4()) 34 | RETURNING 35 | token 36 | ;;; 37 | -- name:verifyToken :: (Bool) 38 | -- :uuid :: String 39 | SELECT 40 | created_at > (now() - INTERVAL '5 minutes') 41 | FROM 42 | token 43 | WHERE 44 | token = :uuid 45 | ;;; 46 | -- name:getSessionJWT :: (String) 47 | -- :username :: String 48 | -- :pass :: String 49 | SELECT auth_login(:username, :pass) 50 | ;;; 51 | -- name:verifyJWT :: User 52 | -- :jwt :: String 53 | WITH user_id AS ( 54 | SELECT auth_jwt_decode(:jwt) AS user_id 55 | ) 56 | SELECT 57 | id 58 | , username 59 | , email 60 | , languages 61 | FROM 62 | users 63 | JOIN user_id 64 | ON users.id = user_id.user_id 65 | ;;; 66 | -- name:updatePassword :: User 67 | -- :user :: User 68 | -- :password :: String 69 | UPDATE 70 | users 71 | SET 72 | passpass = :password 73 | WHERE 74 | users.id = :user.userId 75 | RETURNING 76 | id 77 | , username 78 | , email 79 | , languages 80 | ;;; 81 | -- name:getUser :: (Int, String) 82 | -- :userName :: String 83 | -- :userPassword :: String 84 | SELECT 85 | id, username 86 | FROM 87 | users 88 | WHERE 89 | username = :userName 90 | AND passpass = crypt(:userPassword, passpass) 91 | ;;; 92 | -- name:getUserById :: (Int, String) 93 | -- :userName :: String 94 | SELECT 95 | id, username 96 | FROM 97 | users 98 | WHERE 99 | username = :userName 100 | ;;; 101 | -- name:getAllWords :: [Word] 102 | -- :user :: User 103 | SELECT 104 | id, language, word, definition, keywords, difficulty 105 | FROM 106 | words 107 | WHERE 108 | userid = :user.userId 109 | ;;; 110 | -- name:getQuizzWordsLang :: [Word] 111 | -- :user :: User 112 | -- :lang :: String 113 | WITH possible_words AS ( 114 | SELECT 115 | id 116 | FROM 117 | words 118 | WHERE 119 | userid = :user.userId AND 120 | language = :lang 121 | ORDER BY 122 | get_word_score(last_query_at, difficulty) DESC 123 | LIMIT 124 | 100 125 | ) 126 | SELECT 127 | w.id, w.language, w.word, w.definition, w.keywords, w.difficulty 128 | FROM 129 | possible_words p join words w ON p.id = w.id 130 | ORDER BY 131 | random() 132 | LIMIT 133 | 5 134 | ;;; 135 | -- name:getQuizzResponse :: (Bool) 136 | -- :wordId :: WordId 137 | -- :testResponse :: String 138 | SELECT * FROM verify_word_full(:wordId, :testResponse); 139 | ;;; 140 | -- name:getLastWords :: [Word] 141 | -- :user :: User 142 | SELECT 143 | id, language, word, definition, keywords, difficulty 144 | FROM 145 | words 146 | WHERE 147 | userid = :user.userId 148 | ORDER BY 149 | inserted_at DESC 150 | LIMIT 20 151 | ;;; 152 | -- name:getWordsByKeyword :: [Word] 153 | -- :user :: User 154 | -- :keyword :: String 155 | SELECT 156 | id, language, word, definition, keywords, difficulty 157 | FROM 158 | words 159 | WHERE 160 | userid = :user.userId AND 161 | :keyword = ANY ( keywords ) 162 | LIMIT 20 163 | ;;; 164 | -- name:getAllKeywords :: [(String)] 165 | -- :user :: User 166 | SELECT 167 | DISTINCT ( UNNEST ( keywords ) ) 168 | FROM 169 | words 170 | WHERE 171 | userid = :user.userId 172 | ;;; 173 | -- name:getSearchWords :: [Word] 174 | -- :user :: User 175 | -- :searchWord :: String 176 | SELECT 177 | id, language, word, definition, keywords, difficulty 178 | FROM 179 | words 180 | WHERE 181 | userid = :user.userId AND 182 | word LIKE '%' || :searchWord || '%' 183 | LIMIT 184 | 20 185 | ;;; 186 | -- name:getSearchWordsUser :: [Word] 187 | -- :user :: User 188 | SELECT 189 | id, language, word, definition, keywords, difficulty 190 | FROM 191 | words 192 | WHERE 193 | userid = :user.userId 194 | ORDER BY 195 | id DESC 196 | LIMIT 197 | 20 198 | ;;; 199 | -- name:getSearchKeyword :: [Word] 200 | -- :user :: User 201 | -- :keyword :: String 202 | SELECT 203 | id, language, word, definition, keywords, difficulty 204 | FROM 205 | words 206 | WHERE 207 | userid = :user.userId AND 208 | :keyword = ANY (keywords) 209 | LIMIT 210 | 20 211 | ;;; 212 | -- name:getSearchWordsKeyword :: [Word] 213 | -- :user :: User 214 | -- :searchWord :: String 215 | -- :keyword :: String 216 | SELECT 217 | id, language, word, definition, keywords, difficulty 218 | FROM 219 | words 220 | WHERE 221 | userid = :user.userId AND 222 | word LIKE '%' || :searchWord || '%' AND 223 | :keyword = ANY (keywords) 224 | LIMIT 225 | 20 226 | ;;; 227 | -- name:getWordById :: Word 228 | -- :user :: User 229 | -- :wordId :: WordId 230 | SELECT 231 | id, language, word, definition, keywords, difficulty 232 | FROM 233 | words 234 | WHERE 235 | id = :wordId 236 | AND userid = :user.userId 237 | ;;; 238 | -- name:updateWordById :: Word 239 | -- :user :: User 240 | -- :wordId :: WordId 241 | -- :newWord :: Word 242 | UPDATE 243 | words 244 | SET 245 | "language" = :newWord.language 246 | , "word" = :newWord.word 247 | , "definition" = :newWord.definition 248 | , "keywords" = :newWord.keywords 249 | , "difficulty" = :newWord.difficulty 250 | WHERE 251 | "id" = :wordId 252 | AND "userid" = :user.userId 253 | RETURNING 254 | "id" 255 | , "language" 256 | , "word" 257 | , "definition" 258 | , "keywords" 259 | , "difficulty" 260 | ;;; 261 | -- name:insertWord :: (Integer) 262 | -- :user :: User 263 | -- :newWord :: Word 264 | INSERT INTO 265 | words 266 | (userid, language, word, keywords, definition) 267 | VALUES 268 | (:user.userId, :newWord.language, :newWord.word, :newWord.keywords, :newWord.definition) 269 | ;;; 270 | -- name:deleteWordById :: (Integer) 271 | -- :user :: User 272 | -- :wordId :: Int 273 | DELETE 274 | FROM 275 | words 276 | WHERE 277 | id = :wordId 278 | AND userid = :user.userId 279 | ;;;; 280 | -- find similar words: 281 | -- SELECT 282 | -- w1.word, w2.word, levenshtein(w1.word, w2.word) 283 | -- FROM 284 | -- words w1, 285 | -- words w2 286 | -- WHERE 287 | -- w1.userid = 1 288 | -- AND w2.userid = 1 289 | -- AND w1.id != w2.id 290 | -- AND w1.word = 'to grate' 291 | -- AND levenshtein(w1.word, w2.word) < 3 292 | -- ; 293 | -------------------------------------------------------------------------------- /src/Server.hs: -------------------------------------------------------------------------------- 1 | module Server where 2 | 3 | import Protolude 4 | import Control.Monad.Logger 5 | import Network.HTTP.Media ((//)) 6 | import Network.Wai 7 | import Network.Wai.Handler.Warp ( run ) 8 | import Network.Wai.Middleware.RequestLogger 9 | ( logStdoutDev ) 10 | 11 | import Servant 12 | import qualified Data.Vector as V 13 | import qualified Data.ByteString.Base64 as BS64 14 | import Servant.Multipart 15 | import Text.Read hiding (String) 16 | import Data.Text (unpack) 17 | import Data.Byteable 18 | import Mustache 19 | import Crypto.Hash 20 | import Data.List ((!!)) 21 | import HandlerM 22 | import SharedEnv 23 | import Text.Mustache.Types 24 | import qualified Data.Aeson as A 25 | import qualified Data.HashMap.Strict as HM 26 | import qualified Data.ByteString.Lazy as BSL 27 | import Servant.HTML.Blaze 28 | import Text.Blaze.Html5 as H 29 | ( Html ) 30 | import Data.Settings 31 | import Database.PostgreSQL.LibPQ hiding (status) 32 | import Database.Queries 33 | import API.Facebook 34 | import Template 35 | import Utils 36 | import Cache 37 | import Data 38 | import Css 39 | import Form 40 | import Auth 41 | 42 | data OctetStreamFavico 43 | 44 | instance Accept OctetStreamFavico where 45 | contentType _ = "image" // "x-icon" 46 | 47 | instance MimeRender OctetStreamFavico ByteString where 48 | mimeRender _ = BSL.fromStrict 49 | 50 | type API = "static" :> Raw 51 | :<|> AuthProtect "custom-auth" :> FrontAPI 52 | 53 | server :: ServerT API HandlerM 54 | server = 55 | staticServer 56 | :<|> frontServer 57 | where 58 | staticServer = serveDirectoryFileServer "www" 59 | 60 | 61 | type FrontAPI = Get '[HTML] H.Html 62 | :<|> "register" :> Get '[HTML] H.Html 63 | :<|> "register" :> MultipartForm Mem RegisterForm :> Post '[HTML] H.Html 64 | :<|> "logout" :> Post '[HTML] H.Html 65 | :<|> "login" :> Get '[HTML] H.Html 66 | :<|> "login" :> MultipartForm Mem UserLoginForm :> Post '[HTML] H.Html 67 | :<|> "login" :> "facebook" :> QueryParam "code" Text :> QueryParam "state" Text :> QueryParam "error" Text :> QueryParam "error_code" Integer :> QueryParam "error_description" Text :> Get '[HTML] H.Html 68 | :<|> "account" :> Get '[HTML] H.Html 69 | :<|> "account" :> MultipartForm Mem UserUpdateForm :> Post '[HTML] H.Html 70 | :<|> "dashboard" :> Get '[HTML] H.Html 71 | :<|> "dashboard" :> MultipartForm Mem SearchForm :> Post '[HTML] H.Html 72 | :<|> "flashcard" :> "add" :> Get '[HTML] H.Html 73 | :<|> "flashcard" :> "add" :> MultipartForm Mem FlashCardForm :> Post '[HTML] H.Html 74 | :<|> "flashcard" :> "edit" :> Capture "flashCardId" Integer :> Get '[HTML] H.Html 75 | :<|> "flashcard" :> "edit" :> Capture "flashCardId" Integer :> MultipartForm Mem FlashCardForm :> Post '[HTML] H.Html 76 | :<|> "flashcard" :> "delete" :> Capture "flashCardId" Integer :> Get '[HTML] H.Html 77 | :<|> "quizz" :> Get '[HTML] H.Html 78 | :<|> "quizz" :> "finish" :> Get '[HTML] H.Html 79 | :<|> "quizz" :> "answer" :> Capture "flashCardId" Integer :> Get '[HTML] H.Html 80 | :<|> "quizz" :> MultipartForm Mem QuizzForm :> Post '[HTML] H.Html 81 | :<|> "favicon.ico" :> Get '[OctetStreamFavico] ByteString 82 | :<|> "sitemap.xml" :> Get '[PlainText] Text 83 | :<|> "robots.txt" :> Get '[PlainText] Text 84 | 85 | 86 | 87 | frontServer :: Session -> ServerT FrontAPI HandlerM 88 | frontServer session = 89 | getHomePage 90 | :<|> getRegisterPage [] 91 | :<|> postRegisterPage 92 | :<|> postLogoutPage 93 | :<|> getLoginPage [] 94 | :<|> postLoginPage 95 | :<|> loginFacebookCallback 96 | :<|> getAccountPage [] 97 | :<|> postAccountPage 98 | :<|> getDashboardPage [] Nothing 99 | :<|> postDashboardSearchPage 100 | :<|> getFlashCardAddPage [] 101 | :<|> postFlashCardAddPage 102 | :<|> getFlashCardEditPage [] 103 | :<|> postFlashCardEditPage 104 | :<|> getFlashCardDeletePage 105 | :<|> getQuizzPage [] 106 | :<|> getQuizzFinishPage 107 | :<|> getQuizzAnswerPage [] 108 | :<|> postQuizzPage 109 | :<|> faviconIco 110 | :<|> sitemapXml 111 | :<|> robotsTxt 112 | 113 | where 114 | getHomePage :: HandlerM H.Html 115 | getHomePage = do 116 | css <- izidictCSSText 117 | facebookUrlLogin' <- facebookUrlLogin 118 | baseUrl' <- baseUrl 119 | let frontEndVariables = A.Object $ HM.fromList [ 120 | ("session", A.toJSON session) 121 | ] 122 | 123 | let frontContext = Object $ HM.fromList [ 124 | ("css", String $ css) 125 | , ("frontEndVariables", String . decodeUtf8 . BSL.toStrict . A.encode $ frontEndVariables) 126 | , ("facebookLoginUrl", String facebookUrlLogin') 127 | , ("base_url", String baseUrl') 128 | ] 129 | $(logInfo) ("homepage" ::Text) 130 | template <- compileTemplate "home.html" 131 | preEscapedToMarkupSubstituteTemplate template frontContext 132 | 133 | getRegisterPage :: [Message] -> HandlerM H.Html 134 | getRegisterPage messages = do 135 | css <- izidictCSSText 136 | facebookUrlLogin' <- facebookUrlLogin 137 | baseUrl' <- baseUrl 138 | let frontEndVariables = A.Object $ HM.fromList [ 139 | ("session", A.toJSON session) 140 | ] 141 | 142 | let frontContext = Object $ HM.fromList [ 143 | ("css", String $ css) 144 | , ("frontEndVariables", String . decodeUtf8 . BSL.toStrict . A.encode $ frontEndVariables) 145 | , ("messages", Array . V.fromList $ map (toMustache . MessageMustache . description) messages) 146 | , ("facebookLoginUrl", String facebookUrlLogin') 147 | , ("base_url", String baseUrl') 148 | ] 149 | $(logInfo) ("homepage" ::Text) 150 | template <- compileTemplate "register.html" 151 | preEscapedToMarkupSubstituteTemplate template frontContext 152 | 153 | postRegisterPage :: RegisterForm -> HandlerM H.Html 154 | postRegisterPage form' = do 155 | eitherUserInserted <- runSqlFile 156 | "sql/registerUser.sql" 157 | [ Just (Oid 25, encodeUtf8 . registerFormEmail $ form', Binary) 158 | , Just (Oid 25, encodeUtf8 . registerFormPassword $ form', Binary) 159 | ] :: HandlerM (Either ExceptionPostgreSQL [User]) 160 | 161 | case eitherUserInserted of 162 | Left pgErr -> do 163 | case pgErr of 164 | ExceptionPGUniqueViolation -> do 165 | $(logInfo) ("User already in database") 166 | getRegisterPage [(Message "User already registered")] 167 | _ -> do 168 | $(logInfo) ("Unknown PG Exception: " <> (show pgErr) :: Text) 169 | throwError $ err302 { 170 | errHeaders = [ 171 | ("Location", "/login") 172 | ] 173 | } 174 | Right userInserted' -> do 175 | -- Send a welcoming email if new user 176 | $(logInfo) ("log: " <> (show userInserted') :: Text) 177 | $(logInfo) ("Need to send a welcoming email to the user") 178 | $(logInfo) ("Inserting the 10 default general culture flashcard for this user") 179 | _ <- runSqlFile' 180 | "sql/insertDefaultFlashCards.sql" 181 | [ Just (Oid 25, show . userId $ (userInserted'!!0), Text) 182 | ] :: HandlerM [Integer] 183 | throwError $ err302 { 184 | errHeaders = [ 185 | ("Location", "/login") 186 | ] 187 | } 188 | 189 | postLogoutPage :: HandlerM H.Html 190 | postLogoutPage = do 191 | throwError $ err302 { 192 | errHeaders = [ 193 | ("Location", "/") 194 | , ("Set-Cookie", "jwt=deleted; path=/; expires=Thu, 01 Jan 1970 00:00:00 GMT") 195 | ] 196 | } 197 | 198 | getLoginPage :: [Message] -> HandlerM H.Html 199 | getLoginPage messages = do 200 | css <- izidictCSSText 201 | baseUrl' <- baseUrl 202 | let frontEndVariables = A.Object $ HM.fromList [ 203 | ("session", A.toJSON session) 204 | ] 205 | 206 | let frontContext = Object $ HM.fromList [ 207 | ("css", String $ css) 208 | , ("messages", Array . V.fromList $ map (toMustache . MessageMustache . description) messages) 209 | , ("frontEndVariables", String . decodeUtf8 . BSL.toStrict . A.encode $ frontEndVariables) 210 | , ("base_url", String baseUrl') 211 | ] 212 | template <- compileTemplate "login.html" 213 | preEscapedToMarkupSubstituteTemplate template frontContext 214 | 215 | postLoginPage :: UserLoginForm -> HandlerM H.Html 216 | postLoginPage form = do 217 | jwtSecrets <- runSqlFile' 218 | "sql/getNewRandomSession.sql" 219 | [ Just (Oid 25, encodeUtf8 . userLoginFormEmail $ form, Text) 220 | , Just (Oid 25, encodeUtf8 . userLoginFormPassword $ form, Text) 221 | ] :: HandlerM [Text] 222 | 223 | if length jwtSecrets > 0 224 | then do 225 | let jwtHeader = BS64.encode $ "{\"alg\": \"HS256\", \"typ\": \"JWT\"}" 226 | let jwtPayload = BS64.encode $ "{\"email\": \"" <> (encodeUtf8 . userLoginFormEmail $ form) <> "\"}" 227 | let jwtSignature = BS64.encode $ toBytes $ hmacAlg SHA256 (encodeUtf8 $ jwtSecrets!!0) (jwtHeader <> "." <> jwtPayload) 228 | 229 | let jwt = jwtHeader <> "." <> jwtPayload <> "." <> jwtSignature 230 | 231 | throwError $ err302 { 232 | errHeaders = [ 233 | ("Location", "/dashboard") 234 | , ("Set-Cookie", "jwt=" <> jwt <> "; path=/; expires=Thu, 01 Jan 2200 00:00:00 GMT") 235 | ] 236 | } 237 | else getLoginPage [Message "Wrong credentials"] 238 | 239 | getAccountPage :: [Message] -> HandlerM H.Html 240 | getAccountPage messages = do 241 | loggedInOr302 session 242 | css <- izidictCSSText 243 | baseUrl' <- baseUrl 244 | let frontEndVariables = A.Object $ HM.fromList [ 245 | ("session", A.toJSON session) 246 | ] 247 | 248 | let frontContext = Object $ HM.fromList [ 249 | ("css", String $ css) 250 | , ("account", (toMustache . UserMustache . sessionUser $ session)) 251 | , ("messages", Array . V.fromList $ map (toMustache . MessageMustache . description) messages) 252 | , ("frontEndVariables", String . decodeUtf8 . BSL.toStrict . A.encode $ frontEndVariables) 253 | , ("base_url", String baseUrl') 254 | ] 255 | template <- compileTemplate "account.html" 256 | preEscapedToMarkupSubstituteTemplate template frontContext 257 | 258 | postAccountPage :: UserUpdateForm -> HandlerM H.Html 259 | postAccountPage form' = do 260 | loggedInOr302 session 261 | $(logInfo) ("log: " <> (show form') :: Text) 262 | -- check password 263 | passwordChecked <- runSqlFile' 264 | "sql/checkPassword.sql" 265 | [ Just (Oid 25, show . userEmail . sessionUser $ session, Text) -- User Email 266 | , Just (Oid 25, encodeUtf8 . userUpdateFormPassword $ form', Text) -- Password 267 | ] :: HandlerM [Integer] 268 | _ <- if length passwordChecked > 1 269 | then return mempty 270 | else getAccountPage [(Message "Wrong credentials")] 271 | 272 | -- update password 273 | _ <- runSqlFile' 274 | "sql/updatePassword.sql" 275 | [ Just (Oid 25, encodeUtf8 . userEmail . sessionUser $ session, Text) -- User Email 276 | , Just (Oid 25, encodeUtf8 . userUpdateFormNewPassword $ form', Text) -- Password 277 | ] :: HandlerM [Integer] 278 | 279 | throwError $ err302 { 280 | errHeaders = [ 281 | ("Location", "/account") 282 | ] 283 | } 284 | 285 | getDashboardPage :: [Message] -> Maybe Text -> HandlerM H.Html 286 | getDashboardPage messages mSearchText = do 287 | loggedInOr302 session 288 | flashcards <- case mSearchText of 289 | Just searchText -> runSqlFile' 290 | "sql/searchFlashCards.sql" 291 | [ Just (Oid 25, show . userId . sessionUser $ session, Text) -- User ID 292 | , Just (Oid 25, encodeUtf8 searchText, Text) 293 | ] :: HandlerM [FlashCard] 294 | Nothing -> runSqlFile' 295 | "sql/getFlashCards.sql" 296 | [ Just (Oid 25, show . userId . sessionUser $ session, Text) -- User ID 297 | ] :: HandlerM [FlashCard] 298 | css <- izidictCSSText 299 | baseUrl' <- baseUrl 300 | let frontEndVariables = A.Object $ HM.fromList [ 301 | ("session", A.toJSON session) 302 | ] 303 | 304 | let frontContext = Object $ HM.fromList [ 305 | ("flashcards", Array . V.fromList $ map (toMustache . FlashCardMustache) flashcards) 306 | , ("css", String $ css) 307 | , ("messages", Array . V.fromList $ map (toMustache . MessageMustache . description) messages) 308 | , ("frontEndVariables", String . decodeUtf8 . BSL.toStrict . A.encode $ frontEndVariables) 309 | , ("base_url", String baseUrl') 310 | ] 311 | template <- compileTemplate "dashboard.html" 312 | preEscapedToMarkupSubstituteTemplate template frontContext 313 | 314 | postDashboardSearchPage :: SearchForm -> HandlerM H.Html 315 | postDashboardSearchPage form' = do 316 | getDashboardPage [] (Just $ searchFormText form') 317 | 318 | getFlashCardAddPage :: [Message] -> HandlerM H.Html 319 | getFlashCardAddPage messages = do 320 | loggedInOr302 session 321 | css <- izidictCSSText 322 | baseUrl' <- baseUrl 323 | let frontEndVariables = A.Object $ HM.fromList [ 324 | ("session", A.toJSON session) 325 | ] 326 | 327 | let frontContext = Object $ HM.fromList [ 328 | ("css", String $ css) 329 | , ("messages", Array . V.fromList $ map (toMustache . MessageMustache . description) messages) 330 | , ("frontEndVariables", String . decodeUtf8 . BSL.toStrict . A.encode $ frontEndVariables) 331 | , ("base_url", String baseUrl') 332 | ] 333 | template <- compileTemplate "flashcard.add.html" 334 | preEscapedToMarkupSubstituteTemplate template frontContext 335 | 336 | postFlashCardAddPage :: FlashCardForm -> HandlerM H.Html 337 | postFlashCardAddPage form' = do 338 | loggedInOr302 session 339 | _ <- runSqlFile' 340 | "sql/addFlashCard.sql" 341 | [ Just (Oid 25, show . userId . sessionUser $ session, Text) -- User Id 342 | , Just (Oid 25, encodeUtf8 . flashCardFormRecto $ form', Text) 343 | , Just (Oid 25, encodeUtf8 $ "{" <> (mconcat . intersperse "," $ flashCardFormTags form') <> "}", Text) 344 | , Just (Oid 25, encodeUtf8 . flashCardFormVerso $ form', Text) 345 | ] :: HandlerM [Integer] 346 | throwError $ err302 { 347 | errHeaders = [ 348 | ("Location", "/dashboard") 349 | ] 350 | } 351 | 352 | getFlashCardEditPage :: [Message] -> Integer -> HandlerM H.Html 353 | getFlashCardEditPage messages flashCardId' = do 354 | loggedInOr302 session 355 | css <- izidictCSSText 356 | baseUrl' <- baseUrl 357 | flashcards <- runSqlFile' 358 | "sql/getFlashCard.sql" 359 | [ Just (Oid 25, show . userId . sessionUser $ session, Text) -- User ID 360 | , Just (Oid 25, show flashCardId', Text) -- FlashCard ID 361 | ] :: HandlerM [FlashCard] 362 | $(logInfo) ("log: " <> (show flashcards) :: Text) 363 | if length flashcards < 1 364 | then 365 | throwError $ err302 { 366 | errHeaders = [ 367 | ("Location", "/") 368 | ] 369 | } 370 | else return () 371 | let frontEndVariables = A.Object $ HM.fromList [ 372 | ("session", A.toJSON session) 373 | ] 374 | 375 | let frontContext = Object $ HM.fromList [ 376 | ("css", String $ css) 377 | , ("flashcard", (toMustache . FlashCardMustache) (flashcards!!0)) 378 | , ("messages", Array . V.fromList $ map (toMustache . MessageMustache . description) messages) 379 | , ("frontEndVariables", String . decodeUtf8 . BSL.toStrict . A.encode $ frontEndVariables) 380 | , ("base_url", String baseUrl') 381 | ] 382 | template <- compileTemplate "flashcard.edit.html" 383 | preEscapedToMarkupSubstituteTemplate template frontContext 384 | 385 | postFlashCardEditPage :: Integer -> FlashCardForm -> HandlerM H.Html 386 | postFlashCardEditPage flashCardId' form' = do 387 | _ <- runSqlFile' 388 | "sql/updateFlashCard.sql" 389 | [ Just (Oid 25, show . userId . sessionUser $ session, Text) -- User Id 390 | , Just (Oid 25, show flashCardId', Text) -- Word Id 391 | , Just (Oid 25, encodeUtf8 . flashCardFormRecto $ form', Text) 392 | , Just (Oid 25, encodeUtf8 $ "{" <> (mconcat . intersperse "," $ flashCardFormTags form') <> "}", Text) 393 | , Just (Oid 25, encodeUtf8 . flashCardFormVerso $ form', Text) 394 | ] :: HandlerM [Integer] 395 | throwError $ err302 { 396 | errHeaders = [ 397 | ("Location", "/dashboard") 398 | ] 399 | } 400 | 401 | getFlashCardDeletePage :: Integer -> HandlerM H.Html 402 | getFlashCardDeletePage flashCardId' = do 403 | loggedInOr302 session 404 | _ <- runSqlFile' 405 | "sql/deleteFlashCard.sql" 406 | [ Just (Oid 25, show . userId . sessionUser $ session, Text) -- User Id 407 | , Just (Oid 25, show flashCardId', Text) -- Word Id 408 | ] :: HandlerM [Integer] 409 | throwError $ err302 { 410 | errHeaders = [ 411 | ("Location", "/dashboard") 412 | ] 413 | } 414 | 415 | getQuizzPage :: [Message] -> HandlerM H.Html 416 | getQuizzPage messages = do 417 | loggedInOr302 session 418 | css <- izidictCSSText 419 | baseUrl' <- baseUrl 420 | flashcards <- runSqlFile' 421 | "sql/getQuizzFlashCard.sql" 422 | [ Just (Oid 25, show . userId . sessionUser $ session, Text) -- User Id 423 | ] :: HandlerM [FlashCard] 424 | 425 | if length flashcards < 1 426 | then throwError $ err302 {errHeaders = [("Location", "/quizz/finish")]} 427 | else return () 428 | 429 | let frontEndVariables = A.Object $ HM.fromList [ 430 | ("session", A.toJSON session) 431 | ] 432 | 433 | let frontContext = Object $ HM.fromList [ 434 | ("css", String $ css) 435 | , ("flashcard", (toMustache . FlashCardMustache) (flashcards!!0)) 436 | , ("messages", Array . V.fromList $ map (toMustache . MessageMustache . description) messages) 437 | , ("frontEndVariables", String . decodeUtf8 . BSL.toStrict . A.encode $ frontEndVariables) 438 | , ("base_url", String baseUrl') 439 | ] 440 | template <- compileTemplate "quizz.html" 441 | preEscapedToMarkupSubstituteTemplate template frontContext 442 | 443 | getQuizzFinishPage :: HandlerM H.Html 444 | getQuizzFinishPage = do 445 | loggedInOr302 session 446 | css <- izidictCSSText 447 | baseUrl' <- baseUrl 448 | let frontEndVariables = A.Object $ HM.fromList [ 449 | ("session", A.toJSON session) 450 | ] 451 | let frontContext = Object $ HM.fromList [ 452 | ("css", String $ css) 453 | , ("frontEndVariables", String . decodeUtf8 . BSL.toStrict . A.encode $ frontEndVariables) 454 | , ("base_url", String baseUrl') 455 | ] 456 | template <- compileTemplate "quizz.finish.html" 457 | preEscapedToMarkupSubstituteTemplate template frontContext 458 | 459 | getQuizzAnswerPage :: [Message] -> Integer -> HandlerM H.Html 460 | getQuizzAnswerPage messages flashCardId' = do 461 | loggedInOr302 session 462 | flashcards <- runSqlFile' 463 | "sql/getFlashCard.sql" 464 | [ Just (Oid 25, show . userId . sessionUser $ session, Text) -- User ID 465 | , Just (Oid 25, show flashCardId', Text) -- FlashCard ID 466 | ] :: HandlerM [FlashCard] 467 | 468 | css <- izidictCSSText 469 | baseUrl' <- baseUrl 470 | let frontEndVariables = A.Object $ HM.fromList [ 471 | ("session", A.toJSON session) 472 | ] 473 | 474 | let frontContext = Object $ HM.fromList [ 475 | ("css", String $ css) 476 | , ("flashcard", (toMustache . FlashCardMustache) (flashcards!!0)) 477 | , ("messages", Array . V.fromList $ map (toMustache . MessageMustache . description) messages) 478 | , ("frontEndVariables", String . decodeUtf8 . BSL.toStrict . A.encode $ frontEndVariables) 479 | , ("base_url", String baseUrl') 480 | ] 481 | 482 | template <- compileTemplate "quizz.answer.html" 483 | preEscapedToMarkupSubstituteTemplate template frontContext 484 | 485 | postQuizzPage :: QuizzForm -> HandlerM H.Html 486 | postQuizzPage form' = do 487 | loggedInOr302 session 488 | 489 | let sqlFile = case quizzFormRecto form' of 490 | Just _ -> "sql/verifyFlashCardRectoAnswer.sql" 491 | Nothing -> "sql/verifyFlashCardVersoAnswer.sql" 492 | -- verify the word 493 | flashCardVerified <- runSqlFile' 494 | sqlFile 495 | [ Just (Oid 25, show . userId . sessionUser $ session, Text) -- User Id 496 | , Just (Oid 25, encodeUtf8 . quizzFormId $ form', Text) -- FlashCard Id 497 | , Just (Oid 25, encodeUtf8 ((fromMaybe "" $ quizzFormRecto form') <> (fromMaybe "" $ quizzFormVerso form')), Text) -- Answer 498 | ] :: HandlerM [Bool] 499 | _ <- if (flashCardVerified!!0) 500 | then do 501 | runSqlFile' 502 | "sql/increaseBucketFlashCard.sql" 503 | [ Just (Oid 25, show . userId . sessionUser $ session, Text) -- User Id 504 | , Just (Oid 25, encodeUtf8 . quizzFormId $ form', Text) -- FlashCard Id 505 | ] :: HandlerM [Integer] 506 | else do 507 | runSqlFile' 508 | "sql/decreaseBucketFlashCard.sql" 509 | [ Just (Oid 25, show . userId . sessionUser $ session, Text) -- User Id 510 | , Just (Oid 25, encodeUtf8 . quizzFormId $ form', Text) -- FlashCard Id 511 | ] :: HandlerM [Integer] 512 | 513 | getQuizzAnswerPage [(Message (if (flashCardVerified!!0) then "Right answer :)" else "Wrong answer :("))] (read . unpack . quizzFormId $ form' :: Integer) 514 | 515 | faviconIco :: HandlerM ByteString 516 | faviconIco = do 517 | fileBS <- readCacheOrFileBS "www/favicon.ico" 518 | return $ fileBS 519 | 520 | sitemapXml :: HandlerM Text 521 | sitemapXml = do 522 | baseUrl' <- baseUrl 523 | let frontContext = Object $ HM.fromList [ 524 | ("base_url", String baseUrl') 525 | ] 526 | 527 | template <- compileTemplate "sitemap.xml" 528 | return $ substituteTemplate template frontContext 529 | 530 | robotsTxt :: HandlerM Text 531 | robotsTxt = do 532 | baseUrl' <- baseUrl 533 | let frontContext = Object $ HM.fromList [ 534 | ("base_url", String baseUrl') 535 | ] 536 | 537 | template <- compileTemplate "robots.txt" 538 | return $ substituteTemplate template frontContext 539 | 540 | 541 | loginFacebookCallback :: Maybe Text -> Maybe Text -> Maybe Text -> Maybe Integer -> Maybe Text -> HandlerM H.Html 542 | loginFacebookCallback mCode _ _ _ _ = do 543 | code <- case mCode of 544 | Nothing -> do 545 | $(logInfo) "didnt receive the code & state" 546 | throwError $ err302 {errHeaders = [("Location", "/")]} 547 | Just code' -> return code' 548 | 549 | sharedEnv <- ask 550 | let facebookAppId = facebook_appid . settings $ sharedEnv 551 | let facebookRedirectUri = (base_url . settings $ sharedEnv) <> "/login/facebook" 552 | let facebookAppSecret = facebook_appsecret . settings $ sharedEnv 553 | let facebookAppToken = facebook_apptoken . settings $ sharedEnv 554 | 555 | fbAccessToken <- getFacebookAccessToken facebookAppId facebookAppSecret facebookRedirectUri code 556 | 557 | fbToken <- getFacebookToken facebookAppToken fbAccessToken 558 | 559 | let userId' = user_id fbToken 560 | 561 | fbPermissions <- getFacebookPermissionList facebookAppToken userId' 562 | 563 | let nbDeclinedPermissions = length $ filter (\p -> (status p) == "declined") (fBPermissionList fbPermissions) 564 | 565 | if nbDeclinedPermissions > 0 566 | then do 567 | $(logInfo) ("Some Facebook permission were rejected, need to re-ask" :: Text) 568 | let facebookClientId = facebook_appid . settings $ sharedEnv 569 | throwError $ err302 {errHeaders = [("Location", encodeUtf8 $ "https://www.facebook.com/v3.2/dialog/oauth?client_id=" <> facebookClientId <> "&redirect_uri=" <> facebookRedirectUri <> "&auth_type=rerequest&scope=public_profile,email")]} 570 | else return () 571 | 572 | -- Retrieving email address + personnal information 573 | fbUser <- getFacebookUser fbAccessToken userId' 574 | randomPassword <- liftIO $ generateRandomPassword 575 | 576 | -- Create a new account 577 | eitherNBUserInserted <- runSqlFile 578 | "sql/insertUser.sql" 579 | [ Just (Oid 25, encodeUtf8 . first_name $ fbUser, Text) 580 | , Just (Oid 25, encodeUtf8 . last_name $ fbUser, Binary) 581 | , Just (Oid 25, encodeUtf8 . email $ fbUser, Binary) 582 | , Just (Oid 25, encodeUtf8 randomPassword, Binary)] 583 | :: HandlerM (Either ExceptionPostgreSQL [User]) 584 | 585 | $(logInfo) ("either nb user inserted: " <> (show eitherNBUserInserted) :: Text) 586 | 587 | case eitherNBUserInserted of 588 | Right userInserted' -> do 589 | let userInserted = userInserted'!!0 590 | -- Send a welcoming email if new user 591 | $(logInfo) ("Need to send a welcoming email to the user " <> (show userInserted) :: Text) 592 | -- Insert the default FlashCards 593 | _ <- runSqlFile' 594 | "sql/insertDefaultFlashCards.sql" 595 | [ Just (Oid 25, show . userId $ userInserted, Text) 596 | ] :: HandlerM [Integer] 597 | return () 598 | Left pgErr -> do 599 | case pgErr of 600 | ExceptionPGUniqueViolation -> $(logInfo) ("User already in database") 601 | _ -> $(logInfo) ("Unknown PG Exception: " <> (show pgErr) :: Text) 602 | 603 | jwtSecrets <- runSqlFile' 604 | "sql/getNewRandomSessionWithoutPasswordCheck.sql" 605 | [ Just (Oid 25, encodeUtf8 . email $ fbUser, Text) 606 | ] :: HandlerM [Text] 607 | 608 | let jwtHeader = BS64.encode $ "{\"alg\": \"HS256\", \"typ\": \"JWT\"}" 609 | let jwtPayload = BS64.encode $ "{\"email\": \"" <> (encodeUtf8 . email $ fbUser) <> "\"}" 610 | 611 | let jwtSignature = BS64.encode $ toBytes $ hmacAlg SHA256 (encodeUtf8 $ jwtSecrets!!0) (jwtHeader <> "." <> jwtPayload) 612 | 613 | let jwt = jwtHeader <> "." <> jwtPayload <> "." <> jwtSignature 614 | 615 | throwError $ err302 { 616 | errHeaders = [ 617 | ("Location", "/dashboard") 618 | , ("Set-Cookie", "jwt=" <> jwt <> "; path=/; expires=Thu, 01 Jan 2200 00:00:00 GMT") 619 | ] 620 | } 621 | 622 | 623 | startApp :: SharedEnv -> IO () 624 | startApp sharedEnv = 625 | run (app_port . settings $ sharedEnv) (logStdoutDev (app sharedEnv) ) 626 | 627 | app :: SharedEnv -> Application 628 | -- serveWithContext :: (HasServer api context) => Proxy api -> Context context -> Server api -> Application 629 | -- hoistServer :: HasServer api '[] => Proxy api -> (forall x. m x -> n x) -> ServerT api m -> ServerT api n 630 | -- hoistServerWithContext :: HasServer api context => Proxy api -> Proxy context -> (forall x . m x -> n x) -> ServerT api m -> ServerT api n 631 | app c = serveWithContext api (authServerContext (dbConnectionPool c)) $ hoistServerWithContext api contextProxy (nt c) server 632 | 633 | api :: Proxy API 634 | api = Proxy 635 | -------------------------------------------------------------------------------- /src/SharedEnv.hs: -------------------------------------------------------------------------------- 1 | module SharedEnv where 2 | 3 | import Protolude 4 | 5 | import qualified Data.Text as T 6 | import qualified Control.Concurrent.STM.TMVar as STMVar 7 | import Data.HashMap.Strict as HM 8 | import Database.PostgreSQL.LibPQ (Connection) 9 | import Database (initConnectionPool) 10 | import Data.Pool ( Pool ) 11 | import Text.Mustache.Types 12 | import Data 13 | 14 | 15 | data SharedEnv = SharedEnv 16 | { settings :: Settings 17 | , cache :: STMVar.TMVar (HashMap Text ByteString) 18 | , cacheTemplate :: STMVar.TMVar (HashMap FilePath Template) 19 | , dbConnectionPool :: Pool Connection 20 | } deriving (Generic) 21 | 22 | 23 | initSharedEnv :: T.Text -> STMVar.TMVar (HashMap Text ByteString) -> STMVar.TMVar TemplateCache -> IO (SharedEnv) 24 | initSharedEnv pathFileCfg tCache tCachetemplate = do 25 | settingsLoaded <- loadSettings pathFileCfg 26 | 27 | -- Setup the DB pools connection 28 | dbConnectionPool' <- initConnectionPool $ "service=" <> (pgservice settingsLoaded) 29 | 30 | return (SharedEnv settingsLoaded tCache tCachetemplate dbConnectionPool') 31 | -------------------------------------------------------------------------------- /src/Template.hs: -------------------------------------------------------------------------------- 1 | module Template where 2 | 3 | import Protolude 4 | 5 | import Data.HashMap.Strict 6 | import Control.Concurrent.STM.TMVar 7 | import Control.Exception 8 | import Text.Mustache 9 | import Text.Blaze.Html 10 | import SharedEnv 11 | import Data.Settings 12 | import HandlerM 13 | 14 | data LCException = TemplateParseException 15 | deriving (Show) 16 | 17 | instance Exception LCException 18 | 19 | compileTemplate' :: FilePath -> IO Template 20 | compileTemplate' templateName = do 21 | let searchSpace = ["src/templates/", "templates/", "emails/"] 22 | compiled <- automaticCompile searchSpace templateName 23 | case compiled of 24 | Left err -> do 25 | putStrLn $ ("TemplateParseException: " <> (show err) :: Text) 26 | throw TemplateParseException 27 | Right template -> return template 28 | 29 | 30 | compileTemplate :: FilePath -> HandlerM Template 31 | compileTemplate templateName = do 32 | sharedEnv <- ask 33 | case production . settings $ sharedEnv of 34 | True -> do 35 | let tCacheTemplate = cacheTemplate sharedEnv 36 | 37 | templateCache' <- liftIO $ atomically $ readTMVar tCacheTemplate 38 | 39 | let mCacheValue = lookup templateName templateCache' 40 | case mCacheValue of 41 | -- if the key exists in the templateCache', return it 42 | Just template -> return template 43 | -- if the template doesnt exists, load and compile the 44 | -- template with the partials, then save it into the 45 | -- cache 46 | Nothing -> do 47 | -- check the cache 48 | template <- liftIO $ compileTemplate' templateName 49 | let newCache = insert templateName template templateCache' 50 | _ <- liftIO $ atomically $ swapTMVar tCacheTemplate newCache 51 | return $ template 52 | False -> liftIO $ compileTemplate' templateName 53 | 54 | 55 | -- substituteTemplate template context = substitute template (object ["ctx" ~= context]) 56 | substituteTemplate :: ToMustache ctx => Template -> ctx -> Text 57 | substituteTemplate template context = substitute template context 58 | 59 | preEscapedToMarkupSubstituteTemplate :: ToMustache ctx => Template -> ctx -> HandlerM Html 60 | preEscapedToMarkupSubstituteTemplate template context = do 61 | return $ preEscapedToMarkup $ substitute template context 62 | -------------------------------------------------------------------------------- /src/Utils.hs: -------------------------------------------------------------------------------- 1 | module Utils where 2 | 3 | import Protolude 4 | 5 | import Data.Text (pack) 6 | import System.Random 7 | import Servant 8 | import HandlerM 9 | import SharedEnv 10 | import Data 11 | 12 | 13 | facebookUrlLogin :: HandlerM Text 14 | facebookUrlLogin = do 15 | sharedEnv <- ask 16 | let facebookState = "CSRF1" 17 | let facebookRedirectUri = (base_url . settings $ sharedEnv ) <> "/login/facebook" 18 | let facebookClientId = facebook_appid . settings $ sharedEnv 19 | return $ "https://www.facebook.com/v3.2/dialog/oauth?response_type=code&client_id=" <> facebookClientId <> "&redirect_uri=" <> facebookRedirectUri <> "&state=" <> facebookState <> "&scope=public_profile,email" 20 | 21 | baseUrl :: HandlerM Text 22 | baseUrl = do 23 | sharedEnv <- ask 24 | return $ base_url . settings $ sharedEnv 25 | 26 | 27 | loggedInOr302 :: Session -> HandlerM () 28 | loggedInOr302 AnonymousSession = do 29 | throwError $ err302 { 30 | errHeaders = [ 31 | ("Location", encodeUtf8 "/") 32 | ] 33 | } 34 | loggedInOr302 _ = return () 35 | 36 | 37 | generateRandomPassword :: IO Text 38 | generateRandomPassword = do 39 | newPassword <- passwordString [] 40 | return $ pack newPassword 41 | where passwordString :: [Char] -> IO [Char] 42 | passwordString fullPassword@[_,_,_,_,_,_,_,_] = return fullPassword 43 | passwordString currPassword = do 44 | newIntR <- getStdRandom (randomR (48, 122)) :: IO Int 45 | if (48 < newIntR && newIntR < 57) || (65 < newIntR && newIntR < 90) || (97 < newIntR && newIntR < 122) 46 | then passwordString (chr(newIntR):currPassword) 47 | else passwordString currPassword 48 | -------------------------------------------------------------------------------- /src/templates/account.html: -------------------------------------------------------------------------------- 1 | 2 | 3 | {{> head.html}} 4 | 5 | 6 | 7 |
8 | {{> header-logo.html}} 9 | 10 |
    11 |
  • 12 | Home 13 |
    • 14 |
15 | 16 | {{> nav.login.html}} 17 |
18 | 19 | {{> nav.fullscreen.html}} 20 | 21 |
22 |
23 |

My account

24 | {{#account}} 25 |
26 | 27 | 28 | 29 |
30 | 31 | 32 |
33 | 34 | 35 |
36 | 37 |
38 | {{/account}} 39 |
40 |
41 | 42 | {{> footer.html}} 43 | 44 | 47 | 48 | 49 | -------------------------------------------------------------------------------- /src/templates/dashboard.html: -------------------------------------------------------------------------------- 1 | 2 | 3 | {{> head.html}} 4 | 5 | 6 | 7 |
8 | {{> header-logo.html}} 9 | 10 |
    11 |
  • 12 | Home 13 |
    • 14 |
15 | 16 | {{> nav.login.html}} 17 |
18 | 19 | {{> nav.fullscreen.html}} 20 | 21 |
22 |
23 |

Your FlashCard dashboard

24 |
25 | 26 |
27 |
28 | Add a flashcard 29 |
30 |
31 | Take a quizz 32 |
33 |

Search a flashcard

34 |
35 | 36 | 37 |
38 | 39 |

My FlashCards

40 | {{#flashcards}} 41 |
42 |
43 | Edit FlashCard 44 | Delete FlashCard 45 |
46 |
47 |

{{recto}}

48 |
49 |
50 |

{{verso}}

51 |
52 |
53 | {{/flashcards}} 54 |
55 |
56 | 57 | {{> footer.html}} 58 | 59 | 62 | 63 | 64 | -------------------------------------------------------------------------------- /src/templates/flashcard.add.html: -------------------------------------------------------------------------------- 1 | 2 | 3 | {{> head.html}} 4 | 5 | 6 | 7 |
8 | {{> header-logo.html}} 9 | 10 |
    11 |
  • 12 | Home 13 |
    • 14 |
15 | 16 | {{> nav.login.html}} 17 |
18 | 19 | {{> nav.fullscreen.html}} 20 | 21 |
22 |
23 |

Add a flashcard

24 |
25 | 26 |
27 | 28 |
29 |
30 |
31 | 32 |
33 |
34 | 35 |
36 |
37 | 38 |
39 |

Tags:

40 | {{#tags}} 41 |
42 | 43 | Delete tag 44 |
45 | {{/tags}} 46 | Add a tag 47 |
48 |
49 |
50 |
51 | 52 | {{> footer.html}} 53 | 54 | 57 | 58 | 59 | -------------------------------------------------------------------------------- /src/templates/flashcard.edit.html: -------------------------------------------------------------------------------- 1 | 2 | 3 | {{> head.html}} 4 | 5 | 6 | 7 |
8 | {{> header-logo.html}} 9 | 10 |
    11 |
  • 12 | Home 13 |
    • 14 |
15 | 16 | {{> nav.login.html}} 17 |
18 | 19 | {{> nav.fullscreen.html}} 20 | 21 |
22 |
23 |

Edit a flashcard

24 | {{#flashcard}} 25 |
26 | 27 |
28 | 29 |
30 |
31 |
32 | 33 |
34 |
35 | 36 |
37 |
38 | 39 |
40 |

Tags:

41 | {{#tags}} 42 |
43 | 44 | Delete tag 45 |
46 | {{/tags}} 47 | Add a tag 48 |
49 |
50 | {{/flashcard}} 51 |
52 |
53 | 54 | {{> footer.html}} 55 | 56 | 59 | 60 | 61 | -------------------------------------------------------------------------------- /src/templates/footer.html: -------------------------------------------------------------------------------- 1 | 24 | -------------------------------------------------------------------------------- /src/templates/head.html: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 | 6 | 7 | 8 | 9 | 10 | 11 | 12 | 13 | 14 | 15 | 16 | 17 | 18 | 19 | 20 | 21 | 22 | 23 | 24 | IziDict - All Your FlashCards Online! 25 | 26 | 27 | -------------------------------------------------------------------------------- /src/templates/header-logo.html: -------------------------------------------------------------------------------- 1 |
2 | 3 | header logo image 4 |

IziDict.com

5 | 6 |
7 | -------------------------------------------------------------------------------- /src/templates/home.html: -------------------------------------------------------------------------------- 1 | 2 | 3 | {{> head.html}} 4 | 5 | 6 | 7 |
8 | {{> header-logo.html}} 9 | 10 |
    11 |
  • 12 | Home 13 |
    • 14 |
15 | 16 | {{> nav.login.html}} 17 |
18 | 19 | {{> nav.fullscreen.html}} 20 | 21 |
22 |
23 |

All your FlashCard - Online!

24 |
25 | 26 |
27 |

Never forget anything!

28 |

FlashCards 29 | are mostly used to consolidate your vocabulary in any languages, 30 | but as this method is generic, you can use it to remember 31 | absolutely anything. Remembering and increasing your general 32 | culture becomes easy.

33 |

Your memory uses a two way binding. You link an idea or word in 34 | two way.

35 |

For instance if you're a video game fan, and I'm asking you what 36 | represents the year 1981, you will probably never guess. But if I'm 37 | asking to you when the character Mario was created, maybe you'll 38 | retrieve the information much faster.

39 |

The method used at IziDict.com 40 | heavily rely on how the memory works.

41 |

You create your FlashCards online (recto and verso), and can 42 | take quizzes about them. If you pass the quizz about a FlashCard, 43 | it will move to a higher bucket of FlashCard, that will be asked to 44 | you later. If you fail, the FlashCard will be moved to a lower 45 | bucket of FlashCard, that will be asked to you sooner.

46 |
47 |
48 |
49 | 50 |
51 |
52 | 53 |
54 |
55 |
56 |

This method has been proven to be very effective for various 57 | subject like:

58 |
    59 |
  • increase your general knowledge
    • 60 |
  • increase your vocabulary
    • 61 |
  • revised for your next test
    • 62 |
  • learn a new language
    • 63 |
  • …
    • 64 |
65 |

Still not convinced? Give it a try or contact us.

66 | 67 |

Bonus: Why this font?

68 |

Sans Forgetica is a downloadable font that is scientifically designed to help you remember your study notes.

69 | 70 |
71 |
72 | 73 | {{> footer.html}} 74 | 75 | 78 | 79 | 80 | -------------------------------------------------------------------------------- /src/templates/login.html: -------------------------------------------------------------------------------- 1 | 2 | 3 | {{> head.html}} 4 | 5 | 6 | 7 |
8 | {{> header-logo.html}} 9 | 10 |
    11 |
  • 12 | Home 13 |
    • 14 |
15 | 16 | {{> nav.login.html}} 17 |
18 | 19 | {{> nav.fullscreen.html}} 20 | 21 |
22 |
23 |

Login

24 | No account? Register here 25 |
    26 | {{#messages}} 27 |
  • {{message}}
    • 28 | {{/messages}} 29 |
30 | 31 |
32 | 33 | 34 |
35 | 36 | 37 |
38 | 39 |
40 |
41 |
42 | 43 | {{> footer.html}} 44 | 45 | 48 | 49 | 50 | -------------------------------------------------------------------------------- /src/templates/nav.fullscreen.html: -------------------------------------------------------------------------------- 1 | 16 | -------------------------------------------------------------------------------- /src/templates/nav.login.html: -------------------------------------------------------------------------------- 1 | 10 | -------------------------------------------------------------------------------- /src/templates/quizz.answer.html: -------------------------------------------------------------------------------- 1 | 2 | 3 | {{> head.html}} 4 | 5 | 6 | 7 | 8 | 9 |
10 | {{> header-logo.html}} 11 | 12 |
    13 |
  • 14 | Home 15 |
    • 16 |
17 | 18 | {{> nav.login.html}} 19 |
20 | 21 | {{> nav.fullscreen.html}} 22 | 23 |
24 |
25 |

Answer

26 |
27 |
    28 | {{#messages}} 29 |
  • {{{message}}}
    • 30 | {{/messages}} 31 |
32 | 33 |
34 | Next? 35 |
36 |
37 | 38 | {{#flashcard}} 39 |
40 |
41 | Edit FlashCard 42 | Delete FlashCard 43 |
44 |
45 |

{{recto}}

46 |
47 |
48 |

{{verso}}

49 |
50 |
51 | {{/flashcard}} 52 |
53 |
54 | 55 | {{> footer.html}} 56 | 57 | 60 | 61 | 62 | -------------------------------------------------------------------------------- /src/templates/quizz.finish.html: -------------------------------------------------------------------------------- 1 | 2 | 3 | {{> head.html}} 4 | 5 | 6 | 7 | 8 | 9 |
10 | {{> header-logo.html}} 11 | 12 |
    13 |
  • 14 | Home 15 |
    • 16 |
17 | 18 | {{> nav.login.html}} 19 |
20 | 21 | {{> nav.fullscreen.html}} 22 | 23 |
24 |
25 |

Congratulation

26 |

You can rest until tomorrow :)

27 |

You don't have anymore FlashCard to do for today.

28 |

See ya!

29 |
30 |
31 | 32 | {{> footer.html}} 33 | 34 | 37 | 38 | 39 | -------------------------------------------------------------------------------- /src/templates/quizz.html: -------------------------------------------------------------------------------- 1 | 2 | 3 | {{> head.html}} 4 | 5 | 6 | 7 |
8 | {{> header-logo.html}} 9 | 10 |
    11 |
  • 12 | Home 13 |
    • 14 |
15 | 16 | {{> nav.login.html}} 17 |
18 | 19 | {{> nav.fullscreen.html}} 20 | 21 |
22 |
23 |

Take a quizz

24 | {{#flashcard}} 25 |
26 | 27 |
28 | 29 |
30 |
31 |
32 | 33 |
34 |
35 | 36 |
37 |
38 |
39 | {{/flashcard}} 40 |
41 |
42 | 43 | {{> footer.html}} 44 | 45 | 48 | 49 | 50 | -------------------------------------------------------------------------------- /src/templates/register.html: -------------------------------------------------------------------------------- 1 | 2 | 3 | {{> head.html}} 4 | 5 | 6 | 7 |
8 | {{> header-logo.html}} 9 | 10 |
    11 |
  • 12 | Home 13 |
    • 14 |
15 | 16 | {{> nav.login.html}} 17 |
18 | 19 | {{> nav.fullscreen.html}} 20 | 21 |
22 |
23 |

Join the community!

24 |
25 | 26 | 27 |
28 | 29 | 30 |
31 | 32 |
33 |
34 |
35 | 36 | {{> footer.html}} 37 | 38 | 41 | 42 | 43 | -------------------------------------------------------------------------------- /src/templates/robots.txt: -------------------------------------------------------------------------------- 1 | # Disallow 2 | User-agent: * 3 | Disallow: /dashboard 4 | User-agent: * 5 | Disallow: /account 6 | User-agent: * 7 | Disallow: /quizz 8 | User-agent: * 9 | Disallow: /flashcard/* 10 | 11 | # Allow 12 | User-agent: * 13 | Allow: / 14 | 15 | Sitemap: {{base_url}}/sitemap.xml 16 | -------------------------------------------------------------------------------- /src/templates/sitemap.xml: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | {{base_url}}/ 5 | monthly 6 | 1 7 | 8 | 9 | {{base_url}}/register 10 | monthly 11 | 0.1 12 | 13 | 14 | {{base_url}}/login 15 | monthly 16 | 0.1 17 | 18 | 19 | -------------------------------------------------------------------------------- /stack.yaml: -------------------------------------------------------------------------------- 1 | # This file was automatically generated by 'stack init' 2 | # 3 | # Some commonly used options have been documented as comments in this file. 4 | # For advanced use and comprehensive documentation of the format, please see: 5 | # https://docs.haskellstack.org/en/stable/yaml_configuration/ 6 | 7 | # Resolver to choose a 'specific' stackage snapshot or a compiler version. 8 | # A snapshot resolver dictates the compiler version and the set of packages 9 | # to be used for project dependencies. For example: 10 | # 11 | # resolver: lts-3.5 12 | # resolver: nightly-2015-09-21 13 | # resolver: ghc-7.10.2 14 | # resolver: ghcjs-0.1.0_ghc-7.10.2 15 | # 16 | # The location of a snapshot can be provided as a file or url. Stack assumes 17 | # a snapshot provided as a file might change, whereas a url resource does not. 18 | # 19 | # resolver: ./custom-snapshot.yaml 20 | # resolver: https://example.com/snapshots/2018-01-01.yaml 21 | resolver: lts-12.6 22 | 23 | # User packages to be built. 24 | # Various formats can be used as shown in the example below. 25 | # 26 | # packages: 27 | # - some-directory 28 | # - https://example.com/foo/bar/baz-0.0.2.tar.gz 29 | # - location: 30 | # git: https://github.com/commercialhaskell/stack.git 31 | # commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a 32 | # - location: https://github.com/commercialhaskell/stack/commit/e7b331f14bcffb8367cd58fbfc8b40ec7642100a 33 | # subdirs: 34 | # - auto-update 35 | # - wai 36 | packages: 37 | - . 38 | # Dependency packages to be pulled from upstream that are not in the resolver 39 | # using the same syntax as the packages field. 40 | # (e.g., acme-missiles-0.3) 41 | # 42 | extra-deps: 43 | - HDBC-postgresql-2.3.2.5 44 | 45 | # Override default flag values for local packages and extra-deps 46 | # flags: {} 47 | 48 | # Extra package databases containing global packages 49 | # extra-package-dbs: [] 50 | 51 | # Control whether we use the GHC we find on the path 52 | # system-ghc: true 53 | # 54 | # Require a specific version of stack, using version ranges 55 | # require-stack-version: -any # Default 56 | # require-stack-version: ">=1.7" 57 | # 58 | # Override the architecture used by stack, especially useful on Windows 59 | # arch: i386 60 | # arch: x86_64 61 | # 62 | # Extra directories used by stack for building 63 | # extra-include-dirs: [/path/to/dir] 64 | # extra-lib-dirs: [/path/to/dir] 65 | # 66 | # Allow a newer minor version of GHC than the snapshot specifies 67 | # compiler-check: newer-minor 68 | -------------------------------------------------------------------------------- /static/fonts/glyphicons-halflings-regular.eot: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/FlogFr/FlashCard/17029f9b84f23c43f67702b77bd7418cdf0a9d28/static/fonts/glyphicons-halflings-regular.eot -------------------------------------------------------------------------------- /static/fonts/glyphicons-halflings-regular.ttf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/FlogFr/FlashCard/17029f9b84f23c43f67702b77bd7418cdf0a9d28/static/fonts/glyphicons-halflings-regular.ttf -------------------------------------------------------------------------------- /static/fonts/glyphicons-halflings-regular.woff: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/FlogFr/FlashCard/17029f9b84f23c43f67702b77bd7418cdf0a9d28/static/fonts/glyphicons-halflings-regular.woff -------------------------------------------------------------------------------- /static/tmp/autogen-FQn2C_-6.js: -------------------------------------------------------------------------------- 1 | document.getElementById("hident4").innerHTML="This text was added by the Javascript part of the homepage widget.";$(function(){$("#js-commentForm").submit(function(event){event.preventDefault();var message=$("#js-createCommentTextarea").val();if(!message){alert("Please fill out the comment form first.");return};$.ajax({url:'http://127.1:3000/comments',type:'POST',contentType:"application/json",data:JSON.stringify({message:message}),success:function(data){var newNode=$("
  • ");newNode.text(data.message);console.log(data);$("#js-commentList").append(newNode)},error:function(data){console.log("Error creating comment: "+data)}})})}) -------------------------------------------------------------------------------- /static/tmp/autogen-PE46a7-4.css: -------------------------------------------------------------------------------- 1 | h2#hident4{color:#990 2 | }li{line-height:2em;font-size:16px 3 | }#js-createCommentTextarea{width:400px;height:100px}.masthead,.navbar{background-color:rgb(27, 28, 29)}.navbar-default .navbar-nav > .active > a{background-color:transparent;border-bottom:2px solid white}.navbar-nav{padding-bottom:1em}.masthead{margin-top:-21px;color:white;text-align:center;min-height:500px}.masthead .header{max-width:700px;margin:0 auto;font-family:Lato,'Helvetica Neue',Arial,Helvetica,sans-serif}.masthead h1.header{margin-top:1em;margin-bottom:0em;font-size:4.5em;line-height:1.2em;font-weight:normal}.masthead h2{font-size:1.7em;font-weight:normal}.masthead .btn{margin:1em 0}.bs-callout{padding:20px;margin:20px 0;border:1px solid #eee;border-left-width:5px;border-radius:3px}.bs-callout p:last-child{margin-bottom:0}.bs-callout-info{border-left-color:#1b809e}.bs-docs-section{margin-bottom:60px}.bs-docs-section:last-child{margin-bottom:0}#message{margin-bottom:40px} -------------------------------------------------------------------------------- /static/tmp/autogen-dAT6QVJx.js: -------------------------------------------------------------------------------- 1 | document.getElementById("hident4").innerHTML="This text was added by the Javascript part of the homepage widget.";$(function(){$("#js-commentForm").submit(function(event){event.preventDefault();var message=$("#js-createCommentTextarea").val();if(!message){alert("Please fill out the comment form first.");return};$.ajax({url:'/comments',type:'POST',contentType:"application/json",data:JSON.stringify({message:message}),success:function(data){var newNode=$("
  • ");newNode.text(data.message);console.log(data);$("#js-commentList").append(newNode)},error:function(data){console.log("Error creating comment: "+data)}})})}) -------------------------------------------------------------------------------- /static/tmp/autogen-f9mZBX8C.js: -------------------------------------------------------------------------------- 1 | document.getElementById("hident4").innerHTML="This text was added by the Javascript part of the homepage widget.";$(function(){$("#js-commentForm").submit(function(event){event.preventDefault();var message=$("#js-createCommentTextarea").val();if(!message){alert("Please fill out the comment form first.");return};$.ajax({url:'http://127.0.0.1:3000/comments',type:'POST',contentType:"application/json",data:JSON.stringify({message:message}),success:function(data){var newNode=$("
  • ");newNode.text(data.message);console.log(data);$("#js-commentList").append(newNode)},error:function(data){console.log("Error creating comment: "+data)}})})}) -------------------------------------------------------------------------------- /templates/default-layout-wrapper.hamlet: -------------------------------------------------------------------------------- 1 | $newline never 2 | \ 3 | \ 4 | \ 5 | \ 6 | \ 7 | 8 | 9 | 10 | 11 | #{pageTitle pc} 12 | <meta name="description" content=""> 13 | <meta name="author" content=""> 14 | 15 | <meta name="viewport" content="width=device-width,initial-scale=1"> 16 | 17 | ^{pageHead pc} 18 | 19 | \<!--[if lt IE 9]> 20 | \<script src="http://html5shiv.googlecode.com/svn/trunk/html5.js"></script> 21 | \<![endif]--> 22 | <script type="text/javascript" src="https://cdnjs.cloudflare.com/ajax/libs/jquery/2.1.4/jquery.js"> 23 | <script type="text/javascript" src="https://cdnjs.cloudflare.com/ajax/libs/js-cookie/2.0.3/js.cookie.min.js"> 24 | 25 | \<!-- Bootstrap-3.3.7 compiled and minified JavaScript --> 26 | <script src="https://maxcdn.bootstrapcdn.com/bootstrap/3.3.7/js/bootstrap.min.js" integrity="sha384-Tc5IQib027qvyjSMfHjOMaLkfuWVxZxUPnCJA7l2mCWNIpG9mGCD8wGNIcPD7Txa" crossorigin="anonymous"> 27 | 28 | <script> 29 | /* The `defaultCsrfMiddleware` Middleware added in Foundation.hs adds a CSRF token to the request cookies. */ 30 | /* AJAX requests should add that token to a header to be validated by the server. */ 31 | /* See the CSRF documentation in the Yesod.Core.Handler module of the yesod-core package for details. */ 32 | var csrfHeaderName = "#{TE.decodeUtf8 $ CI.foldedCase defaultCsrfHeaderName}"; 33 | 34 | var csrfCookieName = "#{TE.decodeUtf8 defaultCsrfCookieName}"; 35 | var csrfToken = Cookies.get(csrfCookieName); 36 | 37 | 38 | if (csrfToken) { 39 | \ $.ajaxPrefilter(function( options, originalOptions, jqXHR ) { 40 | \ if (!options.crossDomain) { 41 | \ jqXHR.setRequestHeader(csrfHeaderName, csrfToken); 42 | \ } 43 | \ }); 44 | } 45 | 46 | <script> 47 | document.documentElement.className = document.documentElement.className.replace(/\bno-js\b/,'js'); 48 | <body> 49 | ^{pageBody pc} 50 | 51 | $maybe analytics <- appAnalytics $ appSettings master 52 | <script> 53 | if(!window.location.href.match(/localhost/)){ 54 | (function(i,s,o,g,r,a,m){i['GoogleAnalyticsObject']=r;i[r]=i[r]||function(){ 55 | (i[r].q=i[r].q||[]).push(arguments)},i[r].l=1*new Date();a=s.createElement(o), 56 | m=s.getElementsByTagName(o)[0];a.async=1;a.src=g;m.parentNode.insertBefore(a,m) 57 | })(window,document,'script','https://www.google-analytics.com/analytics.js','ga'); 58 | 59 | ga('create', '#{analytics}', 'auto'); 60 | ga('send', 'pageview'); 61 | } 62 | -------------------------------------------------------------------------------- /templates/default-layout.hamlet: -------------------------------------------------------------------------------- 1 | 2 | <!-- Static navbar --> 3 | <nav .navbar.navbar-default.navbar-static-top> 4 | <div .container> 5 | <div .navbar-header> 6 | <button type="button" .navbar-toggle.collapsed data-toggle="collapse" data-target="#navbar" aria-expanded="false" aria-controls="navbar"> 7 | <span class="sr-only">Toggle navigation</span> 8 | <span class="icon-bar"></span> 9 | <span class="icon-bar"></span> 10 | <span class="icon-bar"></span> 11 | 12 | <div #navbar .collapse.navbar-collapse> 13 | <ul .nav.navbar-nav> 14 | $forall MenuItem label route _ <- navbarLeftFilteredMenuItems 15 | <li :Just route == mcurrentRoute:.active> 16 | <a href="@{route}">#{label} 17 | 18 | <ul .nav.navbar-nav.navbar-right> 19 | $forall MenuItem label route _ <- navbarRightFilteredMenuItems 20 | <li :Just route == mcurrentRoute:.active> 21 | <a href="@{route}">#{label} 22 | 23 | <!-- Page Contents --> 24 | 25 | <div .container> 26 | $if not $ Just HomeR == mcurrentRoute 27 | <ul .breadcrumb> 28 | $forall bc <- parents 29 | <li> 30 | <a href="@{fst bc}">#{snd bc} 31 | 32 | <li .active>#{title} 33 | 34 | $maybe msg <- mmsg 35 | <div .alert.alert-info #message>#{msg} 36 | 37 | 38 | $if (Just HomeR == mcurrentRoute) 39 | ^{widget} 40 | $else 41 | <div .container> 42 | <div .row> 43 | <div .col-md-12> 44 | ^{widget} 45 | 46 | <!-- Footer --> 47 | <footer .footer> 48 | <div .container> 49 | <p .text-muted> 50 | #{appCopyright $ appSettings master} 51 | -------------------------------------------------------------------------------- /templates/default-layout.lucius: -------------------------------------------------------------------------------- 1 | .masthead, 2 | .navbar { 3 | background-color: rgb(27, 28, 29); 4 | } 5 | 6 | .navbar-default .navbar-nav > .active > a { 7 | background-color: transparent; 8 | border-bottom: 2px solid white; 9 | } 10 | 11 | .navbar-nav { 12 | padding-bottom: 1em; 13 | } 14 | 15 | .masthead { 16 | margin-top: -21px; 17 | color: white; 18 | text-align: center; 19 | min-height: 500px; 20 | } 21 | 22 | .masthead .header { 23 | max-width: 700px; 24 | margin: 0 auto; 25 | font-family: Lato,'Helvetica Neue',Arial,Helvetica,sans-serif; 26 | } 27 | 28 | .masthead h1.header { 29 | margin-top: 1em; 30 | margin-bottom: 0em; 31 | font-size: 4.5em; 32 | line-height: 1.2em; 33 | font-weight: normal; 34 | } 35 | 36 | .masthead h2 { 37 | font-size: 1.7em; 38 | font-weight: normal; 39 | } 40 | 41 | .masthead .btn { 42 | margin: 1em 0; 43 | } 44 | 45 | 46 | /* Common styles for all types */ 47 | .bs-callout { 48 | padding: 20px; 49 | margin: 20px 0; 50 | border: 1px solid #eee; 51 | border-left-width: 5px; 52 | border-radius: 3px; 53 | } 54 | 55 | .bs-callout p:last-child { 56 | margin-bottom: 0; 57 | } 58 | 59 | .bs-callout-info { 60 | border-left-color: #1b809e; 61 | } 62 | 63 | /* Space things out */ 64 | .bs-docs-section { 65 | margin-bottom: 60px; 66 | } 67 | .bs-docs-section:last-child { 68 | margin-bottom: 0; 69 | } 70 | 71 | #message { 72 | margin-bottom: 40px; 73 | } 74 | -------------------------------------------------------------------------------- /templates/homepage.hamlet: -------------------------------------------------------------------------------- 1 | <div .masthead> 2 | <div .container> 3 | <div .row> 4 | <h1 .header> 5 | Yesod—a modern framework for blazing fast websites 6 | <h2> 7 | Fast, stable & spiced with great community 8 | <a href="http://www.yesodweb.com/book/" .btn.btn-info.btn-lg> 9 | Read the Book 10 | 11 | <div .container> 12 | <!-- Starting 13 | ================================================== --> 14 | <div .bs-docs-section> 15 | <div .row> 16 | <div .col-lg-12> 17 | <div .page-header> 18 | <h1 #start>Starting 19 | 20 | <p> 21 | Now that you have a working project you should use the 22 | <a href=http://www.yesodweb.com/book/>Yesod book</a> to learn more. 23 | <p> 24 | You can also use this scaffolded site to explore some concepts, and best practices. 25 | 26 | <ul .list-group> 27 | 28 | <li .list-group-item> 29 | This page was generated by the <tt>#{handlerName}</tt> handler in 30 | <tt>Handler/Home.hs</tt>. 31 | 32 | <li .list-group-item> 33 | The <tt>#{handlerName}</tt> handler is set to generate your 34 | site's home screen in Routes file 35 | <tt>config/routes 36 | 37 | <li .list-group-item> 38 | We can link to other handlers, like the <a href="@{CommentR}">Comment</a>. 39 | 40 | <li .list-group-item> 41 | The HTML you are seeing now is actually composed by a number of <em>widgets</em>, # 42 | most of them are brought together by the <tt>defaultLayout</tt> function which # 43 | is defined in the <tt>Foundation.hs</tt> module, and used by <tt>#{handlerName}</tt>. # 44 | All the files for templates and wigdets are in <tt>templates</tt>. 45 | 46 | <li .list-group-item> 47 | A Widget's Html, Css and Javascript are separated in three files with the 48 | <tt>.hamlet</tt>, <tt>.lucius</tt> and <tt>.julius</tt> extensions. 49 | 50 | <li .list-group-item ##{aDomId}> 51 | If you had javascript enabled then you wouldn't be seeing this. 52 | 53 | <hr> 54 | 55 | <!-- Forms 56 | ================================================== --> 57 | <div .bs-docs-section> 58 | <div .row> 59 | <div .col-lg-12> 60 | <div .page-header> 61 | <h1 #forms>Forms 62 | 63 | <p> 64 | This is an example of a form. Read the 65 | <a href="http://www.yesodweb.com/book/forms">Forms chapter</a> # 66 | on the yesod book to learn more about them. 67 | 68 | <div .row> 69 | <div .col-lg-6> 70 | <div .bs-callout bs-callout-info well> 71 | <form .form-horizontal method=post action=@{HomeR}#forms enctype=#{formEnctype}> 72 | ^{formWidget} 73 | 74 | <button .btn.btn-primary type="submit"> 75 | Upload it! 76 | 77 | 78 | <div .col-lg-4.col-lg-offset-1> 79 | <div .bs-callout.bs-callout-info.upload-response> 80 | 81 | $maybe (FileForm info con) <- submission 82 | Your file type is <em>#{fileContentType info}</em>. You say it has: <em>#{con}</em> 83 | 84 | $nothing 85 | File upload result will be here... 86 | 87 | 88 | <hr> 89 | 90 | <!-- JSON 91 | ================================================== --> 92 | <div .bs-docs-section> 93 | <div .row> 94 | <div .col-lg-12> 95 | <div .page-header> 96 | <h1 #json>JSON 97 | 98 | <p> 99 | Yesod has JSON support baked-in. 100 | The form below makes an AJAX request with Javascript, 101 | then updates the page with your submission. 102 | (see <tt>Handler/Comment.hs</tt>, <tt>templates/homepage.julius</tt>, 103 | and <tt>Handler/Home.hs</tt> for the implementation). 104 | 105 | <div .row> 106 | <div .col-lg-6> 107 | <div .bs-callout.bs-callout-info.well> 108 | <form .form-horizontal ##{commentFormId}> 109 | <div .field> 110 | <textarea rows="2" ##{commentTextareaId} placeholder="Your comment here..." required></textarea> 111 | 112 | <button .btn.btn-primary type=submit> 113 | Create comment 114 | 115 | <div .col-lg-4.col-lg-offset-1> 116 | <div .bs-callout.bs-callout-info> 117 | <small> 118 | Your comments will appear here. You can also open the 119 | console log to see the raw response from the server. 120 | <ul ##{commentListId}> 121 | 122 | <hr> 123 | 124 | <!-- Testing 125 | ================================================== --> 126 | <div .bs-docs-section> 127 | <div .row> 128 | <div .col-lg-12> 129 | <div .page-header> 130 | <h1 #test>Testing 131 | 132 | <p> 133 | And last but not least, Testing. In <tt>test/Spec.hs</tt> you will find a # 134 | test suite that performs tests on this page. 135 | <p> 136 | You can run your tests by doing: <code>stack test</code> 137 | -------------------------------------------------------------------------------- /templates/homepage.julius: -------------------------------------------------------------------------------- 1 | document.getElementById(#{toJSON aDomId}).innerHTML = "This text was added by the Javascript part of the homepage widget."; 2 | 3 | $(function() { 4 | $("##{rawJS commentFormId}").submit(function(event) { 5 | event.preventDefault(); 6 | 7 | var message = $("##{rawJS commentTextareaId}").val(); 8 | // (Browsers that enforce the "required" attribute on the textarea won't see this alert) 9 | if (!message) { 10 | alert("Please fill out the comment form first."); 11 | return; 12 | } 13 | 14 | // Make an AJAX request to the server to create a new comment 15 | $.ajax({ 16 | url: '@{CommentR}', 17 | type: 'POST', 18 | contentType: "application/json", 19 | data: JSON.stringify({ 20 | message: message, 21 | }), 22 | success: function (data) { 23 | var newNode = $("<li></li>"); 24 | newNode.text(data.message); 25 | console.log(data); 26 | $("##{rawJS commentListId}").append(newNode); 27 | }, 28 | error: function (data) { 29 | console.log("Error creating comment: " + data); 30 | }, 31 | }); 32 | 33 | }); 34 | }); 35 | -------------------------------------------------------------------------------- /templates/homepage.lucius: -------------------------------------------------------------------------------- 1 | h2##{aDomId} { 2 | color: #990 3 | } 4 | 5 | li { 6 | line-height: 2em; 7 | font-size: 16px 8 | } 9 | 10 | ##{commentTextareaId} { 11 | width: 400px; 12 | height: 100px; 13 | } 14 | -------------------------------------------------------------------------------- /test/Spec.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE QuasiQuotes, OverloadedStrings #-} 2 | module Main (main) where 3 | 4 | import API (runApp, app) 5 | import User 6 | import SQL 7 | import Test.Hspec 8 | import Test.Hspec.Wai 9 | import Test.Hspec.Wai.JSON 10 | import Test.QuickCheck 11 | 12 | 13 | genUser :: Gen User 14 | genUser = elements [ 15 | User (-1) "testuser1" (Just "testemail1") ["EN", "FR"] 16 | , User (-2) "testuser2" (Just "testemail2") ["DE", "FR"] 17 | , User (-3) "testuser3" (Nothing) ["EN", "DE"] 18 | , User (-4) "testuser4" (Just "testemail4") ["PL"] 19 | ] 20 | 21 | -- with :: IO a -> SpecWith a -> Spec 22 | main :: IO () 23 | main = hspec spec 24 | 25 | spec :: Spec 26 | spec = with webApp $ do 27 | describe "GET /auth/token" $ do 28 | it "responds with 200" $ 29 | get "/auth/token" `shouldRespondWith` 302 30 | where webApp = do 31 | pool <- initConnectionPool "service=words" 32 | return $ app pool 33 | -------------------------------------------------------------------------------- /test/index.html: -------------------------------------------------------------------------------- 1 | <!DOCTYPE html> 2 | <html> 3 | <head> 4 | <meta charset="utf-8"> 5 | <title>IziDict - My Dictionary (1) 6 | 7 | 8 | 9 | 10 | 11 | 12 | 13 | 14 | 25 | 26 | 27 | -------------------------------------------------------------------------------- /test/tests.sh: -------------------------------------------------------------------------------- 1 | #!/bin/bash -e 2 | 3 | curl -i -v http://127.1:8080/words 4 | curl -i -v -X POST -H 'Content-Type: application/json' -d '{ "wordId": 12 , "wordLanguage": "EN" , "wordWord": "wordWord" , "wordKeywords": [] , "wordDefinition": "wordDefinition" , "wordDifficulty": 2 }' http://127.1:8080/words 5 | -------------------------------------------------------------------------------- /verify/0001-words.sql: -------------------------------------------------------------------------------- 1 | -- Verify words:0001-words on pg 2 | 3 | BEGIN; 4 | 5 | SELECT "id", "language", "words", "keywords", "definition", "difficulty" 6 | FROM words 7 | WHERE false; 8 | 9 | ROLLBACK; 10 | -------------------------------------------------------------------------------- /verify/0002-users.sql: -------------------------------------------------------------------------------- 1 | -- Verify words:0002-users on pg 2 | 3 | BEGIN; 4 | 5 | -- XXX Add verifications here. 6 | 7 | ROLLBACK; 8 | -------------------------------------------------------------------------------- /verify/0003-tokens.sql: -------------------------------------------------------------------------------- 1 | -- Verify words:0003-tokens on pg 2 | 3 | BEGIN; 4 | 5 | -- XXX Add verifications here. 6 | 7 | ROLLBACK; 8 | -------------------------------------------------------------------------------- /verify/0004-session.sql: -------------------------------------------------------------------------------- 1 | -- Verify words:0004-session on pg 2 | 3 | BEGIN; 4 | 5 | -- XXX Add verifications here. 6 | 7 | ROLLBACK; 8 | -------------------------------------------------------------------------------- /verify/0005-scoring.sql: -------------------------------------------------------------------------------- 1 | -- Verify words:0005-scoring on pg 2 | 3 | BEGIN; 4 | 5 | -- XXX Add verifications here. 6 | 7 | ROLLBACK; 8 | -------------------------------------------------------------------------------- /verify/0006-update-user.sql: -------------------------------------------------------------------------------- 1 | -- Verify words:0006-update-user on pg 2 | 3 | BEGIN; 4 | 5 | -- XXX Add verifications here. 6 | 7 | ROLLBACK; 8 | -------------------------------------------------------------------------------- /www/favico.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/FlogFr/FlashCard/17029f9b84f23c43f67702b77bd7418cdf0a9d28/www/favico.png -------------------------------------------------------------------------------- /www/favicon.ico: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/FlogFr/FlashCard/17029f9b84f23c43f67702b77bd7418cdf0a9d28/www/favicon.ico -------------------------------------------------------------------------------- /www/fonts/Roboto-Black.ttf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/FlogFr/FlashCard/17029f9b84f23c43f67702b77bd7418cdf0a9d28/www/fonts/Roboto-Black.ttf -------------------------------------------------------------------------------- /www/fonts/Roboto-BlackItalic.ttf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/FlogFr/FlashCard/17029f9b84f23c43f67702b77bd7418cdf0a9d28/www/fonts/Roboto-BlackItalic.ttf -------------------------------------------------------------------------------- /www/fonts/Roboto-Bold.ttf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/FlogFr/FlashCard/17029f9b84f23c43f67702b77bd7418cdf0a9d28/www/fonts/Roboto-Bold.ttf -------------------------------------------------------------------------------- /www/fonts/Roboto-BoldItalic.ttf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/FlogFr/FlashCard/17029f9b84f23c43f67702b77bd7418cdf0a9d28/www/fonts/Roboto-BoldItalic.ttf -------------------------------------------------------------------------------- /www/fonts/Roboto-Italic.ttf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/FlogFr/FlashCard/17029f9b84f23c43f67702b77bd7418cdf0a9d28/www/fonts/Roboto-Italic.ttf -------------------------------------------------------------------------------- /www/fonts/Roboto-Light.ttf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/FlogFr/FlashCard/17029f9b84f23c43f67702b77bd7418cdf0a9d28/www/fonts/Roboto-Light.ttf -------------------------------------------------------------------------------- /www/fonts/Roboto-LightItalic.ttf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/FlogFr/FlashCard/17029f9b84f23c43f67702b77bd7418cdf0a9d28/www/fonts/Roboto-LightItalic.ttf -------------------------------------------------------------------------------- /www/fonts/Roboto-Medium.ttf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/FlogFr/FlashCard/17029f9b84f23c43f67702b77bd7418cdf0a9d28/www/fonts/Roboto-Medium.ttf -------------------------------------------------------------------------------- /www/fonts/Roboto-MediumItalic.ttf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/FlogFr/FlashCard/17029f9b84f23c43f67702b77bd7418cdf0a9d28/www/fonts/Roboto-MediumItalic.ttf -------------------------------------------------------------------------------- /www/fonts/Roboto-Regular.ttf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/FlogFr/FlashCard/17029f9b84f23c43f67702b77bd7418cdf0a9d28/www/fonts/Roboto-Regular.ttf -------------------------------------------------------------------------------- /www/fonts/Roboto-Thin.ttf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/FlogFr/FlashCard/17029f9b84f23c43f67702b77bd7418cdf0a9d28/www/fonts/Roboto-Thin.ttf -------------------------------------------------------------------------------- /www/fonts/Roboto-ThinItalic.ttf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/FlogFr/FlashCard/17029f9b84f23c43f67702b77bd7418cdf0a9d28/www/fonts/Roboto-ThinItalic.ttf -------------------------------------------------------------------------------- /www/fonts/RobotoSlab-Bold.ttf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/FlogFr/FlashCard/17029f9b84f23c43f67702b77bd7418cdf0a9d28/www/fonts/RobotoSlab-Bold.ttf -------------------------------------------------------------------------------- /www/fonts/RobotoSlab-Light.ttf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/FlogFr/FlashCard/17029f9b84f23c43f67702b77bd7418cdf0a9d28/www/fonts/RobotoSlab-Light.ttf -------------------------------------------------------------------------------- /www/fonts/RobotoSlab-Regular.ttf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/FlogFr/FlashCard/17029f9b84f23c43f67702b77bd7418cdf0a9d28/www/fonts/RobotoSlab-Regular.ttf -------------------------------------------------------------------------------- /www/fonts/RobotoSlab-Thin.ttf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/FlogFr/FlashCard/17029f9b84f23c43f67702b77bd7418cdf0a9d28/www/fonts/RobotoSlab-Thin.ttf -------------------------------------------------------------------------------- /www/fonts/SansForgetica-Regular.otf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/FlogFr/FlashCard/17029f9b84f23c43f67702b77bd7418cdf0a9d28/www/fonts/SansForgetica-Regular.otf -------------------------------------------------------------------------------- /www/home.html: -------------------------------------------------------------------------------- 1 | index.html -------------------------------------------------------------------------------- /www/images/dictionnary.logo.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/FlogFr/FlashCard/17029f9b84f23c43f67702b77bd7418cdf0a9d28/www/images/dictionnary.logo.png -------------------------------------------------------------------------------- /www/images/icons.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/FlogFr/FlashCard/17029f9b84f23c43f67702b77bd7418cdf0a9d28/www/images/icons.png -------------------------------------------------------------------------------- /www/images/icons.xcf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/FlogFr/FlashCard/17029f9b84f23c43f67702b77bd7418cdf0a9d28/www/images/icons.xcf -------------------------------------------------------------------------------- /www/images/idea.1.jpg: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/FlogFr/FlashCard/17029f9b84f23c43f67702b77bd7418cdf0a9d28/www/images/idea.1.jpg -------------------------------------------------------------------------------- /www/images/memory.1.jpg: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/FlogFr/FlashCard/17029f9b84f23c43f67702b77bd7418cdf0a9d28/www/images/memory.1.jpg -------------------------------------------------------------------------------- /www/images/memory.2.jpg: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/FlogFr/FlashCard/17029f9b84f23c43f67702b77bd7418cdf0a9d28/www/images/memory.2.jpg -------------------------------------------------------------------------------- /www/images/memory.3.jpg: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/FlogFr/FlashCard/17029f9b84f23c43f67702b77bd7418cdf0a9d28/www/images/memory.3.jpg -------------------------------------------------------------------------------- /www/index.html: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 | 6 | IziDict - My Dictionary Online (1) 7 | 8 | 9 | 10 | 11 | 12 | 13 | 14 | 15 | 16 | 17 | 33 | 34 | 35 | 36 | -------------------------------------------------------------------------------- /www/login.html: -------------------------------------------------------------------------------- 1 | index.html -------------------------------------------------------------------------------- /www/normalize.css: -------------------------------------------------------------------------------- 1 | /*! normalize.css v8.0.0 | MIT License | github.com/necolas/normalize.css */ 2 | 3 | /* Document 4 | ========================================================================== */ 5 | 6 | /** 7 | * 1. Correct the line height in all browsers. 8 | * 2. Prevent adjustments of font size after orientation changes in iOS. 9 | */ 10 | 11 | html { 12 | line-height: 1.15; /* 1 */ 13 | -webkit-text-size-adjust: 100%; /* 2 */ 14 | } 15 | 16 | /* Sections 17 | ========================================================================== */ 18 | 19 | /** 20 | * Remove the margin in all browsers. 21 | */ 22 | 23 | body { 24 | margin: 0; 25 | } 26 | 27 | /** 28 | * Correct the font size and margin on `h1` elements within `section` and 29 | * `article` contexts in Chrome, Firefox, and Safari. 30 | */ 31 | 32 | h1 { 33 | font-size: 2em; 34 | margin: 0.67em 0; 35 | } 36 | 37 | /* Grouping content 38 | ========================================================================== */ 39 | 40 | /** 41 | * 1. Add the correct box sizing in Firefox. 42 | * 2. Show the overflow in Edge and IE. 43 | */ 44 | 45 | hr { 46 | box-sizing: content-box; /* 1 */ 47 | height: 0; /* 1 */ 48 | overflow: visible; /* 2 */ 49 | } 50 | 51 | /** 52 | * 1. Correct the inheritance and scaling of font size in all browsers. 53 | * 2. Correct the odd `em` font sizing in all browsers. 54 | */ 55 | 56 | pre { 57 | font-family: monospace, monospace; /* 1 */ 58 | font-size: 1em; /* 2 */ 59 | } 60 | 61 | /* Text-level semantics 62 | ========================================================================== */ 63 | 64 | /** 65 | * Remove the gray background on active links in IE 10. 66 | */ 67 | 68 | a { 69 | background-color: transparent; 70 | } 71 | 72 | /** 73 | * 1. Remove the bottom border in Chrome 57- 74 | * 2. Add the correct text decoration in Chrome, Edge, IE, Opera, and Safari. 75 | */ 76 | 77 | abbr[title] { 78 | border-bottom: none; /* 1 */ 79 | text-decoration: underline; /* 2 */ 80 | text-decoration: underline dotted; /* 2 */ 81 | } 82 | 83 | /** 84 | * Add the correct font weight in Chrome, Edge, and Safari. 85 | */ 86 | 87 | b, 88 | strong { 89 | font-weight: bolder; 90 | } 91 | 92 | /** 93 | * 1. Correct the inheritance and scaling of font size in all browsers. 94 | * 2. Correct the odd `em` font sizing in all browsers. 95 | */ 96 | 97 | code, 98 | kbd, 99 | samp { 100 | font-family: monospace, monospace; /* 1 */ 101 | font-size: 1em; /* 2 */ 102 | } 103 | 104 | /** 105 | * Add the correct font size in all browsers. 106 | */ 107 | 108 | small { 109 | font-size: 80%; 110 | } 111 | 112 | /** 113 | * Prevent `sub` and `sup` elements from affecting the line height in 114 | * all browsers. 115 | */ 116 | 117 | sub, 118 | sup { 119 | font-size: 75%; 120 | line-height: 0; 121 | position: relative; 122 | vertical-align: baseline; 123 | } 124 | 125 | sub { 126 | bottom: -0.25em; 127 | } 128 | 129 | sup { 130 | top: -0.5em; 131 | } 132 | 133 | /* Embedded content 134 | ========================================================================== */ 135 | 136 | /** 137 | * Remove the border on images inside links in IE 10. 138 | */ 139 | 140 | img { 141 | border-style: none; 142 | } 143 | 144 | /* Forms 145 | ========================================================================== */ 146 | 147 | /** 148 | * 1. Change the font styles in all browsers. 149 | * 2. Remove the margin in Firefox and Safari. 150 | */ 151 | 152 | button, 153 | input, 154 | optgroup, 155 | select, 156 | textarea { 157 | font-family: inherit; /* 1 */ 158 | font-size: 100%; /* 1 */ 159 | line-height: 1.15; /* 1 */ 160 | margin: 0; /* 2 */ 161 | } 162 | 163 | /** 164 | * Show the overflow in IE. 165 | * 1. Show the overflow in Edge. 166 | */ 167 | 168 | button, 169 | input { /* 1 */ 170 | overflow: visible; 171 | } 172 | 173 | /** 174 | * Remove the inheritance of text transform in Edge, Firefox, and IE. 175 | * 1. Remove the inheritance of text transform in Firefox. 176 | */ 177 | 178 | button, 179 | select { /* 1 */ 180 | text-transform: none; 181 | } 182 | 183 | /** 184 | * Correct the inability to style clickable types in iOS and Safari. 185 | */ 186 | 187 | button, 188 | [type="button"], 189 | [type="reset"], 190 | [type="submit"] { 191 | -webkit-appearance: button; 192 | } 193 | 194 | /** 195 | * Remove the inner border and padding in Firefox. 196 | */ 197 | 198 | button::-moz-focus-inner, 199 | [type="button"]::-moz-focus-inner, 200 | [type="reset"]::-moz-focus-inner, 201 | [type="submit"]::-moz-focus-inner { 202 | border-style: none; 203 | padding: 0; 204 | } 205 | 206 | /** 207 | * Restore the focus styles unset by the previous rule. 208 | */ 209 | 210 | button:-moz-focusring, 211 | [type="button"]:-moz-focusring, 212 | [type="reset"]:-moz-focusring, 213 | [type="submit"]:-moz-focusring { 214 | outline: 1px dotted ButtonText; 215 | } 216 | 217 | /** 218 | * Correct the padding in Firefox. 219 | */ 220 | 221 | fieldset { 222 | padding: 0.35em 0.75em 0.625em; 223 | } 224 | 225 | /** 226 | * 1. Correct the text wrapping in Edge and IE. 227 | * 2. Correct the color inheritance from `fieldset` elements in IE. 228 | * 3. Remove the padding so developers are not caught out when they zero out 229 | * `fieldset` elements in all browsers. 230 | */ 231 | 232 | legend { 233 | box-sizing: border-box; /* 1 */ 234 | color: inherit; /* 2 */ 235 | display: table; /* 1 */ 236 | max-width: 100%; /* 1 */ 237 | padding: 0; /* 3 */ 238 | white-space: normal; /* 1 */ 239 | } 240 | 241 | /** 242 | * Add the correct vertical alignment in Chrome, Firefox, and Opera. 243 | */ 244 | 245 | progress { 246 | vertical-align: baseline; 247 | } 248 | 249 | /** 250 | * Remove the default vertical scrollbar in IE 10+. 251 | */ 252 | 253 | textarea { 254 | overflow: auto; 255 | } 256 | 257 | /** 258 | * 1. Add the correct box sizing in IE 10. 259 | * 2. Remove the padding in IE 10. 260 | */ 261 | 262 | [type="checkbox"], 263 | [type="radio"] { 264 | box-sizing: border-box; /* 1 */ 265 | padding: 0; /* 2 */ 266 | } 267 | 268 | /** 269 | * Correct the cursor style of increment and decrement buttons in Chrome. 270 | */ 271 | 272 | [type="number"]::-webkit-inner-spin-button, 273 | [type="number"]::-webkit-outer-spin-button { 274 | height: auto; 275 | } 276 | 277 | /** 278 | * 1. Correct the odd appearance in Chrome and Safari. 279 | * 2. Correct the outline style in Safari. 280 | */ 281 | 282 | [type="search"] { 283 | -webkit-appearance: textfield; /* 1 */ 284 | outline-offset: -2px; /* 2 */ 285 | } 286 | 287 | /** 288 | * Remove the inner padding in Chrome and Safari on macOS. 289 | */ 290 | 291 | [type="search"]::-webkit-search-decoration { 292 | -webkit-appearance: none; 293 | } 294 | 295 | /** 296 | * 1. Correct the inability to style clickable types in iOS and Safari. 297 | * 2. Change font properties to `inherit` in Safari. 298 | */ 299 | 300 | ::-webkit-file-upload-button { 301 | -webkit-appearance: button; /* 1 */ 302 | font: inherit; /* 2 */ 303 | } 304 | 305 | /* Interactive 306 | ========================================================================== */ 307 | 308 | /* 309 | * Add the correct display in Edge, IE 10+, and Firefox. 310 | */ 311 | 312 | details { 313 | display: block; 314 | } 315 | 316 | /* 317 | * Add the correct display in all browsers. 318 | */ 319 | 320 | summary { 321 | display: list-item; 322 | } 323 | 324 | /* Misc 325 | ========================================================================== */ 326 | 327 | /** 328 | * Add the correct display in IE 10+. 329 | */ 330 | 331 | template { 332 | display: none; 333 | } 334 | 335 | /** 336 | * Add the correct display in IE 10. 337 | */ 338 | 339 | [hidden] { 340 | display: none; 341 | } 342 | -------------------------------------------------------------------------------- /www/profile.html: -------------------------------------------------------------------------------- 1 | index.html -------------------------------------------------------------------------------- /www/register.html: -------------------------------------------------------------------------------- 1 | index.html --------------------------------------------------------------------------------