Compare commits
1 commit
Author | SHA1 | Date | |
---|---|---|---|
|
0dcc9635db |
36
.github/workflows/tests.yml
vendored
36
.github/workflows/tests.yml
vendored
|
@ -1,36 +0,0 @@
|
||||||
name: Tests
|
|
||||||
|
|
||||||
on:
|
|
||||||
pull_request:
|
|
||||||
push:
|
|
||||||
branches:
|
|
||||||
- master
|
|
||||||
workflow_dispatch:
|
|
||||||
|
|
||||||
jobs:
|
|
||||||
build:
|
|
||||||
name: CI
|
|
||||||
runs-on: ${{ matrix.os }}
|
|
||||||
strategy:
|
|
||||||
fail-fast: false
|
|
||||||
matrix:
|
|
||||||
os:
|
|
||||||
- ubuntu-latest
|
|
||||||
#-macos-latest
|
|
||||||
#-windows-latest
|
|
||||||
#resolver:
|
|
||||||
#- nightly
|
|
||||||
#- lts-18.7
|
|
||||||
|
|
||||||
steps:
|
|
||||||
- name: Clone project
|
|
||||||
uses: actions/checkout@v2
|
|
||||||
|
|
||||||
- name: Build and run tests
|
|
||||||
shell: bash
|
|
||||||
run: |
|
|
||||||
set -ex
|
|
||||||
mkdir -p ../_newstack
|
|
||||||
stack upgrade --force-download --local-bin-path ../_newstack
|
|
||||||
../_newstack/stack --version
|
|
||||||
../_newstack/stack test --fast --no-terminal
|
|
2
.gitignore
vendored
2
.gitignore
vendored
|
@ -29,5 +29,3 @@ tmp
|
||||||
.cache
|
.cache
|
||||||
tags
|
tags
|
||||||
purs/docset/purescript-local.docset/
|
purs/docset/purescript-local.docset/
|
||||||
.ghc.environment.x86_64-linux-8.6.5
|
|
||||||
.vscode
|
|
||||||
|
|
24
Makefile
24
Makefile
|
@ -1,6 +1,3 @@
|
||||||
_DOCKER:=docker
|
|
||||||
_DOCKER_COMPOSE:=docker compose
|
|
||||||
|
|
||||||
.PHONY: clean build
|
.PHONY: clean build
|
||||||
|
|
||||||
all: build
|
all: build
|
||||||
|
@ -29,8 +26,9 @@ migrate-createdb:
|
||||||
serve:
|
serve:
|
||||||
@stack exec espial -- +RTS -T
|
@stack exec espial -- +RTS -T
|
||||||
|
|
||||||
_ESPIAL_PS_ID = $$($(_DOCKER_COMPOSE) ps -q espial)
|
_ESPIAL_PS_ID = $$(docker-compose ps -q espial)
|
||||||
_LOCAL_INSTALL_PATH = $$(stack path | grep local-install-root | awk -e '{print $$2}')
|
_LOCAL_INSTALL_PATH = $$(stack path | grep local-install-root | awk -e '{print $$2}')
|
||||||
|
_EKG_ASSETS_PATH = $$(find .stack-work -type d | grep ekg.*assets)
|
||||||
|
|
||||||
docker-compose-build: build
|
docker-compose-build: build
|
||||||
@rm -Rf dist && mkdir -p dist
|
@rm -Rf dist && mkdir -p dist
|
||||||
|
@ -38,20 +36,22 @@ docker-compose-build: build
|
||||||
@cp -R static dist
|
@cp -R static dist
|
||||||
@rm -Rf dist/static/tmp
|
@rm -Rf dist/static/tmp
|
||||||
@cp -R config dist
|
@cp -R config dist
|
||||||
@$(_DOCKER_COMPOSE) build espial
|
@mkdir -p dist/ekg/assets
|
||||||
|
@cp -R $(_EKG_ASSETS_PATH) dist/ekg
|
||||||
|
@docker-compose build espial
|
||||||
docker-compose-up:
|
docker-compose-up:
|
||||||
@$(_DOCKER_COMPOSE) up --no-deps --no-build espial
|
@docker-compose up --no-deps --no-build espial
|
||||||
docker-compose-down:
|
docker-compose-down:
|
||||||
@$(_DOCKER_COMPOSE) down
|
@docker-compose down
|
||||||
docker-compose-up-d:
|
docker-compose-up-d:
|
||||||
@$(_DOCKER_COMPOSE) up --no-deps --no-build -d espial
|
@docker-compose up --no-deps --no-build -d espial
|
||||||
docker-compose-pull:
|
docker-compose-pull:
|
||||||
@$(_DOCKER_COMPOSE) pull espial
|
@docker-compose pull espial
|
||||||
docker-compose-push:
|
docker-compose-push:
|
||||||
@docker tag localhost/espial:espial $(HUB_REPO)/espial:espial
|
@docker tag localhost/espial:espial $(HUB_REPO)/espial:espial
|
||||||
@$(_DOCKER_COMPOSE) push espial
|
@docker-compose push espial
|
||||||
docker-espial-logs:
|
docker-espial-logs:
|
||||||
@$(_DOCKER) logs -f --since `date -u +%FT%TZ` $(_ESPIAL_PS_ID)
|
@docker logs -f --since `date -u +%FT%TZ` $(_ESPIAL_PS_ID)
|
||||||
docker-espial-shell:
|
docker-espial-shell:
|
||||||
@$(docker_espial) sh
|
@$(docker_espial) sh
|
||||||
|
|
||||||
|
@ -61,7 +61,7 @@ ifeq ($(_HUB_REPO),)
|
||||||
_HUB_REPO := "localhost"
|
_HUB_REPO := "localhost"
|
||||||
endif
|
endif
|
||||||
|
|
||||||
docker_espial = $(_DOCKER_COMPOSE) exec espial
|
docker_espial = docker-compose exec espial
|
||||||
|
|
||||||
clean:
|
clean:
|
||||||
@stack clean
|
@stack clean
|
||||||
|
|
39
README.md
39
README.md
|
@ -8,24 +8,18 @@ The bookmarks are stored in a sqlite3 database, for ease of deployment & mainten
|
||||||
|
|
||||||
The easist way for logged-in users to add bookmarks, is with the "bookmarklet", found on the Settings page.
|
The easist way for logged-in users to add bookmarks, is with the "bookmarklet", found on the Settings page.
|
||||||
|
|
||||||
Also, see the android app for adding bookmarks via an Android Share intent https://github.com/jonschoning/espial-share-android
|
|
||||||
|
|
||||||
## demo server
|
## demo server
|
||||||
|
|
||||||
log in — username: demo password: demo
|
log in — username: demo password: demo
|
||||||
|
|
||||||
https://esp.ae8.org/u:demo
|
https://esp.ae8.org/u:demo
|
||||||
|
|
||||||
![jpg](https://i.imgur.com/jdnV93c.png)
|
![jpg](https://i.imgur.com/XikHLua.png)
|
||||||
|
|
||||||
## Docker Setup
|
|
||||||
|
|
||||||
see https://github.com/jonschoning/espial-docker
|
|
||||||
|
|
||||||
## Server Setup (from source)
|
## Server Setup (from source)
|
||||||
|
|
||||||
1. Install the Stack executable here:
|
1. [Install Stack](https://haskell-lang.org/get-started)
|
||||||
- https://tech.fpcomplete.com/haskell/get-started
|
- On POSIX systems, this is usually `curl -sSL https://get.haskellstack.org/ | sh`
|
||||||
|
|
||||||
2. Build executables
|
2. Build executables
|
||||||
|
|
||||||
|
@ -45,36 +39,25 @@ see https://github.com/jonschoning/espial-docker
|
||||||
stack exec migration -- createuser --conn espial.sqlite3 --userName myusername --userPassword myuserpassword
|
stack exec migration -- createuser --conn espial.sqlite3 --userName myusername --userPassword myuserpassword
|
||||||
```
|
```
|
||||||
|
|
||||||
5. Import a pinboard bookmark file for a user (optional)
|
5. Import a bookmark file for a user (optional)
|
||||||
|
|
||||||
```
|
```
|
||||||
stack exec migration -- importbookmarks --conn espial.sqlite3 --userName myusername --bookmarkFile sample-bookmarks.json
|
stack exec migration -- importbookmarks --conn espial.sqlite3 --userName myusername --bookmarkFile sample-bookmarks.json
|
||||||
```
|
```
|
||||||
|
|
||||||
6. Import a firefox bookmark file for a user (optional)
|
6. Start a production server:
|
||||||
|
|
||||||
```
|
```
|
||||||
stack exec migration -- importfirefoxbookmarks --conn espial.sqlite3 --userName myusername --bookmarkFile firefox-bookmarks.json
|
stack exec espial -- +RTS -T
|
||||||
```
|
```
|
||||||
|
|
||||||
7. Start a production server:
|
see `config/settings.yml` for changing default run-time parameters / environment variables
|
||||||
|
|
||||||
```
|
default app http port: `3000`
|
||||||
stack exec espial
|
|
||||||
```
|
|
||||||
|
|
||||||
### Configuration
|
default ekg http port: `8000`
|
||||||
|
|
||||||
See `config/settings.yml` for changing default run-time parameters & environment variables.
|
ssl: use reverse proxy
|
||||||
- `config/settings.yml` is embedded into the app executable when compiled, so after changing `config/settings.yml`, run `stack build` again to apply the new settings.
|
|
||||||
- `config/settings.yml` values formatted like `_env:ENV_VAR_NAME:default_value` can be
|
|
||||||
overridden by the specified environment variable.
|
|
||||||
- Example
|
|
||||||
- `_env:PORT:3000`
|
|
||||||
- environment variable `PORT`
|
|
||||||
- default app http port: `3000`
|
|
||||||
|
|
||||||
SSL: use reverse proxy
|
|
||||||
|
|
||||||
## Development
|
## Development
|
||||||
|
|
||||||
|
@ -93,7 +76,7 @@ SSL: use reverse proxy
|
||||||
|
|
||||||
- See `purs/` folder
|
- See `purs/` folder
|
||||||
|
|
||||||
## Import Bookmark file format (pinboard compatible format)
|
## Import Bookmark file format
|
||||||
|
|
||||||
see `sample-bookmarks.json`, which contains a JSON array, each line containing a `FileBookmark` object.
|
see `sample-bookmarks.json`, which contains a JSON array, each line containing a `FileBookmark` object.
|
||||||
|
|
||||||
|
|
|
@ -1,5 +0,0 @@
|
||||||
# Security Policy
|
|
||||||
|
|
||||||
## Reporting a Vulnerability
|
|
||||||
|
|
||||||
Please report vulnerabilities to jonschoning@gmail.com
|
|
|
@ -12,57 +12,18 @@ import ClassyPrelude
|
||||||
import Lens.Micro
|
import Lens.Micro
|
||||||
|
|
||||||
import Options.Generic
|
import Options.Generic
|
||||||
import qualified Options.Applicative as OA
|
|
||||||
import qualified Data.Text as T
|
|
||||||
|
|
||||||
data Password
|
|
||||||
= PasswordText Text
|
|
||||||
| PasswordFile FilePath
|
|
||||||
deriving (Show, Read)
|
|
||||||
|
|
||||||
parsePassword :: OA.Parser Password
|
|
||||||
parsePassword = passwordText <|> passwordFile
|
|
||||||
where
|
|
||||||
passwordText = PasswordText <$> OA.strOption
|
|
||||||
( OA.long "userPassword"
|
|
||||||
<> OA.metavar "PASSWORD"
|
|
||||||
<> OA.help "Password in plain-text"
|
|
||||||
)
|
|
||||||
|
|
||||||
passwordFile = PasswordFile <$> OA.strOption
|
|
||||||
( OA.long "userPasswordFile"
|
|
||||||
<> OA.metavar "FILE"
|
|
||||||
<> OA.help "Password file"
|
|
||||||
)
|
|
||||||
|
|
||||||
instance ParseFields Password
|
|
||||||
|
|
||||||
instance ParseRecord Password where
|
|
||||||
parseRecord = fmap getOnly parseRecord
|
|
||||||
|
|
||||||
instance ParseField Password where
|
|
||||||
parseField _ _ _ _ = parsePassword
|
|
||||||
|
|
||||||
data MigrationOpts
|
data MigrationOpts
|
||||||
= CreateDB { conn :: Text}
|
= CreateDB { conn :: Text}
|
||||||
| CreateUser { conn :: Text
|
| CreateUser { conn :: Text
|
||||||
, userName :: Text
|
, userName :: Text
|
||||||
, userPassword :: Password
|
, userPassword :: Text
|
||||||
, privateDefault :: Maybe Bool
|
, userApiToken :: Maybe Text }
|
||||||
, archiveDefault :: Maybe Bool
|
|
||||||
, privacyLock :: Maybe Bool }
|
|
||||||
| CreateApiKey { conn :: Text
|
|
||||||
, userName :: Text }
|
|
||||||
| DeleteUser { conn :: Text
|
| DeleteUser { conn :: Text
|
||||||
, userName :: Text}
|
, userName :: Text}
|
||||||
| DeleteApiKey { conn :: Text
|
|
||||||
, userName :: Text }
|
|
||||||
| ImportBookmarks { conn :: Text
|
| ImportBookmarks { conn :: Text
|
||||||
, userName :: Text
|
, userName :: Text
|
||||||
, bookmarkFile :: FilePath}
|
, bookmarkFile :: FilePath}
|
||||||
| ImportFirefoxBookmarks { conn :: Text
|
|
||||||
, userName :: Text
|
|
||||||
, bookmarkFile :: FilePath }
|
|
||||||
| ExportBookmarks { conn :: Text
|
| ExportBookmarks { conn :: Text
|
||||||
, userName :: Text
|
, userName :: Text
|
||||||
, bookmarkFile :: FilePath}
|
, bookmarkFile :: FilePath}
|
||||||
|
@ -78,97 +39,54 @@ main :: IO ()
|
||||||
main = do
|
main = do
|
||||||
args <- getRecord "Migrations"
|
args <- getRecord "Migrations"
|
||||||
case args of
|
case args of
|
||||||
PrintMigrateDB {..} ->
|
PrintMigrateDB conn ->
|
||||||
P.runSqlite conn dumpMigration
|
P.runSqlite conn dumpMigration
|
||||||
|
|
||||||
CreateDB {..} -> do
|
CreateDB conn -> do
|
||||||
let connInfo = P.mkSqliteConnectionInfo conn
|
let connInfo = P.mkSqliteConnectionInfo conn
|
||||||
& set P.fkEnabled False
|
& set P.fkEnabled False
|
||||||
P.runSqliteInfo connInfo runMigrations
|
P.runSqliteInfo connInfo runMigrations
|
||||||
|
|
||||||
CreateUser{..} ->
|
CreateUser conn uname upass utoken ->
|
||||||
P.runSqlite conn $ do
|
P.runSqlite conn $ do
|
||||||
passwordText <- liftIO . fmap T.strip $ case userPassword of
|
hash' <- liftIO (hashPassword upass)
|
||||||
PasswordText s -> pure s
|
|
||||||
PasswordFile f -> readFileUtf8 f
|
|
||||||
hash' <- liftIO (hashPassword passwordText)
|
|
||||||
void $ P.upsertBy
|
void $ P.upsertBy
|
||||||
(UniqueUserName userName)
|
(UniqueUserName uname)
|
||||||
(User userName hash' Nothing False False False)
|
(User uname hash' utoken False False False)
|
||||||
[ UserPasswordHash P.=. hash'
|
[ UserPasswordHash P.=. hash'
|
||||||
, UserPrivateDefault P.=. fromMaybe False privateDefault
|
, UserApiToken P.=. utoken
|
||||||
, UserArchiveDefault P.=. fromMaybe False archiveDefault
|
, UserPrivateDefault P.=. False
|
||||||
, UserPrivacyLock P.=. fromMaybe False privacyLock
|
, UserArchiveDefault P.=. False
|
||||||
|
, UserPrivacyLock P.=. False
|
||||||
]
|
]
|
||||||
pure () :: DB ()
|
pure () :: DB ()
|
||||||
|
|
||||||
CreateApiKey {..} ->
|
DeleteUser conn uname ->
|
||||||
P.runSqlite conn $ do
|
P.runSqlite conn $ do
|
||||||
apiKey@(ApiKey plainKey) <- liftIO generateApiKey
|
muser <- P.getBy (UniqueUserName uname)
|
||||||
muser <- P.getBy (UniqueUserName userName)
|
|
||||||
case muser of
|
case muser of
|
||||||
Nothing -> liftIO (print (userName ++ " not found"))
|
Nothing -> liftIO (print (uname ++ "not found"))
|
||||||
Just (P.Entity uid _) -> do
|
Just (P.Entity uid _) -> do
|
||||||
-- API key is only displayed once after creation,
|
P.deleteCascade uid
|
||||||
-- since it is stored in hashed form.
|
|
||||||
let hashedKey = hashApiKey apiKey
|
|
||||||
P.update uid [ UserApiToken P.=. Just hashedKey ]
|
|
||||||
liftIO $ print plainKey
|
|
||||||
|
|
||||||
DeleteApiKey {..} ->
|
|
||||||
P.runSqlite conn $ do
|
|
||||||
muser <- P.getBy (UniqueUserName userName)
|
|
||||||
case muser of
|
|
||||||
Nothing -> liftIO (print (userName ++ " not found"))
|
|
||||||
Just (P.Entity uid _) -> do
|
|
||||||
P.update uid [ UserApiToken P.=. Nothing ]
|
|
||||||
|
|
||||||
DeleteUser {..} ->
|
|
||||||
P.runSqlite conn $ do
|
|
||||||
muser <- P.getBy (UniqueUserName userName)
|
|
||||||
case muser of
|
|
||||||
Nothing -> liftIO (print (userName ++ "not found"))
|
|
||||||
Just (P.Entity uid _) -> do
|
|
||||||
P.delete uid
|
|
||||||
pure () :: DB ()
|
pure () :: DB ()
|
||||||
|
|
||||||
ExportBookmarks {..} ->
|
ImportBookmarks conn uname file ->
|
||||||
P.runSqlite conn $ do
|
P.runSqlite conn $ do
|
||||||
muser <- P.getBy (UniqueUserName userName)
|
muser <- P.getBy (UniqueUserName uname)
|
||||||
case muser of
|
case muser of
|
||||||
Just (P.Entity uid _) -> exportFileBookmarks uid bookmarkFile
|
Just (P.Entity uid _) -> insertFileBookmarks uid file
|
||||||
Nothing -> liftIO (print (userName ++ "not found"))
|
Nothing -> liftIO (print (uname ++ "not found"))
|
||||||
|
|
||||||
ImportBookmarks {..} ->
|
ExportBookmarks conn uname file ->
|
||||||
P.runSqlite conn $ do
|
P.runSqlite conn $ do
|
||||||
muser <- P.getBy (UniqueUserName userName)
|
muser <- P.getBy (UniqueUserName uname)
|
||||||
case muser of
|
case muser of
|
||||||
Just (P.Entity uid _) -> do
|
Just (P.Entity uid _) -> exportFileBookmarks uid file
|
||||||
result <- insertFileBookmarks uid bookmarkFile
|
Nothing -> liftIO (print (uname ++ "not found"))
|
||||||
case result of
|
|
||||||
Left e -> liftIO (print e)
|
|
||||||
Right n -> liftIO (print (show n ++ " bookmarks imported."))
|
|
||||||
Nothing -> liftIO (print (userName ++ "not found"))
|
|
||||||
|
|
||||||
|
ImportNotes conn uname dir ->
|
||||||
ImportFirefoxBookmarks {..} ->
|
|
||||||
P.runSqlite conn $ do
|
P.runSqlite conn $ do
|
||||||
muser <- P.getBy (UniqueUserName userName)
|
muser <- P.getBy (UniqueUserName uname)
|
||||||
case muser of
|
case muser of
|
||||||
Just (P.Entity uid _) -> do
|
Just (P.Entity uid _) -> insertDirFileNotes uid dir
|
||||||
result <- insertFFBookmarks uid bookmarkFile
|
Nothing -> liftIO (print (uname ++ "not found"))
|
||||||
case result of
|
|
||||||
Left e -> liftIO (print e)
|
|
||||||
Right n -> liftIO (print (show n ++ " bookmarks imported."))
|
|
||||||
Nothing -> liftIO (print (userName ++ "not found"))
|
|
||||||
|
|
||||||
ImportNotes {..} ->
|
|
||||||
P.runSqlite conn $ do
|
|
||||||
muser <- P.getBy (UniqueUserName userName)
|
|
||||||
case muser of
|
|
||||||
Just (P.Entity uid _) -> do
|
|
||||||
result <- insertDirFileNotes uid noteDirectory
|
|
||||||
case result of
|
|
||||||
Left e -> liftIO (print e)
|
|
||||||
Right n -> liftIO (print (show n ++ " notes imported."))
|
|
||||||
Nothing -> liftIO (print (userName ++ "not found"))
|
|
||||||
|
|
22
changelog.md
22
changelog.md
|
@ -1,25 +1,3 @@
|
||||||
__v0.0.15__
|
|
||||||
Avoid using external static/tmp folder for generated static files
|
|
||||||
|
|
||||||
__v0.0.14__
|
|
||||||
upgrade to purescript v0.15
|
|
||||||
increase bookmarklet window height
|
|
||||||
|
|
||||||
__v0.0.13__
|
|
||||||
add setting ALLOW_NON_HTTP_URL_SCHEMES (default false)
|
|
||||||
|
|
||||||
__v0.0.12__
|
|
||||||
update to ghc9
|
|
||||||
|
|
||||||
__v0.0.11__
|
|
||||||
add api key auth.
|
|
||||||
add CreateApiKey/DeleteApiKey commands to executable 'migration'
|
|
||||||
|
|
||||||
__v0.0.10__
|
|
||||||
update purescript&package versions
|
|
||||||
|
|
||||||
__v0.0.9__
|
|
||||||
(rolling releases)
|
|
||||||
|
|
||||||
__v0.0.7__
|
__v0.0.7__
|
||||||
|
|
||||||
|
|
|
@ -8,7 +8,6 @@
|
||||||
-- notes
|
-- notes
|
||||||
!/#UserNameP/notes NotesR GET
|
!/#UserNameP/notes NotesR GET
|
||||||
!/#UserNameP/notes/add AddNoteViewR GET
|
!/#UserNameP/notes/add AddNoteViewR GET
|
||||||
!/notes/add AddNoteSlimViewR GET
|
|
||||||
!/#UserNameP/notes/feed.xml NotesFeedR GET
|
!/#UserNameP/notes/feed.xml NotesFeedR GET
|
||||||
!/#UserNameP/notes/#NtSlug NoteR GET
|
!/#UserNameP/notes/#NtSlug NoteR GET
|
||||||
!/api/note/add AddNoteR POST
|
!/api/note/add AddNoteR POST
|
||||||
|
@ -20,11 +19,7 @@
|
||||||
!/#UserNameP/#SharedP UserSharedR GET
|
!/#UserNameP/#SharedP UserSharedR GET
|
||||||
!/#UserNameP/#FilterP UserFilterR GET
|
!/#UserNameP/#FilterP UserFilterR GET
|
||||||
!/#UserNameP/#TagsP UserTagsR GET
|
!/#UserNameP/#TagsP UserTagsR GET
|
||||||
|
|
||||||
!/#UserNameP/feed.xml UserFeedR GET
|
!/#UserNameP/feed.xml UserFeedR GET
|
||||||
!/#UserNameP/#SharedP/feed.xml UserFeedSharedR GET
|
|
||||||
!/#UserNameP/#FilterP/feed.xml UserFeedFilterR GET
|
|
||||||
!/#UserNameP/#TagsP/feed.xml UserFeedTagsR GET
|
|
||||||
|
|
||||||
-- settings
|
-- settings
|
||||||
/Settings AccountSettingsR GET
|
/Settings AccountSettingsR GET
|
||||||
|
@ -37,11 +32,6 @@ api/accountSettings EditAccountSettingsR POST
|
||||||
/add AddViewR GET
|
/add AddViewR GET
|
||||||
api/add AddR POST
|
api/add AddR POST
|
||||||
|
|
||||||
-- api
|
|
||||||
api/lookuptitle LookupTitleR POST
|
|
||||||
api/tagcloud UserTagCloudR POST
|
|
||||||
api/tagcloudmode UserTagCloudModeR POST
|
|
||||||
|
|
||||||
-- edit
|
-- edit
|
||||||
/bm/#Int64 DeleteR DELETE
|
/bm/#Int64 DeleteR DELETE
|
||||||
/bm/#Int64/read ReadR POST
|
/bm/#Int64/read ReadR POST
|
||||||
|
|
|
@ -18,8 +18,8 @@ ip-from-header: "_env:IP_FROM_HEADER:false"
|
||||||
# Optional values with the following production defaults.
|
# Optional values with the following production defaults.
|
||||||
# In development, they default to the inverse.
|
# In development, they default to the inverse.
|
||||||
#
|
#
|
||||||
detailed-logging: "_env:DETAILED_LOGGING" # false
|
# detailed-logging: false
|
||||||
should-log-all: "_env:SHOULD_LOG_ALL" # false
|
# should-log-all: false
|
||||||
# reload-templates: false
|
# reload-templates: false
|
||||||
# mutable-static: false
|
# mutable-static: false
|
||||||
# skip-combining: false
|
# skip-combining: false
|
||||||
|
@ -37,11 +37,7 @@ database:
|
||||||
copyright: Insert copyright statement here
|
copyright: Insert copyright statement here
|
||||||
#analytics: UA-YOURCODE
|
#analytics: UA-YOURCODE
|
||||||
|
|
||||||
archive-socks-proxy-host: "_env:ARCHIVE_SOCKS_PROXY_HOST"
|
ekg-host: "_env:EKG_HOST:0.0.0.0"
|
||||||
archive-socks-proxy-port: "_env:ARCHIVE_SOCKS_PROXY_PORT"
|
ekg-port: "_env:EKG_PORT:8000"
|
||||||
|
|
||||||
source-code-uri: "_env:SOURCE_CODE_URI:https://github.com/jonschoning/espial"
|
source-code-uri: "https://github.com/jonschoning/espial"
|
||||||
|
|
||||||
ssl-only: "_env:SSL_ONLY" # false
|
|
||||||
|
|
||||||
allow-non-http-url-schemes: "_env:ALLOW_NON_HTTP_URL_SCHEMES:false"
|
|
||||||
|
|
|
@ -7,16 +7,10 @@ services:
|
||||||
dockerfile: ../Dockerfile
|
dockerfile: ../Dockerfile
|
||||||
ports:
|
ports:
|
||||||
- "3000:3000"
|
- "3000:3000"
|
||||||
|
- "8000:8000"
|
||||||
volumes:
|
volumes:
|
||||||
- '$APPDATA:/app/data'
|
- '$APPDATA:/app/data'
|
||||||
network_mode: host
|
|
||||||
environment:
|
environment:
|
||||||
- IP_FROM_HEADER=true
|
- IP_FROM_HEADER=true
|
||||||
- SQLITE_DATABASE=/app/data/espial.sqlite3
|
- SQLITE_DATABASE=/app/data/espial.sqlite3
|
||||||
# - SSL_ONLY=false
|
- ekg_datadir=ekg
|
||||||
# - DETAILED_LOGGING=false
|
|
||||||
# - SHOULD_LOG_ALL=false
|
|
||||||
# - ARCHIVE_SOCKS_PROXY_HOST=localhost
|
|
||||||
# - ARCHIVE_SOCKS_PROXY_PORT=8888
|
|
||||||
# - SOURCE_CODE_URI=https://github.com/jonschoning/espial
|
|
||||||
# - ALLOW_NON_HTTP_URL_SCHEMES=false
|
|
||||||
|
|
339
espial.cabal
339
espial.cabal
|
@ -1,11 +1,13 @@
|
||||||
cabal-version: 1.12
|
cabal-version: 1.12
|
||||||
|
|
||||||
-- This file has been generated from package.yaml by hpack version 0.35.0.
|
-- This file has been generated from package.yaml by hpack version 0.31.2.
|
||||||
--
|
--
|
||||||
-- see: https://github.com/sol/hpack
|
-- see: https://github.com/sol/hpack
|
||||||
|
--
|
||||||
|
-- hash: da944088abb7ae887d67efd710c100bdbd5587072c6ddcfdc5d05392e7509d85
|
||||||
|
|
||||||
name: espial
|
name: espial
|
||||||
version: 0.0.15
|
version: 0.0.8
|
||||||
synopsis: Espial is an open-source, web-based bookmarking server.
|
synopsis: Espial is an open-source, web-based bookmarking server.
|
||||||
description: .
|
description: .
|
||||||
Espial is an open-source, web-based bookmarking server.
|
Espial is an open-source, web-based bookmarking server.
|
||||||
|
@ -62,6 +64,7 @@ extra-source-files:
|
||||||
purs/src/App.purs
|
purs/src/App.purs
|
||||||
purs/src/Globals.js
|
purs/src/Globals.js
|
||||||
purs/src/Globals.purs
|
purs/src/Globals.purs
|
||||||
|
purs/src/Main.js
|
||||||
purs/src/Main.purs
|
purs/src/Main.purs
|
||||||
purs/src/Marked.js
|
purs/src/Marked.js
|
||||||
purs/src/Marked.purs
|
purs/src/Marked.purs
|
||||||
|
@ -76,7 +79,6 @@ extra-source-files:
|
||||||
purs/src/Component/NNote.purs
|
purs/src/Component/NNote.purs
|
||||||
purs/src/Component/RawHtml.js
|
purs/src/Component/RawHtml.js
|
||||||
purs/src/Component/RawHtml.purs
|
purs/src/Component/RawHtml.purs
|
||||||
purs/src/Component/TagCloud.purs
|
|
||||||
purs/test/Main.purs
|
purs/test/Main.purs
|
||||||
|
|
||||||
source-repository head
|
source-repository head
|
||||||
|
@ -120,86 +122,48 @@ library
|
||||||
Paths_espial
|
Paths_espial
|
||||||
hs-source-dirs:
|
hs-source-dirs:
|
||||||
src
|
src
|
||||||
default-extensions:
|
default-extensions: BangPatterns CPP ConstraintKinds DataKinds DeriveDataTypeable DeriveGeneric EmptyDataDecls FlexibleContexts FlexibleInstances GADTs GeneralizedNewtypeDeriving InstanceSigs KindSignatures LambdaCase MultiParamTypeClasses MultiWayIf NoImplicitPrelude OverloadedStrings PolyKinds PolymorphicComponents QuasiQuotes Rank2Types RankNTypes RecordWildCards ScopedTypeVariables StandaloneDeriving TemplateHaskell TupleSections TypeApplications TypeFamilies TypeOperators TypeSynonymInstances ViewPatterns
|
||||||
BangPatterns
|
|
||||||
BlockArguments
|
|
||||||
CPP
|
|
||||||
ConstraintKinds
|
|
||||||
DataKinds
|
|
||||||
DeriveDataTypeable
|
|
||||||
DeriveGeneric
|
|
||||||
DerivingStrategies
|
|
||||||
EmptyDataDecls
|
|
||||||
FlexibleContexts
|
|
||||||
FlexibleInstances
|
|
||||||
GADTs
|
|
||||||
GeneralizedNewtypeDeriving
|
|
||||||
InstanceSigs
|
|
||||||
KindSignatures
|
|
||||||
LambdaCase
|
|
||||||
MultiParamTypeClasses
|
|
||||||
MultiWayIf
|
|
||||||
NoImplicitPrelude
|
|
||||||
OverloadedStrings
|
|
||||||
PolyKinds
|
|
||||||
PolymorphicComponents
|
|
||||||
PartialTypeSignatures
|
|
||||||
QuasiQuotes
|
|
||||||
Rank2Types
|
|
||||||
RankNTypes
|
|
||||||
RecordWildCards
|
|
||||||
ScopedTypeVariables
|
|
||||||
StandaloneDeriving
|
|
||||||
TemplateHaskell
|
|
||||||
TupleSections
|
|
||||||
TypeApplications
|
|
||||||
TypeFamilies
|
|
||||||
TypeOperators
|
|
||||||
TypeSynonymInstances
|
|
||||||
UndecidableInstances
|
|
||||||
ViewPatterns
|
|
||||||
build-depends:
|
build-depends:
|
||||||
aeson >=1.4
|
aeson >=1.4
|
||||||
, attoparsec
|
, attoparsec
|
||||||
, base >=4.8.2.0 && <4.9 || >=4.9.1.0 && <5
|
, base >=4.8.2.0 && <4.9 || >=4.9.1.0 && <5
|
||||||
, base64
|
|
||||||
, bcrypt >=0.0.8
|
, bcrypt >=0.0.8
|
||||||
, blaze-html >=0.9 && <1.0
|
, blaze-html >=0.9 && <1.0
|
||||||
, bytestring >=0.9 && <0.14
|
, bytestring >=0.9 && <0.11
|
||||||
, case-insensitive
|
, case-insensitive
|
||||||
, classy-prelude >=1.4 && <1.6
|
, classy-prelude >=1.4 && <1.6
|
||||||
, classy-prelude-conduit >=1.4 && <1.6
|
, classy-prelude-conduit >=1.4 && <1.6
|
||||||
, classy-prelude-yesod >=1.4 && <1.6
|
, classy-prelude-yesod >=1.4 && <1.6
|
||||||
, conduit >=1.0 && <2.0
|
, conduit >=1.0 && <2.0
|
||||||
, connection
|
|
||||||
, containers
|
, containers
|
||||||
, cryptohash-sha256
|
|
||||||
, data-default
|
, data-default
|
||||||
, directory >=1.1 && <1.4
|
, directory >=1.1 && <1.4
|
||||||
|
, ekg
|
||||||
|
, ekg-core
|
||||||
, entropy
|
, entropy
|
||||||
, esqueleto
|
, esqueleto
|
||||||
, fast-logger >=2.2 && <4
|
, fast-logger >=2.2 && <2.5
|
||||||
, file-embed
|
, file-embed
|
||||||
, foreign-store
|
, foreign-store
|
||||||
, hjsmin >=0.1 && <0.3
|
, hjsmin >=0.1 && <0.3
|
||||||
, hscolour
|
, hscolour
|
||||||
, html-entities
|
|
||||||
, http-api-data >=0.3.4
|
, http-api-data >=0.3.4
|
||||||
, http-client
|
, http-client
|
||||||
, http-client-tls ==0.3.*
|
, http-client-tls >=0.3 && <0.4
|
||||||
, http-conduit ==2.3.*
|
, http-conduit >=2.3 && <2.4
|
||||||
, http-types
|
, http-types
|
||||||
, iso8601-time >=0.1.3
|
, iso8601-time >=0.1.3
|
||||||
, microlens
|
, microlens
|
||||||
, monad-logger ==0.3.*
|
, monad-logger >=0.3 && <0.4
|
||||||
|
, monad-metrics
|
||||||
, mtl
|
, mtl
|
||||||
, parser-combinators
|
, parser-combinators
|
||||||
, persistent >=2.8 && <2.14
|
, persistent >=2.8 && <2.10
|
||||||
, persistent-sqlite >=2.6.2
|
, persistent-sqlite >=2.6.2
|
||||||
, persistent-template >=2.5 && <2.13
|
, persistent-template >=2.5 && <2.9
|
||||||
, pretty-show
|
, pretty-show
|
||||||
, safe
|
, safe
|
||||||
, shakespeare ==2.0.*
|
, shakespeare >=2.0 && <2.1
|
||||||
, template-haskell
|
, template-haskell
|
||||||
, text >=0.11 && <2.0
|
, text >=0.11 && <2.0
|
||||||
, time
|
, time
|
||||||
|
@ -207,22 +171,23 @@ library
|
||||||
, unordered-containers
|
, unordered-containers
|
||||||
, vector
|
, vector
|
||||||
, wai
|
, wai
|
||||||
, wai-extra >=3.0 && <3.2
|
, wai-extra >=3.0 && <3.1
|
||||||
, wai-logger
|
, wai-logger >=2.2 && <2.4
|
||||||
, warp >=3.0 && <3.4
|
, wai-middleware-metrics
|
||||||
|
, warp >=3.0 && <3.3
|
||||||
, yaml >=0.8 && <0.12
|
, yaml >=0.8 && <0.12
|
||||||
, yesod >=1.6 && <1.8
|
, yesod >=1.6 && <1.7
|
||||||
, yesod-auth >=1.6 && <1.8
|
, yesod-auth >=1.6 && <1.7
|
||||||
, yesod-core >=1.6 && <1.8
|
, yesod-core >=1.6 && <1.7
|
||||||
, yesod-form >=1.6 && <1.8
|
, yesod-form >=1.6 && <1.7
|
||||||
, yesod-newsfeed >=1.6 && <1.8
|
, yesod-newsfeed >=1.6 && <1.7
|
||||||
, yesod-static >=1.6 && <1.8
|
, yesod-static >=1.6 && <1.7
|
||||||
default-language: Haskell2010
|
|
||||||
if (flag(dev)) || (flag(library-only))
|
if (flag(dev)) || (flag(library-only))
|
||||||
ghc-options: -Wall -fwarn-tabs -O0
|
ghc-options: -Wall -fwarn-tabs -O0
|
||||||
cpp-options: -DDEVELOPMENT
|
cpp-options: -DDEVELOPMENT
|
||||||
else
|
else
|
||||||
ghc-options: -Wall -fwarn-tabs -O2
|
ghc-options: -Wall -fwarn-tabs -O2
|
||||||
|
default-language: Haskell2010
|
||||||
|
|
||||||
executable espial
|
executable espial
|
||||||
main-is: main.hs
|
main-is: main.hs
|
||||||
|
@ -231,88 +196,50 @@ executable espial
|
||||||
Paths_espial
|
Paths_espial
|
||||||
hs-source-dirs:
|
hs-source-dirs:
|
||||||
app
|
app
|
||||||
default-extensions:
|
default-extensions: BangPatterns CPP ConstraintKinds DataKinds DeriveDataTypeable DeriveGeneric EmptyDataDecls FlexibleContexts FlexibleInstances GADTs GeneralizedNewtypeDeriving InstanceSigs KindSignatures LambdaCase MultiParamTypeClasses MultiWayIf NoImplicitPrelude OverloadedStrings PolyKinds PolymorphicComponents QuasiQuotes Rank2Types RankNTypes RecordWildCards ScopedTypeVariables StandaloneDeriving TemplateHaskell TupleSections TypeApplications TypeFamilies TypeOperators TypeSynonymInstances ViewPatterns
|
||||||
BangPatterns
|
|
||||||
BlockArguments
|
|
||||||
CPP
|
|
||||||
ConstraintKinds
|
|
||||||
DataKinds
|
|
||||||
DeriveDataTypeable
|
|
||||||
DeriveGeneric
|
|
||||||
DerivingStrategies
|
|
||||||
EmptyDataDecls
|
|
||||||
FlexibleContexts
|
|
||||||
FlexibleInstances
|
|
||||||
GADTs
|
|
||||||
GeneralizedNewtypeDeriving
|
|
||||||
InstanceSigs
|
|
||||||
KindSignatures
|
|
||||||
LambdaCase
|
|
||||||
MultiParamTypeClasses
|
|
||||||
MultiWayIf
|
|
||||||
NoImplicitPrelude
|
|
||||||
OverloadedStrings
|
|
||||||
PolyKinds
|
|
||||||
PolymorphicComponents
|
|
||||||
PartialTypeSignatures
|
|
||||||
QuasiQuotes
|
|
||||||
Rank2Types
|
|
||||||
RankNTypes
|
|
||||||
RecordWildCards
|
|
||||||
ScopedTypeVariables
|
|
||||||
StandaloneDeriving
|
|
||||||
TemplateHaskell
|
|
||||||
TupleSections
|
|
||||||
TypeApplications
|
|
||||||
TypeFamilies
|
|
||||||
TypeOperators
|
|
||||||
TypeSynonymInstances
|
|
||||||
UndecidableInstances
|
|
||||||
ViewPatterns
|
|
||||||
ghc-options: -threaded -rtsopts -with-rtsopts=-N
|
ghc-options: -threaded -rtsopts -with-rtsopts=-N
|
||||||
build-depends:
|
build-depends:
|
||||||
aeson >=1.4
|
aeson >=1.4
|
||||||
, attoparsec
|
, attoparsec
|
||||||
, base >=4.8.2.0 && <4.9 || >=4.9.1.0 && <5
|
, base >=4.8.2.0 && <4.9 || >=4.9.1.0 && <5
|
||||||
, base64
|
|
||||||
, bcrypt >=0.0.8
|
, bcrypt >=0.0.8
|
||||||
, blaze-html >=0.9 && <1.0
|
, blaze-html >=0.9 && <1.0
|
||||||
, bytestring >=0.9 && <0.14
|
, bytestring >=0.9 && <0.11
|
||||||
, case-insensitive
|
, case-insensitive
|
||||||
, classy-prelude >=1.4 && <1.6
|
, classy-prelude >=1.4 && <1.6
|
||||||
, classy-prelude-conduit >=1.4 && <1.6
|
, classy-prelude-conduit >=1.4 && <1.6
|
||||||
, classy-prelude-yesod >=1.4 && <1.6
|
, classy-prelude-yesod >=1.4 && <1.6
|
||||||
, conduit >=1.0 && <2.0
|
, conduit >=1.0 && <2.0
|
||||||
, connection
|
|
||||||
, containers
|
, containers
|
||||||
, cryptohash-sha256
|
|
||||||
, data-default
|
, data-default
|
||||||
, directory >=1.1 && <1.4
|
, directory >=1.1 && <1.4
|
||||||
|
, ekg
|
||||||
|
, ekg-core
|
||||||
, entropy
|
, entropy
|
||||||
, espial
|
, espial
|
||||||
, esqueleto
|
, esqueleto
|
||||||
, fast-logger >=2.2 && <4
|
, fast-logger >=2.2 && <2.5
|
||||||
, file-embed
|
, file-embed
|
||||||
, foreign-store
|
, foreign-store
|
||||||
, hjsmin >=0.1 && <0.3
|
, hjsmin >=0.1 && <0.3
|
||||||
, hscolour
|
, hscolour
|
||||||
, html-entities
|
|
||||||
, http-api-data >=0.3.4
|
, http-api-data >=0.3.4
|
||||||
, http-client
|
, http-client
|
||||||
, http-client-tls ==0.3.*
|
, http-client-tls >=0.3 && <0.4
|
||||||
, http-conduit ==2.3.*
|
, http-conduit >=2.3 && <2.4
|
||||||
, http-types
|
, http-types
|
||||||
, iso8601-time >=0.1.3
|
, iso8601-time >=0.1.3
|
||||||
, microlens
|
, microlens
|
||||||
, monad-logger ==0.3.*
|
, monad-logger >=0.3 && <0.4
|
||||||
|
, monad-metrics
|
||||||
, mtl
|
, mtl
|
||||||
, parser-combinators
|
, parser-combinators
|
||||||
, persistent >=2.8 && <2.14
|
, persistent >=2.8 && <2.10
|
||||||
, persistent-sqlite >=2.6.2
|
, persistent-sqlite >=2.6.2
|
||||||
, persistent-template >=2.5 && <2.13
|
, persistent-template >=2.5 && <2.9
|
||||||
, pretty-show
|
, pretty-show
|
||||||
, safe
|
, safe
|
||||||
, shakespeare ==2.0.*
|
, shakespeare >=2.0 && <2.1
|
||||||
, template-haskell
|
, template-haskell
|
||||||
, text >=0.11 && <2.0
|
, text >=0.11 && <2.0
|
||||||
, time
|
, time
|
||||||
|
@ -320,19 +247,20 @@ executable espial
|
||||||
, unordered-containers
|
, unordered-containers
|
||||||
, vector
|
, vector
|
||||||
, wai
|
, wai
|
||||||
, wai-extra >=3.0 && <3.2
|
, wai-extra >=3.0 && <3.1
|
||||||
, wai-logger
|
, wai-logger >=2.2 && <2.4
|
||||||
, warp >=3.0 && <3.4
|
, wai-middleware-metrics
|
||||||
|
, warp >=3.0 && <3.3
|
||||||
, yaml >=0.8 && <0.12
|
, yaml >=0.8 && <0.12
|
||||||
, yesod >=1.6 && <1.8
|
, yesod >=1.6 && <1.7
|
||||||
, yesod-auth >=1.6 && <1.8
|
, yesod-auth >=1.6 && <1.7
|
||||||
, yesod-core >=1.6 && <1.8
|
, yesod-core >=1.6 && <1.7
|
||||||
, yesod-form >=1.6 && <1.8
|
, yesod-form >=1.6 && <1.7
|
||||||
, yesod-newsfeed >=1.6 && <1.8
|
, yesod-newsfeed >=1.6 && <1.7
|
||||||
, yesod-static >=1.6 && <1.8
|
, yesod-static >=1.6 && <1.7
|
||||||
default-language: Haskell2010
|
|
||||||
if flag(library-only)
|
if flag(library-only)
|
||||||
buildable: False
|
buildable: False
|
||||||
|
default-language: Haskell2010
|
||||||
|
|
||||||
executable migration
|
executable migration
|
||||||
main-is: Main.hs
|
main-is: Main.hs
|
||||||
|
@ -340,90 +268,51 @@ executable migration
|
||||||
Paths_espial
|
Paths_espial
|
||||||
hs-source-dirs:
|
hs-source-dirs:
|
||||||
app/migration
|
app/migration
|
||||||
default-extensions:
|
default-extensions: BangPatterns CPP ConstraintKinds DataKinds DeriveDataTypeable DeriveGeneric EmptyDataDecls FlexibleContexts FlexibleInstances GADTs GeneralizedNewtypeDeriving InstanceSigs KindSignatures LambdaCase MultiParamTypeClasses MultiWayIf NoImplicitPrelude OverloadedStrings PolyKinds PolymorphicComponents QuasiQuotes Rank2Types RankNTypes RecordWildCards ScopedTypeVariables StandaloneDeriving TemplateHaskell TupleSections TypeApplications TypeFamilies TypeOperators TypeSynonymInstances ViewPatterns
|
||||||
BangPatterns
|
|
||||||
BlockArguments
|
|
||||||
CPP
|
|
||||||
ConstraintKinds
|
|
||||||
DataKinds
|
|
||||||
DeriveDataTypeable
|
|
||||||
DeriveGeneric
|
|
||||||
DerivingStrategies
|
|
||||||
EmptyDataDecls
|
|
||||||
FlexibleContexts
|
|
||||||
FlexibleInstances
|
|
||||||
GADTs
|
|
||||||
GeneralizedNewtypeDeriving
|
|
||||||
InstanceSigs
|
|
||||||
KindSignatures
|
|
||||||
LambdaCase
|
|
||||||
MultiParamTypeClasses
|
|
||||||
MultiWayIf
|
|
||||||
NoImplicitPrelude
|
|
||||||
OverloadedStrings
|
|
||||||
PolyKinds
|
|
||||||
PolymorphicComponents
|
|
||||||
PartialTypeSignatures
|
|
||||||
QuasiQuotes
|
|
||||||
Rank2Types
|
|
||||||
RankNTypes
|
|
||||||
RecordWildCards
|
|
||||||
ScopedTypeVariables
|
|
||||||
StandaloneDeriving
|
|
||||||
TemplateHaskell
|
|
||||||
TupleSections
|
|
||||||
TypeApplications
|
|
||||||
TypeFamilies
|
|
||||||
TypeOperators
|
|
||||||
TypeSynonymInstances
|
|
||||||
UndecidableInstances
|
|
||||||
ViewPatterns
|
|
||||||
ghc-options: -threaded -rtsopts -with-rtsopts=-N
|
ghc-options: -threaded -rtsopts -with-rtsopts=-N
|
||||||
build-depends:
|
build-depends:
|
||||||
aeson >=1.4
|
aeson >=1.4
|
||||||
, attoparsec
|
, attoparsec
|
||||||
, base >=4.8.2.0 && <4.9 || >=4.9.1.0 && <5
|
, base >=4.8.2.0 && <4.9 || >=4.9.1.0 && <5
|
||||||
, base64
|
|
||||||
, bcrypt >=0.0.8
|
, bcrypt >=0.0.8
|
||||||
, blaze-html >=0.9 && <1.0
|
, blaze-html >=0.9 && <1.0
|
||||||
, bytestring >=0.9 && <0.14
|
, bytestring >=0.9 && <0.11
|
||||||
, case-insensitive
|
, case-insensitive
|
||||||
, classy-prelude >=1.4 && <1.6
|
, classy-prelude >=1.4 && <1.6
|
||||||
, classy-prelude-conduit >=1.4 && <1.6
|
, classy-prelude-conduit >=1.4 && <1.6
|
||||||
, classy-prelude-yesod >=1.4 && <1.6
|
, classy-prelude-yesod >=1.4 && <1.6
|
||||||
, conduit >=1.0 && <2.0
|
, conduit >=1.0 && <2.0
|
||||||
, connection
|
|
||||||
, containers
|
, containers
|
||||||
, cryptohash-sha256
|
|
||||||
, data-default
|
, data-default
|
||||||
, directory >=1.1 && <1.4
|
, directory >=1.1 && <1.4
|
||||||
|
, ekg
|
||||||
|
, ekg-core
|
||||||
, entropy
|
, entropy
|
||||||
, espial
|
, espial
|
||||||
, esqueleto
|
, esqueleto
|
||||||
, fast-logger >=2.2 && <4
|
, fast-logger >=2.2 && <2.5
|
||||||
, file-embed
|
, file-embed
|
||||||
, foreign-store
|
, foreign-store
|
||||||
, hjsmin >=0.1 && <0.3
|
, hjsmin >=0.1 && <0.3
|
||||||
, hscolour
|
, hscolour
|
||||||
, html-entities
|
|
||||||
, http-api-data >=0.3.4
|
, http-api-data >=0.3.4
|
||||||
, http-client
|
, http-client
|
||||||
, http-client-tls ==0.3.*
|
, http-client-tls >=0.3 && <0.4
|
||||||
, http-conduit ==2.3.*
|
, http-conduit >=2.3 && <2.4
|
||||||
, http-types
|
, http-types
|
||||||
, iso8601-time >=0.1.3
|
, iso8601-time >=0.1.3
|
||||||
, microlens
|
, microlens
|
||||||
, monad-logger ==0.3.*
|
, monad-logger >=0.3 && <0.4
|
||||||
|
, monad-metrics
|
||||||
, mtl
|
, mtl
|
||||||
, optparse-applicative
|
|
||||||
, optparse-generic >=1.2.3
|
, optparse-generic >=1.2.3
|
||||||
, parser-combinators
|
, parser-combinators
|
||||||
, persistent >=2.8 && <2.14
|
, persistent >=2.8 && <2.10
|
||||||
, persistent-sqlite >=2.6.2
|
, persistent-sqlite >=2.6.2
|
||||||
, persistent-template >=2.5 && <2.13
|
, persistent-template >=2.5 && <2.9
|
||||||
, pretty-show
|
, pretty-show
|
||||||
, safe
|
, safe
|
||||||
, shakespeare ==2.0.*
|
, shakespeare >=2.0 && <2.1
|
||||||
, template-haskell
|
, template-haskell
|
||||||
, text >=0.11 && <2.0
|
, text >=0.11 && <2.0
|
||||||
, time
|
, time
|
||||||
|
@ -431,19 +320,20 @@ executable migration
|
||||||
, unordered-containers
|
, unordered-containers
|
||||||
, vector
|
, vector
|
||||||
, wai
|
, wai
|
||||||
, wai-extra >=3.0 && <3.2
|
, wai-extra >=3.0 && <3.1
|
||||||
, wai-logger
|
, wai-logger >=2.2 && <2.4
|
||||||
, warp >=3.0 && <3.4
|
, wai-middleware-metrics
|
||||||
|
, warp >=3.0 && <3.3
|
||||||
, yaml >=0.8 && <0.12
|
, yaml >=0.8 && <0.12
|
||||||
, yesod >=1.6 && <1.8
|
, yesod >=1.6 && <1.7
|
||||||
, yesod-auth >=1.6 && <1.8
|
, yesod-auth >=1.6 && <1.7
|
||||||
, yesod-core >=1.6 && <1.8
|
, yesod-core >=1.6 && <1.7
|
||||||
, yesod-form >=1.6 && <1.8
|
, yesod-form >=1.6 && <1.7
|
||||||
, yesod-newsfeed >=1.6 && <1.8
|
, yesod-newsfeed >=1.6 && <1.7
|
||||||
, yesod-static >=1.6 && <1.8
|
, yesod-static >=1.6 && <1.7
|
||||||
default-language: Haskell2010
|
|
||||||
if flag(library-only)
|
if flag(library-only)
|
||||||
buildable: False
|
buildable: False
|
||||||
|
default-language: Haskell2010
|
||||||
|
|
||||||
test-suite test
|
test-suite test
|
||||||
type: exitcode-stdio-1.0
|
type: exitcode-stdio-1.0
|
||||||
|
@ -455,89 +345,51 @@ test-suite test
|
||||||
Paths_espial
|
Paths_espial
|
||||||
hs-source-dirs:
|
hs-source-dirs:
|
||||||
test
|
test
|
||||||
default-extensions:
|
default-extensions: BangPatterns CPP ConstraintKinds DataKinds DeriveDataTypeable DeriveGeneric EmptyDataDecls FlexibleContexts FlexibleInstances GADTs GeneralizedNewtypeDeriving InstanceSigs KindSignatures LambdaCase MultiParamTypeClasses MultiWayIf NoImplicitPrelude OverloadedStrings PolyKinds PolymorphicComponents QuasiQuotes Rank2Types RankNTypes RecordWildCards ScopedTypeVariables StandaloneDeriving TemplateHaskell TupleSections TypeApplications TypeFamilies TypeOperators TypeSynonymInstances ViewPatterns
|
||||||
BangPatterns
|
|
||||||
BlockArguments
|
|
||||||
CPP
|
|
||||||
ConstraintKinds
|
|
||||||
DataKinds
|
|
||||||
DeriveDataTypeable
|
|
||||||
DeriveGeneric
|
|
||||||
DerivingStrategies
|
|
||||||
EmptyDataDecls
|
|
||||||
FlexibleContexts
|
|
||||||
FlexibleInstances
|
|
||||||
GADTs
|
|
||||||
GeneralizedNewtypeDeriving
|
|
||||||
InstanceSigs
|
|
||||||
KindSignatures
|
|
||||||
LambdaCase
|
|
||||||
MultiParamTypeClasses
|
|
||||||
MultiWayIf
|
|
||||||
NoImplicitPrelude
|
|
||||||
OverloadedStrings
|
|
||||||
PolyKinds
|
|
||||||
PolymorphicComponents
|
|
||||||
PartialTypeSignatures
|
|
||||||
QuasiQuotes
|
|
||||||
Rank2Types
|
|
||||||
RankNTypes
|
|
||||||
RecordWildCards
|
|
||||||
ScopedTypeVariables
|
|
||||||
StandaloneDeriving
|
|
||||||
TemplateHaskell
|
|
||||||
TupleSections
|
|
||||||
TypeApplications
|
|
||||||
TypeFamilies
|
|
||||||
TypeOperators
|
|
||||||
TypeSynonymInstances
|
|
||||||
UndecidableInstances
|
|
||||||
ViewPatterns
|
|
||||||
ghc-options: -Wall
|
ghc-options: -Wall
|
||||||
build-depends:
|
build-depends:
|
||||||
aeson >=1.4
|
aeson >=1.4
|
||||||
, attoparsec
|
, attoparsec
|
||||||
, base >=4.8.2.0 && <4.9 || >=4.9.1.0 && <5
|
, base >=4.8.2.0 && <4.9 || >=4.9.1.0 && <5
|
||||||
, base64
|
|
||||||
, bcrypt >=0.0.8
|
, bcrypt >=0.0.8
|
||||||
, blaze-html >=0.9 && <1.0
|
, blaze-html >=0.9 && <1.0
|
||||||
, bytestring >=0.9 && <0.14
|
, bytestring >=0.9 && <0.11
|
||||||
, case-insensitive
|
, case-insensitive
|
||||||
, classy-prelude >=1.4 && <1.6
|
, classy-prelude >=1.4 && <1.6
|
||||||
, classy-prelude-conduit >=1.4 && <1.6
|
, classy-prelude-conduit >=1.4 && <1.6
|
||||||
, classy-prelude-yesod >=1.4 && <1.6
|
, classy-prelude-yesod >=1.4 && <1.6
|
||||||
, conduit >=1.0 && <2.0
|
, conduit >=1.0 && <2.0
|
||||||
, connection
|
|
||||||
, containers
|
, containers
|
||||||
, cryptohash-sha256
|
|
||||||
, data-default
|
, data-default
|
||||||
, directory >=1.1 && <1.4
|
, directory >=1.1 && <1.4
|
||||||
|
, ekg
|
||||||
|
, ekg-core
|
||||||
, entropy
|
, entropy
|
||||||
, espial
|
, espial
|
||||||
, esqueleto
|
, esqueleto
|
||||||
, fast-logger >=2.2 && <4
|
, fast-logger >=2.2 && <2.5
|
||||||
, file-embed
|
, file-embed
|
||||||
, foreign-store
|
, foreign-store
|
||||||
, hjsmin >=0.1 && <0.3
|
, hjsmin >=0.1 && <0.3
|
||||||
, hscolour
|
, hscolour
|
||||||
, hspec >=2.0.0
|
, hspec >=2.0.0
|
||||||
, html-entities
|
|
||||||
, http-api-data >=0.3.4
|
, http-api-data >=0.3.4
|
||||||
, http-client
|
, http-client
|
||||||
, http-client-tls ==0.3.*
|
, http-client-tls >=0.3 && <0.4
|
||||||
, http-conduit ==2.3.*
|
, http-conduit >=2.3 && <2.4
|
||||||
, http-types
|
, http-types
|
||||||
, iso8601-time >=0.1.3
|
, iso8601-time >=0.1.3
|
||||||
, microlens
|
, microlens
|
||||||
, monad-logger ==0.3.*
|
, monad-logger >=0.3 && <0.4
|
||||||
|
, monad-metrics
|
||||||
, mtl
|
, mtl
|
||||||
, parser-combinators
|
, parser-combinators
|
||||||
, persistent >=2.8 && <2.14
|
, persistent >=2.8 && <2.10
|
||||||
, persistent-sqlite >=2.6.2
|
, persistent-sqlite >=2.6.2
|
||||||
, persistent-template >=2.5 && <2.13
|
, persistent-template >=2.5 && <2.9
|
||||||
, pretty-show
|
, pretty-show
|
||||||
, safe
|
, safe
|
||||||
, shakespeare ==2.0.*
|
, shakespeare >=2.0 && <2.1
|
||||||
, template-haskell
|
, template-haskell
|
||||||
, text >=0.11 && <2.0
|
, text >=0.11 && <2.0
|
||||||
, time
|
, time
|
||||||
|
@ -545,15 +397,16 @@ test-suite test
|
||||||
, unordered-containers
|
, unordered-containers
|
||||||
, vector
|
, vector
|
||||||
, wai
|
, wai
|
||||||
, wai-extra >=3.0 && <3.2
|
, wai-extra >=3.0 && <3.1
|
||||||
, wai-logger
|
, wai-logger >=2.2 && <2.4
|
||||||
, warp >=3.0 && <3.4
|
, wai-middleware-metrics
|
||||||
|
, warp >=3.0 && <3.3
|
||||||
, yaml >=0.8 && <0.12
|
, yaml >=0.8 && <0.12
|
||||||
, yesod >=1.6 && <1.8
|
, yesod >=1.6 && <1.7
|
||||||
, yesod-auth >=1.6 && <1.8
|
, yesod-auth >=1.6 && <1.7
|
||||||
, yesod-core >=1.6 && <1.8
|
, yesod-core >=1.6 && <1.7
|
||||||
, yesod-form >=1.6 && <1.8
|
, yesod-form >=1.6 && <1.7
|
||||||
, yesod-newsfeed >=1.6 && <1.8
|
, yesod-newsfeed >=1.6 && <1.7
|
||||||
, yesod-static >=1.6 && <1.8
|
, yesod-static >=1.6 && <1.7
|
||||||
, yesod-test
|
, yesod-test
|
||||||
default-language: Haskell2010
|
default-language: Haskell2010
|
||||||
|
|
|
@ -1,11 +0,0 @@
|
||||||
{
|
|
||||||
"folders": [
|
|
||||||
{
|
|
||||||
"path": "."
|
|
||||||
},
|
|
||||||
{
|
|
||||||
"path": "purs"
|
|
||||||
}
|
|
||||||
],
|
|
||||||
"settings": {}
|
|
||||||
}
|
|
44
package.yaml
44
package.yaml
|
@ -1,6 +1,6 @@
|
||||||
name: espial
|
name: espial
|
||||||
synopsis: Espial is an open-source, web-based bookmarking server.
|
synopsis: Espial is an open-source, web-based bookmarking server.
|
||||||
version: "0.0.15"
|
version: "0.0.8"
|
||||||
description: ! '
|
description: ! '
|
||||||
|
|
||||||
Espial is an open-source, web-based bookmarking server.
|
Espial is an open-source, web-based bookmarking server.
|
||||||
|
@ -42,13 +42,11 @@ extra-source-files:
|
||||||
|
|
||||||
default-extensions:
|
default-extensions:
|
||||||
- BangPatterns
|
- BangPatterns
|
||||||
- BlockArguments
|
|
||||||
- CPP
|
- CPP
|
||||||
- ConstraintKinds
|
- ConstraintKinds
|
||||||
- DataKinds
|
- DataKinds
|
||||||
- DeriveDataTypeable
|
- DeriveDataTypeable
|
||||||
- DeriveGeneric
|
- DeriveGeneric
|
||||||
- DerivingStrategies
|
|
||||||
- EmptyDataDecls
|
- EmptyDataDecls
|
||||||
- FlexibleContexts
|
- FlexibleContexts
|
||||||
- FlexibleInstances
|
- FlexibleInstances
|
||||||
|
@ -63,7 +61,6 @@ default-extensions:
|
||||||
- OverloadedStrings
|
- OverloadedStrings
|
||||||
- PolyKinds
|
- PolyKinds
|
||||||
- PolymorphicComponents
|
- PolymorphicComponents
|
||||||
- PartialTypeSignatures
|
|
||||||
- QuasiQuotes
|
- QuasiQuotes
|
||||||
- Rank2Types
|
- Rank2Types
|
||||||
- RankNTypes
|
- RankNTypes
|
||||||
|
@ -76,7 +73,6 @@ default-extensions:
|
||||||
- TypeFamilies
|
- TypeFamilies
|
||||||
- TypeOperators
|
- TypeOperators
|
||||||
- TypeSynonymInstances
|
- TypeSynonymInstances
|
||||||
- UndecidableInstances
|
|
||||||
- ViewPatterns
|
- ViewPatterns
|
||||||
|
|
||||||
dependencies:
|
dependencies:
|
||||||
|
@ -85,34 +81,37 @@ dependencies:
|
||||||
# See: https://ghc.haskell.org/trac/ghc/ticket/12130
|
# See: https://ghc.haskell.org/trac/ghc/ticket/12130
|
||||||
- base >=4.8.2.0 && <4.9 || >=4.9.1.0 && <5
|
- base >=4.8.2.0 && <4.9 || >=4.9.1.0 && <5
|
||||||
|
|
||||||
- yesod >=1.6 && <1.8
|
- yesod >=1.6 && <1.7
|
||||||
- yesod-core >=1.6 && <1.8
|
- yesod-core >=1.6 && <1.7
|
||||||
- yesod-auth >=1.6 && <1.8
|
- yesod-auth >=1.6 && <1.7
|
||||||
- yesod-static >=1.6 && <1.8
|
- yesod-static >=1.6 && <1.7
|
||||||
- yesod-form >=1.6 && <1.8
|
- yesod-form >=1.6 && <1.7
|
||||||
- yesod-newsfeed >= 1.6 && < 1.8
|
- yesod-newsfeed >= 1.6 && < 1.7
|
||||||
- classy-prelude >=1.4 && <1.6
|
- classy-prelude >=1.4 && <1.6
|
||||||
- classy-prelude-conduit >=1.4 && <1.6
|
- classy-prelude-conduit >=1.4 && <1.6
|
||||||
- classy-prelude-yesod >=1.4 && <1.6
|
- classy-prelude-yesod >=1.4 && <1.6
|
||||||
- bytestring >=0.9 && <0.14
|
- bytestring >=0.9 && <0.11
|
||||||
- text >=0.11 && <2.0
|
- text >=0.11 && <2.0
|
||||||
- persistent >=2.8 && <2.14
|
- persistent >=2.8 && <2.10
|
||||||
|
# - persistent-postgresql >=2.8 && <2.9
|
||||||
- blaze-html >= 0.9 && < 1.0
|
- blaze-html >= 0.9 && < 1.0
|
||||||
- persistent-template >=2.5 && <2.13
|
- persistent-template >=2.5 && <2.9
|
||||||
- template-haskell
|
- template-haskell
|
||||||
- shakespeare >=2.0 && <2.1
|
- shakespeare >=2.0 && <2.1
|
||||||
- hjsmin >=0.1 && <0.3
|
- hjsmin >=0.1 && <0.3
|
||||||
- wai-extra >=3.0 && <3.2
|
# - monad-control >=0.3 && <1.1
|
||||||
|
- wai-extra >=3.0 && <3.1
|
||||||
- yaml >=0.8 && <0.12
|
- yaml >=0.8 && <0.12
|
||||||
- http-client-tls >=0.3 && <0.4
|
- http-client-tls >=0.3 && <0.4
|
||||||
- http-conduit >=2.3 && <2.4
|
- http-conduit >=2.3 && <2.4
|
||||||
- directory >=1.1 && <1.4
|
- directory >=1.1 && <1.4
|
||||||
- warp >=3.0 && <3.4
|
- warp >=3.0 && <3.3
|
||||||
- data-default
|
- data-default
|
||||||
|
# - aeson >=0.6 && <1.4
|
||||||
- conduit >=1.0 && <2.0
|
- conduit >=1.0 && <2.0
|
||||||
- monad-logger >=0.3 && <0.4
|
- monad-logger >=0.3 && <0.4
|
||||||
- fast-logger >=2.2 && <4
|
- fast-logger >=2.2 && <2.5
|
||||||
- wai-logger
|
- wai-logger >=2.2 && <2.4
|
||||||
- file-embed
|
- file-embed
|
||||||
- safe
|
- safe
|
||||||
- unordered-containers
|
- unordered-containers
|
||||||
|
@ -127,6 +126,8 @@ dependencies:
|
||||||
- attoparsec
|
- attoparsec
|
||||||
- bcrypt >= 0.0.8
|
- bcrypt >= 0.0.8
|
||||||
- entropy
|
- entropy
|
||||||
|
- ekg
|
||||||
|
- ekg-core
|
||||||
- esqueleto
|
- esqueleto
|
||||||
- hscolour
|
- hscolour
|
||||||
- http-api-data >= 0.3.4
|
- http-api-data >= 0.3.4
|
||||||
|
@ -134,15 +135,13 @@ dependencies:
|
||||||
- http-types
|
- http-types
|
||||||
- iso8601-time >=0.1.3
|
- iso8601-time >=0.1.3
|
||||||
- microlens
|
- microlens
|
||||||
|
- monad-metrics
|
||||||
- mtl
|
- mtl
|
||||||
- persistent-sqlite >=2.6.2
|
- persistent-sqlite >=2.6.2
|
||||||
- pretty-show
|
- pretty-show
|
||||||
- transformers >= 0.2.2
|
- transformers >= 0.2.2
|
||||||
|
- wai-middleware-metrics
|
||||||
- parser-combinators
|
- parser-combinators
|
||||||
- html-entities
|
|
||||||
- connection
|
|
||||||
- base64
|
|
||||||
- cryptohash-sha256
|
|
||||||
|
|
||||||
# The library contains all of our application code. The executable
|
# The library contains all of our application code. The executable
|
||||||
# defined below is just a thin wrapper.
|
# defined below is just a thin wrapper.
|
||||||
|
@ -187,7 +186,6 @@ executables:
|
||||||
dependencies:
|
dependencies:
|
||||||
- espial
|
- espial
|
||||||
- optparse-generic >= 1.2.3
|
- optparse-generic >= 1.2.3
|
||||||
- optparse-applicative
|
|
||||||
|
|
||||||
# Test suite
|
# Test suite
|
||||||
tests:
|
tests:
|
||||||
|
|
|
@ -1,32 +1,30 @@
|
||||||
.PHONY: clean build
|
.PHONY: clean build
|
||||||
|
|
||||||
all: bundle
|
all: build
|
||||||
|
|
||||||
install:
|
install:
|
||||||
@npm run spago install
|
spago install
|
||||||
|
|
||||||
build:
|
build:
|
||||||
@npm run spago build
|
@spago build
|
||||||
|
@spago bundle-app --to dist/bundle.js
|
||||||
bundle: build
|
@npm run parcel-build
|
||||||
@npm run esbuild-bundle
|
|
||||||
@npm run esbuild-bundle-min
|
|
||||||
@rm -f dist/*.gz
|
@rm -f dist/*.gz
|
||||||
@gzip -k dist/app.min.js.map
|
@gzip -k dist/app.min.js.map
|
||||||
@gzip -k dist/app.min.js
|
@gzip -k dist/app.min.js
|
||||||
@find dist -type f -printf "%kK\\t%h/%f\\n" | sort -k 2
|
@find dist -type f -printf "%kK\\t%h/%f\\n" | sort -k 2
|
||||||
@cp dist/app.min.js ../static/js/app.min.js
|
|
||||||
@cp dist/app.min.js.gz ../static/js/app.min.js.gz
|
|
||||||
@cp dist/app.min.js.map ../static/js/app.min.js.map
|
@cp dist/app.min.js.map ../static/js/app.min.js.map
|
||||||
@cp dist/app.min.js.map.gz ../static/js/app.min.js.map.gz
|
@cp dist/app.min.js.map.gz ../static/js/app.min.js.map.gz
|
||||||
|
@cp dist/app.min.js ../static/js/app.min.js
|
||||||
|
@cp dist/app.min.js.gz ../static/js/app.min.js.gz
|
||||||
|
|
||||||
docs:
|
docs:
|
||||||
@rm -Rf generated-docs
|
@rm -Rf generated-docs
|
||||||
@npm run purs -- docs ".spago/*/*/src/**/*.purs" --format html
|
@purs docs ".spago/*/*/src/**/*.purs" --format html
|
||||||
|
|
||||||
docset: docs
|
docset: docs
|
||||||
@(cd docset; python3 ./gen-docset.py)
|
@(cd docset; python3 ./gen-docset.py)
|
||||||
clean:
|
clean:
|
||||||
rm -f dist/*
|
rm -f dist/*
|
||||||
|
|
||||||
# inotifywait -m -r -q -e close_write --format '%T %w%f' --timefmt '%T' src | while read FILE; do echo $FILE; make build; done
|
# inotifywait -m -r -q -e close_write --format '%T %w%f' --timefmt '%T' src | while read FILE; do echo $FILE; make; done
|
||||||
|
|
|
@ -1,6 +1,6 @@
|
||||||
## Development (Posix only)
|
## Development (Posix only)
|
||||||
|
|
||||||
1. Install `purescript`, `spago`, `parcel-bundler`:
|
1. Install `purescript`, `purescript-spago`, `parcel-bundler`:
|
||||||
|
|
||||||
```
|
```
|
||||||
npm install
|
npm install
|
||||||
|
|
|
@ -12,7 +12,7 @@ from html import unescape
|
||||||
from bs4 import BeautifulSoup
|
from bs4 import BeautifulSoup
|
||||||
|
|
||||||
class Generator:
|
class Generator:
|
||||||
GENERATED_DOCS = '../generated-docs/html'
|
GENERATED_DOCS = '../generated-docs'
|
||||||
OUTPUT = 'purescript-local.docset'
|
OUTPUT = 'purescript-local.docset'
|
||||||
|
|
||||||
def documents_path(self, *paths):
|
def documents_path(self, *paths):
|
||||||
|
|
10690
purs/package-lock.json
generated
10690
purs/package-lock.json
generated
File diff suppressed because it is too large
Load diff
|
@ -2,21 +2,15 @@
|
||||||
"name": "espial",
|
"name": "espial",
|
||||||
"private": true,
|
"private": true,
|
||||||
"scripts": {
|
"scripts": {
|
||||||
"spago": "spago",
|
|
||||||
"purs": "purs",
|
|
||||||
"make-install": "make install",
|
"make-install": "make install",
|
||||||
"make-watch": "inotifywait -m -r -q -e close_write --format '%T %w%f' --timefmt '%T' src | while read FILE; do echo $FILE; make; done",
|
"make-watch": "inotifywait -m -r -q -e close_write --format '%T %w%f' --timefmt '%T' src | while read FILE; do echo $FILE; make; done",
|
||||||
"esbuild-bundle": "esbuild ./output/Main/index.js --bundle --format=iife --global-name=PS --target=chrome58,firefox57,edge18 --outfile=dist/app.js",
|
"parcel-build": "parcel build dist/bundle.js --out-file dist/app.min.js --public-url /static/js/"
|
||||||
"esbuild-bundle-min": "esbuild ./output/Main/index.js --bundle --format=iife --global-name=PS --target=chrome58,firefox57,edge18 --minify --sourcemap --outfile=dist/app.min.js"
|
|
||||||
},
|
},
|
||||||
"devDependencies": {
|
"devDependencies": {
|
||||||
"esbuild": "^0.15.12",
|
"marked": "^0.7.0",
|
||||||
"purescript": "^0.15.6",
|
"moment": "^2.24.0",
|
||||||
"spago": "0.20.9"
|
"parcel-bundler": "^1.12.3",
|
||||||
|
"terser": "^4.0.0"
|
||||||
},
|
},
|
||||||
"dependencies": {
|
"dependencies": {}
|
||||||
"dompurify": "^2.4.0",
|
|
||||||
"marked": "^4.1.1",
|
|
||||||
"moment": "^2.29.4"
|
|
||||||
}
|
|
||||||
}
|
}
|
||||||
|
|
|
@ -1,42 +1,11 @@
|
||||||
{-
|
let mkPackage =
|
||||||
### Overriding/Patching a package
|
https://raw.githubusercontent.com/purescript/package-sets/psc-0.13.3-20190818/src/mkPackage.dhall sha256:0b197efa1d397ace6eb46b243ff2d73a3da5638d8d0ac8473e8e4a8fc528cf57
|
||||||
let upstream = --
|
|
||||||
in upstream
|
|
||||||
with halogen.version = "master"
|
|
||||||
with halogen.repo = "https://example.com/path/to/git/repo.git"
|
|
||||||
with halogen-vdom.version = "v4.0.0"
|
|
||||||
|
|
||||||
### Additions
|
|
||||||
let upstream = --
|
|
||||||
in upstream
|
|
||||||
with new-package-name =
|
|
||||||
{ dependencies =
|
|
||||||
[ "dependency1"
|
|
||||||
, "dependency2"
|
|
||||||
]
|
|
||||||
, repo =
|
|
||||||
"https://example.com/path/to/git/repo.git"
|
|
||||||
, version =
|
|
||||||
"<version>"
|
|
||||||
}
|
|
||||||
-}
|
|
||||||
let upstream =
|
let upstream =
|
||||||
https://raw.githubusercontent.com/purescript/package-sets/psc-0.15.4-20221026/src/packages.dhall
|
https://raw.githubusercontent.com/purescript/package-sets/psc-0.13.3-20190818/src/packages.dhall sha256:c95c4a8b8033a48a350106b759179f68a695c7ea2208228c522866fd43814dc8
|
||||||
sha256:8dc0b394f5861bb0136f652f3f826a88eaffb2bc0ecf0251468ed668102f5d0c
|
|
||||||
|
|
||||||
in upstream
|
let overrides = {=}
|
||||||
with simple-json =
|
|
||||||
{ dependencies =
|
let additions = {=}
|
||||||
[ "arrays"
|
|
||||||
, "exceptions"
|
in upstream // overrides // additions
|
||||||
, "foreign"
|
|
||||||
, "foreign-object"
|
|
||||||
, "nullable"
|
|
||||||
, "prelude"
|
|
||||||
, "record"
|
|
||||||
, "typelevel-prelude"
|
|
||||||
, "variant"
|
|
||||||
]
|
|
||||||
, repo = "https://github.com/justinwoo/purescript-simple-json.git"
|
|
||||||
, version = "v9.0.0"
|
|
||||||
}
|
|
||||||
|
|
|
@ -1,41 +1,26 @@
|
||||||
{ sources = [ "src/**/*.purs", "test/**/*.purs" ]
|
{ sources =
|
||||||
, name = "espial"
|
[ "src/**/*.purs", "test/**/*.purs" ]
|
||||||
|
, name =
|
||||||
|
"espial"
|
||||||
, dependencies =
|
, dependencies =
|
||||||
[ "aff"
|
[ "aff"
|
||||||
|
, "simple-json"
|
||||||
, "affjax"
|
, "affjax"
|
||||||
, "affjax-web"
|
|
||||||
, "argonaut"
|
, "argonaut"
|
||||||
, "arrays"
|
, "arrays"
|
||||||
, "console"
|
, "console"
|
||||||
, "const"
|
, "debug"
|
||||||
, "dom-indexed"
|
|
||||||
, "effect"
|
, "effect"
|
||||||
, "either"
|
, "either"
|
||||||
, "foldable-traversable"
|
|
||||||
, "foreign"
|
|
||||||
, "foreign-object"
|
|
||||||
, "form-urlencoded"
|
|
||||||
, "functions"
|
, "functions"
|
||||||
, "halogen"
|
, "halogen"
|
||||||
, "http-methods"
|
|
||||||
, "integers"
|
|
||||||
, "js-uri"
|
|
||||||
, "maybe"
|
|
||||||
, "media-types"
|
|
||||||
, "newtype"
|
|
||||||
, "nullable"
|
|
||||||
, "numbers"
|
|
||||||
, "partial"
|
|
||||||
, "prelude"
|
, "prelude"
|
||||||
, "profunctor-lenses"
|
, "psci-support"
|
||||||
, "simple-json"
|
|
||||||
, "strings"
|
, "strings"
|
||||||
, "transformers"
|
, "transformers"
|
||||||
, "tuples"
|
|
||||||
, "web-dom"
|
|
||||||
, "web-events"
|
|
||||||
, "web-html"
|
, "web-html"
|
||||||
, "web-xhr"
|
, "profunctor-lenses"
|
||||||
]
|
]
|
||||||
, packages = ./packages.dhall
|
, packages =
|
||||||
|
./packages.dhall
|
||||||
}
|
}
|
||||||
|
|
|
@ -2,16 +2,15 @@ module App where
|
||||||
|
|
||||||
import Prelude
|
import Prelude
|
||||||
|
|
||||||
import Affjax.Web (Response, Error)
|
import Affjax (Response, ResponseFormatError)
|
||||||
import Affjax.Web (defaultRequest) as AX
|
import Affjax (defaultRequest) as AX
|
||||||
import Affjax.Web as Ax
|
import Affjax as Ax
|
||||||
import Affjax.RequestBody as AXReq
|
import Affjax.RequestBody as AXReq
|
||||||
import Affjax.RequestHeader (RequestHeader(..))
|
import Affjax.RequestHeader (RequestHeader(..))
|
||||||
import Affjax.ResponseFormat as AXRes
|
import Affjax.ResponseFormat as AXRes
|
||||||
import Affjax.StatusCode (StatusCode(..))
|
import Data.Argonaut (Json)
|
||||||
import Data.Argonaut (decodeJson)
|
|
||||||
import Data.Array ((:))
|
import Data.Array ((:))
|
||||||
import Data.Either (Either(..), hush)
|
import Data.Either (Either(..))
|
||||||
import Data.FormURLEncoded (FormURLEncoded)
|
import Data.FormURLEncoded (FormURLEncoded)
|
||||||
import Data.HTTP.Method (Method(..))
|
import Data.HTTP.Method (Method(..))
|
||||||
import Data.Maybe (Maybe(..))
|
import Data.Maybe (Maybe(..))
|
||||||
|
@ -19,7 +18,7 @@ import Data.MediaType.Common (applicationFormURLEncoded, applicationJSON)
|
||||||
import Effect.Aff (Aff)
|
import Effect.Aff (Aff)
|
||||||
import Effect.Class (liftEffect)
|
import Effect.Class (liftEffect)
|
||||||
import Globals (app')
|
import Globals (app')
|
||||||
import Model (Bookmark, Bookmark'(..), Note, Note'(..), AccountSettings, AccountSettings'(..), TagCloudMode, TagCloudMode'(..), TagCloud)
|
import Model (Bookmark, Bookmark'(..), Note, Note'(..), AccountSettings, AccountSettings'(..))
|
||||||
import Simple.JSON as J
|
import Simple.JSON as J
|
||||||
import Web.HTML (window)
|
import Web.HTML (window)
|
||||||
import Web.HTML.Location (reload)
|
import Web.HTML.Location (reload)
|
||||||
|
@ -35,46 +34,28 @@ toggleStar bid action = do
|
||||||
let path = "bm/" <> show bid <> "/" <> show action
|
let path = "bm/" <> show bid <> "/" <> show action
|
||||||
void (fetchUrlEnc POST path Nothing AXRes.ignore)
|
void (fetchUrlEnc POST path Nothing AXRes.ignore)
|
||||||
|
|
||||||
destroy :: Int -> Aff (Either Error (Response Unit))
|
destroy :: Int -> Aff (Response (Either ResponseFormatError Unit))
|
||||||
destroy bid =
|
destroy bid =
|
||||||
fetchUrlEnc DELETE ("bm/" <> show bid) Nothing AXRes.ignore
|
fetchUrlEnc DELETE ("bm/" <> show bid) Nothing AXRes.ignore
|
||||||
|
|
||||||
markRead :: Int -> Aff (Either Error (Response Unit))
|
markRead :: Int -> Aff (Response (Either ResponseFormatError Unit))
|
||||||
markRead bid = do
|
markRead bid = do
|
||||||
let path = "bm/" <> show bid <> "/read"
|
let path = "bm/" <> show bid <> "/read"
|
||||||
fetchUrlEnc POST path Nothing AXRes.ignore
|
fetchUrlEnc POST path Nothing AXRes.ignore
|
||||||
|
|
||||||
editBookmark :: Bookmark -> Aff (Either Error (Response String))
|
editBookmark :: Bookmark -> Aff (Response (Either ResponseFormatError Unit))
|
||||||
editBookmark bm = do
|
editBookmark bm = do
|
||||||
fetchJson POST "api/add" (Just (Bookmark' bm)) AXRes.string
|
fetchJson POST "api/add" (Just (Bookmark' bm)) AXRes.ignore
|
||||||
|
|
||||||
editNote :: Note -> Aff (Either Error (Response String))
|
editNote :: Note -> Aff (Response (Either ResponseFormatError Json))
|
||||||
editNote bm = do
|
editNote bm = do
|
||||||
fetchJson POST "api/note/add" (Just (Note' bm)) AXRes.string
|
fetchJson POST "api/note/add" (Just (Note' bm)) AXRes.json
|
||||||
|
|
||||||
lookupTitle :: Bookmark -> Aff (Maybe String)
|
destroyNote :: Int -> Aff (Response (Either ResponseFormatError Unit))
|
||||||
lookupTitle bm = do
|
|
||||||
eres <- fetchJson POST "api/lookuptitle" (Just (Bookmark' bm)) AXRes.string
|
|
||||||
pure $ hush eres >>= \res ->
|
|
||||||
if (res.status == StatusCode 200)
|
|
||||||
then Just res.body
|
|
||||||
else Nothing
|
|
||||||
|
|
||||||
getTagCloud :: TagCloudMode -> Aff (Maybe TagCloud)
|
|
||||||
getTagCloud mode = do
|
|
||||||
eres <- fetchJson POST "api/tagcloud" (Just (TagCloudMode' mode)) AXRes.json
|
|
||||||
pure $ hush eres >>= \res ->
|
|
||||||
hush (decodeJson res.body)
|
|
||||||
|
|
||||||
updateTagCloudMode :: TagCloudMode -> Aff (Either Error (Response Unit))
|
|
||||||
updateTagCloudMode mode = do
|
|
||||||
fetchJson POST "api/tagcloudmode" (Just (TagCloudMode' mode)) AXRes.ignore
|
|
||||||
|
|
||||||
destroyNote :: Int -> Aff (Either Error (Response Unit))
|
|
||||||
destroyNote nid = do
|
destroyNote nid = do
|
||||||
fetchUrlEnc DELETE ("api/note/" <> show nid) Nothing AXRes.ignore
|
fetchUrlEnc DELETE ("api/note/" <> show nid) Nothing AXRes.ignore
|
||||||
|
|
||||||
editAccountSettings :: AccountSettings -> Aff (Either Error (Response Unit))
|
editAccountSettings :: AccountSettings -> Aff (Response (Either ResponseFormatError Unit))
|
||||||
editAccountSettings us = do
|
editAccountSettings us = do
|
||||||
fetchJson POST "api/accountSettings" (Just (AccountSettings' us)) AXRes.ignore
|
fetchJson POST "api/accountSettings" (Just (AccountSettings' us)) AXRes.ignore
|
||||||
|
|
||||||
|
@ -92,7 +73,7 @@ fetchJson
|
||||||
-> String
|
-> String
|
||||||
-> Maybe b
|
-> Maybe b
|
||||||
-> AXRes.ResponseFormat a
|
-> AXRes.ResponseFormat a
|
||||||
-> Aff (Either Error (Response a))
|
-> Aff (Response (Either ResponseFormatError a))
|
||||||
fetchJson method path content rt =
|
fetchJson method path content rt =
|
||||||
fetchPath method path [ContentType applicationJSON] (AXReq.string <<< J.writeJSON <$> content) rt
|
fetchPath method path [ContentType applicationJSON] (AXReq.string <<< J.writeJSON <$> content) rt
|
||||||
|
|
||||||
|
@ -102,7 +83,7 @@ fetchUrlEnc
|
||||||
-> String
|
-> String
|
||||||
-> Maybe FormURLEncoded
|
-> Maybe FormURLEncoded
|
||||||
-> AXRes.ResponseFormat a
|
-> AXRes.ResponseFormat a
|
||||||
-> Aff (Either Error (Response a))
|
-> Aff (Response (Either ResponseFormatError a))
|
||||||
fetchUrlEnc method path content rt =
|
fetchUrlEnc method path content rt =
|
||||||
fetchPath method path [ContentType applicationFormURLEncoded] (AXReq.FormURLEncoded <$> content) rt
|
fetchPath method path [ContentType applicationFormURLEncoded] (AXReq.FormURLEncoded <$> content) rt
|
||||||
|
|
||||||
|
@ -113,7 +94,7 @@ fetchPath
|
||||||
-> Array RequestHeader
|
-> Array RequestHeader
|
||||||
-> Maybe AXReq.RequestBody
|
-> Maybe AXReq.RequestBody
|
||||||
-> AXRes.ResponseFormat a
|
-> AXRes.ResponseFormat a
|
||||||
-> Aff (Either Error (Response a))
|
-> Aff (Response (Either ResponseFormatError a))
|
||||||
fetchPath method path headers content rt =
|
fetchPath method path headers content rt =
|
||||||
fetchUrl method ((app' unit).homeR <> path) headers content rt
|
fetchUrl method ((app' unit).homeR <> path) headers content rt
|
||||||
|
|
||||||
|
@ -124,7 +105,7 @@ fetchUrl
|
||||||
-> Array RequestHeader
|
-> Array RequestHeader
|
||||||
-> Maybe AXReq.RequestBody
|
-> Maybe AXReq.RequestBody
|
||||||
-> AXRes.ResponseFormat a
|
-> AXRes.ResponseFormat a
|
||||||
-> Aff (Either Error (Response a))
|
-> Aff (Response (Either ResponseFormatError a))
|
||||||
fetchUrl method url headers content rt =
|
fetchUrl method url headers content rt =
|
||||||
Ax.request
|
Ax.request
|
||||||
AX.defaultRequest
|
AX.defaultRequest
|
||||||
|
|
|
@ -4,12 +4,14 @@ import Prelude hiding (div)
|
||||||
|
|
||||||
import App (editAccountSettings)
|
import App (editAccountSettings)
|
||||||
import Data.Lens (Lens', lens, use, (%=))
|
import Data.Lens (Lens', lens, use, (%=))
|
||||||
|
import Data.Maybe (Maybe(..))
|
||||||
import Effect.Aff (Aff)
|
import Effect.Aff (Aff)
|
||||||
|
import Globals (app')
|
||||||
import Halogen as H
|
import Halogen as H
|
||||||
import Halogen.HTML (div, input, text)
|
import Halogen.HTML (HTML, div, input, text)
|
||||||
import Halogen.HTML.Elements (label)
|
import Halogen.HTML.Elements (label)
|
||||||
import Halogen.HTML.Events (onChecked)
|
import Halogen.HTML.Events (onChecked)
|
||||||
import Halogen.HTML.Properties (InputType(..), checked, for, id, name, type_)
|
import Halogen.HTML.Properties (InputType(..), checked, for, id_, name, type_)
|
||||||
import Model (AccountSettings)
|
import Model (AccountSettings)
|
||||||
import Util (class_)
|
import Util (class_)
|
||||||
import Web.Event.Event (Event)
|
import Web.Event.Event (Event)
|
||||||
|
@ -32,7 +34,7 @@ data EditField
|
||||||
|
|
||||||
|
|
||||||
-- | The bookmark component definition.
|
-- | The bookmark component definition.
|
||||||
usetting :: forall q i o. AccountSettings -> H.Component q i o Aff
|
usetting :: forall q i o. AccountSettings -> H.Component HTML q i o Aff
|
||||||
usetting u' =
|
usetting u' =
|
||||||
H.mkComponent
|
H.mkComponent
|
||||||
{ initialState: const (mkState u')
|
{ initialState: const (mkState u')
|
||||||
|
@ -40,6 +42,7 @@ usetting u' =
|
||||||
, eval: H.mkEval $ H.defaultEval { handleAction = handleAction }
|
, eval: H.mkEval $ H.defaultEval { handleAction = handleAction }
|
||||||
}
|
}
|
||||||
where
|
where
|
||||||
|
app = app' unit
|
||||||
|
|
||||||
mkState u =
|
mkState u =
|
||||||
{ us: u
|
{ us: u
|
||||||
|
@ -50,27 +53,27 @@ usetting u' =
|
||||||
div [ class_ "settings-form" ]
|
div [ class_ "settings-form" ]
|
||||||
[ div [ class_ "fw7 mb2"] [ text "Account Settings" ]
|
[ div [ class_ "fw7 mb2"] [ text "Account Settings" ]
|
||||||
, div [ class_ "flex items-center mb2" ]
|
, div [ class_ "flex items-center mb2" ]
|
||||||
[ input [ type_ InputCheckbox , class_ "pointer mr2" , id "archiveDefault", name "archiveDefault"
|
[ input [ type_ InputCheckbox , class_ "pointer mr2" , id_ "archiveDefault", name "archiveDefault"
|
||||||
, checked (us.archiveDefault) , onChecked (editField EarchiveDefault) ]
|
, checked (us.archiveDefault) , onChecked (editField EarchiveDefault) ]
|
||||||
, label [ for "archiveDefault", class_ "lh-copy" ]
|
, label [ for "archiveDefault", class_ "lh-copy" ]
|
||||||
[ text "Archive Non-Private Bookmarks (archive.li)" ]
|
[ text "Archive Non-Private Bookmarks (archive.li)" ]
|
||||||
]
|
]
|
||||||
, div [ class_ "flex items-center mb2" ]
|
, div [ class_ "flex items-center mb2" ]
|
||||||
[ input [ type_ InputCheckbox , class_ "pointer mr2" , id "privateDefault", name "privateDefault"
|
[ input [ type_ InputCheckbox , class_ "pointer mr2" , id_ "privateDefault", name "privateDefault"
|
||||||
, checked (us.privateDefault) , onChecked (editField EprivateDefault) ]
|
, checked (us.privateDefault) , onChecked (editField EprivateDefault) ]
|
||||||
, label [ for "privateDefault", class_ "lh-copy" ]
|
, label [ for "privateDefault", class_ "lh-copy" ]
|
||||||
[ text "Default new bookmarks to Private" ]
|
[ text "Default new bookmarks to Private" ]
|
||||||
]
|
]
|
||||||
, div [ class_ "flex items-center mb2" ]
|
, div [ class_ "flex items-center mb2" ]
|
||||||
[ input [ type_ InputCheckbox , class_ "pointer mr2" , id "privacyLock", name "privacyLock"
|
[ input [ type_ InputCheckbox , class_ "pointer mr2" , id_ "privacyLock", name "privacyLock"
|
||||||
, checked (us.privacyLock) , onChecked (editField EprivacyLock) ]
|
, checked (us.privacyLock) , onChecked (editField EprivacyLock) ]
|
||||||
, label [ for "privacyLock", class_ "lh-copy" ]
|
, label [ for "privacyLock", class_ "lh-copy" ]
|
||||||
[ text "Privacy Lock (Private Account)" ]
|
[ text "Privacy Lock (Private Account)" ]
|
||||||
]
|
]
|
||||||
]
|
]
|
||||||
where
|
where
|
||||||
editField :: forall a. (a -> EditField) -> a -> UAction
|
editField :: forall a. (a -> EditField) -> a -> Maybe UAction
|
||||||
editField f = UEditField <<< f
|
editField f = Just <<< UEditField <<< f
|
||||||
|
|
||||||
handleAction :: UAction -> H.HalogenM UState UAction () o Aff Unit
|
handleAction :: UAction -> H.HalogenM UState UAction () o Aff Unit
|
||||||
handleAction (UEditField f) = do
|
handleAction (UEditField f) = do
|
||||||
|
@ -81,6 +84,6 @@ usetting u' =
|
||||||
us <- use _us
|
us <- use _us
|
||||||
void $ H.liftAff (editAccountSettings us)
|
void $ H.liftAff (editAccountSettings us)
|
||||||
|
|
||||||
handleAction (USubmit _) = do
|
handleAction (USubmit e) = do
|
||||||
us <- use _us
|
us <- use _us
|
||||||
void $ H.liftAff (editAccountSettings us)
|
void $ H.liftAff (editAccountSettings us)
|
||||||
|
|
|
@ -2,36 +2,32 @@ module Component.Add where
|
||||||
|
|
||||||
import Prelude hiding (div)
|
import Prelude hiding (div)
|
||||||
|
|
||||||
import Affjax (printError)
|
import App (destroy, editBookmark)
|
||||||
import Affjax.StatusCode (StatusCode(..))
|
import Data.Array (drop, foldMap)
|
||||||
import App (destroy, editBookmark, lookupTitle)
|
|
||||||
import Data.Either (Either(..))
|
|
||||||
import Data.Lens (Lens', lens, use, (%=), (.=))
|
import Data.Lens (Lens', lens, use, (%=), (.=))
|
||||||
import Data.Maybe (Maybe(..), fromMaybe, isJust, maybe)
|
import Data.Maybe (Maybe(..), maybe)
|
||||||
import Data.Monoid (guard)
|
import Data.Monoid (guard)
|
||||||
import Data.String (Pattern(..), null, stripPrefix)
|
import Data.String (null)
|
||||||
|
import Data.String (split) as S
|
||||||
|
import Data.String.Pattern (Pattern(..))
|
||||||
import Data.Tuple (fst, snd)
|
import Data.Tuple (fst, snd)
|
||||||
import Effect.Aff (Aff)
|
import Effect.Aff (Aff)
|
||||||
import Effect.Class (liftEffect)
|
import Effect.Class (liftEffect)
|
||||||
import Effect.Console (log)
|
import Globals (app', closeWindow, mmoment8601)
|
||||||
import Globals (closeWindow, mmoment8601)
|
|
||||||
import Halogen as H
|
import Halogen as H
|
||||||
import Halogen.HTML (button, div, form, input, label, p, span, table, tbody_, td, td_, text, textarea, tr_)
|
import Halogen.HTML (HTML, br_, button, div, form, input, label, p, span, table, tbody_, td, td_, text, textarea, tr_)
|
||||||
import Halogen.HTML.Events (onSubmit, onValueChange, onChecked, onClick)
|
import Halogen.HTML.Events (onSubmit, onValueChange, onChecked, onClick)
|
||||||
import Halogen.HTML.Properties (ButtonType(..), InputType(..), autocomplete, autofocus, checked, disabled, for, id, name, required, rows, title, type_, value)
|
import Halogen.HTML.Properties (autofocus, ButtonType(..), InputType(..), autocomplete, checked, for, id_, name, required, rows, title, type_, value)
|
||||||
import Model (Bookmark)
|
import Model (Bookmark)
|
||||||
import Util (_curQuerystring, _loc, _doc, _lookupQueryStringValue, attr, class_, ifElseH, whenH)
|
import Util (_curQuerystring, _loc, _lookupQueryStringValue, attr, class_, ifElseH, whenH)
|
||||||
import Web.Event.Event (Event, preventDefault)
|
import Web.Event.Event (Event, preventDefault)
|
||||||
import Web.HTML (window)
|
import Web.HTML (window)
|
||||||
import Web.HTML.HTMLDocument (referrer)
|
import Web.HTML.Location (setHref)
|
||||||
import Web.HTML.Location (setHref, origin)
|
|
||||||
import DOM.HTML.Indexed.AutocompleteType (AutocompleteType(..))
|
|
||||||
|
|
||||||
data BAction
|
data BAction
|
||||||
= BEditField EditField
|
= BEditField EditField
|
||||||
| BEditSubmit Event
|
| BEditSubmit Event
|
||||||
| BDeleteAsk Boolean
|
| BDeleteAsk Boolean
|
||||||
| BLookupTitle
|
|
||||||
| BDestroy
|
| BDestroy
|
||||||
|
|
||||||
data EditField
|
data EditField
|
||||||
|
@ -46,9 +42,7 @@ type BState =
|
||||||
{ bm :: Bookmark
|
{ bm :: Bookmark
|
||||||
, edit_bm :: Bookmark
|
, edit_bm :: Bookmark
|
||||||
, deleteAsk :: Boolean
|
, deleteAsk :: Boolean
|
||||||
, loading :: Boolean
|
|
||||||
, destroyed :: Boolean
|
, destroyed :: Boolean
|
||||||
, apiError :: Maybe String
|
|
||||||
}
|
}
|
||||||
|
|
||||||
_bm :: Lens' BState Bookmark
|
_bm :: Lens' BState Bookmark
|
||||||
|
@ -57,10 +51,7 @@ _bm = lens _.bm (_ { bm = _ })
|
||||||
_edit_bm :: Lens' BState Bookmark
|
_edit_bm :: Lens' BState Bookmark
|
||||||
_edit_bm = lens _.edit_bm (_ { edit_bm = _ })
|
_edit_bm = lens _.edit_bm (_ { edit_bm = _ })
|
||||||
|
|
||||||
_apiError :: Lens' BState (Maybe String)
|
addbmark :: forall q i o. Bookmark -> H.Component HTML q i o Aff
|
||||||
_apiError = lens _.apiError (_ { apiError = _ })
|
|
||||||
|
|
||||||
addbmark :: forall q i o. Bookmark -> H.Component q i o Aff
|
|
||||||
addbmark b' =
|
addbmark b' =
|
||||||
H.mkComponent
|
H.mkComponent
|
||||||
{ initialState: const (mkState b')
|
{ initialState: const (mkState b')
|
||||||
|
@ -68,64 +59,59 @@ addbmark b' =
|
||||||
, eval: H.mkEval $ H.defaultEval { handleAction = handleAction }
|
, eval: H.mkEval $ H.defaultEval { handleAction = handleAction }
|
||||||
}
|
}
|
||||||
where
|
where
|
||||||
|
app = app' unit
|
||||||
|
|
||||||
mkState b =
|
mkState b =
|
||||||
{ bm: b
|
{ bm: b
|
||||||
, edit_bm: b
|
, edit_bm: b
|
||||||
, deleteAsk: false
|
, deleteAsk: false
|
||||||
, destroyed: false
|
, destroyed: false
|
||||||
, loading: false
|
|
||||||
, apiError: Nothing
|
|
||||||
}
|
}
|
||||||
|
|
||||||
render :: forall m. BState -> H.ComponentHTML BAction () m
|
render :: forall m. BState -> H.ComponentHTML BAction () m
|
||||||
render s@{ bm, edit_bm, apiError } =
|
render s@{ bm, edit_bm } =
|
||||||
ifElseH (not s.destroyed)
|
ifElseH (not s.destroyed)
|
||||||
display_edit
|
display_edit
|
||||||
display_destroyed
|
display_destroyed
|
||||||
where
|
where
|
||||||
display_edit _ =
|
display_edit _ =
|
||||||
form [ onSubmit BEditSubmit ]
|
form [ onSubmit (Just <<< BEditSubmit) ]
|
||||||
[ table [ class_ "w-100" ]
|
[ table [ class_ "w-100" ]
|
||||||
[ tbody_
|
[ tbody_
|
||||||
[ tr_
|
[ tr_
|
||||||
[ td [ class_ "w1" ] [ ]
|
[ td [ class_ "w1" ] [ ]
|
||||||
, td_ [ whenH (bm.bid > 0)
|
, td_ [ whenH (bm.bid > 0)
|
||||||
display_exists,
|
display_exists
|
||||||
whenH (isJust apiError)
|
|
||||||
(alert_notification (fromMaybe "" apiError))
|
|
||||||
]
|
]
|
||||||
]
|
]
|
||||||
, tr_
|
, tr_
|
||||||
[ td_ [ label [ for "url" ] [ text "URL" ] ]
|
[ td_ [ label [ for "url" ] [ text "URL" ] ]
|
||||||
, td_ [ input [ type_ InputUrl , id "url", class_ "w-100 mv1" , required true, name "url", autofocus (null bm.url)
|
, td_ [ input [ type_ InputUrl , id_ "url", class_ "w-100 mv1" , required true, name "url", autofocus (null bm.url)
|
||||||
, value (edit_bm.url) , onValueChange (editField Eurl)] ]
|
, value (edit_bm.url) , onValueChange (editField Eurl)] ]
|
||||||
]
|
]
|
||||||
, tr_
|
, tr_
|
||||||
[ td_ [ label [ for "title" ] [ text "title" ] ]
|
[ td_ [ label [ for "title" ] [ text "title" ] ]
|
||||||
, td [class_ "flex"]
|
, td_ [ input [ type_ InputText , id_ "title", class_ "w-100 mv1" , name "title"
|
||||||
[ input [ type_ InputText , id "title", class_ "w-100 mv1 flex-auto" , name "title" , value (edit_bm.title) , onValueChange (editField Etitle)]
|
, value (edit_bm.title) , onValueChange (editField Etitle)] ]
|
||||||
, button [ disabled s.loading, type_ ButtonButton, onClick \_ -> BLookupTitle, class_ ("ml2 input-reset ba b--navy pointer f6 di dim pa1 ma1 mr0 " <> guard s.loading "bg-light-silver") ] [ text "fetch" ]
|
|
||||||
]
|
|
||||||
]
|
]
|
||||||
, tr_
|
, tr_
|
||||||
[ td_ [ label [ for "description" ] [ text "description" ] ]
|
[ td_ [ label [ for "description" ] [ text "description" ] ]
|
||||||
, td_ [ textarea [ class_ "w-100 mt1 mid-gray" , id "description", name "description", rows 4
|
, td_ [ textarea [ class_ "w-100 mt1 mid-gray" , id_ "description", name "description", rows 4
|
||||||
, value (edit_bm.description) , onValueChange (editField Edescription)] ]
|
, value (edit_bm.description) , onValueChange (editField Edescription)] ]
|
||||||
]
|
]
|
||||||
, tr_
|
, tr_
|
||||||
[ td_ [ label [ for "tags" ] [ text "tags" ] ]
|
[ td_ [ label [ for "tags" ] [ text "tags" ] ]
|
||||||
, td_ [ input [ type_ InputText , id "tags", class_ "w-100 mv1" , name "tags", autocomplete AutocompleteOff, attr "autocapitalize" "off", autofocus (not $ null bm.url)
|
, td_ [ input [ type_ InputText , id_ "tags", class_ "w-100 mv1" , name "tags", autocomplete false, attr "autocapitalize" "off", autofocus (not $ null bm.url)
|
||||||
, value (edit_bm.tags) , onValueChange (editField Etags)] ]
|
, value (edit_bm.tags) , onValueChange (editField Etags)] ]
|
||||||
]
|
]
|
||||||
, tr_
|
, tr_
|
||||||
[ td_ [ label [ for "private" ] [ text "private" ] ]
|
[ td_ [ label [ for "private" ] [ text "private" ] ]
|
||||||
, td_ [ input [ type_ InputCheckbox , id "private", class_ "private pointer" , name "private"
|
, td_ [ input [ type_ InputCheckbox , id_ "private", class_ "private pointer" , name "private"
|
||||||
, checked (edit_bm.private) , onChecked (editField Eprivate)] ]
|
, checked (edit_bm.private) , onChecked (editField Eprivate)] ]
|
||||||
]
|
]
|
||||||
, tr_
|
, tr_
|
||||||
[ td_ [ label [ for "toread" ] [ text "read later" ] ]
|
[ td_ [ label [ for "toread" ] [ text "read later" ] ]
|
||||||
, td_ [ input [ type_ InputCheckbox , id "toread", class_ "toread pointer" , name "toread"
|
, td_ [ input [ type_ InputCheckbox , id_ "toread", class_ "toread pointer" , name "toread"
|
||||||
, checked (edit_bm.toread) , onChecked (editField Etoread)] ]
|
, checked (edit_bm.toread) , onChecked (editField Etoread)] ]
|
||||||
]
|
]
|
||||||
, tr_
|
, tr_
|
||||||
|
@ -144,46 +130,32 @@ addbmark b' =
|
||||||
[ text (maybe " " fst mmoment) ]
|
[ text (maybe " " fst mmoment) ]
|
||||||
, div [ class_ "edit_links dib ml1" ]
|
, div [ class_ "edit_links dib ml1" ]
|
||||||
[ div [ class_ "delete_link di" ]
|
[ div [ class_ "delete_link di" ]
|
||||||
[ button ([ type_ ButtonButton, onClick \_ -> BDeleteAsk true, class_ "delete" ] <> guard s.deleteAsk [ attr "hidden" "hidden" ]) [ text "delete" ]
|
[ button ([ type_ ButtonButton, onClick \_ -> Just (BDeleteAsk true), class_ "delete" ] <> guard s.deleteAsk [ attr "hidden" "hidden" ]) [ text "delete" ]
|
||||||
, span ([ class_ "confirm red" ] <> guard (not s.deleteAsk) [ attr "hidden" "hidden" ])
|
, span ([ class_ "confirm red" ] <> guard (not s.deleteAsk) [ attr "hidden" "hidden" ])
|
||||||
[ button [ type_ ButtonButton, onClick \_ -> BDeleteAsk false] [ text "cancel / " ]
|
[ button [ type_ ButtonButton, onClick \_ -> Just (BDeleteAsk false)] [ text "cancel / " ]
|
||||||
, button [ type_ ButtonButton, onClick \_ -> BDestroy, class_ "red" ] [ text "destroy" ]
|
, button [ type_ ButtonButton, onClick \_ -> Just BDestroy, class_ "red" ] [ text "destroy" ]
|
||||||
]
|
]
|
||||||
]
|
]
|
||||||
]
|
]
|
||||||
]
|
]
|
||||||
|
|
||||||
alert_notification alert_text _ =
|
|
||||||
div [ class_ "alert alert-err" ] [ text alert_text ]
|
|
||||||
|
|
||||||
display_destroyed _ = p [ class_ "red"] [text "you killed this bookmark"]
|
display_destroyed _ = p [ class_ "red"] [text "you killed this bookmark"]
|
||||||
|
|
||||||
editField :: forall a. (a -> EditField) -> a -> BAction
|
editField :: forall a. (a -> EditField) -> a -> Maybe BAction
|
||||||
editField f = BEditField <<< f
|
editField f = Just <<< BEditField <<< f
|
||||||
mmoment = mmoment8601 bm.time
|
mmoment = mmoment8601 bm.time
|
||||||
-- toTextarea =
|
toTextarea =
|
||||||
-- drop 1
|
drop 1
|
||||||
-- <<< foldMap (\x -> [br_, text x])
|
<<< foldMap (\x -> [br_, text x])
|
||||||
-- <<< S.split (Pattern "\n")
|
<<< S.split (Pattern "\n")
|
||||||
|
|
||||||
handleAction :: BAction -> H.HalogenM BState BAction () o Aff Unit
|
handleAction :: BAction -> H.HalogenM BState BAction () o Aff Unit
|
||||||
handleAction (BDeleteAsk e) = do
|
handleAction (BDeleteAsk e) = do
|
||||||
H.modify_ (_ { deleteAsk = e })
|
H.modify_ (_ { deleteAsk = e })
|
||||||
|
|
||||||
handleAction BLookupTitle = do
|
|
||||||
H.modify_ (_ { loading = true })
|
|
||||||
edit_bm <- H.gets _.edit_bm
|
|
||||||
mtitle <- H.liftAff $ lookupTitle edit_bm
|
|
||||||
case mtitle of
|
|
||||||
Just title' -> _edit_bm %= (_ { title = title' })
|
|
||||||
Nothing -> pure $ unit
|
|
||||||
H.modify_ (_ { loading = false })
|
|
||||||
|
|
||||||
handleAction (BDestroy) = do
|
handleAction (BDestroy) = do
|
||||||
bid <- H.gets _.bm.bid
|
bid <- H.gets _.bm.bid
|
||||||
void $ H.liftAff (destroy bid)
|
void $ H.liftAff (destroy bid)
|
||||||
H.modify_ (_ { destroyed = true })
|
H.modify_ (_ { destroyed = true })
|
||||||
|
|
||||||
handleAction (BEditField f) = do
|
handleAction (BEditField f) = do
|
||||||
_edit_bm %= case f of
|
_edit_bm %= case f of
|
||||||
Eurl e -> _ { url = e }
|
Eurl e -> _ { url = e }
|
||||||
|
@ -192,29 +164,14 @@ addbmark b' =
|
||||||
Etags e -> _ { tags = e }
|
Etags e -> _ { tags = e }
|
||||||
Eprivate e -> _ { private = e }
|
Eprivate e -> _ { private = e }
|
||||||
Etoread e -> _ { toread = e }
|
Etoread e -> _ { toread = e }
|
||||||
|
|
||||||
handleAction (BEditSubmit e) = do
|
handleAction (BEditSubmit e) = do
|
||||||
liftEffect (preventDefault e)
|
H.liftEffect (preventDefault e)
|
||||||
edit_bm <- use _edit_bm
|
edit_bm <- use _edit_bm
|
||||||
_apiError .= Nothing
|
void $ H.liftAff (editBookmark edit_bm)
|
||||||
H.liftAff (editBookmark edit_bm) >>= case _ of
|
|
||||||
Left affErr -> do
|
|
||||||
_apiError .= Just (printError affErr)
|
|
||||||
liftEffect $ log (printError affErr)
|
|
||||||
Right { status: StatusCode s } | s >= 200 && s < 300 -> do
|
|
||||||
_bm .= edit_bm
|
_bm .= edit_bm
|
||||||
qs <- liftEffect $ _curQuerystring
|
loc <- liftEffect _loc
|
||||||
doc <- liftEffect $ _doc
|
win <- liftEffect window
|
||||||
ref <- liftEffect $ referrer doc
|
qs <- liftEffect _curQuerystring
|
||||||
loc <- liftEffect $ _loc
|
|
||||||
org <- liftEffect $ origin loc
|
|
||||||
case _lookupQueryStringValue qs "next" of
|
case _lookupQueryStringValue qs "next" of
|
||||||
Just "closeWindow" -> liftEffect $ closeWindow =<< window
|
Just n -> liftEffect (setHref n loc)
|
||||||
Just "back" -> liftEffect $
|
_ -> liftEffect (closeWindow win)
|
||||||
case stripPrefix (Pattern org) ref of
|
|
||||||
Just _ -> setHref ref loc
|
|
||||||
Nothing -> setHref org loc
|
|
||||||
_ -> liftEffect $ closeWindow =<< window
|
|
||||||
Right res -> do
|
|
||||||
_apiError .= Just (res.body)
|
|
||||||
liftEffect $ log (res.body)
|
|
||||||
|
|
|
@ -6,10 +6,11 @@ import Component.BMark (BMessage(..), BSlot, bmark)
|
||||||
import Model (Bookmark, BookmarkId)
|
import Model (Bookmark, BookmarkId)
|
||||||
|
|
||||||
import Data.Array (filter)
|
import Data.Array (filter)
|
||||||
|
import Data.Maybe (Maybe(..))
|
||||||
import Effect.Aff (Aff)
|
import Effect.Aff (Aff)
|
||||||
import Halogen as H
|
import Halogen as H
|
||||||
import Halogen.HTML as HH
|
import Halogen.HTML as HH
|
||||||
import Type.Proxy (Proxy(..))
|
import Data.Symbol (SProxy(..))
|
||||||
|
|
||||||
data LAction =
|
data LAction =
|
||||||
HandleBMessage BookmarkId BMessage
|
HandleBMessage BookmarkId BMessage
|
||||||
|
@ -18,9 +19,9 @@ type ChildSlots =
|
||||||
( bookmark :: BSlot Int
|
( bookmark :: BSlot Int
|
||||||
)
|
)
|
||||||
|
|
||||||
_bookmark = Proxy :: Proxy "bookmark"
|
_bookmark = SProxy :: SProxy "bookmark"
|
||||||
|
|
||||||
blist :: forall q i o. Array Bookmark -> H.Component q i o Aff
|
blist :: forall q i o. Array Bookmark -> H.Component HH.HTML q i o Aff
|
||||||
blist st =
|
blist st =
|
||||||
H.mkComponent
|
H.mkComponent
|
||||||
{ initialState: const st
|
{ initialState: const st
|
||||||
|
@ -31,7 +32,7 @@ blist st =
|
||||||
|
|
||||||
render :: Array Bookmark -> H.ComponentHTML LAction ChildSlots Aff
|
render :: Array Bookmark -> H.ComponentHTML LAction ChildSlots Aff
|
||||||
render bms =
|
render bms =
|
||||||
HH.div_ $ map (\b -> HH.slot _bookmark b.bid (bmark b) unit (HandleBMessage b.bid)) bms
|
HH.div_ $ map (\b -> HH.slot _bookmark b.bid (bmark b) unit (Just <<< HandleBMessage b.bid)) bms
|
||||||
|
|
||||||
handleAction :: LAction -> H.HalogenM (Array Bookmark) LAction ChildSlots o Aff Unit
|
handleAction :: LAction -> H.HalogenM (Array Bookmark) LAction ChildSlots o Aff Unit
|
||||||
handleAction (HandleBMessage bid BNotifyRemove) = do
|
handleAction (HandleBMessage bid BNotifyRemove) = do
|
||||||
|
|
|
@ -2,38 +2,31 @@ module Component.BMark where
|
||||||
|
|
||||||
import Prelude hiding (div)
|
import Prelude hiding (div)
|
||||||
|
|
||||||
import Affjax (printError)
|
import App (StarAction(..), destroy, editBookmark, markRead, toggleStar)
|
||||||
import Affjax.StatusCode (StatusCode(..))
|
|
||||||
import App (StarAction(..), destroy, editBookmark, markRead, toggleStar, lookupTitle)
|
|
||||||
import Component.Markdown as Markdown
|
import Component.Markdown as Markdown
|
||||||
import Data.Const (Const)
|
import Data.Const (Const)
|
||||||
import Data.Either (Either(..))
|
|
||||||
import Data.Lens (Lens', lens, use, (%=), (.=))
|
import Data.Lens (Lens', lens, use, (%=), (.=))
|
||||||
import Data.Maybe (Maybe(..), fromMaybe, isJust)
|
import Data.Maybe (Maybe(..), fromMaybe, isJust)
|
||||||
import Data.Monoid (guard)
|
import Data.Monoid (guard)
|
||||||
import Data.Nullable (toMaybe)
|
import Data.Nullable (toMaybe)
|
||||||
import Data.String (null, split, take, replaceAll) as S
|
import Data.String (null, split, take) as S
|
||||||
import Data.String.Pattern (Pattern(..), Replacement(..))
|
import Data.String.Pattern (Pattern(..))
|
||||||
|
import Data.Symbol (SProxy(..))
|
||||||
import Effect.Aff (Aff)
|
import Effect.Aff (Aff)
|
||||||
import Effect.Class (liftEffect)
|
import Globals (app')
|
||||||
import Effect.Class.Console (log)
|
|
||||||
import Globals (app', setFocus, toLocaleDateString)
|
|
||||||
import Halogen as H
|
import Halogen as H
|
||||||
import Halogen.HTML (a, br_, button, div, div_, form, input, label, span, text, textarea)
|
import Halogen.HTML (HTML, a, br_, button, div, div_, form, input, label, span, text, textarea)
|
||||||
import Halogen.HTML as HH
|
import Halogen.HTML as HH
|
||||||
import Halogen.HTML.Events (onSubmit, onValueChange, onChecked, onClick)
|
import Halogen.HTML.Events (onSubmit, onValueChange, onChecked, onClick)
|
||||||
import Halogen.HTML.Properties (ButtonType(..), InputType(..), autocomplete, checked, disabled, for, href, id, name, required, rows, target, title, type_, value)
|
import Halogen.HTML.Properties (ButtonType(..), InputType(..), autocomplete, checked, for, href, id_, name, required, rows, target, title, type_, value)
|
||||||
import Model (Bookmark)
|
import Model (Bookmark)
|
||||||
import Type.Proxy (Proxy(..))
|
import Util (attr, class_, fromNullableStr, ifElseH, whenH, whenA)
|
||||||
import Util (attr, class_, encodeTag, fromNullableStr, ifElseH, whenA, whenH)
|
|
||||||
import Web.Event.Event (Event, preventDefault)
|
import Web.Event.Event (Event, preventDefault)
|
||||||
import DOM.HTML.Indexed.AutocompleteType (AutocompleteType(..))
|
|
||||||
|
|
||||||
-- | UI Events
|
-- | UI Events
|
||||||
data BAction
|
data BAction
|
||||||
= BStar Boolean
|
= BStar Boolean
|
||||||
| BDeleteAsk Boolean
|
| BDeleteAsk Boolean
|
||||||
| BLookupTitle
|
|
||||||
| BDestroy
|
| BDestroy
|
||||||
| BEdit Boolean
|
| BEdit Boolean
|
||||||
| BEditField EditField
|
| BEditField EditField
|
||||||
|
@ -60,8 +53,6 @@ type BState =
|
||||||
, edit_bm :: Bookmark
|
, edit_bm :: Bookmark
|
||||||
, deleteAsk:: Boolean
|
, deleteAsk:: Boolean
|
||||||
, edit :: Boolean
|
, edit :: Boolean
|
||||||
, loading :: Boolean
|
|
||||||
, apiError :: Maybe String
|
|
||||||
}
|
}
|
||||||
|
|
||||||
_bm :: Lens' BState Bookmark
|
_bm :: Lens' BState Bookmark
|
||||||
|
@ -73,16 +64,13 @@ _edit_bm = lens _.edit_bm (_ { edit_bm = _ })
|
||||||
_edit :: Lens' BState Boolean
|
_edit :: Lens' BState Boolean
|
||||||
_edit = lens _.edit (_ { edit = _ })
|
_edit = lens _.edit (_ { edit = _ })
|
||||||
|
|
||||||
_apiError :: Lens' BState (Maybe String)
|
_markdown = SProxy :: SProxy "markdown"
|
||||||
_apiError = lens _.apiError (_ { apiError = _ })
|
|
||||||
|
|
||||||
_markdown = Proxy :: Proxy "markdown"
|
|
||||||
|
|
||||||
type ChildSlots =
|
type ChildSlots =
|
||||||
( markdown :: Markdown.Slot Unit
|
( markdown :: Markdown.Slot Unit
|
||||||
)
|
)
|
||||||
|
|
||||||
bmark :: forall q i. Bookmark -> H.Component q i BMessage Aff
|
bmark :: forall q i. Bookmark -> H.Component HTML q i BMessage Aff
|
||||||
bmark b' =
|
bmark b' =
|
||||||
H.mkComponent
|
H.mkComponent
|
||||||
{ initialState: const (mkState b')
|
{ initialState: const (mkState b')
|
||||||
|
@ -97,13 +85,11 @@ bmark b' =
|
||||||
, edit_bm: b
|
, edit_bm: b
|
||||||
, deleteAsk: false
|
, deleteAsk: false
|
||||||
, edit: false
|
, edit: false
|
||||||
, loading: false
|
|
||||||
, apiError: Nothing
|
|
||||||
}
|
}
|
||||||
|
|
||||||
render :: BState -> H.ComponentHTML BAction ChildSlots Aff
|
render :: BState -> H.ComponentHTML BAction ChildSlots Aff
|
||||||
render s@{ bm, edit_bm, apiError } =
|
render s@{ bm, edit_bm } =
|
||||||
div [ id (show bm.bid) , class_ ("bookmark w-100 mw7 pa1 mb3" <> guard bm.private " private")] $
|
div [ id_ (show bm.bid) , class_ ("bookmark w-100 mw7 pa1 mb3" <> guard bm.private " private")] $
|
||||||
[ whenH app.dat.isowner
|
[ whenH app.dat.isowner
|
||||||
star
|
star
|
||||||
, ifElseH s.edit
|
, ifElseH s.edit
|
||||||
|
@ -115,7 +101,7 @@ bmark b' =
|
||||||
|
|
||||||
star _ =
|
star _ =
|
||||||
div [ class_ ("star fl pointer" <> guard bm.selected " selected") ]
|
div [ class_ ("star fl pointer" <> guard bm.selected " selected") ]
|
||||||
[ button [ class_ "moon-gray", onClick \_ -> BStar (not bm.selected) ] [ text "✭" ] ]
|
[ button [ class_ "moon-gray", onClick \_ -> Just (BStar (not bm.selected)) ] [ text "✭" ] ]
|
||||||
|
|
||||||
display _ =
|
display _ =
|
||||||
div [ class_ "display" ] $
|
div [ class_ "display" ] $
|
||||||
|
@ -136,18 +122,18 @@ bmark b' =
|
||||||
[ text tag ])
|
[ text tag ])
|
||||||
(S.split (Pattern " ") bm.tags)
|
(S.split (Pattern " ") bm.tags)
|
||||||
|
|
||||||
, a [ class_ "link f7 dib gray w4", href (linkToFilterSingle bm.slug), title shdatetime ]
|
, a [ class_ "link f7 dib gray w4", href (linkToFilterSingle bm.slug) ]
|
||||||
[ text shdate ]
|
[ text shtime ]
|
||||||
|
|
||||||
-- links
|
-- links
|
||||||
, whenH app.dat.isowner $ \_ ->
|
, whenH app.dat.isowner $ \_ ->
|
||||||
div [ class_ "edit_links di" ]
|
div [ class_ "edit_links di" ]
|
||||||
[ button [ type_ ButtonButton, onClick \_ -> BEdit true, class_ "edit light-silver hover-blue" ] [ text "edit " ]
|
[ button [ type_ ButtonButton, onClick \_ -> Just (BEdit true), class_ "edit light-silver hover-blue" ] [ text "edit " ]
|
||||||
, div [ class_ "delete_link di" ]
|
, div [ class_ "delete_link di" ]
|
||||||
[ button [ type_ ButtonButton, onClick \_ -> BDeleteAsk true, class_ ("delete light-silver hover-blue" <> guard s.deleteAsk " dn") ] [ text "delete" ]
|
[ button [ type_ ButtonButton, onClick \_ -> Just (BDeleteAsk true), class_ ("delete light-silver hover-blue" <> guard s.deleteAsk " dn") ] [ text "delete" ]
|
||||||
, span ([ class_ ("confirm red" <> guard (not s.deleteAsk) " dn") ] )
|
, span ([ class_ ("confirm red" <> guard (not s.deleteAsk) " dn") ] )
|
||||||
[ button [ type_ ButtonButton, onClick \_ -> BDeleteAsk false] [ text "cancel / " ]
|
[ button [ type_ ButtonButton, onClick \_ -> Just (BDeleteAsk false)] [ text "cancel / " ]
|
||||||
, button [ type_ ButtonButton, onClick \_ -> BDestroy, class_ "red" ] [ text "destroy" ]
|
, button [ type_ ButtonButton, onClick \_ -> Just BDestroy, class_ "red" ] [ text "destroy" ]
|
||||||
]
|
]
|
||||||
]
|
]
|
||||||
]
|
]
|
||||||
|
@ -155,63 +141,58 @@ bmark b' =
|
||||||
div [ class_ "read di" ] $
|
div [ class_ "read di" ] $
|
||||||
guard bm.toread
|
guard bm.toread
|
||||||
[ text " "
|
[ text " "
|
||||||
, button [ onClick \_ -> BMarkRead, class_ "mark_read" ] [ text "mark as read"]
|
, button [ onClick \_ -> Just BMarkRead, class_ "mark_read" ] [ text "mark as read"]
|
||||||
]
|
]
|
||||||
]
|
]
|
||||||
|
|
||||||
|
|
||||||
display_edit _ =
|
display_edit _ =
|
||||||
div [ class_ "edit_bookmark_form pa2 pt0 bg-white" ] $
|
div [ class_ "edit_bookmark_form pa2 pt0 bg-white" ] $
|
||||||
[ whenH (isJust apiError)
|
[ form [ onSubmit (Just <<< BEditSubmit) ]
|
||||||
(alert_notification (fromMaybe "" apiError))
|
|
||||||
, form [ onSubmit BEditSubmit ]
|
|
||||||
[ div_ [ text "url" ]
|
[ div_ [ text "url" ]
|
||||||
, input [ type_ InputUrl , class_ "url w-100 mb2 pt1 edit_form_input" , required true , name "url"
|
, input [ type_ InputUrl , class_ "url w-100 mb2 pt1 f7 edit_form_input" , required true , name "url"
|
||||||
, value (edit_bm.url) , onValueChange (editField Eurl) ]
|
, value (edit_bm.url) , onValueChange (editField Eurl) ]
|
||||||
|
, br_
|
||||||
, div_ [ text "title" ]
|
, div_ [ text "title" ]
|
||||||
, div [class_ "flex"]
|
, input [ type_ InputText , class_ "title w-100 mb2 pt1 f7 edit_form_input" , name "title"
|
||||||
[input [ type_ InputText , class_ "title w-100 mb2 pt1 edit_form_input" , name "title"
|
|
||||||
, value (edit_bm.title) , onValueChange (editField Etitle) ]
|
, value (edit_bm.title) , onValueChange (editField Etitle) ]
|
||||||
, button [ disabled s.loading, type_ ButtonButton, onClick \_ -> BLookupTitle, class_ ("ml1 pa1 mb2 dark-gray ba b--moon-gray bg-near-white pointer rdim f7 " <> guard s.loading "bg-light-silver") ] [ text "fetch" ]
|
, br_
|
||||||
]
|
|
||||||
, div_ [ text "description" ]
|
, div_ [ text "description" ]
|
||||||
, textarea [ class_ "description w-100 mb1 pt1 edit_form_input" , name "description", rows 5
|
, textarea [ class_ "description w-100 mb1 pt1 f7 edit_form_input" , name "description", rows 5
|
||||||
, value (edit_bm.description) , onValueChange (editField Edescription) ]
|
, value (edit_bm.description) , onValueChange (editField Edescription) ]
|
||||||
, div [ id "tags_input_box"]
|
, br_
|
||||||
|
, div [ id_ "tags_input_box"]
|
||||||
[ div_ [ text "tags" ]
|
[ div_ [ text "tags" ]
|
||||||
, input [ id (tagid edit_bm), type_ InputText , class_ "tags w-100 mb1 pt1 edit_form_input" , name "tags"
|
, input [ type_ InputText , class_ "tags w-100 mb1 pt1 f7 edit_form_input" , name "tags"
|
||||||
, autocomplete AutocompleteOff, attr "autocapitalize" "off"
|
, autocomplete false, attr "autocapitalize" "off"
|
||||||
, value (edit_bm.tags) , onValueChange (editField Etags) ]
|
, value (edit_bm.tags) , onValueChange (editField Etags) ]
|
||||||
|
, br_
|
||||||
]
|
]
|
||||||
, div [ class_ "edit_form_checkboxes mv3"]
|
, div [ class_ "edit_form_checkboxes mv3"]
|
||||||
[ input [ type_ InputCheckbox , class_ "private pointer" , id "edit_private", name "private"
|
[ input [ type_ InputCheckbox , class_ "private pointer" , id_ "edit_private", name "private"
|
||||||
, checked (edit_bm.private) , onChecked (editField Eprivate) ]
|
, checked (edit_bm.private) , onChecked (editField Eprivate) ]
|
||||||
, text " "
|
, text " "
|
||||||
, label [ for "edit_private" , class_ "mr2" ] [ text "private" ]
|
, label [ for "edit_private" , class_ "mr2" ] [ text "private" ]
|
||||||
, text " "
|
, text " "
|
||||||
, input [ type_ InputCheckbox , class_ "toread pointer" , id "edit_toread", name "toread"
|
, input [ type_ InputCheckbox , class_ "toread pointer" , id_ "edit_toread", name "toread"
|
||||||
, checked (edit_bm.toread) , onChecked (editField Etoread) ]
|
, checked (edit_bm.toread) , onChecked (editField Etoread) ]
|
||||||
, text " "
|
, text " "
|
||||||
, label [ for "edit_toread" ] [ text "to-read" ]
|
, label [ for "edit_toread" ] [ text "to-read" ]
|
||||||
|
, br_
|
||||||
]
|
]
|
||||||
, input [ type_ InputSubmit , class_ "mr1 pv1 ph2 dark-gray ba b--moon-gray bg-near-white pointer rdim" , value "save" ]
|
, input [ type_ InputSubmit , class_ "mr1 pv1 ph2 dark-gray ba b--moon-gray bg-near-white pointer rdim" , value "save" ]
|
||||||
, text " "
|
, text " "
|
||||||
, input [ type_ InputReset , class_ "pv1 ph2 dark-gray ba b--moon-gray bg-near-white pointer rdim" , value "cancel"
|
, input [ type_ InputReset , class_ "pv1 ph2 dark-gray ba b--moon-gray bg-near-white pointer rdim" , value "cancel"
|
||||||
, onClick \_ -> BEdit false ]
|
, onClick \_ -> Just (BEdit false) ]
|
||||||
]
|
]
|
||||||
]
|
]
|
||||||
|
|
||||||
alert_notification alert_text _ =
|
|
||||||
div [ class_ "alert alert-err" ] [ text alert_text ]
|
|
||||||
|
|
||||||
editField :: forall a. (a -> EditField) -> a -> BAction
|
editField :: forall a. (a -> EditField) -> a -> Maybe BAction
|
||||||
editField f = BEditField <<< f
|
editField f = Just <<< BEditField <<< f
|
||||||
linkToFilterSingle slug = fromNullableStr app.userR <> "/b:" <> slug
|
linkToFilterSingle slug = fromNullableStr app.userR <> "/b:" <> slug
|
||||||
linkToFilterTag tag = fromNullableStr app.userR <> "/t:" <> encodeTag tag
|
linkToFilterTag tag = fromNullableStr app.userR <> "/t:" <> tag
|
||||||
shdate = toLocaleDateString bm.time
|
shtime = S.take 16 bm.time `append` "Z"
|
||||||
shdatetime = S.take 16 bm.time `append` "Z"
|
|
||||||
|
|
||||||
tagid bm = show bm.bid <> "_tags"
|
|
||||||
|
|
||||||
handleAction :: BAction -> H.HalogenM BState BAction ChildSlots BMessage Aff Unit
|
handleAction :: BAction -> H.HalogenM BState BAction ChildSlots BMessage Aff Unit
|
||||||
|
|
||||||
|
@ -243,10 +224,6 @@ bmark b' =
|
||||||
bm <- use _bm
|
bm <- use _bm
|
||||||
_edit_bm .= bm
|
_edit_bm .= bm
|
||||||
_edit .= e
|
_edit .= e
|
||||||
_apiError .= Nothing
|
|
||||||
H.liftEffect $
|
|
||||||
when e
|
|
||||||
(setFocus (tagid bm))
|
|
||||||
|
|
||||||
-- | Update Form Field
|
-- | Update Form Field
|
||||||
handleAction (BEditField f) = do
|
handleAction (BEditField f) = do
|
||||||
|
@ -258,29 +235,10 @@ bmark b' =
|
||||||
Eprivate e -> _ { private = e }
|
Eprivate e -> _ { private = e }
|
||||||
Etoread e -> _ { toread = e }
|
Etoread e -> _ { toread = e }
|
||||||
|
|
||||||
-- | Lookup Title
|
|
||||||
handleAction BLookupTitle = do
|
|
||||||
H.modify_ (_ { loading = true })
|
|
||||||
edit_bm <- H.gets _.edit_bm
|
|
||||||
mtitle <- H.liftAff $ lookupTitle edit_bm
|
|
||||||
case mtitle of
|
|
||||||
Just title' -> _edit_bm %= (_ { title = title' })
|
|
||||||
Nothing -> pure $ unit
|
|
||||||
H.modify_ (_ { loading = false })
|
|
||||||
|
|
||||||
-- | Submit
|
-- | Submit
|
||||||
handleAction (BEditSubmit e) = do
|
handleAction (BEditSubmit e) = do
|
||||||
H.liftEffect (preventDefault e)
|
H.liftEffect (preventDefault e)
|
||||||
edit_bm <- use _edit_bm
|
edit_bm <- use _edit_bm
|
||||||
_apiError .= Nothing
|
void $ H.liftAff (editBookmark edit_bm)
|
||||||
let edit_bm' = edit_bm { tags = S.replaceAll (Pattern ",") (Replacement " ") edit_bm.tags }
|
_bm .= edit_bm
|
||||||
H.liftAff (editBookmark edit_bm') >>= case _ of
|
|
||||||
Left affErr -> do
|
|
||||||
_apiError .= Just (printError affErr)
|
|
||||||
liftEffect $ log (printError affErr)
|
|
||||||
Right { status: StatusCode s } | s >= 200 && s < 300 -> do
|
|
||||||
_bm .= edit_bm'
|
|
||||||
_edit .= false
|
_edit .= false
|
||||||
Right res -> do
|
|
||||||
_apiError .= Just (res.body)
|
|
||||||
liftEffect $ log (res.body)
|
|
||||||
|
|
|
@ -5,9 +5,10 @@ import Data.Const (Const)
|
||||||
import Effect.Aff (Aff)
|
import Effect.Aff (Aff)
|
||||||
import Foreign.Marked (marked)
|
import Foreign.Marked (marked)
|
||||||
import Halogen as H
|
import Halogen as H
|
||||||
|
import Halogen.HTML as HH
|
||||||
import Prelude (Void)
|
import Prelude (Void)
|
||||||
|
|
||||||
type Slot = H.Slot (Const Void) Void
|
type Slot = H.Slot (Const Void) Void
|
||||||
|
|
||||||
component :: forall q o. H.Component q String o Aff
|
component :: forall q o. H.Component HH.HTML q String o Aff
|
||||||
component = RH.mkComponent marked
|
component = RH.mkComponent marked
|
||||||
|
|
|
@ -12,7 +12,7 @@ import Globals (app', mmoment8601)
|
||||||
import Halogen as H
|
import Halogen as H
|
||||||
import Halogen.HTML (a, br_, div, text)
|
import Halogen.HTML (a, br_, div, text)
|
||||||
import Halogen.HTML as HH
|
import Halogen.HTML as HH
|
||||||
import Halogen.HTML.Properties (href, id, title)
|
import Halogen.HTML.Properties (href, id_, title)
|
||||||
import Model (Note, NoteSlug)
|
import Model (Note, NoteSlug)
|
||||||
import Util (class_, fromNullableStr)
|
import Util (class_, fromNullableStr)
|
||||||
|
|
||||||
|
@ -27,7 +27,7 @@ type NLState =
|
||||||
}
|
}
|
||||||
|
|
||||||
|
|
||||||
nlist :: forall q i o. Array Note -> H.Component q i o Aff
|
nlist :: forall q i o. Array Note -> H.Component HH.HTML q i o Aff
|
||||||
nlist st' =
|
nlist st' =
|
||||||
H.mkComponent
|
H.mkComponent
|
||||||
{ initialState: const (mkState st')
|
{ initialState: const (mkState st')
|
||||||
|
@ -45,11 +45,11 @@ nlist st' =
|
||||||
}
|
}
|
||||||
|
|
||||||
render :: NLState -> H.ComponentHTML NLAction () Aff
|
render :: NLState -> H.ComponentHTML NLAction () Aff
|
||||||
render { notes } =
|
render st@{ notes } =
|
||||||
HH.div_ (map renderNote notes)
|
HH.div_ (map renderNote notes)
|
||||||
where
|
where
|
||||||
renderNote note =
|
renderNote note =
|
||||||
div [ id (show note.id)
|
div [ id_ (show note.id)
|
||||||
, class_ ("note w-100 mw7 pa1 mb2"
|
, class_ ("note w-100 mw7 pa1 mb2"
|
||||||
<> if note.shared then "" else " private")] $
|
<> if note.shared then "" else " private")] $
|
||||||
[ div [ class_ "display" ] $
|
[ div [ class_ "display" ] $
|
||||||
|
|
|
@ -2,35 +2,29 @@ module Component.NNote where
|
||||||
|
|
||||||
import Prelude hiding (div)
|
import Prelude hiding (div)
|
||||||
|
|
||||||
import Affjax (printError)
|
|
||||||
import Affjax.StatusCode (StatusCode(..))
|
|
||||||
import App (destroyNote, editNote)
|
import App (destroyNote, editNote)
|
||||||
import Component.Markdown as Markdown
|
import Component.Markdown as Markdown
|
||||||
import Data.Array (drop, foldMap)
|
import Data.Array (drop, foldMap)
|
||||||
import Data.Either (Either(..))
|
import Data.Either (Either(..))
|
||||||
import Data.Lens (Lens', lens, use, (%=), (.=))
|
import Data.Lens (Lens', lens, use, (%=), (.=))
|
||||||
import Data.Maybe (Maybe(..), fromMaybe, isJust, maybe)
|
import Data.Maybe (Maybe(..), maybe)
|
||||||
import Data.Monoid (guard)
|
import Data.Monoid (guard)
|
||||||
import Data.String (null, split) as S
|
import Data.String (null, split) as S
|
||||||
import Data.String (null, stripPrefix)
|
|
||||||
import Data.String.Pattern (Pattern(..))
|
import Data.String.Pattern (Pattern(..))
|
||||||
import Data.Tuple (fst, snd)
|
import Data.Tuple (fst, snd)
|
||||||
import Effect.Aff (Aff)
|
import Effect.Aff (Aff)
|
||||||
import Effect.Class (liftEffect)
|
import Effect.Class (liftEffect)
|
||||||
import Effect.Console (log)
|
import Globals (app', mmoment8601)
|
||||||
import Globals (app', mmoment8601, setFocus, closeWindow)
|
|
||||||
import Halogen as H
|
import Halogen as H
|
||||||
import Halogen.HTML (br_, button, div, form, input, label, p, span, text, textarea)
|
import Halogen.HTML (br_, button, div, form, input, label, p, span, text, textarea)
|
||||||
import Halogen.HTML as HH
|
import Halogen.HTML as HH
|
||||||
import Halogen.HTML.Events (onChecked, onClick, onSubmit, onValueChange)
|
import Halogen.HTML.Events (onChecked, onClick, onSubmit, onValueChange)
|
||||||
import Halogen.HTML.Properties (ButtonType(..), InputType(..), autofocus, checked, for, id, name, rows, title, type_, value)
|
import Halogen.HTML.Properties (ButtonType(..), InputType(..), checked, for, id_, name, rows, title, type_, value)
|
||||||
import Model (Note)
|
import Model (Note)
|
||||||
import Type.Proxy (Proxy(..))
|
import Util (_loc, class_, fromNullableStr, ifElseH)
|
||||||
import Util (_curQuerystring, _doc, _loc, _lookupQueryStringValue, class_, fromNullableStr, ifElseH, whenH)
|
|
||||||
import Web.Event.Event (Event, preventDefault)
|
import Web.Event.Event (Event, preventDefault)
|
||||||
import Web.HTML (window)
|
import Web.HTML.Location (setHref)
|
||||||
import Web.HTML.HTMLDocument (referrer)
|
import Data.Symbol (SProxy(..))
|
||||||
import Web.HTML.Location (origin, setHref)
|
|
||||||
|
|
||||||
data NAction
|
data NAction
|
||||||
= NNop
|
= NNop
|
||||||
|
@ -46,7 +40,6 @@ type NState =
|
||||||
, deleteAsk :: Boolean
|
, deleteAsk :: Boolean
|
||||||
, edit :: Boolean
|
, edit :: Boolean
|
||||||
, destroyed :: Boolean
|
, destroyed :: Boolean
|
||||||
, apiError :: Maybe String
|
|
||||||
}
|
}
|
||||||
|
|
||||||
_note :: Lens' NState Note
|
_note :: Lens' NState Note
|
||||||
|
@ -58,9 +51,6 @@ _edit_note = lens _.edit_note (_ { edit_note = _ })
|
||||||
_edit :: Lens' NState Boolean
|
_edit :: Lens' NState Boolean
|
||||||
_edit = lens _.edit (_ { edit = _ })
|
_edit = lens _.edit (_ { edit = _ })
|
||||||
|
|
||||||
_apiError :: Lens' NState (Maybe String)
|
|
||||||
_apiError = lens _.apiError (_ { apiError = _ })
|
|
||||||
|
|
||||||
-- | FormField Edits
|
-- | FormField Edits
|
||||||
data EditField
|
data EditField
|
||||||
= Etitle String
|
= Etitle String
|
||||||
|
@ -68,13 +58,13 @@ data EditField
|
||||||
| EisMarkdown Boolean
|
| EisMarkdown Boolean
|
||||||
| Eshared Boolean
|
| Eshared Boolean
|
||||||
|
|
||||||
_markdown = Proxy :: Proxy "markdown"
|
_markdown = SProxy :: SProxy "markdown"
|
||||||
|
|
||||||
type ChildSlots =
|
type ChildSlots =
|
||||||
( markdown :: Markdown.Slot Unit
|
( markdown :: Markdown.Slot Unit
|
||||||
)
|
)
|
||||||
|
|
||||||
nnote :: forall q i o. Note -> H.Component q i o Aff
|
nnote :: forall q i o. Note -> H.Component HH.HTML q i o Aff
|
||||||
nnote st' =
|
nnote st' =
|
||||||
H.mkComponent
|
H.mkComponent
|
||||||
{ initialState: const (mkState st')
|
{ initialState: const (mkState st')
|
||||||
|
@ -90,11 +80,10 @@ nnote st' =
|
||||||
, deleteAsk: false
|
, deleteAsk: false
|
||||||
, edit: note'.id <= 0
|
, edit: note'.id <= 0
|
||||||
, destroyed: false
|
, destroyed: false
|
||||||
, apiError: Nothing
|
|
||||||
}
|
}
|
||||||
|
|
||||||
render :: NState -> H.ComponentHTML NAction ChildSlots Aff
|
render :: NState -> H.ComponentHTML NAction ChildSlots Aff
|
||||||
render st@{ note, edit_note, apiError } =
|
render st@{ note, edit_note } =
|
||||||
ifElseH st.destroyed
|
ifElseH st.destroyed
|
||||||
display_destroyed
|
display_destroyed
|
||||||
(const (ifElseH st.edit
|
(const (ifElseH st.edit
|
||||||
|
@ -103,7 +92,7 @@ nnote st' =
|
||||||
where
|
where
|
||||||
|
|
||||||
renderNote _ =
|
renderNote _ =
|
||||||
div [ id (show note.id) , class_ ("note w-100 mw7 pa1 mb2")] $
|
div [ id_ (show note.id) , class_ ("note w-100 mw7 pa1 mb2")] $
|
||||||
[ div [ class_ "display" ] $
|
[ div [ class_ "display" ] $
|
||||||
[ div [ class_ ("link f5 lh-title")]
|
[ div [ class_ ("link f5 lh-title")]
|
||||||
[ text $ if S.null note.title then "[no title]" else note.title ]
|
[ text $ if S.null note.title then "[no title]" else note.title ]
|
||||||
|
@ -119,42 +108,40 @@ nnote st' =
|
||||||
[ text $ if note.shared then "public" else "private" ]
|
[ text $ if note.shared then "public" else "private" ]
|
||||||
]
|
]
|
||||||
]
|
]
|
||||||
, whenH app.dat.isowner $ \_ ->
|
]
|
||||||
div [ class_ "edit_links db mt3" ]
|
<> -- | Render Action Links
|
||||||
[ button [ type_ ButtonButton, onClick \_ -> NEdit true, class_ "edit light-silver hover-blue" ] [ text "edit " ]
|
[ div [ class_ "edit_links db mt3" ]
|
||||||
|
[ button [ type_ ButtonButton, onClick \_ -> Just (NEdit true), class_ "edit light-silver hover-blue" ] [ text "edit " ]
|
||||||
, div [ class_ "delete_link di" ]
|
, div [ class_ "delete_link di" ]
|
||||||
[ button [ type_ ButtonButton, onClick \_ -> NDeleteAsk true, class_ ("delete light-silver hover-blue" <> guard st.deleteAsk " dn") ] [ text "delete" ]
|
[ button [ type_ ButtonButton, onClick \_ -> Just (NDeleteAsk true), class_ ("delete light-silver hover-blue" <> guard st.deleteAsk " dn") ] [ text "delete" ]
|
||||||
, span ([ class_ ("confirm red" <> guard (not st.deleteAsk) " dn") ] )
|
, span ([ class_ ("confirm red" <> guard (not st.deleteAsk) " dn") ] )
|
||||||
[ button [ type_ ButtonButton, onClick \_ -> NDeleteAsk false] [ text "cancel / " ]
|
[ button [ type_ ButtonButton, onClick \_ -> Just (NDeleteAsk false)] [ text "cancel / " ]
|
||||||
, button [ type_ ButtonButton, onClick \_ -> NDestroy, class_ "red" ] [ text "destroy" ]
|
, button [ type_ ButtonButton, onClick \_ -> Just NDestroy, class_ "red" ] [ text "destroy" ]
|
||||||
]
|
]
|
||||||
]
|
]
|
||||||
]
|
]
|
||||||
|
|
||||||
]
|
]
|
||||||
|
|
||||||
renderNote_edit _ =
|
renderNote_edit _ =
|
||||||
form [ onSubmit NEditSubmit ]
|
form [ onSubmit (Just <<< NEditSubmit) ]
|
||||||
[ whenH (isJust apiError)
|
[ p [ class_ "mt2 mb1"] [ text "title:" ]
|
||||||
(alert_notification (fromMaybe "" apiError))
|
, input [ type_ InputText , class_ "title w-100 mb1 pt1 f7 edit_form_input" , name "title"
|
||||||
, p [ class_ "mt2 mb1"] [ text "title:" ]
|
, value (edit_note.title) , onValueChange (editField Etitle)
|
||||||
, input [ type_ InputText , class_ "title w-100 mb1 pt1 edit_form_input" , name "title"
|
|
||||||
, value (edit_note.title) , onValueChange (editField Etitle), autofocus (null edit_note.title)
|
|
||||||
]
|
]
|
||||||
, br_
|
, br_
|
||||||
, p [ class_ "mt2 mb1"] [ text "description:" ]
|
, p [ class_ "mt2 mb1"] [ text "description:" ]
|
||||||
, textarea [ id (notetextid edit_note), class_ "description w-100 mb1 pt1 edit_form_input" , name "text", rows 25
|
, textarea [ class_ "description w-100 mb1 pt1 f7 edit_form_input" , name "text", rows 30
|
||||||
, value (edit_note.text) , onValueChange (editField Etext)
|
, value (edit_note.text) , onValueChange (editField Etext)
|
||||||
]
|
]
|
||||||
, div [ class_ "edit_form_checkboxes mb3"]
|
, div [ class_ "edit_form_checkboxes mb3"]
|
||||||
[ input [ type_ InputCheckbox , class_ "is-markdown pointer" , id "edit_ismarkdown", name "ismarkdown"
|
[ input [ type_ InputCheckbox , class_ "is-markdown pointer" , id_ "edit_ismarkdown", name "ismarkdown"
|
||||||
, checked (edit_note.isMarkdown) , onChecked (editField EisMarkdown) ]
|
, checked (edit_note.isMarkdown) , onChecked (editField EisMarkdown) ]
|
||||||
, text " "
|
, text " "
|
||||||
, label [ for "edit_ismarkdown" , class_ "mr2" ] [ text "use markdown?" ]
|
, label [ for "edit_ismarkdown" , class_ "mr2" ] [ text "use markdown?" ]
|
||||||
, br_
|
, br_
|
||||||
]
|
]
|
||||||
, div [ class_ "edit_form_checkboxes mb3"]
|
, div [ class_ "edit_form_checkboxes mb3"]
|
||||||
[ input [ type_ InputCheckbox , class_ "is-markdown pointer" , id "edit_shared", name "shared"
|
[ input [ type_ InputCheckbox , class_ "is-markdown pointer" , id_ "edit_shared", name "shared"
|
||||||
, checked (edit_note.shared) , onChecked (editField Eshared) ]
|
, checked (edit_note.shared) , onChecked (editField Eshared) ]
|
||||||
, text " "
|
, text " "
|
||||||
, label [ for "edit_shared" , class_ "mr2" ] [ text "public?" ]
|
, label [ for "edit_shared" , class_ "mr2" ] [ text "public?" ]
|
||||||
|
@ -167,24 +154,20 @@ nnote st' =
|
||||||
, input [ type_ InputReset
|
, input [ type_ InputReset
|
||||||
, class_ "pv1 ph2 dark-gray ba b--moon-gray bg-near-white pointer rdim"
|
, class_ "pv1 ph2 dark-gray ba b--moon-gray bg-near-white pointer rdim"
|
||||||
, value "cancel"
|
, value "cancel"
|
||||||
, onClick \_ -> NEdit false
|
, onClick \_ -> Just (NEdit false)
|
||||||
]
|
]
|
||||||
]
|
]
|
||||||
|
|
||||||
display_destroyed _ = p [ class_ "red"] [text "you killed this note"]
|
display_destroyed _ = p [ class_ "red"] [text "you killed this note"]
|
||||||
|
|
||||||
alert_notification alert_text _ =
|
|
||||||
div [ class_ "alert alert-err" ] [ text alert_text ]
|
|
||||||
|
|
||||||
mmoment n = mmoment8601 n.created
|
mmoment n = mmoment8601 n.created
|
||||||
editField :: forall a. (a -> EditField) -> a -> NAction
|
editField :: forall a. (a -> EditField) -> a -> Maybe NAction
|
||||||
editField f = NEditField <<< f
|
editField f = Just <<< NEditField <<< f
|
||||||
toTextarea input =
|
toTextarea input =
|
||||||
S.split (Pattern "\n") input
|
S.split (Pattern "\n") input
|
||||||
# foldMap (\x -> [br_, text x])
|
# foldMap (\x -> [br_, text x])
|
||||||
# drop 1
|
# drop 1
|
||||||
|
|
||||||
notetextid note = show note.id <> "_text"
|
|
||||||
|
|
||||||
handleAction :: NAction -> H.HalogenM NState NAction ChildSlots o Aff Unit
|
handleAction :: NAction -> H.HalogenM NState NAction ChildSlots o Aff Unit
|
||||||
handleAction (NNop) = pure unit
|
handleAction (NNop) = pure unit
|
||||||
|
@ -212,38 +195,18 @@ nnote st' =
|
||||||
note <- use _note
|
note <- use _note
|
||||||
_edit_note .= note
|
_edit_note .= note
|
||||||
_edit .= e
|
_edit .= e
|
||||||
qs <- liftEffect _curQuerystring
|
|
||||||
case {e:e, q:_lookupQueryStringValue qs "next"} of
|
|
||||||
{e:false, q:Just "closeWindow"} -> liftEffect $ closeWindow =<< window
|
|
||||||
_ -> H.liftEffect $ whenM (pure e) (setFocus (notetextid note))
|
|
||||||
|
|
||||||
|
|
||||||
-- | Submit
|
-- | Submit
|
||||||
handleAction (NEditSubmit e) = do
|
handleAction (NEditSubmit e) = do
|
||||||
H.liftEffect (preventDefault e)
|
H.liftEffect (preventDefault e)
|
||||||
edit_note <- use _edit_note
|
edit_note <- use _edit_note
|
||||||
_apiError .= Nothing
|
res <- H.liftAff (editNote edit_note)
|
||||||
H.liftAff (editNote edit_note) >>= case _ of
|
case res.body of
|
||||||
Left affErr -> do
|
Left err -> pure unit
|
||||||
_apiError .= Just (printError affErr)
|
Right r -> do
|
||||||
liftEffect $ log (printError affErr)
|
if (edit_note.id == 0)
|
||||||
Right { status: StatusCode s } | s >= 200 && s < 300 -> do
|
then do
|
||||||
qs <- liftEffect _curQuerystring
|
liftEffect (setHref (fromNullableStr app.noteR) =<< _loc)
|
||||||
doc <- liftEffect $ _doc
|
|
||||||
ref <- liftEffect $ referrer doc
|
|
||||||
loc <- liftEffect $ _loc
|
|
||||||
org <- liftEffect $ origin loc
|
|
||||||
case _lookupQueryStringValue qs "next" of
|
|
||||||
Just "closeWindow" -> liftEffect $ closeWindow =<< window
|
|
||||||
Just "back" -> liftEffect $
|
|
||||||
if isJust (stripPrefix (Pattern org) ref)
|
|
||||||
then setHref ref loc
|
|
||||||
else setHref org loc
|
|
||||||
_ -> if (edit_note.id == 0)
|
|
||||||
then liftEffect $ setHref (fromNullableStr app.noteR) =<< _loc
|
|
||||||
else do
|
else do
|
||||||
_note .= edit_note
|
_note .= edit_note
|
||||||
_edit .= false
|
_edit .= false
|
||||||
Right res -> do
|
|
||||||
_apiError .= Just (res.body)
|
|
||||||
liftEffect $ log (res.body)
|
|
||||||
|
|
|
@ -1,5 +1,5 @@
|
||||||
// use at your own risk!
|
// use at your own risk!
|
||||||
export const unsafeSetInnerHTML = function(element) {
|
exports.unsafeSetInnerHTML = function(element) {
|
||||||
return function(html) {
|
return function(html) {
|
||||||
return function() {
|
return function() {
|
||||||
element.innerHTML = html;
|
element.innerHTML = html;
|
||||||
|
|
|
@ -19,7 +19,6 @@ data Action i
|
||||||
= SetInnerHTML
|
= SetInnerHTML
|
||||||
| Receive (Input i)
|
| Receive (Input i)
|
||||||
|
|
||||||
type Input :: forall k. k -> k
|
|
||||||
type Input i = i
|
type Input i = i
|
||||||
|
|
||||||
type State i =
|
type State i =
|
||||||
|
@ -27,10 +26,10 @@ type State i =
|
||||||
, inputval :: Input i
|
, inputval :: Input i
|
||||||
}
|
}
|
||||||
|
|
||||||
component :: forall q o. H.Component q (Input String) o Aff
|
component :: forall q o. H.Component HH.HTML q (Input String) o Aff
|
||||||
component = mkComponent RawHTML
|
component = mkComponent RawHTML
|
||||||
|
|
||||||
mkComponent :: forall q i o. (Input i -> RawHTML) -> H.Component q (Input i) o Aff
|
mkComponent :: forall q i o. (Input i -> RawHTML) -> H.Component HH.HTML q (Input i) o Aff
|
||||||
mkComponent toRawHTML =
|
mkComponent toRawHTML =
|
||||||
H.mkComponent
|
H.mkComponent
|
||||||
{ initialState: \inputval -> { elRef: H.RefLabel "inputval", inputval }
|
{ initialState: \inputval -> { elRef: H.RefLabel "inputval", inputval }
|
||||||
|
@ -54,7 +53,7 @@ mkComponent toRawHTML =
|
||||||
mel <- H.getHTMLElementRef elRef
|
mel <- H.getHTMLElementRef elRef
|
||||||
for_ mel \el -> do
|
for_ mel \el -> do
|
||||||
{ inputval } <- H.get
|
{ inputval } <- H.get
|
||||||
H.liftAff $ forkAff $ makeAff \_ -> do
|
H.liftAff $ forkAff $ makeAff \cb -> do
|
||||||
liftEffect $ unsafeSetInnerHTML el (toRawHTML inputval)
|
liftEffect $ unsafeSetInnerHTML el (toRawHTML inputval)
|
||||||
mempty
|
mempty
|
||||||
pure unit
|
pure unit
|
||||||
|
|
|
@ -1,173 +0,0 @@
|
||||||
module Component.TagCloud where
|
|
||||||
|
|
||||||
import Prelude hiding (div)
|
|
||||||
|
|
||||||
import App (getTagCloud, updateTagCloudMode)
|
|
||||||
import Data.Array (concat, cons, delete, notElem, null, sortBy)
|
|
||||||
import Data.Foldable (maximum, minimum)
|
|
||||||
import Data.Int (toNumber)
|
|
||||||
import Data.Lens (Lens', lens)
|
|
||||||
import Data.Maybe (Maybe(..), fromMaybe)
|
|
||||||
import Data.Monoid (guard)
|
|
||||||
import Data.String (joinWith, toLower, null) as S
|
|
||||||
import Data.String (toLower)
|
|
||||||
import Data.Tuple (fst, uncurry)
|
|
||||||
import Effect.Aff (Aff)
|
|
||||||
import Foreign.Object (Object)
|
|
||||||
import Foreign.Object (toUnfoldable, empty, values) as F
|
|
||||||
import Globals (app')
|
|
||||||
import Halogen (AttrName(..))
|
|
||||||
import Halogen as H
|
|
||||||
import Halogen.HTML (HTML, a, attr, button, div, text)
|
|
||||||
import Halogen.HTML.Events (onClick)
|
|
||||||
import Halogen.HTML.Properties (ButtonType(..), href, title, type_)
|
|
||||||
import Data.Number (log)
|
|
||||||
import Model (TagCloud, TagCloudModeF(..), isExpanded, isRelated, setExpanded, tagCloudModeFromF)
|
|
||||||
import Util (class_, encodeTag, fromNullableStr, ifElseA, whenH)
|
|
||||||
|
|
||||||
data TAction
|
|
||||||
= TInitialize
|
|
||||||
| TExpanded Boolean
|
|
||||||
| TChangeMode TagCloudModeF
|
|
||||||
|
|
||||||
type TState =
|
|
||||||
{ mode :: TagCloudModeF
|
|
||||||
, tagcloud :: TagCloud
|
|
||||||
}
|
|
||||||
|
|
||||||
_mode :: Lens' TState TagCloudModeF
|
|
||||||
_mode = lens _.mode (_ { mode = _ })
|
|
||||||
|
|
||||||
tagcloudcomponent :: forall q i o. TagCloudModeF -> H.Component q i o Aff
|
|
||||||
tagcloudcomponent m' =
|
|
||||||
H.mkComponent
|
|
||||||
{ initialState: const (mkState m')
|
|
||||||
, render
|
|
||||||
, eval: H.mkEval $ H.defaultEval { handleAction = handleAction
|
|
||||||
, initialize = Just TInitialize
|
|
||||||
}
|
|
||||||
}
|
|
||||||
where
|
|
||||||
app = app' unit
|
|
||||||
mkState m =
|
|
||||||
{ mode: m
|
|
||||||
, tagcloud: F.empty
|
|
||||||
}
|
|
||||||
|
|
||||||
render :: TState -> H.ComponentHTML TAction () Aff
|
|
||||||
render { mode:TagCloudModeNone } =
|
|
||||||
div [class_ "tag_cloud" ] []
|
|
||||||
render { mode, tagcloud } =
|
|
||||||
div [class_ "tag_cloud mv3" ]
|
|
||||||
[
|
|
||||||
div [class_ "tag_cloud_header mb2"] $
|
|
||||||
ifElseA (isRelated mode)
|
|
||||||
(\_ -> do --RELATED
|
|
||||||
[ button [ type_ ButtonButton, class_ ("pa1 f7 link hover-blue mr1 b")
|
|
||||||
, onClick \_ -> TExpanded (not (isExpanded mode))
|
|
||||||
] [text "Related Tags"]
|
|
||||||
]
|
|
||||||
)
|
|
||||||
(\_ -> do -- NOT RELATED
|
|
||||||
[ button [ type_ ButtonButton, class_ ("pa1 f7 link hover-blue mr1" <> guard (mode == modetop) " b")
|
|
||||||
, title "show a cloud of your most-used tags"
|
|
||||||
, onClick \_ -> TChangeMode modetop
|
|
||||||
] [text "Top Tags"]
|
|
||||||
, button [ type_ ButtonButton, class_ ("pa1 f7 link hover-blue ml2 " <> guard (mode == modelb1) " b")
|
|
||||||
, title "show all tags"
|
|
||||||
, onClick \_ -> TChangeMode modelb1
|
|
||||||
] [text "all"]
|
|
||||||
, text "‧"
|
|
||||||
, button [ type_ ButtonButton, class_ ("pa1 f7 link hover-blue" <> guard (mode == modelb2) " b")
|
|
||||||
, title "show tags with at least 2 bookmarks"
|
|
||||||
, onClick \_ -> TChangeMode modelb2
|
|
||||||
] [text "2"]
|
|
||||||
, text "‧"
|
|
||||||
, button [ type_ ButtonButton, class_ ("pa1 f7 link hover-blue" <> guard (mode == modelb5) " b")
|
|
||||||
, title "show tags with at least 5 bookmarks"
|
|
||||||
, onClick \_ -> TChangeMode modelb5
|
|
||||||
] [text "5"]
|
|
||||||
, text "‧"
|
|
||||||
, button [ type_ ButtonButton, class_ ("pa1 f7 link hover-blue" <> guard (mode == modelb10) " b")
|
|
||||||
, title "show tags with at least 10 bookmarks"
|
|
||||||
, onClick \_ -> TChangeMode modelb10
|
|
||||||
] [text "10"]
|
|
||||||
, text "‧"
|
|
||||||
, button [ type_ ButtonButton, class_ ("pa1 f7 link hover-blue" <> guard (mode == modelb20) " b")
|
|
||||||
, title "show tags with at least 20 bookmarks"
|
|
||||||
, onClick \_ -> TChangeMode modelb20
|
|
||||||
] [text "20"]
|
|
||||||
])
|
|
||||||
<> [button [ type_ ButtonButton, class_ "pa1 ml2 f7 link silver hover-blue "
|
|
||||||
, onClick \_ -> TExpanded (not (isExpanded mode))]
|
|
||||||
[ text (if isExpanded mode then "hide" else "show") ]]
|
|
||||||
, whenH (isExpanded mode) \_ -> do
|
|
||||||
let n = fromMaybe 1 (minimum (F.values tagcloud))
|
|
||||||
m = fromMaybe 1 (maximum (F.values tagcloud))
|
|
||||||
div [class_ "tag_cloud_body"] $ case mode of
|
|
||||||
TagCloudModeNone -> []
|
|
||||||
(TagCloudModeRelated _ curtags) ->
|
|
||||||
toArray curtags n m tagcloud
|
|
||||||
_ ->
|
|
||||||
toArray [] n m tagcloud
|
|
||||||
|
|
||||||
]
|
|
||||||
where
|
|
||||||
modetop = TagCloudModeTop (isExpanded mode) 200
|
|
||||||
modelb1 = TagCloudModeLowerBound (isExpanded mode) 1
|
|
||||||
modelb2 = TagCloudModeLowerBound (isExpanded mode) 2
|
|
||||||
modelb5 = TagCloudModeLowerBound (isExpanded mode) 5
|
|
||||||
modelb10 = TagCloudModeLowerBound (isExpanded mode) 10
|
|
||||||
modelb20 = TagCloudModeLowerBound (isExpanded mode) 20
|
|
||||||
|
|
||||||
|
|
||||||
toArray :: Array String -> Int -> Int -> Object Int -> Array (HTML _ _)
|
|
||||||
toArray curtags n m =
|
|
||||||
concat
|
|
||||||
<<< map (uncurry (toSizedTag (map toLower curtags) n m))
|
|
||||||
<<< sortBy (comparing (S.toLower <<< fst))
|
|
||||||
<<< F.toUnfoldable
|
|
||||||
|
|
||||||
linkToFilterTag rest = fromNullableStr app.userR <> (if S.null rest then "" else "/t:" <> rest)
|
|
||||||
|
|
||||||
toSizedTag :: Array String -> Int -> Int -> String -> Int -> _
|
|
||||||
toSizedTag curtags n m k v =
|
|
||||||
[ a [ href (linkToFilterTag (encodeTag k)), class_ "link tag mr1" , style]
|
|
||||||
[ text k ]
|
|
||||||
, whenH (not (null curtags)) \_ -> if (notElem k_lower curtags)
|
|
||||||
then a [href (linkToFilterTag (S.joinWith "+" (map encodeTag (cons k_lower curtags)))), class_ "link mr2 tag-include"] [text "⊕"]
|
|
||||||
else a [href (linkToFilterTag (S.joinWith "+" (map encodeTag (delete k_lower curtags)))), class_ "link mr2 tag-exclude"] [text "⊖"]
|
|
||||||
]
|
|
||||||
where
|
|
||||||
k_lower = toLower k
|
|
||||||
fontsize = rescale identity (toNumber v) (toNumber n) (toNumber m) 100.0 150.0
|
|
||||||
opacity = rescale (log <<< (1.0 + _)) (toNumber v) (toNumber n) (toNumber m) 0.6 1.0
|
|
||||||
style = attr (AttrName "style") ("font-size:" <> show fontsize <> "%" <> ";opacity:" <> show opacity)
|
|
||||||
|
|
||||||
rescale :: (Number -> Number) -> Number -> Number -> Number -> Number -> Number -> Number
|
|
||||||
rescale f v n m l h = (if m - n < 0.01 then 1.0 else (f (v - n) / f (m - n))) * (h - l) + l
|
|
||||||
|
|
||||||
fetchTagCloud :: TagCloudModeF -> H.HalogenM TState TAction () o Aff Unit
|
|
||||||
fetchTagCloud mode' = do
|
|
||||||
case mode' of
|
|
||||||
TagCloudModeNone -> pure unit
|
|
||||||
_ -> do
|
|
||||||
tagcloud <- H.liftAff $ getTagCloud (tagCloudModeFromF mode')
|
|
||||||
H.modify_ (\s -> s {
|
|
||||||
mode = mode',
|
|
||||||
tagcloud = fromMaybe F.empty tagcloud
|
|
||||||
})
|
|
||||||
|
|
||||||
handleAction :: TAction -> H.HalogenM TState TAction () o Aff Unit
|
|
||||||
handleAction TInitialize = do
|
|
||||||
mode <- H.gets _.mode
|
|
||||||
fetchTagCloud mode
|
|
||||||
handleAction (TExpanded expanded) = do
|
|
||||||
H.modify_ (\s -> s { mode = setExpanded s.mode expanded })
|
|
||||||
mode <- H.gets _.mode
|
|
||||||
void $ H.liftAff $ updateTagCloudMode (tagCloudModeFromF mode)
|
|
||||||
handleAction (TChangeMode mode') = do
|
|
||||||
mode <- H.gets _.mode
|
|
||||||
if mode == mode'
|
|
||||||
then handleAction (TExpanded (not (isExpanded mode)))
|
|
||||||
else fetchTagCloud (setExpanded mode' true)
|
|
|
@ -1,12 +1,12 @@
|
||||||
"use strict";
|
"use strict";
|
||||||
|
|
||||||
import moment from 'moment'
|
var moment = require("moment");
|
||||||
|
|
||||||
export const _app = function() {
|
exports._app = function() {
|
||||||
return app;
|
return app;
|
||||||
}
|
}
|
||||||
|
|
||||||
export const _closest = function(just, nothing, selector, el) {
|
exports._closest = function(just, nothing, selector, el) {
|
||||||
var node = el.closest(selector);
|
var node = el.closest(selector);
|
||||||
if(node) {
|
if(node) {
|
||||||
return just(node);
|
return just(node);
|
||||||
|
@ -15,26 +15,43 @@ export const _closest = function(just, nothing, selector, el) {
|
||||||
}
|
}
|
||||||
}
|
}
|
||||||
|
|
||||||
export const _createFormData = function(formElement) {
|
exports._innerHtml = function(el) {
|
||||||
|
return el.innerHTML;
|
||||||
|
}
|
||||||
|
|
||||||
|
exports._setInnerHtml = function(content, el) {
|
||||||
|
el.innerHTML = content;
|
||||||
|
return el;
|
||||||
|
}
|
||||||
|
|
||||||
|
exports._createFormData = function(formElement) {
|
||||||
return new FormData(formElement);
|
return new FormData(formElement);
|
||||||
}
|
}
|
||||||
|
|
||||||
export const _createFormString = function(formElement) {
|
exports._createFormString = function(formElement) {
|
||||||
return new URLSearchParams(new FormData(formElement)).toString()
|
return new URLSearchParams(new FormData(formElement)).toString()
|
||||||
}
|
}
|
||||||
|
|
||||||
export const _createFormArray = function(formElement) {
|
exports._createFormArray = function(formElement) {
|
||||||
return Array.from(new FormData(formElement));
|
return Array.from(new FormData(formElement));
|
||||||
}
|
}
|
||||||
|
|
||||||
export const _moment8601 = function(tuple, s) {
|
exports._getDataAttribute = function(name, el) {
|
||||||
|
return el.dataset[name];
|
||||||
|
}
|
||||||
|
|
||||||
|
exports._setDataAttribute = function(name, value, el) {
|
||||||
|
return el.dataset[name] = value;
|
||||||
|
}
|
||||||
|
|
||||||
|
exports._moment8601 = function(tuple, s) {
|
||||||
var m = moment(s, moment.ISO_8601);
|
var m = moment(s, moment.ISO_8601);
|
||||||
var s1 = m.fromNow();
|
var s1 = m.fromNow();
|
||||||
var s2 = m.format('MMMM D YYYY, h:mm a') + " (" + m.format() + ") ";
|
var s2 = m.format('MMMM D YYYY, h:mm a') + " (" + m.format() + ") ";
|
||||||
return tuple(s1)(s2);
|
return tuple(s1)(s2);
|
||||||
}
|
}
|
||||||
|
|
||||||
export const _mmoment8601 = function(just, nothing, tuple, s) {
|
exports._mmoment8601 = function(just, nothing, tuple, s) {
|
||||||
try {
|
try {
|
||||||
var m = moment(s, moment.ISO_8601);
|
var m = moment(s, moment.ISO_8601);
|
||||||
var s1 = m.fromNow();
|
var s1 = m.fromNow();
|
||||||
|
@ -45,15 +62,6 @@ export const _mmoment8601 = function(just, nothing, tuple, s) {
|
||||||
}
|
}
|
||||||
}
|
}
|
||||||
|
|
||||||
export const _closeWindow = function (window) {
|
exports._closeWindow = function (window) {
|
||||||
window.close();
|
window.close();
|
||||||
};
|
};
|
||||||
|
|
||||||
export const _setFocus = function(elemId) {
|
|
||||||
document.getElementById(elemId).focus();
|
|
||||||
};
|
|
||||||
|
|
||||||
|
|
||||||
export const _toLocaleDateString = function(dateString) {
|
|
||||||
return new Date(dateString).toLocaleDateString(undefined, {dateStyle: 'medium'})
|
|
||||||
}
|
|
||||||
|
|
|
@ -1,17 +1,17 @@
|
||||||
module Globals where
|
module Globals where
|
||||||
|
|
||||||
|
import Data.Function.Uncurried
|
||||||
|
|
||||||
import Data.Maybe (Maybe(..))
|
import Data.Maybe (Maybe(..))
|
||||||
import Data.Newtype (class Newtype)
|
import Data.Nullable (Nullable, toMaybe)
|
||||||
import Data.Nullable (Nullable)
|
|
||||||
import Data.Tuple (Tuple(..))
|
import Data.Tuple (Tuple(..))
|
||||||
import Effect (Effect)
|
import Effect (Effect)
|
||||||
import Data.Function.Uncurried (Fn0, Fn1, Fn4, runFn0, runFn1, runFn4)
|
|
||||||
import Effect.Uncurried (EffectFn1, EffectFn2, EffectFn4, runEffectFn1, runEffectFn2, runEffectFn4)
|
|
||||||
import Model (Bookmark)
|
import Model (Bookmark)
|
||||||
import Prelude (Unit)
|
import Prelude (Unit, pure, ($))
|
||||||
import Web.DOM (Node)
|
import Web.DOM (Element, Node)
|
||||||
import Web.HTML (HTMLFormElement, Window)
|
import Web.HTML (HTMLElement, HTMLFormElement, Window)
|
||||||
import Web.XHR.FormData (FormData)
|
import Web.XHR.FormData (FormData)
|
||||||
|
import Data.Newtype (class Newtype)
|
||||||
|
|
||||||
type App =
|
type App =
|
||||||
{ csrfHeaderName :: String
|
{ csrfHeaderName :: String
|
||||||
|
@ -36,21 +36,31 @@ foreign import _app :: Fn0 App
|
||||||
app' :: Unit -> App
|
app' :: Unit -> App
|
||||||
app' _ = runFn0 _app
|
app' _ = runFn0 _app
|
||||||
|
|
||||||
foreign import _closest :: forall a. EffectFn4 (a -> Maybe a) (Maybe a) String Node (Maybe Node)
|
foreign import _closest :: forall a. Fn4 (a -> Maybe a) (Maybe a) String Node (Maybe Node)
|
||||||
|
|
||||||
closest :: String -> Node -> Effect (Maybe Node)
|
closest :: String -> Node -> Effect (Maybe Node)
|
||||||
closest selector node = runEffectFn4 _closest Just Nothing selector node
|
closest selector node = pure $ runFn4 _closest Just Nothing selector node
|
||||||
|
|
||||||
foreign import _moment8601 :: EffectFn2 (String -> String -> Tuple String String) String (Tuple String String)
|
foreign import _moment8601 :: Fn2 (String -> String -> Tuple String String) String (Tuple String String)
|
||||||
|
|
||||||
moment8601 :: String -> Effect (Tuple String String)
|
moment8601 :: String -> Effect (Tuple String String)
|
||||||
moment8601 s = runEffectFn2 _moment8601 Tuple s
|
moment8601 s = pure $ runFn2 _moment8601 Tuple s
|
||||||
|
|
||||||
foreign import _mmoment8601 :: forall a. Fn4 (a -> Maybe a) (Maybe a) (String -> String -> Tuple String String) String (Maybe (Tuple String String))
|
foreign import _mmoment8601 :: forall a. Fn4 (a -> Maybe a) (Maybe a) (String -> String -> Tuple String String) String (Maybe (Tuple String String))
|
||||||
|
|
||||||
mmoment8601 :: String -> Maybe (Tuple String String)
|
mmoment8601 :: String -> Maybe (Tuple String String)
|
||||||
mmoment8601 s = runFn4 _mmoment8601 Just Nothing Tuple s
|
mmoment8601 s = runFn4 _mmoment8601 Just Nothing Tuple s
|
||||||
|
|
||||||
|
foreign import _innerHtml :: Fn1 HTMLElement String
|
||||||
|
|
||||||
|
innerHtml :: HTMLElement -> Effect String
|
||||||
|
innerHtml n = pure $ runFn1 _innerHtml n
|
||||||
|
|
||||||
|
foreign import _setInnerHtml :: Fn2 String HTMLElement HTMLElement
|
||||||
|
|
||||||
|
setInnerHtml :: String -> HTMLElement -> Effect HTMLElement
|
||||||
|
setInnerHtml c n = pure $ runFn2 _setInnerHtml c n
|
||||||
|
|
||||||
foreign import _createFormData :: Fn1 HTMLFormElement FormData
|
foreign import _createFormData :: Fn1 HTMLFormElement FormData
|
||||||
|
|
||||||
createFormData :: HTMLFormElement -> FormData
|
createFormData :: HTMLFormElement -> FormData
|
||||||
|
@ -67,21 +77,21 @@ foreign import _createFormArray :: Fn1 HTMLFormElement (Array (Array String))
|
||||||
createFormArray :: HTMLFormElement -> (Array (Array String))
|
createFormArray :: HTMLFormElement -> (Array (Array String))
|
||||||
createFormArray f = runFn1 _createFormArray f
|
createFormArray f = runFn1 _createFormArray f
|
||||||
|
|
||||||
foreign import _closeWindow :: EffectFn1 Window Unit
|
foreign import _getDataAttribute :: Fn2 String Element (Nullable String)
|
||||||
|
|
||||||
|
getDataAttribute :: String -> Element -> Effect (Maybe String)
|
||||||
|
getDataAttribute k n = pure $ toMaybe $ runFn2 _getDataAttribute k n
|
||||||
|
|
||||||
|
foreign import _setDataAttribute :: Fn3 String String Element Unit
|
||||||
|
|
||||||
|
setDataAttribute :: String -> String -> Element -> Effect Unit
|
||||||
|
setDataAttribute k v n = pure $ runFn3 _setDataAttribute k v n
|
||||||
|
|
||||||
|
foreign import _closeWindow :: Fn1 Window Unit
|
||||||
|
|
||||||
closeWindow :: Window -> Effect Unit
|
closeWindow :: Window -> Effect Unit
|
||||||
closeWindow win = runEffectFn1 _closeWindow win
|
closeWindow win = pure $ runFn1 _closeWindow win
|
||||||
|
|
||||||
newtype RawHTML = RawHTML String
|
newtype RawHTML = RawHTML String
|
||||||
|
|
||||||
derive instance newtypeRawHTML :: Newtype RawHTML _
|
derive instance newtypeRawHTML :: Newtype RawHTML _
|
||||||
|
|
||||||
foreign import _setFocus :: EffectFn1 String Unit
|
|
||||||
|
|
||||||
setFocus :: String -> Effect Unit
|
|
||||||
setFocus s = runEffectFn1 _setFocus s
|
|
||||||
|
|
||||||
foreign import _toLocaleDateString :: Fn1 String String
|
|
||||||
|
|
||||||
toLocaleDateString :: String -> String
|
|
||||||
toLocaleDateString s = runFn1 _toLocaleDateString s
|
|
||||||
|
|
5
purs/src/Main.js
Normal file
5
purs/src/Main.js
Normal file
|
@ -0,0 +1,5 @@
|
||||||
|
"use strict";
|
||||||
|
|
||||||
|
exports._mainImpl = function() {
|
||||||
|
return window.PS = PS;
|
||||||
|
}
|
|
@ -3,24 +3,28 @@ module Main where
|
||||||
import Prelude
|
import Prelude
|
||||||
|
|
||||||
import App (logout)
|
import App (logout)
|
||||||
import Component.AccountSettings (usetting)
|
|
||||||
import Component.Add (addbmark)
|
import Component.Add (addbmark)
|
||||||
import Component.BList (blist)
|
import Component.BList (blist)
|
||||||
import Component.NList (nlist)
|
import Component.NList (nlist)
|
||||||
import Component.NNote (nnote)
|
import Component.NNote (nnote)
|
||||||
import Component.TagCloud (tagcloudcomponent)
|
import Component.AccountSettings (usetting)
|
||||||
import Data.Foldable (traverse_)
|
import Data.Foldable (traverse_)
|
||||||
import Effect (Effect)
|
import Effect (Effect)
|
||||||
import Effect.Aff (Aff, launchAff)
|
import Effect.Aff (Aff, launchAff)
|
||||||
import Effect.Class (liftEffect)
|
import Effect.Class (liftEffect)
|
||||||
import Halogen.Aff as HA
|
import Halogen.Aff as HA
|
||||||
import Halogen.VDom.Driver (runUI)
|
import Halogen.VDom.Driver (runUI)
|
||||||
import Model (AccountSettings, Bookmark, Note, TagCloudMode, tagCloudModeToF)
|
import Model (Bookmark, Note, AccountSettings)
|
||||||
import Web.DOM.Element (setAttribute)
|
import Web.DOM.Element (setAttribute)
|
||||||
import Web.DOM.ParentNode (QuerySelector(..))
|
import Web.DOM.ParentNode (QuerySelector(..))
|
||||||
import Web.Event.Event (Event, preventDefault)
|
import Web.Event.Event (Event, preventDefault)
|
||||||
import Web.HTML.HTMLElement (toElement)
|
import Web.HTML.HTMLElement (toElement)
|
||||||
|
|
||||||
|
foreign import _mainImpl :: Effect Unit
|
||||||
|
|
||||||
|
main :: Effect Unit
|
||||||
|
main = _mainImpl
|
||||||
|
|
||||||
logoutE :: Event -> Effect Unit
|
logoutE :: Event -> Effect Unit
|
||||||
logoutE e = void <<< launchAff <<< logout =<< preventDefault e
|
logoutE e = void <<< launchAff <<< logout =<< preventDefault e
|
||||||
|
|
||||||
|
@ -31,12 +35,6 @@ renderBookmarks renderElSelector bmarks = do
|
||||||
void $ runUI (blist bmarks) unit el
|
void $ runUI (blist bmarks) unit el
|
||||||
viewRendered
|
viewRendered
|
||||||
|
|
||||||
renderTagCloud :: String -> TagCloudMode -> Effect Unit
|
|
||||||
renderTagCloud renderElSelector tagCloudMode = do
|
|
||||||
HA.runHalogenAff do
|
|
||||||
HA.selectElement (QuerySelector renderElSelector) >>= traverse_ \el -> do
|
|
||||||
void $ runUI (tagcloudcomponent (tagCloudModeToF tagCloudMode)) unit el
|
|
||||||
|
|
||||||
renderAddForm :: String -> Bookmark -> Effect Unit
|
renderAddForm :: String -> Bookmark -> Effect Unit
|
||||||
renderAddForm renderElSelector bmark = do
|
renderAddForm renderElSelector bmark = do
|
||||||
HA.runHalogenAff do
|
HA.runHalogenAff do
|
||||||
|
|
|
@ -1,12 +1,11 @@
|
||||||
import { marked } from 'marked';
|
var marked = require("marked");
|
||||||
import DOMPurify from "dompurify"
|
|
||||||
|
|
||||||
marked.setOptions({
|
marked.setOptions({
|
||||||
pedantic: false,
|
pedantic: false,
|
||||||
gfm: true
|
gfm: true
|
||||||
});
|
});
|
||||||
|
|
||||||
export const markedImpl = function(str) {
|
exports.markedImpl = function(str) {
|
||||||
if (!str) return "";
|
if (!str) return "";
|
||||||
return DOMPurify.sanitize(marked.parse(str));
|
return marked(str);
|
||||||
};
|
};
|
||||||
|
|
|
@ -1,14 +1,6 @@
|
||||||
module Model where
|
module Model where
|
||||||
|
|
||||||
import Control.Monad.Except (runExcept)
|
|
||||||
import Data.Array (intercalate)
|
|
||||||
import Data.Either (hush)
|
|
||||||
import Data.Maybe (fromMaybe)
|
|
||||||
import Data.Nullable (Nullable)
|
import Data.Nullable (Nullable)
|
||||||
import Data.String (Pattern(..), split)
|
|
||||||
import Foreign (Foreign, readInt, readString, unsafeToForeign)
|
|
||||||
import Foreign.Object (Object)
|
|
||||||
import Prelude (class Eq, pure, ($), (<$>))
|
|
||||||
import Simple.JSON as J
|
import Simple.JSON as J
|
||||||
|
|
||||||
type BookmarkId = Int
|
type BookmarkId = Int
|
||||||
|
@ -29,8 +21,8 @@ type Bookmark =
|
||||||
}
|
}
|
||||||
|
|
||||||
newtype Bookmark' = Bookmark' Bookmark
|
newtype Bookmark' = Bookmark' Bookmark
|
||||||
derive newtype instance J.ReadForeign Bookmark'
|
derive newtype instance bookmark_rfI :: J.ReadForeign Bookmark'
|
||||||
derive newtype instance J.WriteForeign Bookmark'
|
derive newtype instance bookmark_wfI :: J.WriteForeign Bookmark'
|
||||||
|
|
||||||
type NoteId = Int
|
type NoteId = Int
|
||||||
type NoteSlug = String
|
type NoteSlug = String
|
||||||
|
@ -48,8 +40,8 @@ type Note =
|
||||||
}
|
}
|
||||||
|
|
||||||
newtype Note' = Note' Note
|
newtype Note' = Note' Note
|
||||||
derive newtype instance J.ReadForeign Note'
|
derive newtype instance note_rfI :: J.ReadForeign Note'
|
||||||
derive newtype instance J.WriteForeign Note'
|
derive newtype instance note_wfI :: J.WriteForeign Note'
|
||||||
|
|
||||||
type AccountSettings =
|
type AccountSettings =
|
||||||
{ archiveDefault :: Boolean
|
{ archiveDefault :: Boolean
|
||||||
|
@ -58,72 +50,5 @@ type AccountSettings =
|
||||||
}
|
}
|
||||||
|
|
||||||
newtype AccountSettings' = AccountSettings' AccountSettings
|
newtype AccountSettings' = AccountSettings' AccountSettings
|
||||||
derive newtype instance J.ReadForeign AccountSettings'
|
derive newtype instance usersettings_rfI :: J.ReadForeign AccountSettings'
|
||||||
derive newtype instance J.WriteForeign AccountSettings'
|
derive newtype instance usersettings_wfI :: J.WriteForeign AccountSettings'
|
||||||
|
|
||||||
type TagCloudMode =
|
|
||||||
{ mode :: String
|
|
||||||
, value :: Foreign
|
|
||||||
, expanded :: Boolean
|
|
||||||
}
|
|
||||||
newtype TagCloudMode' = TagCloudMode' TagCloudMode
|
|
||||||
derive newtype instance J.ReadForeign TagCloudMode'
|
|
||||||
derive newtype instance J.WriteForeign TagCloudMode'
|
|
||||||
|
|
||||||
type TagCloud = Object Int
|
|
||||||
|
|
||||||
data TagCloudModeF
|
|
||||||
= TagCloudModeTop Boolean Int
|
|
||||||
| TagCloudModeLowerBound Boolean Int
|
|
||||||
| TagCloudModeRelated Boolean (Array String)
|
|
||||||
| TagCloudModeNone
|
|
||||||
|
|
||||||
derive instance Eq TagCloudModeF
|
|
||||||
|
|
||||||
tagCloudModeToF :: TagCloudMode -> TagCloudModeF
|
|
||||||
tagCloudModeToF tagCloudMode =
|
|
||||||
fromMaybe TagCloudModeNone $ hush $ runExcept $
|
|
||||||
case tagCloudMode.mode of
|
|
||||||
"top" -> TagCloudModeTop tagCloudMode.expanded <$> readInt tagCloudMode.value
|
|
||||||
"lowerBound" -> TagCloudModeLowerBound tagCloudMode.expanded <$> readInt tagCloudMode.value
|
|
||||||
"related" -> (\s -> TagCloudModeRelated tagCloudMode.expanded (split (Pattern " ") s)) <$> readString tagCloudMode.value
|
|
||||||
_ -> pure TagCloudModeNone
|
|
||||||
|
|
||||||
tagCloudModeFromF :: TagCloudModeF -> TagCloudMode
|
|
||||||
tagCloudModeFromF (TagCloudModeTop e i) =
|
|
||||||
{ mode: "top" , value: unsafeToForeign i, expanded: e }
|
|
||||||
tagCloudModeFromF (TagCloudModeLowerBound e i) =
|
|
||||||
{ mode: "lowerBound" , value: unsafeToForeign i, expanded: e }
|
|
||||||
tagCloudModeFromF (TagCloudModeRelated e tags) =
|
|
||||||
{ mode: "related" , value: unsafeToForeign (intercalate " " tags), expanded: e }
|
|
||||||
tagCloudModeFromF TagCloudModeNone =
|
|
||||||
{ mode: "none" , value: unsafeToForeign "", expanded: false }
|
|
||||||
|
|
||||||
isExpanded :: TagCloudModeF -> Boolean
|
|
||||||
isExpanded (TagCloudModeTop e _) = e
|
|
||||||
isExpanded (TagCloudModeLowerBound e _) = e
|
|
||||||
isExpanded (TagCloudModeRelated e _) = e
|
|
||||||
isExpanded TagCloudModeNone = false
|
|
||||||
|
|
||||||
isRelated :: TagCloudModeF -> Boolean
|
|
||||||
isRelated (TagCloudModeRelated _ _) = true
|
|
||||||
isRelated _ = false
|
|
||||||
|
|
||||||
setExpanded :: TagCloudModeF -> Boolean -> TagCloudModeF
|
|
||||||
setExpanded (TagCloudModeTop _ i) e' = TagCloudModeTop e' i
|
|
||||||
setExpanded (TagCloudModeLowerBound _ i) e' = TagCloudModeLowerBound e' i
|
|
||||||
setExpanded (TagCloudModeRelated _ i) e' = TagCloudModeRelated e' i
|
|
||||||
setExpanded TagCloudModeNone _ = TagCloudModeNone
|
|
||||||
|
|
||||||
showMode :: TagCloudModeF -> String
|
|
||||||
showMode (TagCloudModeTop _ _) = "top"
|
|
||||||
showMode (TagCloudModeLowerBound _ _) = "lowerBound"
|
|
||||||
showMode (TagCloudModeRelated _ _) = "related"
|
|
||||||
showMode TagCloudModeNone = ""
|
|
||||||
|
|
||||||
-- isSameMode :: TagCloudModeF -> TagCloudModeF -> Boolean
|
|
||||||
-- isSameMode (TagCloudModeTop _ _) (TagCloudModeTop _ _) = true
|
|
||||||
-- isSameMode (TagCloudModeLowerBound _ _) (TagCloudModeLowerBound _ _) = true
|
|
||||||
-- isSameMode (TagCloudModeRelated _ _) (TagCloudModeRelated _ _) = true
|
|
||||||
-- isSameMode TagCloudModeNone TagCloudModeNone = true
|
|
||||||
-- isSameMode _ _ = false
|
|
||||||
|
|
|
@ -8,13 +8,12 @@ import Data.Foldable (for_)
|
||||||
import Data.Maybe (Maybe(..), fromJust, fromMaybe, maybe)
|
import Data.Maybe (Maybe(..), fromJust, fromMaybe, maybe)
|
||||||
import Data.Nullable (Nullable, toMaybe)
|
import Data.Nullable (Nullable, toMaybe)
|
||||||
import Data.String (Pattern(..), Replacement(..), drop, replaceAll, split, take)
|
import Data.String (Pattern(..), Replacement(..), drop, replaceAll, split, take)
|
||||||
import Data.String as S
|
|
||||||
import Data.Tuple (Tuple(..), fst, snd)
|
import Data.Tuple (Tuple(..), fst, snd)
|
||||||
import Effect (Effect)
|
import Effect (Effect)
|
||||||
|
import Global.Unsafe (unsafeDecodeURIComponent)
|
||||||
import Halogen (ClassName(..))
|
import Halogen (ClassName(..))
|
||||||
import Halogen.HTML as HH
|
import Halogen.HTML as HH
|
||||||
import Halogen.HTML.Properties as HP
|
import Halogen.HTML.Properties as HP
|
||||||
import JSURI (decodeURIComponent, encodeURIComponent)
|
|
||||||
import Partial.Unsafe (unsafePartial)
|
import Partial.Unsafe (unsafePartial)
|
||||||
import Web.DOM (Element, Node)
|
import Web.DOM (Element, Node)
|
||||||
import Web.DOM.Document (toNonElementParentNode)
|
import Web.DOM.Document (toNonElementParentNode)
|
||||||
|
@ -30,9 +29,6 @@ import Web.HTML.HTMLElement (fromElement) as HE
|
||||||
import Web.HTML.Location (search)
|
import Web.HTML.Location (search)
|
||||||
import Web.HTML.Window (document, location)
|
import Web.HTML.Window (document, location)
|
||||||
|
|
||||||
unsafeDecode :: String -> String
|
|
||||||
unsafeDecode str = unsafePartial $ fromJust $ decodeURIComponent str
|
|
||||||
|
|
||||||
-- Halogen
|
-- Halogen
|
||||||
|
|
||||||
class_ :: forall r i. String -> HP.IProp ( "class" :: String | r) i
|
class_ :: forall r i. String -> HP.IProp ( "class" :: String | r) i
|
||||||
|
@ -98,7 +94,7 @@ _parseQueryString srh = do
|
||||||
let qs = let srh' = take 1 srh in if (srh' == "#" || srh' == "?") then drop 1 srh else srh
|
let qs = let srh' = take 1 srh in if (srh' == "#" || srh' == "?") then drop 1 srh else srh
|
||||||
mapMaybe go $ (filter (_ /= "") <<< split (Pattern "&")) qs
|
mapMaybe go $ (filter (_ /= "") <<< split (Pattern "&")) qs
|
||||||
where
|
where
|
||||||
decode = unsafeDecode <<< replaceAll (Pattern "+") (Replacement " ")
|
decode = unsafeDecodeURIComponent <<< replaceAll (Pattern "+") (Replacement " ")
|
||||||
go kv =
|
go kv =
|
||||||
case split (Pattern "=") kv of
|
case split (Pattern "=") kv of
|
||||||
[k] -> Just (Tuple (decode k) Nothing)
|
[k] -> Just (Tuple (decode k) Nothing)
|
||||||
|
@ -118,9 +114,6 @@ _mt = MaybeT
|
||||||
_mt_pure :: forall a. Maybe a -> MaybeT Effect a
|
_mt_pure :: forall a. Maybe a -> MaybeT Effect a
|
||||||
_mt_pure = MaybeT <<< pure
|
_mt_pure = MaybeT <<< pure
|
||||||
|
|
||||||
encodeTag :: String -> String
|
|
||||||
encodeTag = fromMaybe "" <<< encodeURIComponent <<< replaceAll (Pattern "+") (Replacement "%2B")
|
|
||||||
|
|
||||||
dummyAttr :: forall r i. HP.IProp r i
|
dummyAttr :: forall r i. HP.IProp r i
|
||||||
dummyAttr = HP.attr (HH.AttrName "data-dummy") ""
|
dummyAttr = HP.attr (HH.AttrName "data-dummy") ""
|
||||||
|
|
||||||
|
@ -142,14 +135,8 @@ whenA b k = if b then k unit else []
|
||||||
ifElseH :: forall p i. Boolean -> (Unit -> HH.HTML p i) -> (Unit -> HH.HTML p i) -> HH.HTML p i
|
ifElseH :: forall p i. Boolean -> (Unit -> HH.HTML p i) -> (Unit -> HH.HTML p i) -> HH.HTML p i
|
||||||
ifElseH b f k = if b then f unit else k unit
|
ifElseH b f k = if b then f unit else k unit
|
||||||
|
|
||||||
ifElseA :: forall t. Boolean -> (Unit -> Array t) -> (Unit -> Array t) -> Array t
|
|
||||||
ifElseA b f k = if b then f unit else k unit
|
|
||||||
|
|
||||||
maybeH :: forall a p i. Maybe a -> (a -> HH.HTML p i) -> HH.HTML p i
|
maybeH :: forall a p i. Maybe a -> (a -> HH.HTML p i) -> HH.HTML p i
|
||||||
maybeH m k = maybe (HH.text "") k m
|
maybeH m k = maybe (HH.text "") k m
|
||||||
|
|
||||||
fromNullableStr :: Nullable String -> String
|
fromNullableStr :: Nullable String -> String
|
||||||
fromNullableStr = fromMaybe "" <<< toMaybe
|
fromNullableStr = fromMaybe "" <<< toMaybe
|
||||||
|
|
||||||
monthNames :: Array String
|
|
||||||
monthNames = ["january", "february", "march", "april", "may", "june", "july", "august", "september", "october", "november", "december"]
|
|
||||||
|
|
|
@ -1,5 +1,4 @@
|
||||||
{-# OPTIONS_GHC -fno-warn-orphans #-}
|
{-# OPTIONS_GHC -fno-warn-orphans #-}
|
||||||
{-# OPTIONS_GHC -fno-warn-partial-type-signatures #-}
|
|
||||||
|
|
||||||
module Application
|
module Application
|
||||||
( getApplicationDev
|
( getApplicationDev
|
||||||
|
@ -16,7 +15,7 @@ module Application
|
||||||
) where
|
) where
|
||||||
|
|
||||||
import Control.Monad.Logger (liftLoc, runLoggingT)
|
import Control.Monad.Logger (liftLoc, runLoggingT)
|
||||||
import Database.Persist.Sqlite (ConnectionPool, mkSqliteConnectionInfo, createSqlitePoolFromInfo, fkEnabled, runSqlPool, sqlDatabase, sqlPoolSize)
|
import Database.Persist.Sqlite (createSqlitePool, runSqlPool, sqlDatabase, sqlPoolSize)
|
||||||
import Import
|
import Import
|
||||||
import Language.Haskell.TH.Syntax (qLocation)
|
import Language.Haskell.TH.Syntax (qLocation)
|
||||||
import Lens.Micro
|
import Lens.Micro
|
||||||
|
@ -29,6 +28,12 @@ import Network.Wai.Middleware.Gzip
|
||||||
import Network.Wai.Middleware.MethodOverride
|
import Network.Wai.Middleware.MethodOverride
|
||||||
import Network.Wai.Middleware.RequestLogger (Destination(Logger), IPAddrSource(..), OutputFormat(..), destination, mkRequestLogger, outputFormat)
|
import Network.Wai.Middleware.RequestLogger (Destination(Logger), IPAddrSource(..), OutputFormat(..), destination, mkRequestLogger, outputFormat)
|
||||||
import System.Log.FastLogger (defaultBufSize, newStdoutLoggerSet, toLogStr)
|
import System.Log.FastLogger (defaultBufSize, newStdoutLoggerSet, toLogStr)
|
||||||
|
import Yesod.Auth (getAuth)
|
||||||
|
|
||||||
|
import qualified Control.Monad.Metrics as MM
|
||||||
|
import qualified Network.Wai.Metrics as WM
|
||||||
|
import qualified System.Metrics as EKG
|
||||||
|
import qualified System.Remote.Monitoring as EKG
|
||||||
|
|
||||||
-- Import all relevant handler modules here.
|
-- Import all relevant handler modules here.
|
||||||
-- Don't forget to add new modules to your cabal file!
|
-- Don't forget to add new modules to your cabal file!
|
||||||
|
@ -47,6 +52,9 @@ makeFoundation :: AppSettings -> IO App
|
||||||
makeFoundation appSettings = do
|
makeFoundation appSettings = do
|
||||||
appHttpManager <- getGlobalManager
|
appHttpManager <- getGlobalManager
|
||||||
appLogger <- newStdoutLoggerSet defaultBufSize >>= makeYesodLogger
|
appLogger <- newStdoutLoggerSet defaultBufSize >>= makeYesodLogger
|
||||||
|
store <- EKG.newStore
|
||||||
|
EKG.registerGcMetrics store
|
||||||
|
appMetrics <- MM.initializeWith store
|
||||||
appStatic <-
|
appStatic <-
|
||||||
(if appMutableStatic appSettings
|
(if appMutableStatic appSettings
|
||||||
then staticDevel
|
then staticDevel
|
||||||
|
@ -55,29 +63,27 @@ makeFoundation appSettings = do
|
||||||
let mkFoundation appConnPool = App { ..}
|
let mkFoundation appConnPool = App { ..}
|
||||||
tempFoundation = mkFoundation (error "connPool forced in tempFoundation")
|
tempFoundation = mkFoundation (error "connPool forced in tempFoundation")
|
||||||
logFunc = messageLoggerSource tempFoundation appLogger
|
logFunc = messageLoggerSource tempFoundation appLogger
|
||||||
pool <- mkPool logFunc True
|
pool <-
|
||||||
poolMigrations <- mkPool logFunc False
|
flip runLoggingT logFunc $
|
||||||
runLoggingT (runSqlPool runMigrations poolMigrations) logFunc
|
createSqlitePool
|
||||||
|
(sqlDatabase (appDatabaseConf appSettings))
|
||||||
|
(sqlPoolSize (appDatabaseConf appSettings))
|
||||||
|
runLoggingT
|
||||||
|
(runSqlPool runMigrations pool)
|
||||||
|
logFunc
|
||||||
return (mkFoundation pool)
|
return (mkFoundation pool)
|
||||||
where
|
|
||||||
mkPool :: _ -> Bool -> IO ConnectionPool
|
|
||||||
mkPool logFunc isFkEnabled =
|
|
||||||
flip runLoggingT logFunc $ do
|
|
||||||
let dbPath = sqlDatabase (appDatabaseConf appSettings)
|
|
||||||
poolSize = sqlPoolSize (appDatabaseConf appSettings)
|
|
||||||
connInfo = mkSqliteConnectionInfo dbPath &
|
|
||||||
set fkEnabled isFkEnabled
|
|
||||||
createSqlitePoolFromInfo connInfo poolSize
|
|
||||||
|
|
||||||
|
|
||||||
makeApplication :: App -> IO Application
|
makeApplication :: App -> IO Application
|
||||||
makeApplication foundation = do
|
makeApplication foundation = do
|
||||||
logWare <- makeLogWare foundation
|
logWare <- makeLogWare foundation
|
||||||
appPlain <- toWaiAppPlain foundation
|
appPlain <- toWaiAppPlain foundation
|
||||||
return (logWare (makeMiddleware appPlain))
|
let store = appMetrics foundation ^. MM.metricsStore
|
||||||
|
waiMetrics <- WM.registerWaiMetrics store
|
||||||
|
return (logWare (makeMiddleware waiMetrics appPlain))
|
||||||
|
|
||||||
makeMiddleware :: Middleware
|
makeMiddleware :: WM.WaiMetrics -> Middleware
|
||||||
makeMiddleware =
|
makeMiddleware waiMetrics =
|
||||||
|
WM.metrics waiMetrics .
|
||||||
acceptOverride .
|
acceptOverride .
|
||||||
autohead .
|
autohead .
|
||||||
gzip def {gzipFiles = GzipPreCompressed GzipIgnore} .
|
gzip def {gzipFiles = GzipPreCompressed GzipIgnore} .
|
||||||
|
@ -121,6 +127,7 @@ getApplicationDev = do
|
||||||
foundation <- makeFoundation settings
|
foundation <- makeFoundation settings
|
||||||
wsettings <- getDevSettings (warpSettings foundation)
|
wsettings <- getDevSettings (warpSettings foundation)
|
||||||
app <- makeApplication foundation
|
app <- makeApplication foundation
|
||||||
|
forkEKG foundation
|
||||||
return (wsettings, app)
|
return (wsettings, app)
|
||||||
|
|
||||||
getAppSettings :: IO AppSettings
|
getAppSettings :: IO AppSettings
|
||||||
|
@ -130,12 +137,23 @@ getAppSettings = loadYamlSettings [configSettingsYml] [] useEnv
|
||||||
develMain :: IO ()
|
develMain :: IO ()
|
||||||
develMain = develMainHelper getApplicationDev
|
develMain = develMainHelper getApplicationDev
|
||||||
|
|
||||||
|
forkEKG :: App -> IO ()
|
||||||
|
forkEKG foundation =
|
||||||
|
let settings = appSettings foundation in
|
||||||
|
for_ (appEkgHost settings) $ \ekgHost ->
|
||||||
|
for_ (appEkgPort settings) $ \ekgPort ->
|
||||||
|
EKG.forkServerWith
|
||||||
|
(appMetrics foundation ^. MM.metricsStore)
|
||||||
|
(encodeUtf8 ekgHost)
|
||||||
|
ekgPort
|
||||||
|
|
||||||
-- | The @main@ function for an executable running this site.
|
-- | The @main@ function for an executable running this site.
|
||||||
appMain :: IO ()
|
appMain :: IO ()
|
||||||
appMain = do
|
appMain = do
|
||||||
settings <- loadYamlSettingsArgs [configSettingsYmlValue] useEnv
|
settings <- loadYamlSettingsArgs [configSettingsYmlValue] useEnv
|
||||||
foundation <- makeFoundation settings
|
foundation <- makeFoundation settings
|
||||||
app <- makeApplication foundation
|
app <- makeApplication foundation
|
||||||
|
forkEKG foundation
|
||||||
runSettings (warpSettings foundation) app
|
runSettings (warpSettings foundation) app
|
||||||
|
|
||||||
getApplicationRepl :: IO (Int, App, Application)
|
getApplicationRepl :: IO (Int, App, Application)
|
||||||
|
|
|
@ -1,6 +1,5 @@
|
||||||
{-# LANGUAGE DeriveGeneric #-}
|
{-# LANGUAGE DeriveGeneric #-}
|
||||||
{-# LANGUAGE StandaloneDeriving #-}
|
{-# LANGUAGE StandaloneDeriving #-}
|
||||||
{-# LANGUAGE NamedFieldPuns #-}
|
|
||||||
{-# OPTIONS_GHC -fno-warn-unused-matches #-}
|
{-# OPTIONS_GHC -fno-warn-unused-matches #-}
|
||||||
|
|
||||||
module Foundation where
|
module Foundation where
|
||||||
|
@ -8,14 +7,19 @@ module Foundation where
|
||||||
import Import.NoFoundation
|
import Import.NoFoundation
|
||||||
import Database.Persist.Sql (ConnectionPool, runSqlPool)
|
import Database.Persist.Sql (ConnectionPool, runSqlPool)
|
||||||
import Text.Hamlet (hamletFile)
|
import Text.Hamlet (hamletFile)
|
||||||
|
import Text.Jasmine (minifym)
|
||||||
import PathPiece()
|
import PathPiece()
|
||||||
|
|
||||||
|
-- import Yesod.Auth.Dummy
|
||||||
|
|
||||||
|
import Yesod.Default.Util (addStaticContentExternal)
|
||||||
import Yesod.Core.Types
|
import Yesod.Core.Types
|
||||||
import Yesod.Auth.Message
|
import Yesod.Auth.Message
|
||||||
|
import qualified Network.Wai as NW
|
||||||
|
import qualified Control.Monad.Metrics as MM
|
||||||
import qualified Data.CaseInsensitive as CI
|
import qualified Data.CaseInsensitive as CI
|
||||||
import qualified Data.Text.Encoding as TE
|
import qualified Data.Text.Encoding as TE
|
||||||
import qualified Yesod.Core.Unsafe as Unsafe
|
import qualified Yesod.Core.Unsafe as Unsafe
|
||||||
import qualified Network.Wai as Wai
|
|
||||||
|
|
||||||
data App = App
|
data App = App
|
||||||
{ appSettings :: AppSettings
|
{ appSettings :: AppSettings
|
||||||
|
@ -23,6 +27,7 @@ data App = App
|
||||||
, appConnPool :: ConnectionPool -- ^ Database connection pool.
|
, appConnPool :: ConnectionPool -- ^ Database connection pool.
|
||||||
, appHttpManager :: Manager
|
, appHttpManager :: Manager
|
||||||
, appLogger :: Logger
|
, appLogger :: Logger
|
||||||
|
, appMetrics :: !MM.Metrics
|
||||||
} deriving (Typeable)
|
} deriving (Typeable)
|
||||||
|
|
||||||
mkYesodData "App" $(parseRoutesFile "config/routes")
|
mkYesodData "App" $(parseRoutesFile "config/routes")
|
||||||
|
@ -41,51 +46,19 @@ instance YesodPersist App where
|
||||||
instance YesodPersistRunner App where
|
instance YesodPersistRunner App where
|
||||||
getDBRunner = defaultGetDBRunner appConnPool
|
getDBRunner = defaultGetDBRunner appConnPool
|
||||||
|
|
||||||
session_timeout_minutes :: Int
|
|
||||||
session_timeout_minutes = 10080 -- (7 days)
|
|
||||||
|
|
||||||
-- Yesod
|
-- Yesod
|
||||||
|
|
||||||
instance Yesod App where
|
instance Yesod App where
|
||||||
approot = ApprootRequest \app req ->
|
approot = ApprootRequest $ \app req ->
|
||||||
case appRoot (appSettings app) of
|
case appRoot (appSettings app) of
|
||||||
Nothing -> getApprootText guessApproot app req
|
Nothing -> getApprootText guessApproot app req
|
||||||
Just root -> root
|
Just root -> root
|
||||||
|
|
||||||
makeSessionBackend :: App -> IO (Maybe SessionBackend)
|
makeSessionBackend _ = Just <$> defaultClientSessionBackend
|
||||||
makeSessionBackend App {appSettings} = do
|
10080 -- min (7 days)
|
||||||
backend <-
|
|
||||||
defaultClientSessionBackend
|
|
||||||
session_timeout_minutes
|
|
||||||
"config/client_session_key.aes"
|
"config/client_session_key.aes"
|
||||||
maybeSSLOnly $ pure (Just backend)
|
|
||||||
where
|
|
||||||
maybeSSLOnly =
|
|
||||||
if appSSLOnly appSettings
|
|
||||||
then sslOnlySessions
|
|
||||||
else id
|
|
||||||
|
|
||||||
yesodMiddleware :: HandlerFor App res -> HandlerFor App res
|
yesodMiddleware = metricsMiddleware . defaultYesodMiddleware . defaultCsrfMiddleware
|
||||||
yesodMiddleware = customMiddleware . defaultYesodMiddleware . customCsrfMiddleware
|
|
||||||
where
|
|
||||||
customCsrfMiddleware handler = do
|
|
||||||
maybeRoute <- getCurrentRoute
|
|
||||||
dontCheckCsrf <- case maybeRoute of
|
|
||||||
-- `maybeAuthId` checks for the validity of the Authorization
|
|
||||||
-- header anyway, but it is still a good idea to limit this
|
|
||||||
-- flexibility to designated routes.
|
|
||||||
-- For the time being, `AddR` is the only route that accepts an
|
|
||||||
-- authentication token.
|
|
||||||
Just AddR -> isJust <$> lookupHeader "Authorization"
|
|
||||||
_ -> pure False
|
|
||||||
(if dontCheckCsrf then id else defaultCsrfMiddleware) handler
|
|
||||||
|
|
||||||
customMiddleware handler = do
|
|
||||||
addHeader "X-Frame-Options" "DENY"
|
|
||||||
yesod <- getYesod
|
|
||||||
(if appSSLOnly (appSettings yesod)
|
|
||||||
then sslOnlyMiddleware session_timeout_minutes
|
|
||||||
else id) handler
|
|
||||||
|
|
||||||
defaultLayout widget = do
|
defaultLayout widget = do
|
||||||
req <- getRequest
|
req <- getRequest
|
||||||
|
@ -94,8 +67,10 @@ instance Yesod App where
|
||||||
mmsg <- getMessage
|
mmsg <- getMessage
|
||||||
musername <- maybeAuthUsername
|
musername <- maybeAuthUsername
|
||||||
muser <- (fmap.fmap) snd maybeAuthPair
|
muser <- (fmap.fmap) snd maybeAuthPair
|
||||||
|
mcurrentRoute <- getCurrentRoute
|
||||||
|
void $ mapM (incrementRouteEKG req) mcurrentRoute
|
||||||
let msourceCodeUri = appSourceCodeUri (appSettings master)
|
let msourceCodeUri = appSourceCodeUri (appSettings master)
|
||||||
pc <- widgetToPageContent do
|
pc <- widgetToPageContent $ do
|
||||||
setTitle "Espial"
|
setTitle "Espial"
|
||||||
addAppScripts
|
addAppScripts
|
||||||
addStylesheet (StaticR css_tachyons_min_css)
|
addStylesheet (StaticR css_tachyons_min_css)
|
||||||
|
@ -103,6 +78,20 @@ instance Yesod App where
|
||||||
$(widgetFile "default-layout")
|
$(widgetFile "default-layout")
|
||||||
withUrlRenderer $(hamletFile "templates/default-layout-wrapper.hamlet")
|
withUrlRenderer $(hamletFile "templates/default-layout-wrapper.hamlet")
|
||||||
|
|
||||||
|
addStaticContent ext mime content = do
|
||||||
|
master <- getYesod
|
||||||
|
let staticDir = appStaticDir (appSettings master)
|
||||||
|
addStaticContentExternal
|
||||||
|
minifym
|
||||||
|
genFileName
|
||||||
|
staticDir
|
||||||
|
(StaticR . flip StaticRoute [])
|
||||||
|
ext
|
||||||
|
mime
|
||||||
|
content
|
||||||
|
where
|
||||||
|
genFileName lbs = "autogen-" ++ base64md5 lbs
|
||||||
|
|
||||||
shouldLogIO app _source level =
|
shouldLogIO app _source level =
|
||||||
pure $ appShouldLogAll (appSettings app) || level == LevelWarn || level == LevelError
|
pure $ appShouldLogAll (appSettings app) || level == LevelWarn || level == LevelError
|
||||||
makeLogger = return . appLogger
|
makeLogger = return . appLogger
|
||||||
|
@ -142,7 +131,7 @@ popupLayout widget = do
|
||||||
mmsg <- getMessage
|
mmsg <- getMessage
|
||||||
musername <- maybeAuthUsername
|
musername <- maybeAuthUsername
|
||||||
let msourceCodeUri = appSourceCodeUri (appSettings master)
|
let msourceCodeUri = appSourceCodeUri (appSettings master)
|
||||||
pc <- widgetToPageContent do
|
pc <- widgetToPageContent $ do
|
||||||
addAppScripts
|
addAppScripts
|
||||||
addStylesheet (StaticR css_tachyons_min_css)
|
addStylesheet (StaticR css_tachyons_min_css)
|
||||||
addStylesheet (StaticR css_popup_css)
|
addStylesheet (StaticR css_popup_css)
|
||||||
|
@ -150,10 +139,23 @@ popupLayout widget = do
|
||||||
withUrlRenderer $(hamletFile "templates/default-layout-wrapper.hamlet")
|
withUrlRenderer $(hamletFile "templates/default-layout-wrapper.hamlet")
|
||||||
|
|
||||||
|
|
||||||
|
metricsMiddleware :: Handler a -> Handler a
|
||||||
|
metricsMiddleware handler = do
|
||||||
|
req <- getRequest
|
||||||
|
mcurrentRoute <- getCurrentRoute
|
||||||
|
void $ mapM (incrementRouteEKG req) mcurrentRoute
|
||||||
|
handler
|
||||||
|
|
||||||
|
|
||||||
|
incrementRouteEKG :: YesodRequest -> Route App -> Handler ()
|
||||||
|
incrementRouteEKG req = MM.increment . (\r -> "route." <> r <> "." <> method) . pack . constrName
|
||||||
|
where method = decodeUtf8 $ NW.requestMethod $ reqWaiRequest req
|
||||||
|
|
||||||
-- YesodAuth
|
-- YesodAuth
|
||||||
|
|
||||||
instance YesodAuth App where
|
instance YesodAuth App where
|
||||||
type AuthId App = UserId
|
type AuthId App = UserId
|
||||||
|
-- authHttpManager = getHttpManager
|
||||||
authPlugins _ = [dbAuthPlugin]
|
authPlugins _ = [dbAuthPlugin]
|
||||||
authenticate = authenticateCreds
|
authenticate = authenticateCreds
|
||||||
loginDest = const HomeR
|
loginDest = const HomeR
|
||||||
|
@ -164,27 +166,12 @@ instance YesodAuth App where
|
||||||
onLogout =
|
onLogout =
|
||||||
deleteSession userNameKey
|
deleteSession userNameKey
|
||||||
redirectToReferer = const True
|
redirectToReferer = const True
|
||||||
maybeAuthId = do
|
|
||||||
req <- waiRequest
|
|
||||||
let mAuthHeader = lookup "Authorization" (Wai.requestHeaders req)
|
|
||||||
extractKey = stripPrefix "ApiKey " . TE.decodeUtf8
|
|
||||||
case mAuthHeader of
|
|
||||||
Just authHeader ->
|
|
||||||
case extractKey authHeader of
|
|
||||||
Just apiKey -> do
|
|
||||||
user <- liftHandler $ runDB $ getApiKeyUser (ApiKey apiKey)
|
|
||||||
let userId = entityKey <$> user
|
|
||||||
pure userId
|
|
||||||
-- Since we disable CSRF middleware in the presence of Authorization
|
|
||||||
-- header, we need to explicitly check for the validity of the header
|
|
||||||
-- content. Otherwise, a dummy Authorization header with garbage input
|
|
||||||
-- could be provided to circumvent CSRF token requirement, making the app
|
|
||||||
-- vulnerable to CSRF attacks.
|
|
||||||
Nothing -> pure Nothing
|
|
||||||
_ -> defaultMaybeAuthId
|
|
||||||
|
|
||||||
instance YesodAuthPersist App
|
instance YesodAuthPersist App
|
||||||
|
|
||||||
|
instance MM.MonadMetrics Handler where
|
||||||
|
getMetrics = pure . appMetrics =<< getYesod
|
||||||
|
|
||||||
-- session keys
|
-- session keys
|
||||||
|
|
||||||
maybeAuthUsername :: Handler (Maybe Text)
|
maybeAuthUsername :: Handler (Maybe Text)
|
||||||
|
@ -205,7 +192,6 @@ dbAuthPluginName = "db"
|
||||||
dbAuthPlugin :: AuthPlugin App
|
dbAuthPlugin :: AuthPlugin App
|
||||||
dbAuthPlugin = AuthPlugin dbAuthPluginName dbDispatch dbLoginHandler
|
dbAuthPlugin = AuthPlugin dbAuthPluginName dbDispatch dbLoginHandler
|
||||||
where
|
where
|
||||||
dbDispatch :: Text -> [Text] -> AuthHandler App TypedContent
|
|
||||||
dbDispatch "POST" ["login"] = dbPostLoginR >>= sendResponse
|
dbDispatch "POST" ["login"] = dbPostLoginR >>= sendResponse
|
||||||
dbDispatch _ _ = notFound
|
dbDispatch _ _ = notFound
|
||||||
dbLoginHandler toParent = do
|
dbLoginHandler toParent = do
|
||||||
|
@ -244,7 +230,7 @@ authenticateCreds Creds {..} = do
|
||||||
muser <-
|
muser <-
|
||||||
case credsPlugin of
|
case credsPlugin of
|
||||||
p | p == dbAuthPluginName -> liftHandler $ runDB $
|
p | p == dbAuthPluginName -> liftHandler $ runDB $
|
||||||
join <$> mapM (\pwd -> authenticatePassword credsIdent pwd) (lookup "password" credsExtra)
|
join <$> mapM (authenticatePassword credsIdent) (lookup "password" credsExtra)
|
||||||
_ -> pure Nothing
|
_ -> pure Nothing
|
||||||
case muser of
|
case muser of
|
||||||
Nothing -> pure (UserError InvalidUsernamePass)
|
Nothing -> pure (UserError InvalidUsernamePass)
|
||||||
|
|
|
@ -2,12 +2,11 @@ module Generic where
|
||||||
|
|
||||||
import GHC.Generics
|
import GHC.Generics
|
||||||
import ClassyPrelude.Yesod
|
import ClassyPrelude.Yesod
|
||||||
import Data.Kind (Type)
|
|
||||||
|
|
||||||
constrName :: (HasConstructor (Rep a), Generic a)=> a -> String
|
constrName :: (HasConstructor (Rep a), Generic a)=> a -> String
|
||||||
constrName = genericConstrName . from
|
constrName = genericConstrName . from
|
||||||
|
|
||||||
class HasConstructor (f :: Type -> Type) where
|
class HasConstructor (f :: * -> *) where
|
||||||
genericConstrName :: f x -> String
|
genericConstrName :: f x -> String
|
||||||
|
|
||||||
instance HasConstructor f => HasConstructor (D1 c f) where
|
instance HasConstructor f => HasConstructor (D1 c f) where
|
||||||
|
|
|
@ -8,14 +8,14 @@ getAccountSettingsR = do
|
||||||
(_, user) <- requireAuthPair
|
(_, user) <- requireAuthPair
|
||||||
let accountSettingsEl = "accountSettings" :: Text
|
let accountSettingsEl = "accountSettings" :: Text
|
||||||
let accountSettings = toAccountSettingsForm user
|
let accountSettings = toAccountSettingsForm user
|
||||||
defaultLayout do
|
defaultLayout $ do
|
||||||
$(widgetFile "user-settings")
|
$(widgetFile "user-settings")
|
||||||
toWidgetBody [julius|
|
toWidgetBody [julius|
|
||||||
app.userR = "@{UserR (UserNameP $ userName user)}";
|
app.userR = "@{UserR (UserNameP $ userName user)}";
|
||||||
app.dat.accountSettings = #{ toJSON accountSettings } || [];
|
app.dat.accountSettings = #{ toJSON accountSettings } || [];
|
||||||
|]
|
|]
|
||||||
toWidget [julius|
|
toWidget [julius|
|
||||||
PS.renderAccountSettings('##{rawJS accountSettingsEl}')(app.dat.accountSettings)();
|
PS['Main'].renderAccountSettings('##{rawJS accountSettingsEl}')(app.dat.accountSettings)();
|
||||||
|]
|
|]
|
||||||
|
|
||||||
postEditAccountSettingsR :: Handler ()
|
postEditAccountSettingsR :: Handler ()
|
||||||
|
@ -34,23 +34,17 @@ getChangePasswordR = do
|
||||||
|
|
||||||
postChangePasswordR :: Handler Html
|
postChangePasswordR :: Handler Html
|
||||||
postChangePasswordR = do
|
postChangePasswordR = do
|
||||||
(userId, user) <- requireAuthPair
|
userId <- requireAuthId
|
||||||
runInputPostResult ((,) <$> ireq textField "oldpassword" <*> ireq textField "newpassword") >>= \case
|
mauthuname <- maybeAuthUsername
|
||||||
FormSuccess (old, new) -> do
|
mresult <- runInputPostResult ((,) <$> ireq textField "oldpassword" <*> ireq textField "newpassword")
|
||||||
runDB (authenticatePassword (userName user) old) >>= \case
|
case (mauthuname, mresult) of
|
||||||
Nothing -> setMessage "Incorrect Old Password"
|
(Just uname, FormSuccess (old, new)) -> do
|
||||||
Just _ -> validateNewPassword new >>= \case
|
muser <- runDB (authenticatePassword uname old)
|
||||||
Just newValid -> do
|
case muser of
|
||||||
newHash <- liftIO (hashPassword newValid)
|
Just _ -> do
|
||||||
void $ runDB (update userId [UserPasswordHash CP.=. newHash])
|
new' <- liftIO (hashPassword new)
|
||||||
|
void $ runDB (update userId [UserPasswordHash CP.=. new'])
|
||||||
setMessage "Password Changed Successfully"
|
setMessage "Password Changed Successfully"
|
||||||
_ -> pure ()
|
_ -> setMessage "Incorrect Old Password"
|
||||||
_ -> setMessage "Missing Required Fields"
|
_ -> setMessage "Missing Required Fields"
|
||||||
redirect ChangePasswordR
|
redirect ChangePasswordR
|
||||||
|
|
||||||
validateNewPassword :: Text -> Handler (Maybe Text)
|
|
||||||
validateNewPassword = \case
|
|
||||||
new | length new < 6 -> do
|
|
||||||
setMessage "Password must be at least 6 characters long"
|
|
||||||
pure Nothing
|
|
||||||
new -> pure $ Just new
|
|
||||||
|
|
|
@ -3,7 +3,6 @@ module Handler.Add where
|
||||||
import Import
|
import Import
|
||||||
import Handler.Archive
|
import Handler.Archive
|
||||||
import Data.List (nub)
|
import Data.List (nub)
|
||||||
import qualified Data.Text as T (replace)
|
|
||||||
|
|
||||||
-- View
|
-- View
|
||||||
|
|
||||||
|
@ -12,13 +11,12 @@ getAddViewR = do
|
||||||
userId <- requireAuthId
|
userId <- requireAuthId
|
||||||
|
|
||||||
murl <- lookupGetParam "url"
|
murl <- lookupGetParam "url"
|
||||||
mBookmarkDb <- runDB (fetchBookmarkByUrl userId murl)
|
mformdb <- runDB (pure . fmap _toBookmarkForm =<< fetchBookmarkByUrl userId murl)
|
||||||
let mformdb = fmap _toBookmarkForm mBookmarkDb
|
|
||||||
formurl <- bookmarkFormUrl
|
formurl <- bookmarkFormUrl
|
||||||
|
|
||||||
let renderEl = "addForm" :: Text
|
let renderEl = "addForm" :: Text
|
||||||
|
|
||||||
popupLayout do
|
popupLayout $ do
|
||||||
toWidget [whamlet|
|
toWidget [whamlet|
|
||||||
<div id="#{ renderEl }">
|
<div id="#{ renderEl }">
|
||||||
|]
|
|]
|
||||||
|
@ -26,65 +24,44 @@ getAddViewR = do
|
||||||
app.dat.bmark = #{ toJSON (fromMaybe formurl mformdb) };
|
app.dat.bmark = #{ toJSON (fromMaybe formurl mformdb) };
|
||||||
|]
|
|]
|
||||||
toWidget [julius|
|
toWidget [julius|
|
||||||
PS.renderAddForm('##{rawJS renderEl}')(app.dat.bmark)();
|
PS['Main'].renderAddForm('##{rawJS renderEl}')(app.dat.bmark)();
|
||||||
|]
|
|]
|
||||||
|
|
||||||
bookmarkFormUrl :: Handler BookmarkForm
|
bookmarkFormUrl :: Handler BookmarkForm
|
||||||
bookmarkFormUrl = do
|
bookmarkFormUrl = do
|
||||||
Entity _ user <- requireAuth
|
Entity _ user <- requireAuth
|
||||||
url <- lookupGetParam "url" <&> fromMaybe ""
|
|
||||||
title <- lookupGetParam "title"
|
|
||||||
description <- lookupGetParam "description" <&> fmap Textarea
|
|
||||||
tags <- lookupGetParam "tags"
|
|
||||||
private <- lookupGetParam "private" <&> fmap parseChk <&> (<|> Just (userPrivateDefault user))
|
|
||||||
toread <- lookupGetParam "toread" <&> fmap parseChk
|
|
||||||
pure $
|
|
||||||
BookmarkForm
|
BookmarkForm
|
||||||
{ _url = url
|
<$> (lookupGetParam "url" >>= pure . fromMaybe "")
|
||||||
, _title = title
|
<*> (lookupGetParam "title")
|
||||||
, _description = description
|
<*> (lookupGetParam "description" >>= pure . fmap Textarea)
|
||||||
, _tags = tags
|
<*> (lookupGetParam "tags")
|
||||||
, _private = private
|
<*> (lookupGetParam "private" >>= pure . fmap parseChk <&> (<|> Just (userPrivateDefault user)))
|
||||||
, _toread = toread
|
<*> (lookupGetParam "toread" >>= pure . fmap parseChk)
|
||||||
, _bid = Nothing
|
<*> pure Nothing
|
||||||
, _slug = Nothing
|
<*> pure Nothing
|
||||||
, _selected = Nothing
|
<*> pure Nothing
|
||||||
, _time = Nothing
|
<*> pure Nothing
|
||||||
, _archiveUrl = Nothing
|
<*> pure Nothing
|
||||||
}
|
|
||||||
where
|
where
|
||||||
parseChk s = s == "yes" || s == "on" || s == "true" || s == "1"
|
parseChk s = s == "yes" || s == "on"
|
||||||
|
|
||||||
-- API
|
-- API
|
||||||
|
|
||||||
postAddR :: Handler Text
|
postAddR :: Handler ()
|
||||||
postAddR = do
|
postAddR = do
|
||||||
bookmarkForm <- requireCheckJsonBody
|
bookmarkForm <- requireCheckJsonBody
|
||||||
_handleFormSuccess bookmarkForm >>= \case
|
_handleFormSuccess bookmarkForm >>= \case
|
||||||
Created bid -> sendStatusJSON created201 bid
|
(Created, bid) -> sendStatusJSON created201 bid
|
||||||
Updated _ -> sendResponseStatus noContent204 ()
|
(Updated, _) -> sendResponseStatus noContent204 ()
|
||||||
Failed s -> sendResponseStatus status400 s
|
|
||||||
|
|
||||||
_handleFormSuccess :: BookmarkForm -> Handler (UpsertResult (Key Bookmark))
|
_handleFormSuccess :: BookmarkForm -> Handler (UpsertResult, Key Bookmark)
|
||||||
_handleFormSuccess bookmarkForm = do
|
_handleFormSuccess bookmarkForm = do
|
||||||
(userId, user) <- requireAuthPair
|
(userId, user) <- requireAuthPair
|
||||||
appSettings <- appSettings <$> getYesod
|
|
||||||
case (appAllowNonHttpUrlSchemes appSettings, (parseRequest . unpack . _url) bookmarkForm) of
|
|
||||||
(False, Nothing) -> pure $ Failed "Invalid URL"
|
|
||||||
(_, _) -> do
|
|
||||||
let mkbid = BookmarkKey <$> _bid bookmarkForm
|
|
||||||
tags = maybe [] (nub . words . T.replace "," " ") (_tags bookmarkForm)
|
|
||||||
bm <- liftIO $ _toBookmark userId bookmarkForm
|
bm <- liftIO $ _toBookmark userId bookmarkForm
|
||||||
res <- runDB (upsertBookmark userId mkbid bm tags)
|
(res, kbid) <- runDB (upsertBookmark mkbid bm tags)
|
||||||
forM_ (maybeUpsertResult res) $ \kbid ->
|
|
||||||
whenM (shouldArchiveBookmark user kbid) $
|
whenM (shouldArchiveBookmark user kbid) $
|
||||||
void $ async (archiveBookmarkUrl kbid (unpack (bookmarkHref bm)))
|
void $ async (archiveBookmarkUrl kbid (unpack (bookmarkHref bm)))
|
||||||
pure res
|
pure (res, kbid)
|
||||||
|
where
|
||||||
postLookupTitleR :: Handler ()
|
mkbid = BookmarkKey <$> _bid bookmarkForm
|
||||||
postLookupTitleR = do
|
tags = maybe [] (nub . words) (_tags bookmarkForm)
|
||||||
void requireAuthId
|
|
||||||
bookmarkForm <- (requireCheckJsonBody :: Handler BookmarkForm)
|
|
||||||
fetchPageTitle (unpack (_url bookmarkForm)) >>= \case
|
|
||||||
Left _ -> sendResponseStatus noContent204 ()
|
|
||||||
Right title -> sendResponseStatus ok200 title
|
|
||||||
|
|
|
@ -2,9 +2,7 @@ module Handler.Archive where
|
||||||
|
|
||||||
import Import
|
import Import
|
||||||
import Data.Function ((&))
|
import Data.Function ((&))
|
||||||
import Data.Char (ord)
|
import qualified Data.Attoparsec.ByteString.Char8 as AP
|
||||||
import qualified Data.Attoparsec.ByteString.Char8 as AP8
|
|
||||||
import qualified Data.Attoparsec.ByteString as AP
|
|
||||||
import qualified Data.ByteString as BS
|
import qualified Data.ByteString as BS
|
||||||
import qualified Data.ByteString.Lazy as LBS
|
import qualified Data.ByteString.Lazy as LBS
|
||||||
import qualified Data.ByteString.Char8 as BS8
|
import qualified Data.ByteString.Char8 as BS8
|
||||||
|
@ -12,56 +10,45 @@ import qualified Network.HTTP.Client as NH
|
||||||
import qualified Network.HTTP.Client.TLS as NH
|
import qualified Network.HTTP.Client.TLS as NH
|
||||||
import qualified Network.HTTP.Types.Status as NH
|
import qualified Network.HTTP.Types.Status as NH
|
||||||
import qualified Web.FormUrlEncoded as WH
|
import qualified Web.FormUrlEncoded as WH
|
||||||
import HTMLEntities.Decoder (htmlEncodedText)
|
import qualified Control.Monad.Metrics as MM
|
||||||
import Data.Text.Lazy.Builder (toLazyText)
|
|
||||||
import Network.Wai (requestHeaderHost)
|
|
||||||
import qualified Network.Connection as NC
|
|
||||||
|
|
||||||
shouldArchiveBookmark :: User -> Key Bookmark -> Handler Bool
|
shouldArchiveBookmark :: User -> Key Bookmark -> Handler Bool
|
||||||
shouldArchiveBookmark user kbid =
|
shouldArchiveBookmark user kbid = do
|
||||||
runDB (get kbid) >>= \case
|
runDB (get kbid) >>= \case
|
||||||
Nothing -> pure False
|
Nothing -> pure False
|
||||||
|
|
||||||
Just bm -> do
|
Just bm -> do
|
||||||
pure $
|
pure $
|
||||||
isNothing (bookmarkArchiveHref bm) &&
|
(isNothing $ bookmarkArchiveHref bm) &&
|
||||||
bookmarkShared bm
|
(bookmarkShared bm)
|
||||||
&& not (_isArchiveBlacklisted bm)
|
&& not (_isArchiveBlacklisted bm)
|
||||||
|
&& not (userPrivacyLock user)
|
||||||
&& userArchiveDefault user
|
&& userArchiveDefault user
|
||||||
|
|
||||||
getArchiveManager :: Handler Manager
|
|
||||||
getArchiveManager = do
|
|
||||||
appSettings <- appSettings <$> getYesod
|
|
||||||
let mSocks =
|
|
||||||
NC.SockSettingsSimple <$>
|
|
||||||
fmap unpack (appArchiveSocksProxyHost appSettings) <*>
|
|
||||||
fmap toEnum (appArchiveSocksProxyPort appSettings)
|
|
||||||
NH.newTlsManagerWith (NH.mkManagerSettings def mSocks)
|
|
||||||
|
|
||||||
|
|
||||||
archiveBookmarkUrl :: Key Bookmark -> String -> Handler ()
|
archiveBookmarkUrl :: Key Bookmark -> String -> Handler ()
|
||||||
archiveBookmarkUrl kbid url =
|
archiveBookmarkUrl kbid url =
|
||||||
(_fetchArchiveSubmitInfo >>= \case
|
(_fetchArchiveSubmitInfo >>= \case
|
||||||
Left e -> do
|
Left e -> do
|
||||||
|
MM.increment "archive.fetchSubmitId_noparse"
|
||||||
$(logError) (pack e)
|
$(logError) (pack e)
|
||||||
Right submitInfo -> do
|
Right submitInfo -> do
|
||||||
userId <- requireAuthId
|
userId <- requireAuthId
|
||||||
req <- _buildArchiveSubmitRequest submitInfo url
|
let req = _buildArchiveSubmitRequest submitInfo url
|
||||||
manager <- getArchiveManager
|
MM.increment "archive.submit"
|
||||||
res <- liftIO $ NH.httpLbs req manager
|
res <- liftIO $ NH.httpLbs req =<< NH.getGlobalManager
|
||||||
let status = NH.responseStatus res
|
let status = NH.responseStatus res
|
||||||
let updateArchiveUrl url' = runDB $ updateBookmarkArchiveUrl userId kbid $ Just url'
|
MM.increment ("archive.submit_status_" <> (pack.show) (NH.statusCode status))
|
||||||
|
let updateArchiveUrl = runDB . updateBookmarkArchiveUrl userId kbid . Just
|
||||||
headers = NH.responseHeaders res
|
headers = NH.responseHeaders res
|
||||||
case status of
|
case status of
|
||||||
s | s == NH.status200 ->
|
s | s == NH.status200 ->
|
||||||
for_ (lookup "Refresh" headers >>= _parseRefreshHeaderUrl) updateArchiveUrl
|
for_ (lookup "Refresh" headers >>= _parseRefreshHeaderUrl) updateArchiveUrl
|
||||||
s | s == NH.status302 || s == NH.status307 ->
|
s | s == NH.status302 ->
|
||||||
for_ (lookup "Location" headers) (updateArchiveUrl . decodeUtf8)
|
for_ (lookup "Location" headers) (updateArchiveUrl . decodeUtf8)
|
||||||
_ -> $(logError) (pack (show res)))
|
_ -> $(logError) (pack (show res)))
|
||||||
`catch` (\(e::SomeException) -> ($(logError) $ (pack.show) e) >> throwIO e)
|
`catch` (\(e::SomeException) -> ($(logError) $ (pack.show) e) >> throwIO e)
|
||||||
|
|
||||||
_isArchiveBlacklisted :: Bookmark -> Bool
|
_isArchiveBlacklisted :: Bookmark -> Bool
|
||||||
_isArchiveBlacklisted Bookmark {..} =
|
_isArchiveBlacklisted (Bookmark {..}) =
|
||||||
[ "hulu"
|
[ "hulu"
|
||||||
, "livestream"
|
, "livestream"
|
||||||
, "netflix"
|
, "netflix"
|
||||||
|
@ -77,73 +64,43 @@ _isArchiveBlacklisted Bookmark {..} =
|
||||||
_parseRefreshHeaderUrl :: ByteString -> Maybe Text
|
_parseRefreshHeaderUrl :: ByteString -> Maybe Text
|
||||||
_parseRefreshHeaderUrl h = do
|
_parseRefreshHeaderUrl h = do
|
||||||
let u = BS8.drop 1 $ BS8.dropWhile (/= '=') h
|
let u = BS8.drop 1 $ BS8.dropWhile (/= '=') h
|
||||||
if not (null u)
|
if (not (null u))
|
||||||
then Just $ decodeUtf8 u
|
then Just $ decodeUtf8 u
|
||||||
else Nothing
|
else Nothing
|
||||||
|
|
||||||
_fetchArchiveSubmitInfo :: Handler (Either String (String , String))
|
_buildArchiveSubmitRequest :: (String, String) -> String -> NH.Request
|
||||||
_fetchArchiveSubmitInfo = do
|
_buildArchiveSubmitRequest (action, submitId) href =
|
||||||
req <- buildRequest "https://archive.li/"
|
NH.parseRequest_ ("POST " <> action) & \r ->
|
||||||
manager <- getArchiveManager
|
r { NH.requestHeaders =
|
||||||
res <- liftIO $ NH.httpLbs req manager
|
[ ("User-Agent", _archiveUserAgent)
|
||||||
let body = LBS.toStrict (responseBody res)
|
, ("Content-Type", "application/x-www-form-urlencoded")
|
||||||
action = _parseSubstring (AP8.string "action=\"") (AP8.notChar '"') body
|
]
|
||||||
submitId = _parseSubstring (AP8.string "submitid\" value=\"") (AP8.notChar '"') body
|
, NH.requestBody = NH.RequestBodyLBS $ WH.urlEncodeAsForm ((
|
||||||
if statusCode (responseStatus res) == 200
|
[ ("submitid" , submitId)
|
||||||
then pure $ (,) <$> action <*> submitId
|
, ("url", href)
|
||||||
else pure $ Left $ "Invalid statusCode: " <> show (responseStatus res)
|
]) :: [(String, String)])
|
||||||
|
|
||||||
|
|
||||||
_parseSubstring :: AP8.Parser ByteString -> AP8.Parser Char -> BS.ByteString -> Either String String
|
|
||||||
_parseSubstring start inner = AP8.parseOnly (skipAnyTill start >> AP8.many1 inner)
|
|
||||||
where
|
|
||||||
skipAnyTill end = go where go = end $> () <|> AP8.anyChar *> go
|
|
||||||
|
|
||||||
|
|
||||||
fetchPageTitle :: String -> Handler (Either String Text)
|
|
||||||
fetchPageTitle url =
|
|
||||||
do
|
|
||||||
req <- buildRequest url
|
|
||||||
res <- liftIO $ NH.httpLbs req =<< NH.getGlobalManager
|
|
||||||
let body = LBS.toStrict (responseBody res)
|
|
||||||
pure (decodeHtmlBs <$> parseTitle body)
|
|
||||||
`catch` (\(e :: SomeException) -> do
|
|
||||||
$(logError) $ (pack . show) e
|
|
||||||
pure (Left (show e)))
|
|
||||||
where
|
|
||||||
parseTitle bs =
|
|
||||||
flip AP.parseOnly bs do
|
|
||||||
_ <- skipAnyTill (AP.string "<title")
|
|
||||||
_ <- skipAnyTill (AP.string ">")
|
|
||||||
let lt = toEnum (ord '<')
|
|
||||||
AP.takeTill (== lt)
|
|
||||||
decodeHtmlBs = toStrict . toLazyText . htmlEncodedText . decodeUtf8
|
|
||||||
skipAnyTill end = go where go = end $> () <|> AP.anyWord8 *> go
|
|
||||||
|
|
||||||
_buildArchiveSubmitRequest :: (String, String) -> String -> Handler NH.Request
|
|
||||||
_buildArchiveSubmitRequest (action, submitId) href = do
|
|
||||||
req <- buildRequest ("POST " <> action)
|
|
||||||
pure $ req
|
|
||||||
{ NH.requestHeaders = ("Content-Type", "application/x-www-form-urlencoded") : NH.requestHeaders req
|
|
||||||
, NH.requestBody =
|
|
||||||
NH.RequestBodyLBS $
|
|
||||||
WH.urlEncodeAsForm
|
|
||||||
([("submitid", submitId), ("url", href)] :: [(String, String)])
|
|
||||||
, NH.redirectCount = 0
|
, NH.redirectCount = 0
|
||||||
}
|
}
|
||||||
|
|
||||||
buildRequest :: String -> Handler Request
|
_fetchArchiveSubmitInfo :: Handler (Either String (String , String))
|
||||||
buildRequest url = do
|
_fetchArchiveSubmitInfo = do
|
||||||
ua <- _archiveUserAgent
|
MM.increment "archive.fetchSubmitId"
|
||||||
pure $ NH.parseRequest_ url & \r ->
|
res <- liftIO $ NH.httpLbs buildSubmitRequest =<< NH.getGlobalManager
|
||||||
r { NH.requestHeaders =
|
MM.increment ("archive.fetchSubmitId_status_" <> (pack.show) (NH.statusCode (NH.responseStatus res)))
|
||||||
[ ("Cache-Control", "max-age=0")
|
let body = LBS.toStrict (responseBody res)
|
||||||
, ("User-Agent", ua)
|
action = _parseSubstring (AP.string "action=\"") (AP.notChar '"') body
|
||||||
]
|
submitId = _parseSubstring (AP.string "submitid\" value=\"") (AP.notChar '"') body
|
||||||
}
|
pure $ (,) <$> action <*> submitId
|
||||||
|
where
|
||||||
|
buildSubmitRequest =
|
||||||
|
NH.parseRequest_ "https://archive.li/" & \r ->
|
||||||
|
r {NH.requestHeaders = [("User-Agent", _archiveUserAgent)]}
|
||||||
|
|
||||||
_archiveUserAgent :: Handler ByteString
|
_archiveUserAgent :: ByteString
|
||||||
_archiveUserAgent = do
|
_archiveUserAgent = "espial"
|
||||||
mHost <- requestHeaderHost . reqWaiRequest <$> getRequest
|
|
||||||
pure $ "espial-" <> maybe "" (BS8.takeWhile (/= ':')) mHost
|
|
||||||
|
|
||||||
|
_parseSubstring :: AP.Parser ByteString -> AP.Parser Char -> BS.ByteString -> Either String String
|
||||||
|
_parseSubstring start inner res = do
|
||||||
|
(flip AP.parseOnly) res (skipAnyTill start >> AP.many1 inner)
|
||||||
|
where
|
||||||
|
skipAnyTill end = go where go = end *> pure () <|> AP.anyChar *> go
|
||||||
|
|
|
@ -5,7 +5,6 @@ import Import
|
||||||
|
|
||||||
import Data.FileEmbed (embedFile)
|
import Data.FileEmbed (embedFile)
|
||||||
import Text.Read
|
import Text.Read
|
||||||
import Data.Aeson as A
|
|
||||||
|
|
||||||
-- These handlers embed files in the executable at compile time to avoid a
|
-- These handlers embed files in the executable at compile time to avoid a
|
||||||
-- runtime dependency, and for efficiency.
|
-- runtime dependency, and for efficiency.
|
||||||
|
@ -22,49 +21,11 @@ getRobotsR = return $ TypedContent typePlain
|
||||||
|
|
||||||
|
|
||||||
lookupPagingParams :: Handler (Maybe Int64, Maybe Int64)
|
lookupPagingParams :: Handler (Maybe Int64, Maybe Int64)
|
||||||
lookupPagingParams =
|
lookupPagingParams = do
|
||||||
(,)
|
cq <- fmap parseMaybe (lookupGetParam "count")
|
||||||
<$> getUrlSessionParam "count"
|
cs <- fmap parseMaybe (lookupSession "count")
|
||||||
<*> getUrlParam "page"
|
for_ cq (setSession "count" . (pack . show))
|
||||||
|
pq <- fmap parseMaybe (lookupGetParam "page")
|
||||||
getUrlParam :: (Read a) => Text -> Handler (Maybe a)
|
pure (cq <|> cs, pq)
|
||||||
getUrlParam name = do
|
|
||||||
fmap parseMaybe (lookupGetParam name)
|
|
||||||
where
|
where
|
||||||
parseMaybe x = readMaybe . unpack =<< x
|
parseMaybe x = readMaybe . unpack =<< x
|
||||||
|
|
||||||
getUrlSessionParam :: forall a.
|
|
||||||
(Show a, Read a)
|
|
||||||
=> Text
|
|
||||||
-> Handler (Maybe a)
|
|
||||||
getUrlSessionParam name = do
|
|
||||||
p <- fmap parseMaybe (lookupGetParam name)
|
|
||||||
s <- fmap parseMaybe (lookupSession name)
|
|
||||||
for_ p (setSession name . (pack . show))
|
|
||||||
pure (p <|> s)
|
|
||||||
where
|
|
||||||
parseMaybe :: Maybe Text -> Maybe a
|
|
||||||
parseMaybe x = readMaybe . unpack =<< x
|
|
||||||
|
|
||||||
lookupTagCloudMode :: MonadHandler m => m (Maybe TagCloudMode)
|
|
||||||
lookupTagCloudMode = do
|
|
||||||
(A.decode . fromStrict =<<) <$> lookupSessionBS "tagCloudMode"
|
|
||||||
|
|
||||||
setTagCloudMode :: MonadHandler m => TagCloudMode -> m ()
|
|
||||||
setTagCloudMode = setSessionBS "tagCloudMode" . toStrict . A.encode
|
|
||||||
|
|
||||||
getTagCloudMode :: MonadHandler m => Bool -> [Tag] -> m TagCloudMode
|
|
||||||
getTagCloudMode isowner tags = do
|
|
||||||
ms <- lookupTagCloudMode
|
|
||||||
let expanded = maybe False isExpanded ms
|
|
||||||
pure $
|
|
||||||
if not isowner
|
|
||||||
then TagCloudModeNone
|
|
||||||
else if not (null tags)
|
|
||||||
then TagCloudModeRelated expanded tags
|
|
||||||
else case ms of
|
|
||||||
Nothing -> TagCloudModeTop expanded 200
|
|
||||||
Just (TagCloudModeRelated e _) -> TagCloudModeTop e 200
|
|
||||||
Just m -> m
|
|
||||||
|
|
||||||
|
|
||||||
|
|
|
@ -5,5 +5,5 @@ module Handler.Docs where
|
||||||
import Import
|
import Import
|
||||||
|
|
||||||
getDocsSearchR :: Handler Html
|
getDocsSearchR :: Handler Html
|
||||||
getDocsSearchR = popupLayout
|
getDocsSearchR = popupLayout $
|
||||||
$(widgetFile "docs-search")
|
$(widgetFile "docs-search")
|
||||||
|
|
|
@ -11,16 +11,16 @@ import Import
|
||||||
deleteDeleteR :: Int64 -> Handler Html
|
deleteDeleteR :: Int64 -> Handler Html
|
||||||
deleteDeleteR bid = do
|
deleteDeleteR bid = do
|
||||||
userId <- requireAuthId
|
userId <- requireAuthId
|
||||||
runDB do
|
runDB $ do
|
||||||
let k_bid = BookmarkKey bid
|
let k_bid = BookmarkKey bid
|
||||||
_ <- requireResource userId k_bid
|
_ <- requireResource userId k_bid
|
||||||
delete k_bid
|
deleteCascade k_bid
|
||||||
return ""
|
return ""
|
||||||
|
|
||||||
postReadR :: Int64 -> Handler Html
|
postReadR :: Int64 -> Handler Html
|
||||||
postReadR bid = do
|
postReadR bid = do
|
||||||
userId <- requireAuthId
|
userId <- requireAuthId
|
||||||
runDB do
|
runDB $ do
|
||||||
let k_bid = BookmarkKey bid
|
let k_bid = BookmarkKey bid
|
||||||
_ <- requireResource userId k_bid
|
_ <- requireResource userId k_bid
|
||||||
update k_bid [BookmarkToRead =. False]
|
update k_bid [BookmarkToRead =. False]
|
||||||
|
@ -37,7 +37,7 @@ postUnstarR bid = _setSelected bid False
|
||||||
_setSelected :: Int64 -> Bool -> Handler Html
|
_setSelected :: Int64 -> Bool -> Handler Html
|
||||||
_setSelected bid selected = do
|
_setSelected bid selected = do
|
||||||
userId <- requireAuthId
|
userId <- requireAuthId
|
||||||
runDB do
|
runDB $ do
|
||||||
let k_bid = BookmarkKey bid
|
let k_bid = BookmarkKey bid
|
||||||
bm <- requireResource userId k_bid
|
bm <- requireResource userId k_bid
|
||||||
update k_bid [BookmarkSelected =. selected]
|
update k_bid [BookmarkSelected =. selected]
|
||||||
|
|
|
@ -1,5 +1,4 @@
|
||||||
{-# OPTIONS_GHC -fno-warn-unused-matches #-}
|
{-# OPTIONS_GHC -fno-warn-unused-matches #-}
|
||||||
{-# LANGUAGE TupleSections #-}
|
|
||||||
module Handler.Notes where
|
module Handler.Notes where
|
||||||
|
|
||||||
import Import
|
import Import
|
||||||
|
@ -7,28 +6,25 @@ import Handler.Common (lookupPagingParams)
|
||||||
import qualified Data.Aeson as A
|
import qualified Data.Aeson as A
|
||||||
import qualified Data.Text as T
|
import qualified Data.Text as T
|
||||||
import Yesod.RssFeed
|
import Yesod.RssFeed
|
||||||
|
import Text.Blaze.Html (toHtml)
|
||||||
import qualified Text.Blaze.Html5 as H
|
import qualified Text.Blaze.Html5 as H
|
||||||
import qualified Network.Wai.Internal as W
|
|
||||||
|
|
||||||
getNotesR :: UserNameP -> Handler Html
|
getNotesR :: UserNameP -> Handler Html
|
||||||
getNotesR unamep@(UserNameP uname) = do
|
getNotesR unamep@(UserNameP uname) = do
|
||||||
mauthuname <- maybeAuthUsername
|
muserid <- maybeAuthId
|
||||||
(limit', page') <- lookupPagingParams
|
(limit', page') <- lookupPagingParams
|
||||||
let queryp = "query"
|
let queryp = "query" :: Text
|
||||||
mquery <- lookupGetParam queryp
|
mquery <- lookupGetParam queryp
|
||||||
let limit = maybe 20 fromIntegral limit'
|
let limit = maybe 20 fromIntegral limit'
|
||||||
page = maybe 1 fromIntegral page'
|
page = maybe 1 fromIntegral page'
|
||||||
mqueryp = fmap (queryp,) mquery
|
mqueryp = fmap (\q -> (queryp, q)) mquery
|
||||||
isowner = Just uname == mauthuname
|
(bcount, notes) <- runDB $ do
|
||||||
(bcount, notes) <- runDB do
|
Entity userId _ <- getBy404 (UniqueUserName uname)
|
||||||
Entity userId user <- getBy404 (UniqueUserName uname)
|
let sharedp = if muserid == Just userId then SharedAll else SharedPublic
|
||||||
let sharedp = if isowner then SharedAll else SharedPublic
|
|
||||||
when (not isowner && userPrivacyLock user)
|
|
||||||
(redirect (AuthR LoginR))
|
|
||||||
getNoteList userId mquery sharedp limit page
|
getNoteList userId mquery sharedp limit page
|
||||||
req <- getRequest
|
req <- getRequest
|
||||||
mroute <- getCurrentRoute
|
mroute <- getCurrentRoute
|
||||||
defaultLayout do
|
defaultLayout $ do
|
||||||
rssLink (NotesFeedR unamep) "feed"
|
rssLink (NotesFeedR unamep) "feed"
|
||||||
let pager = $(widgetFile "pager")
|
let pager = $(widgetFile "pager")
|
||||||
search = $(widgetFile "search")
|
search = $(widgetFile "search")
|
||||||
|
@ -37,74 +33,60 @@ getNotesR unamep@(UserNameP uname) = do
|
||||||
toWidgetBody [julius|
|
toWidgetBody [julius|
|
||||||
app.userR = "@{UserR unamep}";
|
app.userR = "@{UserR unamep}";
|
||||||
app.dat.notes = #{ toJSON notes } || [];
|
app.dat.notes = #{ toJSON notes } || [];
|
||||||
app.dat.isowner = #{ isowner };
|
|
||||||
|]
|
|]
|
||||||
toWidget [julius|
|
toWidget [julius|
|
||||||
PS.renderNotes('##{rawJS renderEl}')(app.dat.notes)();
|
PS['Main'].renderNotes('##{rawJS renderEl}')(app.dat.notes)();
|
||||||
|]
|
|]
|
||||||
|
|
||||||
getNoteR :: UserNameP -> NtSlug -> Handler Html
|
getNoteR :: UserNameP -> NtSlug -> Handler Html
|
||||||
getNoteR unamep@(UserNameP uname) slug = do
|
getNoteR unamep@(UserNameP uname) slug = do
|
||||||
mauthuname <- maybeAuthUsername
|
|
||||||
let renderEl = "note" :: Text
|
let renderEl = "note" :: Text
|
||||||
isowner = Just uname == mauthuname
|
|
||||||
note <-
|
note <-
|
||||||
runDB $
|
runDB $
|
||||||
do Entity userId user <- getBy404 (UniqueUserName uname)
|
do Entity userId _ <- getBy404 (UniqueUserName uname)
|
||||||
mnote <- getNote userId slug
|
mnote <- getNote userId slug
|
||||||
note <- maybe notFound pure mnote
|
maybe notFound pure mnote
|
||||||
when (not isowner && (userPrivacyLock user || (not . noteShared . entityVal) note))
|
defaultLayout $ do
|
||||||
(redirect (AuthR LoginR))
|
|
||||||
pure note
|
|
||||||
defaultLayout do
|
|
||||||
$(widgetFile "note")
|
$(widgetFile "note")
|
||||||
toWidgetBody [julius|
|
toWidgetBody [julius|
|
||||||
app.userR = "@{UserR unamep}";
|
app.userR = "@{UserR unamep}";
|
||||||
app.dat.note = #{ toJSON note } || [];
|
app.dat.note = #{ toJSON note } || [];
|
||||||
app.dat.isowner = #{ isowner };
|
|
||||||
|]
|
|]
|
||||||
toWidget [julius|
|
toWidget [julius|
|
||||||
PS.renderNote('##{rawJS renderEl}')(app.dat.note)();
|
PS['Main'].renderNote('##{rawJS renderEl}')(app.dat.note)();
|
||||||
|]
|
|]
|
||||||
|
|
||||||
getAddNoteSlimViewR :: Handler Html
|
|
||||||
getAddNoteSlimViewR = do
|
|
||||||
Entity userId user <- requireAuth
|
|
||||||
getAddNoteViewR (UserNameP (userName user))
|
|
||||||
|
|
||||||
getAddNoteViewR :: UserNameP -> Handler Html
|
getAddNoteViewR :: UserNameP -> Handler Html
|
||||||
getAddNoteViewR unamep@(UserNameP uname) = do
|
getAddNoteViewR unamep@(UserNameP uname) = do
|
||||||
userId <- requireAuthId
|
userId <- requireAuthId
|
||||||
note <- liftIO . _toNote userId =<< noteFormUrl
|
|
||||||
let renderEl = "note" :: Text
|
let renderEl = "note" :: Text
|
||||||
enote = Entity (NoteKey 0) note
|
note <- liftIO $ Entity (NoteKey 0) <$> _toNote userId (NoteForm Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing)
|
||||||
defaultLayout do
|
defaultLayout $ do
|
||||||
$(widgetFile "note")
|
$(widgetFile "note")
|
||||||
toWidgetBody [julius|
|
toWidgetBody [julius|
|
||||||
app.userR = "@{UserR unamep}";
|
app.userR = "@{UserR unamep}";
|
||||||
app.noteR = "@{NoteR unamep (noteSlug (entityVal enote))}";
|
app.noteR = "@{NoteR unamep (noteSlug (entityVal note))}";
|
||||||
app.dat.note = #{ toJSON enote } || [];
|
app.dat.note = #{ toJSON note } || [];
|
||||||
|]
|
|]
|
||||||
toWidget [julius|
|
toWidget [julius|
|
||||||
PS.renderNote('##{rawJS renderEl}')(app.dat.note)();
|
PS['Main'].renderNote('##{rawJS renderEl}')(app.dat.note)();
|
||||||
|]
|
|]
|
||||||
|
|
||||||
deleteDeleteNoteR :: Int64 -> Handler Html
|
deleteDeleteNoteR :: Int64 -> Handler Html
|
||||||
deleteDeleteNoteR nid = do
|
deleteDeleteNoteR nid = do
|
||||||
userId <- requireAuthId
|
userId <- requireAuthId
|
||||||
runDB do
|
runDB $ do
|
||||||
let k_nid = NoteKey nid
|
let k_nid = NoteKey nid
|
||||||
_ <- requireResource userId k_nid
|
_ <- requireResource userId k_nid
|
||||||
delete k_nid
|
deleteCascade k_nid
|
||||||
return ""
|
return ""
|
||||||
|
|
||||||
postAddNoteR :: Handler Text
|
postAddNoteR :: Handler ()
|
||||||
postAddNoteR = do
|
postAddNoteR = do
|
||||||
noteForm <- requireCheckJsonBody
|
noteForm <- requireCheckJsonBody
|
||||||
_handleFormSuccess noteForm >>= \case
|
_handleFormSuccess noteForm >>= \case
|
||||||
Created nid -> sendStatusJSON created201 nid
|
(Created, nid) -> sendStatusJSON created201 nid
|
||||||
Updated _ -> sendResponseStatus noContent204 ()
|
(Updated, _) -> sendResponseStatus noContent204 ()
|
||||||
Failed s -> sendResponseStatus status400 s
|
|
||||||
|
|
||||||
requireResource :: UserId -> Key Note -> DBM Handler Note
|
requireResource :: UserId -> Key Note -> DBM Handler Note
|
||||||
requireResource userId k_nid = do
|
requireResource userId k_nid = do
|
||||||
|
@ -113,11 +95,11 @@ requireResource userId k_nid = do
|
||||||
then return nnote
|
then return nnote
|
||||||
else notFound
|
else notFound
|
||||||
|
|
||||||
_handleFormSuccess :: NoteForm -> Handler (UpsertResult (Key Note))
|
_handleFormSuccess :: NoteForm -> Handler (UpsertResult, Key Note)
|
||||||
_handleFormSuccess noteForm = do
|
_handleFormSuccess noteForm = do
|
||||||
userId <- requireAuthId
|
userId <- requireAuthId
|
||||||
note <- liftIO $ _toNote userId noteForm
|
note <- liftIO $ _toNote userId noteForm
|
||||||
runDB (upsertNote userId knid note)
|
runDB (upsertNote knid note)
|
||||||
where
|
where
|
||||||
knid = NoteKey <$> (_id noteForm >>= \i -> if i > 0 then Just i else Nothing)
|
knid = NoteKey <$> (_id noteForm >>= \i -> if i > 0 then Just i else Nothing)
|
||||||
|
|
||||||
|
@ -138,90 +120,52 @@ instance ToJSON NoteForm where toJSON = A.genericToJSON gNoteFormOptions
|
||||||
gNoteFormOptions :: A.Options
|
gNoteFormOptions :: A.Options
|
||||||
gNoteFormOptions = A.defaultOptions { A.fieldLabelModifier = drop 1 }
|
gNoteFormOptions = A.defaultOptions { A.fieldLabelModifier = drop 1 }
|
||||||
|
|
||||||
noteFormUrl :: Handler NoteForm
|
|
||||||
noteFormUrl = do
|
|
||||||
title <- lookupGetParam "title"
|
|
||||||
description <- lookupGetParam "description" <&> fmap Textarea
|
|
||||||
isMarkdown <- lookupGetParam "isMarkdown" <&> fmap parseChk
|
|
||||||
pure $ NoteForm
|
|
||||||
{ _id = Nothing
|
|
||||||
, _slug = Nothing
|
|
||||||
, _title = title
|
|
||||||
, _text = description
|
|
||||||
, _isMarkdown = isMarkdown
|
|
||||||
, _shared = Nothing
|
|
||||||
, _created = Nothing
|
|
||||||
, _updated = Nothing
|
|
||||||
}
|
|
||||||
where
|
|
||||||
parseChk s = s == "yes" || s == "on" || s == "true" || s == "1"
|
|
||||||
|
|
||||||
_toNote :: UserId -> NoteForm -> IO Note
|
_toNote :: UserId -> NoteForm -> IO Note
|
||||||
_toNote userId NoteForm {..} = do
|
_toNote userId NoteForm {..} = do
|
||||||
time <- liftIO getCurrentTime
|
time <- liftIO getCurrentTime
|
||||||
slug <- maybe mkNtSlug pure _slug
|
slug <- maybe mkNtSlug pure _slug
|
||||||
pure $
|
pure $
|
||||||
Note
|
Note
|
||||||
{ noteUserId = userId
|
userId
|
||||||
, noteSlug = slug
|
slug
|
||||||
, noteLength = length _text
|
(length _text)
|
||||||
, noteTitle = fromMaybe "" _title
|
(fromMaybe "" _title)
|
||||||
, noteText = maybe "" unTextarea _text
|
(maybe "" unTextarea _text)
|
||||||
, noteIsMarkdown = Just True == _isMarkdown
|
(fromMaybe False _isMarkdown)
|
||||||
, noteShared = Just True == _shared
|
(fromMaybe False _shared)
|
||||||
, noteCreated = maybe time unUTCTimeStr _created
|
(fromMaybe time (fmap unUTCTimeStr _created))
|
||||||
, noteUpdated = maybe time unUTCTimeStr _updated
|
(fromMaybe time (fmap unUTCTimeStr _updated))
|
||||||
}
|
|
||||||
|
|
||||||
noteToRssEntry :: (Route App -> Text) -> UserNameP -> Entity Note -> FeedEntry Text
|
noteToRssEntry :: UserNameP -> Entity Note -> FeedEntry (Route App)
|
||||||
noteToRssEntry render usernamep (Entity entryId entry) =
|
noteToRssEntry usernamep (Entity entryId entry) =
|
||||||
FeedEntry
|
FeedEntry { feedEntryLink = NoteR usernamep (noteSlug entry)
|
||||||
{ feedEntryLink = render $ NoteR usernamep (noteSlug entry)
|
, feedEntryUpdated = (noteUpdated entry)
|
||||||
, feedEntryUpdated = noteUpdated entry
|
, feedEntryTitle = (noteTitle entry)
|
||||||
, feedEntryTitle = noteTitle entry
|
, feedEntryContent = (toHtml (noteText entry))
|
||||||
, feedEntryContent = toHtml (noteText entry)
|
|
||||||
, feedEntryEnclosure = Nothing
|
, feedEntryEnclosure = Nothing
|
||||||
, feedEntryCategories = []
|
|
||||||
}
|
}
|
||||||
|
|
||||||
getNotesFeedR :: UserNameP -> Handler RepRss
|
getNotesFeedR :: UserNameP -> Handler RepRss
|
||||||
getNotesFeedR unamep@(UserNameP uname) = do
|
getNotesFeedR unamep@(UserNameP uname) = do
|
||||||
mauthuname <- maybeAuthUsername
|
|
||||||
(limit', page') <- lookupPagingParams
|
(limit', page') <- lookupPagingParams
|
||||||
mquery <- lookupGetParam "query"
|
let queryp = "query" :: Text
|
||||||
|
mquery <- lookupGetParam queryp
|
||||||
let limit = maybe 20 fromIntegral limit'
|
let limit = maybe 20 fromIntegral limit'
|
||||||
page = maybe 1 fromIntegral page'
|
page = maybe 1 fromIntegral page'
|
||||||
isowner = Just uname == mauthuname
|
(bcount, notes) <- runDB $ do
|
||||||
sharedp = if isowner then SharedAll else SharedPublic
|
Entity userId _ <- getBy404 (UniqueUserName uname)
|
||||||
(_, notes) <- runDB do
|
getNoteList userId mquery SharedPublic limit page
|
||||||
Entity userId user <- getBy404 (UniqueUserName uname)
|
|
||||||
when (not isowner && userPrivacyLock user)
|
|
||||||
(redirect (AuthR LoginR))
|
|
||||||
getNoteList userId mquery sharedp limit page
|
|
||||||
render <- getUrlRender
|
|
||||||
let (descr :: Html) = toHtml $ H.text (uname <> " notes")
|
let (descr :: Html) = toHtml $ H.text (uname <> " notes")
|
||||||
entries = map (noteToRssEntry render unamep) notes
|
let entries = map (noteToRssEntry unamep) notes
|
||||||
updated <- case maximumMay (map feedEntryUpdated entries) of
|
updated <- case maximumMay (map feedEntryUpdated entries) of
|
||||||
Nothing -> liftIO getCurrentTime
|
Nothing -> liftIO $ getCurrentTime
|
||||||
Just m -> return m
|
Just m -> return m
|
||||||
(feedLinkSelf, feedLinkHome) <- getFeedLinkSelf
|
rssFeed $ Feed (uname <> " notes")
|
||||||
rssFeedText $
|
(NotesFeedR unamep)
|
||||||
Feed
|
(NotesR unamep)
|
||||||
{ feedTitle = uname <> " notes"
|
uname
|
||||||
, feedLinkSelf = feedLinkSelf
|
descr
|
||||||
, feedLinkHome = feedLinkHome
|
"en"
|
||||||
, feedAuthor = uname
|
updated
|
||||||
, feedDescription = descr
|
Nothing
|
||||||
, feedLanguage = "en"
|
entries
|
||||||
, feedUpdated = updated
|
|
||||||
, feedLogo = Nothing
|
|
||||||
, feedEntries = entries
|
|
||||||
}
|
|
||||||
where
|
|
||||||
getFeedLinkSelf = do
|
|
||||||
request <- getRequest
|
|
||||||
render <- getUrlRender
|
|
||||||
let rawRequest = reqWaiRequest request
|
|
||||||
feedLinkSelf = render HomeR <> (T.drop 1 (decodeUtf8 (W.rawPathInfo rawRequest <> W.rawQueryString rawRequest)))
|
|
||||||
feedLinkHome = render (UserR unamep)
|
|
||||||
pure (feedLinkSelf, feedLinkHome)
|
|
||||||
|
|
|
@ -1,17 +1,15 @@
|
||||||
{-# OPTIONS_GHC -fno-warn-unused-matches #-}
|
{-# OPTIONS_GHC -fno-warn-unused-matches #-}
|
||||||
{-# LANGUAGE TupleSections #-}
|
|
||||||
module Handler.User where
|
module Handler.User where
|
||||||
|
|
||||||
import qualified Data.Text as T
|
import qualified Data.Text as T
|
||||||
import Handler.Common
|
import Handler.Common (lookupPagingParams)
|
||||||
import Import
|
import Import
|
||||||
|
import Text.Blaze.Html (toHtml)
|
||||||
import qualified Text.Blaze.Html5 as H
|
import qualified Text.Blaze.Html5 as H
|
||||||
import Yesod.RssFeed
|
import Yesod.RssFeed
|
||||||
import qualified Data.Map as Map
|
|
||||||
import qualified Network.Wai.Internal as W
|
|
||||||
|
|
||||||
getUserR :: UserNameP -> Handler Html
|
getUserR :: UserNameP -> Handler Html
|
||||||
getUserR uname=
|
getUserR uname@(UserNameP name) = do
|
||||||
_getUser uname SharedAll FilterAll (TagsP [])
|
_getUser uname SharedAll FilterAll (TagsP [])
|
||||||
|
|
||||||
getUserSharedR :: UserNameP -> SharedP -> Handler Html
|
getUserSharedR :: UserNameP -> SharedP -> Handler Html
|
||||||
|
@ -23,7 +21,8 @@ getUserFilterR uname filterp =
|
||||||
_getUser uname SharedAll filterp (TagsP [])
|
_getUser uname SharedAll filterp (TagsP [])
|
||||||
|
|
||||||
getUserTagsR :: UserNameP -> TagsP -> Handler Html
|
getUserTagsR :: UserNameP -> TagsP -> Handler Html
|
||||||
getUserTagsR uname = _getUser uname SharedAll FilterAll
|
getUserTagsR uname pathtags =
|
||||||
|
_getUser uname SharedAll FilterAll pathtags
|
||||||
|
|
||||||
_getUser :: UserNameP -> SharedP -> FilterP -> TagsP -> Handler Html
|
_getUser :: UserNameP -> SharedP -> FilterP -> TagsP -> Handler Html
|
||||||
_getUser unamep@(UserNameP uname) sharedp' filterp' (TagsP pathtags) = do
|
_getUser unamep@(UserNameP uname) sharedp' filterp' (TagsP pathtags) = do
|
||||||
|
@ -31,142 +30,76 @@ _getUser unamep@(UserNameP uname) sharedp' filterp' (TagsP pathtags) = do
|
||||||
(limit', page') <- lookupPagingParams
|
(limit', page') <- lookupPagingParams
|
||||||
let limit = maybe 120 fromIntegral limit'
|
let limit = maybe 120 fromIntegral limit'
|
||||||
page = maybe 1 fromIntegral page'
|
page = maybe 1 fromIntegral page'
|
||||||
isowner = Just uname == mauthuname
|
isowner = maybe False (== uname) mauthuname
|
||||||
sharedp = if isowner then sharedp' else SharedPublic
|
sharedp = if isowner then sharedp' else SharedPublic
|
||||||
filterp = case filterp' of
|
filterp = case filterp' of
|
||||||
FilterSingle _ -> filterp'
|
FilterSingle _ -> filterp'
|
||||||
_ -> if isowner then filterp' else FilterAll
|
_ -> if isowner then filterp' else FilterAll
|
||||||
isAll = filterp == FilterAll && sharedp == SharedAll && null pathtags
|
isAll = filterp == FilterAll && sharedp == SharedAll && pathtags == []
|
||||||
queryp = "query" :: Text
|
queryp = "query" :: Text
|
||||||
mquery <- lookupGetParam queryp
|
mquery <- lookupGetParam queryp
|
||||||
let mqueryp = fmap (queryp,) mquery
|
let mqueryp = fmap (\q -> (queryp, q)) mquery
|
||||||
(bcount, btmarks) <- runDB $ do
|
(bcount, bmarks, alltags) <-
|
||||||
Entity userId user <- getBy404 (UniqueUserName uname)
|
runDB $
|
||||||
|
do Entity userId user <- getBy404 (UniqueUserName uname)
|
||||||
when (not isowner && userPrivacyLock user)
|
when (not isowner && userPrivacyLock user)
|
||||||
(redirect (AuthR LoginR))
|
(redirect (AuthR LoginR))
|
||||||
bookmarksTagsQuery userId sharedp filterp pathtags mquery limit page
|
(cnt, bm) <- bookmarksQuery userId sharedp filterp pathtags mquery limit page
|
||||||
|
tg <- tagsQuery bm
|
||||||
|
pure (cnt, bm, tg)
|
||||||
when (bcount == 0) (case filterp of FilterSingle _ -> notFound; _ -> pure ())
|
when (bcount == 0) (case filterp of FilterSingle _ -> notFound; _ -> pure ())
|
||||||
mroute <- getCurrentRoute
|
mroute <- getCurrentRoute
|
||||||
tagCloudMode <- getTagCloudMode isowner pathtags
|
|
||||||
req <- getRequest
|
req <- getRequest
|
||||||
defaultLayout do
|
defaultLayout $ do
|
||||||
let pager = $(widgetFile "pager")
|
let pager = $(widgetFile "pager")
|
||||||
search = $(widgetFile "search")
|
search = $(widgetFile "search")
|
||||||
renderEl = "bookmarks" :: Text
|
renderEl = "bookmarks" :: Text
|
||||||
tagCloudRenderEl = "tagCloud" :: Text
|
|
||||||
rssLink (UserFeedR unamep) "feed"
|
rssLink (UserFeedR unamep) "feed"
|
||||||
$(widgetFile "user")
|
$(widgetFile "user")
|
||||||
toWidgetBody [julius|
|
toWidgetBody [julius|
|
||||||
app.dat.bmarks = #{ toJSON $ toBookmarkFormList btmarks } || [];
|
app.dat.bmarks = #{ toJSON $ toBookmarkFormList bmarks alltags } || [];
|
||||||
app.dat.isowner = #{ isowner };
|
app.dat.isowner = #{ isowner };
|
||||||
app.userR = "@{UserR unamep}";
|
app.userR = "@{UserR unamep}";
|
||||||
app.tagCloudMode = #{ toJSON $ tagCloudMode } || {};
|
|
||||||
|]
|
|]
|
||||||
toWidget [julius|
|
toWidget [julius|
|
||||||
setTimeout(() => {
|
PS['Main'].renderBookmarks('##{rawJS renderEl}')(app.dat.bmarks)();
|
||||||
PS.renderBookmarks('##{rawJS renderEl}')(app.dat.bmarks)();
|
|
||||||
}, 0);
|
|
||||||
setTimeout(() => {
|
|
||||||
PS.renderTagCloud('##{rawJS tagCloudRenderEl}')(app.tagCloudMode)();
|
|
||||||
}, 0);
|
|
||||||
|]
|
|]
|
||||||
|
|
||||||
-- Form
|
bookmarkToRssEntry :: Entity Bookmark -> FeedEntry Text
|
||||||
|
bookmarkToRssEntry (Entity entryId entry) =
|
||||||
postUserTagCloudR :: Handler ()
|
FeedEntry { feedEntryLink = (bookmarkHref entry)
|
||||||
postUserTagCloudR = do
|
, feedEntryUpdated = (bookmarkTime entry)
|
||||||
userId <- requireAuthId
|
, feedEntryTitle = (bookmarkDescription entry)
|
||||||
mode <- requireCheckJsonBody
|
, feedEntryContent = (toHtml (bookmarkExtended entry))
|
||||||
_updateTagCloudMode mode
|
|
||||||
tc <- runDB $ case mode of
|
|
||||||
TagCloudModeTop _ n -> tagCountTop userId n
|
|
||||||
TagCloudModeLowerBound _ n -> tagCountLowerBound userId n
|
|
||||||
TagCloudModeRelated _ tags -> tagCountRelated userId tags
|
|
||||||
TagCloudModeNone -> notFound
|
|
||||||
sendStatusJSON ok200 (Map.fromList tc :: Map.Map Text Int)
|
|
||||||
|
|
||||||
postUserTagCloudModeR :: Handler ()
|
|
||||||
postUserTagCloudModeR = do
|
|
||||||
userId <- requireAuthId
|
|
||||||
mode <- requireCheckJsonBody
|
|
||||||
_updateTagCloudMode mode
|
|
||||||
|
|
||||||
_updateTagCloudMode :: TagCloudMode -> Handler ()
|
|
||||||
_updateTagCloudMode mode =
|
|
||||||
case mode of
|
|
||||||
TagCloudModeTop _ _ -> setTagCloudMode mode
|
|
||||||
TagCloudModeLowerBound _ _ -> setTagCloudMode mode
|
|
||||||
TagCloudModeRelated _ _ -> setTagCloudMode mode
|
|
||||||
TagCloudModeNone -> notFound
|
|
||||||
|
|
||||||
bookmarkToRssEntry :: (Entity Bookmark, Maybe Text) -> FeedEntry Text
|
|
||||||
bookmarkToRssEntry (Entity entryId entry, tags) =
|
|
||||||
FeedEntry
|
|
||||||
{ feedEntryLink = bookmarkHref entry
|
|
||||||
, feedEntryUpdated = bookmarkTime entry
|
|
||||||
, feedEntryTitle = bookmarkDescription entry
|
|
||||||
, feedEntryContent = toHtml (bookmarkExtended entry)
|
|
||||||
, feedEntryCategories = map (EntryCategory Nothing Nothing) (maybe [] words tags)
|
|
||||||
, feedEntryEnclosure = Nothing
|
, feedEntryEnclosure = Nothing
|
||||||
}
|
}
|
||||||
|
|
||||||
getUserFeedR :: UserNameP -> Handler RepRss
|
getUserFeedR :: UserNameP -> Handler RepRss
|
||||||
getUserFeedR unamep = do
|
getUserFeedR unamep@(UserNameP uname) = do
|
||||||
_getUserFeed unamep SharedAll FilterAll (TagsP [])
|
|
||||||
|
|
||||||
getUserFeedSharedR :: UserNameP -> SharedP -> Handler RepRss
|
|
||||||
getUserFeedSharedR uname sharedp =
|
|
||||||
_getUserFeed uname sharedp FilterAll (TagsP [])
|
|
||||||
|
|
||||||
getUserFeedFilterR :: UserNameP -> FilterP -> Handler RepRss
|
|
||||||
getUserFeedFilterR uname filterp =
|
|
||||||
_getUserFeed uname SharedAll filterp (TagsP [])
|
|
||||||
|
|
||||||
getUserFeedTagsR :: UserNameP -> TagsP -> Handler RepRss
|
|
||||||
getUserFeedTagsR uname = _getUserFeed uname SharedAll FilterAll
|
|
||||||
|
|
||||||
_getUserFeed :: UserNameP -> SharedP -> FilterP -> TagsP -> Handler RepRss
|
|
||||||
_getUserFeed unamep@(UserNameP uname) sharedp' filterp' (TagsP pathtags) = do
|
|
||||||
mauthuname <- maybeAuthUsername
|
mauthuname <- maybeAuthUsername
|
||||||
(limit', page') <- lookupPagingParams
|
(limit', page') <- lookupPagingParams
|
||||||
let limit = maybe 120 fromIntegral limit'
|
let limit = maybe 120 fromIntegral limit'
|
||||||
page = maybe 1 fromIntegral page'
|
page = maybe 1 fromIntegral page'
|
||||||
isowner = Just uname == mauthuname
|
|
||||||
sharedp = if isowner then sharedp' else SharedPublic
|
|
||||||
filterp = case filterp' of
|
|
||||||
FilterSingle _ -> filterp'
|
|
||||||
_ -> if isowner then filterp' else FilterAll
|
|
||||||
-- isAll = filterp == FilterAll && sharedp == SharedAll && null pathtags
|
|
||||||
queryp = "query" :: Text
|
queryp = "query" :: Text
|
||||||
mquery <- lookupGetParam queryp
|
mquery <- lookupGetParam queryp
|
||||||
(_, btmarks) <- runDB $ do
|
(bcount, bmarks, alltags) <-
|
||||||
Entity userId user <- getBy404 (UniqueUserName uname)
|
runDB $
|
||||||
when (not isowner && userPrivacyLock user)
|
do Entity userId user <- getBy404 (UniqueUserName uname)
|
||||||
(redirect (AuthR LoginR))
|
(cnt, bm) <- bookmarksQuery userId SharedPublic FilterAll [] mquery limit page
|
||||||
bookmarksTagsQuery userId sharedp filterp pathtags mquery limit page
|
tg <- tagsQuery bm
|
||||||
|
pure (cnt, bm, tg)
|
||||||
let (descr :: Html) = toHtml $ H.text ("Bookmarks saved by " <> uname)
|
let (descr :: Html) = toHtml $ H.text ("Bookmarks saved by " <> uname)
|
||||||
entries = map bookmarkToRssEntry btmarks
|
let entries = map bookmarkToRssEntry bmarks
|
||||||
updated <- case maximumMay (map feedEntryUpdated entries) of
|
updated <- case maximumMay (map feedEntryUpdated entries) of
|
||||||
Nothing -> liftIO getCurrentTime
|
Nothing -> liftIO $ getCurrentTime
|
||||||
Just m -> return m
|
Just m -> return m
|
||||||
(feedLinkSelf, feedLinkHome) <- getFeedLinkSelf
|
|
||||||
rssFeedText $
|
|
||||||
Feed
|
|
||||||
{ feedTitle = "espial " <> uname
|
|
||||||
, feedLinkSelf = feedLinkSelf
|
|
||||||
, feedLinkHome = feedLinkHome
|
|
||||||
, feedAuthor = uname
|
|
||||||
, feedDescription = descr
|
|
||||||
, feedLanguage = "en"
|
|
||||||
, feedUpdated = updated
|
|
||||||
, feedLogo = Nothing
|
|
||||||
, feedEntries = entries
|
|
||||||
}
|
|
||||||
where
|
|
||||||
getFeedLinkSelf = do
|
|
||||||
request <- getRequest
|
|
||||||
render <- getUrlRender
|
render <- getUrlRender
|
||||||
let rawRequest = reqWaiRequest request
|
rssFeedText $ Feed ("espial " <> uname)
|
||||||
feedLinkSelf = render HomeR <> (T.drop 1 (decodeUtf8 (W.rawPathInfo rawRequest <> W.rawQueryString rawRequest)))
|
(render (UserFeedR unamep))
|
||||||
feedLinkHome = render (UserR unamep)
|
(render (UserR unamep))
|
||||||
pure (feedLinkSelf, feedLinkHome)
|
uname
|
||||||
|
descr
|
||||||
|
"en"
|
||||||
|
updated
|
||||||
|
Nothing
|
||||||
|
entries
|
||||||
|
|
|
@ -48,13 +48,13 @@ aFormToMaybeGetSuccess
|
||||||
:: MonadHandler f
|
:: MonadHandler f
|
||||||
=> AForm f a -> f (Maybe a)
|
=> AForm f a -> f (Maybe a)
|
||||||
aFormToMaybeGetSuccess =
|
aFormToMaybeGetSuccess =
|
||||||
fmap (maybeSuccess . fst) . runFormGet . const . fmap fst . aFormToForm
|
fmap maybeSuccess . fmap fst . runFormGet . const . fmap fst . aFormToForm
|
||||||
|
|
||||||
aFormToMaybePostSuccess
|
aFormToMaybePostSuccess
|
||||||
:: MonadHandlerForm f
|
:: MonadHandlerForm f
|
||||||
=> AForm f a -> f (Maybe a)
|
=> AForm f a -> f (Maybe a)
|
||||||
aFormToMaybePostSuccess =
|
aFormToMaybePostSuccess =
|
||||||
fmap (maybeSuccess . fst) . runFormPostNoToken . const . fmap fst . aFormToForm
|
fmap maybeSuccess . fmap fst . runFormPostNoToken . const . fmap fst . aFormToForm
|
||||||
|
|
||||||
maybeSuccess :: FormResult a -> Maybe a
|
maybeSuccess :: FormResult a -> Maybe a
|
||||||
maybeSuccess (FormSuccess a) = Just a
|
maybeSuccess (FormSuccess a) = Just a
|
||||||
|
@ -83,4 +83,4 @@ attrs n f =
|
||||||
}
|
}
|
||||||
|
|
||||||
cls :: [Text] -> FieldSettings master -> FieldSettings master
|
cls :: [Text] -> FieldSettings master -> FieldSettings master
|
||||||
cls n = attrs [("class", unwords n)]
|
cls n = attrs [("class", intercalate " " n)]
|
||||||
|
|
595
src/Model.hs
595
src/Model.hs
|
@ -1,41 +1,37 @@
|
||||||
{-# LANGUAGE DeriveFunctor #-}
|
|
||||||
{-# OPTIONS_GHC -fno-warn-unused-imports #-}
|
{-# OPTIONS_GHC -fno-warn-unused-imports #-}
|
||||||
|
|
||||||
module Model where
|
module Model where
|
||||||
|
|
||||||
import qualified ClassyPrelude.Yesod as CP
|
import qualified ClassyPrelude.Yesod as CP
|
||||||
import qualified Control.Monad.Combinators as PC (between)
|
|
||||||
import qualified Data.Aeson as A
|
import qualified Data.Aeson as A
|
||||||
import qualified Data.Aeson.KeyMap as KM
|
|
||||||
import qualified Data.Aeson.Types as A (parseFail)
|
|
||||||
import qualified Data.Attoparsec.Text as P
|
import qualified Data.Attoparsec.Text as P
|
||||||
import qualified Data.Time as TI (ParseTime)
|
import qualified Control.Monad.Combinators as PC
|
||||||
import qualified Data.Time.Clock.POSIX as TI (posixSecondsToUTCTime, POSIXTime)
|
import qualified Data.List.NonEmpty as NE
|
||||||
import qualified Data.Time.ISO8601 as TI (parseISO8601, formatISO8601Millis)
|
import qualified Data.Time.ISO8601 as TI
|
||||||
import ClassyPrelude.Yesod hiding ((==.), (||.), on, Value, groupBy, exists, (>=.), (<=.))
|
import qualified Database.Esqueleto as E
|
||||||
import Control.Monad.Fail (MonadFail)
|
import Database.Esqueleto.Internal.Sql as E
|
||||||
import Control.Monad.Trans.Maybe (MaybeT(..), runMaybeT)
|
import qualified Data.Time as TI
|
||||||
|
import ClassyPrelude.Yesod hiding ((||.))
|
||||||
|
import Control.Monad.Trans.Maybe
|
||||||
import Control.Monad.Writer (tell)
|
import Control.Monad.Writer (tell)
|
||||||
import Data.Char (isSpace)
|
import Data.Char (isSpace)
|
||||||
import Data.Either (fromRight)
|
import Data.Either (fromRight)
|
||||||
import Data.Foldable (foldl, foldl1, sequenceA_)
|
import Data.Foldable (foldl, foldl1, sequenceA_)
|
||||||
import Data.List.NonEmpty (NonEmpty(..))
|
import Data.List.NonEmpty (NonEmpty(..))
|
||||||
import Database.Esqueleto.Experimental
|
import Database.Esqueleto hiding ((==.))
|
||||||
import Database.Esqueleto.Internal.Internal (unsafeSqlFunction)
|
import Pretty
|
||||||
import Pretty ()
|
import System.Directory
|
||||||
import System.Directory (listDirectory)
|
|
||||||
import Types
|
import Types
|
||||||
|
|
||||||
import qualified Data.Map.Strict as MS
|
import qualified Data.Map.Strict as MS
|
||||||
|
|
||||||
import ModelCustom
|
import ModelCustom
|
||||||
|
|
||||||
share [mkPersist sqlSettings, mkMigrate "migrateSchema"] [persistLowerCase|
|
share [mkPersist sqlSettings, mkDeleteCascade sqlSettings, mkMigrate "migrateSchema"] [persistLowerCase|
|
||||||
User json
|
User json
|
||||||
Id Int64
|
Id Int64
|
||||||
name Text
|
name Text
|
||||||
passwordHash BCrypt
|
passwordHash BCrypt
|
||||||
apiToken HashedApiKey Maybe
|
apiToken Text Maybe
|
||||||
privateDefault Bool
|
privateDefault Bool
|
||||||
archiveDefault Bool
|
archiveDefault Bool
|
||||||
privacyLock Bool
|
privacyLock Bool
|
||||||
|
@ -44,7 +40,7 @@ User json
|
||||||
|
|
||||||
Bookmark json
|
Bookmark json
|
||||||
Id Int64
|
Id Int64
|
||||||
userId UserId OnDeleteCascade
|
userId UserId
|
||||||
slug BmSlug default="(lower(hex(randomblob(6))))"
|
slug BmSlug default="(lower(hex(randomblob(6))))"
|
||||||
href Text
|
href Text
|
||||||
description Text
|
description Text
|
||||||
|
@ -60,9 +56,9 @@ Bookmark json
|
||||||
|
|
||||||
BookmarkTag json
|
BookmarkTag json
|
||||||
Id Int64
|
Id Int64
|
||||||
userId UserId OnDeleteCascade
|
userId UserId
|
||||||
tag Text
|
tag Text
|
||||||
bookmarkId BookmarkId OnDeleteCascade
|
bookmarkId BookmarkId
|
||||||
seq Int
|
seq Int
|
||||||
UniqueUserTagBookmarkId userId tag bookmarkId
|
UniqueUserTagBookmarkId userId tag bookmarkId
|
||||||
UniqueUserBookmarkIdTagSeq userId bookmarkId tag seq
|
UniqueUserBookmarkIdTagSeq userId bookmarkId tag seq
|
||||||
|
@ -70,7 +66,7 @@ BookmarkTag json
|
||||||
|
|
||||||
Note json
|
Note json
|
||||||
Id Int64
|
Id Int64
|
||||||
userId UserId OnDeleteCascade
|
userId UserId
|
||||||
slug NtSlug default="(lower(hex(randomblob(10))))"
|
slug NtSlug default="(lower(hex(randomblob(10))))"
|
||||||
length Int
|
length Int
|
||||||
title Text
|
title Text
|
||||||
|
@ -140,32 +136,28 @@ migrateIndexes =
|
||||||
, "CREATE INDEX IF NOT EXISTS idx_note_user_created ON note (user_id, created DESC)"
|
, "CREATE INDEX IF NOT EXISTS idx_note_user_created ON note (user_id, created DESC)"
|
||||||
]
|
]
|
||||||
|
|
||||||
sqliteGroupConcat ::
|
sqlite_group_concat ::
|
||||||
PersistField a
|
PersistField a
|
||||||
=> SqlExpr (Value a)
|
=> SqlExpr (E.Value a)
|
||||||
-> SqlExpr (Value a)
|
-> SqlExpr (E.Value a)
|
||||||
-> SqlExpr (Value Text)
|
-> SqlExpr (E.Value Text)
|
||||||
sqliteGroupConcat expr sep = unsafeSqlFunction "GROUP_CONCAT" [expr, sep]
|
sqlite_group_concat expr sep = E.unsafeSqlFunction "GROUP_CONCAT" [expr, sep]
|
||||||
|
|
||||||
authenticatePassword :: Text -> Text -> DB (Maybe (Entity User))
|
authenticatePassword :: Text -> Text -> DB (Maybe (Entity User))
|
||||||
authenticatePassword username password = do
|
authenticatePassword username password = do
|
||||||
getBy (UniqueUserName username) >>= \case
|
muser <- getBy (UniqueUserName username)
|
||||||
Nothing -> pure Nothing
|
case muser of
|
||||||
|
Nothing -> return Nothing
|
||||||
Just dbuser ->
|
Just dbuser ->
|
||||||
if validatePasswordHash (userPasswordHash (entityVal dbuser)) password
|
if validatePasswordHash (userPasswordHash (entityVal dbuser)) password
|
||||||
then pure (Just dbuser)
|
then return (Just dbuser)
|
||||||
else pure Nothing
|
else return Nothing
|
||||||
|
|
||||||
getUserByName :: UserNameP -> DB (Maybe (Entity User))
|
getUserByName :: UserNameP -> DB (Maybe (Entity User))
|
||||||
getUserByName (UserNameP uname) =
|
getUserByName (UserNameP uname) = do
|
||||||
selectFirst [UserName CP.==. uname] []
|
selectFirst [UserName ==. uname] []
|
||||||
|
|
||||||
getApiKeyUser :: ApiKey -> DB (Maybe (Entity User))
|
bookmarksQuery
|
||||||
getApiKeyUser apiKey =
|
|
||||||
selectFirst [UserApiToken CP.==. Just (hashApiKey apiKey)] []
|
|
||||||
|
|
||||||
-- returns a list of pair of bookmark with tags merged into a string
|
|
||||||
bookmarksTagsQuery
|
|
||||||
:: Key User
|
:: Key User
|
||||||
-> SharedP
|
-> SharedP
|
||||||
-> FilterP
|
-> FilterP
|
||||||
|
@ -173,91 +165,73 @@ bookmarksTagsQuery
|
||||||
-> Maybe Text
|
-> Maybe Text
|
||||||
-> Limit
|
-> Limit
|
||||||
-> Page
|
-> Page
|
||||||
-> DB (Int, [(Entity Bookmark, Maybe Text)])
|
-> DB (Int, [Entity Bookmark])
|
||||||
bookmarksTagsQuery userId sharedp filterp tags mquery limit' page =
|
bookmarksQuery userId sharedp filterp tags mquery limit' page =
|
||||||
(,) -- total count
|
(,) -- total count
|
||||||
<$> fmap (sum . fmap unValue)
|
<$> fmap (sum . fmap E.unValue)
|
||||||
(select $ from (table @Bookmark) >>= \b -> do
|
(select $
|
||||||
|
from $ \b -> do
|
||||||
_whereClause b
|
_whereClause b
|
||||||
pure countRows)
|
pure $ E.countRows)
|
||||||
-- paged data
|
-- paged data
|
||||||
<*> (fmap . fmap . fmap) unValue
|
<*> (select $
|
||||||
(select $ from (table @Bookmark) >>= \b -> do
|
from $ \b -> do
|
||||||
_whereClause b
|
_whereClause b
|
||||||
orderBy [desc (b ^. BookmarkTime)]
|
orderBy [desc (b ^. BookmarkTime)]
|
||||||
limit limit'
|
limit limit'
|
||||||
offset ((page - 1) * limit')
|
offset ((page - 1) * limit')
|
||||||
pure (b, subSelect $ from (table @BookmarkTag) >>= \t -> do
|
pure b)
|
||||||
where_ (t ^. BookmarkTagBookmarkId ==. b ^. BookmarkId)
|
|
||||||
groupBy (t ^. BookmarkTagBookmarkId)
|
|
||||||
orderBy [asc (t ^. BookmarkTagSeq)]
|
|
||||||
pure $ sqliteGroupConcat (t ^. BookmarkTagTag) (val " ")))
|
|
||||||
where
|
where
|
||||||
_whereClause b = do
|
_whereClause b = do
|
||||||
where_ $
|
where_ $
|
||||||
foldl (\expr tag ->
|
foldl (\expr tag ->
|
||||||
expr &&. exists ( -- each tag becomes an exists constraint
|
expr &&. (exists $ -- each tag becomes an exists constraint
|
||||||
from (table @BookmarkTag) >>= \t ->
|
from $ \t ->
|
||||||
where_ (t ^. BookmarkTagBookmarkId ==. b ^. BookmarkId &&.
|
where_ (t ^. BookmarkTagBookmarkId E.==. b ^. BookmarkId &&.
|
||||||
(t ^. BookmarkTagTag `like` val tag))))
|
(t ^. BookmarkTagTag `E.like` val tag))))
|
||||||
(b ^. BookmarkUserId ==. val userId)
|
(b ^. BookmarkUserId E.==. val userId)
|
||||||
tags
|
tags
|
||||||
case sharedp of
|
case sharedp of
|
||||||
SharedAll -> pure ()
|
SharedAll -> pure ()
|
||||||
SharedPublic -> where_ (b ^. BookmarkShared ==. val True)
|
SharedPublic -> where_ (b ^. BookmarkShared E.==. val True)
|
||||||
SharedPrivate -> where_ (b ^. BookmarkShared ==. val False)
|
SharedPrivate -> where_ (b ^. BookmarkShared E.==. val False)
|
||||||
case filterp of
|
case filterp of
|
||||||
FilterAll -> pure ()
|
FilterAll -> pure ()
|
||||||
FilterUnread -> where_ (b ^. BookmarkToRead ==. val True)
|
FilterUnread -> where_ (b ^. BookmarkToRead E.==. val True)
|
||||||
FilterStarred -> where_ (b ^. BookmarkSelected ==. val True)
|
FilterStarred -> where_ (b ^. BookmarkSelected E.==. val True)
|
||||||
FilterSingle slug -> where_ (b ^. BookmarkSlug ==. val slug)
|
FilterSingle slug -> where_ (b ^. BookmarkSlug E.==. val slug)
|
||||||
FilterUntagged -> where_ $ notExists $ from (table @BookmarkTag) >>= \t -> where_ $
|
FilterUntagged -> where_ $ notExists $ from (\t -> where_ $
|
||||||
t ^. BookmarkTagBookmarkId ==. b ^. BookmarkId
|
(t ^. BookmarkTagBookmarkId E.==. b ^. BookmarkId))
|
||||||
-- search
|
-- search
|
||||||
sequenceA_ (parseSearchQuery (toLikeExpr b) =<< mquery)
|
sequenceA_ (parseSearchQuery (toLikeExpr b) =<< mquery)
|
||||||
|
|
||||||
toLikeExpr :: SqlExpr (Entity Bookmark) -> Text -> SqlExpr (Value Bool)
|
toLikeExpr :: E.SqlExpr (Entity Bookmark) -> Text -> E.SqlExpr (E.Value Bool)
|
||||||
toLikeExpr b term = fromRight p_allFields (P.parseOnly p_onefield term)
|
toLikeExpr b term = fromRight p_allFields (P.parseOnly p_onefield term)
|
||||||
where
|
where
|
||||||
wild s = (%) ++. val s ++. (%)
|
wild s = (E.%) ++. val s ++. (E.%)
|
||||||
toLikeB field s = b ^. field `like` wild s
|
toLikeB field s = b ^. field `E.like` wild s
|
||||||
p_allFields =
|
p_allFields =
|
||||||
toLikeB BookmarkHref term ||.
|
(toLikeB BookmarkHref term) ||.
|
||||||
toLikeB BookmarkDescription term ||.
|
(toLikeB BookmarkDescription term) ||.
|
||||||
toLikeB BookmarkExtended term ||.
|
(toLikeB BookmarkExtended term) ||.
|
||||||
exists (from (table @BookmarkTag) >>= \t -> where_ $
|
(exists $ from (\t -> where_ $
|
||||||
(t ^. BookmarkTagBookmarkId ==. b ^. BookmarkId) &&.
|
(t ^. BookmarkTagBookmarkId E.==. b ^. BookmarkId) &&.
|
||||||
(t ^. BookmarkTagTag `like` wild term))
|
(t ^. BookmarkTagTag `E.like` (wild term))))
|
||||||
p_onefield = p_url <|> p_title <|> p_description <|> p_tags <|> p_after <|> p_before
|
p_onefield = p_url <|> p_title <|> p_description <|> p_tags <|> p_after <|> p_before
|
||||||
where
|
where
|
||||||
p_url = "url:" *> fmap (toLikeB BookmarkHref) P.takeText
|
p_url = "url:" *> fmap (toLikeB BookmarkHref) P.takeText
|
||||||
p_title = "title:" *> fmap (toLikeB BookmarkDescription) P.takeText
|
p_title = "title:" *> fmap (toLikeB BookmarkDescription) P.takeText
|
||||||
p_description = "description:" *> fmap (toLikeB BookmarkExtended) P.takeText
|
p_description = "description:" *> fmap (toLikeB BookmarkExtended) P.takeText
|
||||||
p_tags = "tags:" *> fmap (\term' -> exists $ from (table @BookmarkTag) >>= \t -> where_ $
|
p_tags = "tags:" *> fmap (\term' -> exists $ from (\t -> where_ $
|
||||||
(t ^. BookmarkTagBookmarkId ==. b ^. BookmarkId) &&.
|
(t ^. BookmarkTagBookmarkId E.==. b ^. BookmarkId) &&.
|
||||||
(t ^. BookmarkTagTag `like` wild term')) P.takeText
|
(t ^. BookmarkTagTag `E.like` wild term'))) P.takeText
|
||||||
p_after = "after:" *> fmap ((b ^. BookmarkTime >=.) . val) (parseTimeText =<< P.takeText)
|
p_after = "after:" *> fmap ((b ^. BookmarkTime E.>=.) . val) (parseTimeText =<< P.takeText)
|
||||||
p_before = "before:" *> fmap ((b ^. BookmarkTime <=.) . val) (parseTimeText =<< P.takeText)
|
p_before = "before:" *> fmap ((b ^. BookmarkTime E.<=.) . val) (parseTimeText =<< P.takeText)
|
||||||
|
|
||||||
|
|
||||||
-- returns a list of pair of bookmark with tags merged into a string
|
|
||||||
allUserBookmarks :: Key User -> DB [(Entity Bookmark, Text)]
|
|
||||||
allUserBookmarks user =
|
|
||||||
(fmap . fmap . fmap) (fromMaybe "" . unValue) $
|
|
||||||
select $ do
|
|
||||||
b <- from (table @Bookmark)
|
|
||||||
where_ (b ^. BookmarkUserId ==. val user)
|
|
||||||
orderBy [asc (b ^. BookmarkTime)]
|
|
||||||
pure (b, subSelect $ from (table @BookmarkTag) >>= \t -> do
|
|
||||||
where_ (t ^. BookmarkTagBookmarkId ==. b ^. BookmarkId)
|
|
||||||
groupBy (t ^. BookmarkTagBookmarkId)
|
|
||||||
orderBy [asc (t ^. BookmarkTagSeq)]
|
|
||||||
pure $ sqliteGroupConcat (t ^. BookmarkTagTag) (val " "))
|
|
||||||
|
|
||||||
parseSearchQuery ::
|
parseSearchQuery ::
|
||||||
(Text -> SqlExpr (Value Bool))
|
(Text -> E.SqlExpr (E.Value Bool))
|
||||||
-> Text
|
-> Text
|
||||||
-> Maybe (SqlQuery ())
|
-> Maybe (E.SqlQuery ())
|
||||||
parseSearchQuery toExpr =
|
parseSearchQuery toExpr =
|
||||||
fmap where_ . either (const Nothing) Just . P.parseOnly andE
|
fmap where_ . either (const Nothing) Just . P.parseOnly andE
|
||||||
where
|
where
|
||||||
|
@ -271,7 +245,7 @@ parseSearchQuery toExpr =
|
||||||
quotedTerm = PC.between (P.char '"') (P.char '"') (P.takeWhile1 (/= '"'))
|
quotedTerm = PC.between (P.char '"') (P.char '"') (P.takeWhile1 (/= '"'))
|
||||||
simpleTerm = P.takeWhile1 (\c -> not (isSpace c) && c /= ':' && c /= '|')
|
simpleTerm = P.takeWhile1 (\c -> not (isSpace c) && c /= ':' && c /= '|')
|
||||||
|
|
||||||
parseTimeText :: (TI.ParseTime t, MonadFail m, Alternative m) => Text -> m t
|
parseTimeText :: (TI.ParseTime t, Monad m, Alternative m) => Text -> m t
|
||||||
parseTimeText t =
|
parseTimeText t =
|
||||||
asum $
|
asum $
|
||||||
flip (parseTimeM True defaultTimeLocale) (unpack t) <$>
|
flip (parseTimeM True defaultTimeLocale) (unpack t) <$>
|
||||||
|
@ -281,26 +255,34 @@ parseTimeText t =
|
||||||
, "%s" -- 1535932800
|
, "%s" -- 1535932800
|
||||||
]
|
]
|
||||||
|
|
||||||
|
tagsQuery :: [Entity Bookmark] -> DB [Entity BookmarkTag]
|
||||||
|
tagsQuery bmarks =
|
||||||
|
select $
|
||||||
|
from $ \t -> do
|
||||||
|
where_ (t ^. BookmarkTagBookmarkId `in_` valList (fmap entityKey bmarks))
|
||||||
|
orderBy [asc (t ^. BookmarkTagSeq)]
|
||||||
|
pure t
|
||||||
|
|
||||||
withTags :: Key Bookmark -> DB [Entity BookmarkTag]
|
withTags :: Key Bookmark -> DB [Entity BookmarkTag]
|
||||||
withTags key = selectList [BookmarkTagBookmarkId CP.==. key] [Asc BookmarkTagSeq]
|
withTags key = selectList [BookmarkTagBookmarkId ==. key] [Asc BookmarkTagSeq]
|
||||||
|
|
||||||
-- Note List Query
|
-- Note List Query
|
||||||
|
|
||||||
|
|
||||||
getNote :: Key User -> NtSlug -> DB (Maybe (Entity Note))
|
getNote :: Key User -> NtSlug -> DB (Maybe (Entity Note))
|
||||||
getNote userKey slug =
|
getNote userKey slug =
|
||||||
selectFirst [NoteUserId CP.==. userKey, NoteSlug CP.==. slug] []
|
selectFirst [NoteUserId ==. userKey, NoteSlug ==. slug] []
|
||||||
|
|
||||||
getNoteList :: Key User -> Maybe Text -> SharedP -> Limit -> Page -> DB (Int, [Entity Note])
|
getNoteList :: Key User -> Maybe Text -> SharedP -> Limit -> Page -> DB (Int, [Entity Note])
|
||||||
getNoteList key mquery sharedp limit' page =
|
getNoteList key mquery sharedp limit' page =
|
||||||
(,) -- total count
|
(,) -- total count
|
||||||
<$> fmap (sum . fmap unValue)
|
<$> fmap (sum . fmap E.unValue)
|
||||||
(select $ do
|
(select $
|
||||||
b <- from (table @Note)
|
from $ \b -> do
|
||||||
_whereClause b
|
_whereClause b
|
||||||
pure countRows)
|
pure $ E.countRows)
|
||||||
<*> (select $ do
|
<*> (select $
|
||||||
b <- from (table @Note)
|
from $ \b -> do
|
||||||
_whereClause b
|
_whereClause b
|
||||||
orderBy [desc (b ^. NoteCreated)]
|
orderBy [desc (b ^. NoteCreated)]
|
||||||
limit limit'
|
limit limit'
|
||||||
|
@ -308,26 +290,26 @@ getNoteList key mquery sharedp limit' page =
|
||||||
pure b)
|
pure b)
|
||||||
where
|
where
|
||||||
_whereClause b = do
|
_whereClause b = do
|
||||||
where_ (b ^. NoteUserId ==. val key)
|
where_ $ (b ^. NoteUserId E.==. val key)
|
||||||
-- search
|
-- search
|
||||||
sequenceA_ (parseSearchQuery (toLikeExpr b) =<< mquery)
|
sequenceA_ (parseSearchQuery (toLikeExpr b) =<< mquery)
|
||||||
case sharedp of
|
case sharedp of
|
||||||
SharedAll -> pure ()
|
SharedAll -> pure ()
|
||||||
SharedPublic -> where_ (b ^. NoteShared ==. val True)
|
SharedPublic -> where_ (b ^. NoteShared E.==. val True)
|
||||||
SharedPrivate -> where_ (b ^. NoteShared ==. val False)
|
SharedPrivate -> where_ (b ^. NoteShared E.==. val False)
|
||||||
|
|
||||||
toLikeExpr :: SqlExpr (Entity Note) -> Text -> SqlExpr (Value Bool)
|
toLikeExpr :: E.SqlExpr (Entity Note) -> Text -> E.SqlExpr (E.Value Bool)
|
||||||
toLikeExpr b term = fromRight p_allFields (P.parseOnly p_onefield term)
|
toLikeExpr b term = fromRight p_allFields (P.parseOnly p_onefield term)
|
||||||
where
|
where
|
||||||
wild s = (%) ++. val s ++. (%)
|
wild s = (E.%) ++. val s ++. (E.%)
|
||||||
toLikeN field s = b ^. field `like` wild s
|
toLikeN field s = b ^. field `E.like` wild s
|
||||||
p_allFields = toLikeN NoteTitle term ||. toLikeN NoteText term
|
p_allFields = toLikeN NoteTitle term ||. toLikeN NoteText term
|
||||||
p_onefield = p_title <|> p_text <|> p_after <|> p_before
|
p_onefield = p_title <|> p_text <|> p_after <|> p_before
|
||||||
where
|
where
|
||||||
p_title = "title:" *> fmap (toLikeN NoteTitle) P.takeText
|
p_title = "title:" *> fmap (toLikeN NoteTitle) P.takeText
|
||||||
p_text = "description:" *> fmap (toLikeN NoteText) P.takeText
|
p_text = "description:" *> fmap (toLikeN NoteText) P.takeText
|
||||||
p_after = "after:" *> fmap ((b ^. NoteCreated >=.) . val) (parseTimeText =<< P.takeText)
|
p_after = "after:" *> fmap ((b ^. NoteCreated E.>=.) . val) (parseTimeText =<< P.takeText)
|
||||||
p_before = "before:" *> fmap ((b ^. NoteCreated <=.) . val) (parseTimeText =<< P.takeText)
|
p_before = "before:" *> fmap ((b ^. NoteCreated E.<=.) . val) (parseTimeText =<< P.takeText)
|
||||||
|
|
||||||
-- Bookmark Files
|
-- Bookmark Files
|
||||||
|
|
||||||
|
@ -337,136 +319,60 @@ mkBookmarkTags userId bookmarkId tags =
|
||||||
|
|
||||||
|
|
||||||
fileBookmarkToBookmark :: UserId -> FileBookmark -> IO Bookmark
|
fileBookmarkToBookmark :: UserId -> FileBookmark -> IO Bookmark
|
||||||
fileBookmarkToBookmark user FileBookmark {..} = do
|
fileBookmarkToBookmark user (FileBookmark {..}) = do
|
||||||
slug <- mkBmSlug
|
slug <- mkBmSlug
|
||||||
pure $
|
pure $
|
||||||
Bookmark
|
Bookmark
|
||||||
{ bookmarkUserId = user
|
user
|
||||||
, bookmarkSlug = slug
|
slug
|
||||||
, bookmarkHref = fileBookmarkHref
|
fileBookmarkHref
|
||||||
, bookmarkDescription = fileBookmarkDescription
|
fileBookmarkDescription
|
||||||
, bookmarkExtended = fileBookmarkExtended
|
fileBookmarkExtended
|
||||||
, bookmarkTime = fileBookmarkTime
|
fileBookmarkTime
|
||||||
, bookmarkShared = fileBookmarkShared
|
fileBookmarkShared
|
||||||
, bookmarkToRead = fileBookmarkToRead
|
fileBookmarkToRead
|
||||||
, bookmarkSelected = Just True == fileBookmarkSelected
|
(fromMaybe False fileBookmarkSelected)
|
||||||
, bookmarkArchiveHref = fileBookmarkArchiveHref
|
fileBookmarkArchiveHref
|
||||||
}
|
|
||||||
|
|
||||||
bookmarkTofileBookmark :: Bookmark -> Text -> FileBookmark
|
bookmarkTofileBookmark :: Bookmark -> Text -> FileBookmark
|
||||||
bookmarkTofileBookmark Bookmark {..} tags =
|
bookmarkTofileBookmark (Bookmark {..}) tags =
|
||||||
FileBookmark
|
FileBookmark
|
||||||
{ fileBookmarkHref = bookmarkHref
|
bookmarkHref
|
||||||
, fileBookmarkDescription = bookmarkDescription
|
bookmarkDescription
|
||||||
, fileBookmarkExtended = bookmarkExtended
|
bookmarkExtended
|
||||||
, fileBookmarkTime = bookmarkTime
|
bookmarkTime
|
||||||
, fileBookmarkShared = bookmarkShared
|
bookmarkShared
|
||||||
, fileBookmarkToRead = bookmarkToRead
|
bookmarkToRead
|
||||||
, fileBookmarkSelected = Just bookmarkSelected
|
(Just bookmarkSelected)
|
||||||
, fileBookmarkArchiveHref = bookmarkArchiveHref
|
bookmarkArchiveHref
|
||||||
, fileBookmarkTags = tags
|
tags
|
||||||
}
|
|
||||||
|
|
||||||
data FFBookmarkNode = FFBookmarkNode
|
|
||||||
{ firefoxBookmarkChildren :: Maybe [FFBookmarkNode]
|
|
||||||
, firefoxBookmarkDateAdded :: !TI.POSIXTime
|
|
||||||
, firefoxBookmarkGuid :: !Text
|
|
||||||
, firefoxBookmarkIconUri :: !(Maybe Text)
|
|
||||||
, firefoxBookmarkId :: !Int
|
|
||||||
, firefoxBookmarkIndex :: !Int
|
|
||||||
, firefoxBookmarkLastModified :: !TI.POSIXTime
|
|
||||||
, firefoxBookmarkRoot :: !(Maybe Text)
|
|
||||||
, firefoxBookmarkTitle :: !Text
|
|
||||||
, firefoxBookmarkType :: !Text
|
|
||||||
, firefoxBookmarkTypeCode :: !Int
|
|
||||||
, firefoxBookmarkUri :: !(Maybe Text)
|
|
||||||
} deriving (Show, Eq, Typeable, Ord)
|
|
||||||
|
|
||||||
instance FromJSON FFBookmarkNode where
|
|
||||||
parseJSON (Object o) =
|
|
||||||
FFBookmarkNode <$>
|
|
||||||
(o A..:? "children") <*>
|
|
||||||
(o .: "dateAdded") <*>
|
|
||||||
o .: "guid" <*>
|
|
||||||
(o A..:? "iconUri") <*>
|
|
||||||
o .: "id" <*>
|
|
||||||
o .: "index" <*>
|
|
||||||
(o .: "lastModified") <*>
|
|
||||||
(o A..:? "root") <*>
|
|
||||||
(o .: "title") <*>
|
|
||||||
(o .: "type") <*>
|
|
||||||
(o .: "typeCode") <*>
|
|
||||||
(o A..:? "uri")
|
|
||||||
parseJSON _ = A.parseFail "bad parse"
|
|
||||||
|
|
||||||
firefoxBookmarkNodeToBookmark :: UserId -> FFBookmarkNode -> IO [Bookmark]
|
|
||||||
firefoxBookmarkNodeToBookmark user FFBookmarkNode {..} =
|
|
||||||
case firefoxBookmarkTypeCode of
|
|
||||||
1 -> do
|
|
||||||
slug <- mkBmSlug
|
|
||||||
pure $
|
|
||||||
[ Bookmark
|
|
||||||
{ bookmarkUserId = user
|
|
||||||
, bookmarkSlug = slug
|
|
||||||
, bookmarkHref = fromMaybe "" firefoxBookmarkUri
|
|
||||||
, bookmarkDescription = firefoxBookmarkTitle
|
|
||||||
, bookmarkExtended = ""
|
|
||||||
, bookmarkTime = TI.posixSecondsToUTCTime (firefoxBookmarkDateAdded / 1000000)
|
|
||||||
, bookmarkShared = True
|
|
||||||
, bookmarkToRead = False
|
|
||||||
, bookmarkSelected = False
|
|
||||||
, bookmarkArchiveHref = Nothing
|
|
||||||
}
|
|
||||||
]
|
|
||||||
2 ->
|
|
||||||
join <$>
|
|
||||||
mapM
|
|
||||||
(firefoxBookmarkNodeToBookmark user)
|
|
||||||
(fromMaybe [] firefoxBookmarkChildren)
|
|
||||||
_ -> pure []
|
|
||||||
|
|
||||||
|
|
||||||
insertFileBookmarks :: Key User -> FilePath -> DB (Either String Int)
|
insertFileBookmarks :: Key User -> FilePath -> DB ()
|
||||||
insertFileBookmarks userId bookmarkFile = do
|
insertFileBookmarks userId bookmarkFile = do
|
||||||
mfmarks <- liftIO $ readFileBookmarks bookmarkFile
|
mfmarks <- liftIO $ readFileBookmarks bookmarkFile
|
||||||
case mfmarks of
|
case mfmarks of
|
||||||
Left e -> pure $ Left e
|
Left e -> print e
|
||||||
Right fmarks -> do
|
Right fmarks -> do
|
||||||
bmarks <- liftIO $ mapM (fileBookmarkToBookmark userId) fmarks
|
bmarks <- liftIO $ mapM (fileBookmarkToBookmark userId) fmarks
|
||||||
mbids <- mapM insertUnique bmarks
|
mbids <- mapM insertUnique bmarks
|
||||||
mapM_ (void . insertUnique) $
|
void $
|
||||||
|
mapM insertUnique $
|
||||||
concatMap (uncurry (mkBookmarkTags userId)) $
|
concatMap (uncurry (mkBookmarkTags userId)) $
|
||||||
catMaybes $
|
catMaybes $
|
||||||
zipWith
|
zipWith
|
||||||
(\mbid tags -> (, tags) <$> mbid)
|
(\mbid tags -> ((, tags) <$> mbid))
|
||||||
mbids
|
mbids
|
||||||
(extractTags <$> fmarks)
|
(extractTags <$> fmarks)
|
||||||
pure $ Right (length bmarks)
|
|
||||||
|
|
||||||
where
|
where
|
||||||
extractTags = words . fileBookmarkTags
|
extractTags = words . fileBookmarkTags
|
||||||
|
|
||||||
insertFFBookmarks :: Key User -> FilePath -> DB (Either String Int)
|
|
||||||
insertFFBookmarks userId bookmarkFile = do
|
|
||||||
mfmarks <- liftIO $ readFFBookmarks bookmarkFile
|
|
||||||
case mfmarks of
|
|
||||||
Left e -> pure $ Left e
|
|
||||||
Right fmarks -> do
|
|
||||||
bmarks <- liftIO $ firefoxBookmarkNodeToBookmark userId fmarks
|
|
||||||
mapM_ (void . insertUnique) bmarks
|
|
||||||
pure $ Right (length bmarks)
|
|
||||||
|
|
||||||
|
|
||||||
readFileBookmarks :: MonadIO m => FilePath -> m (Either String [FileBookmark])
|
readFileBookmarks :: MonadIO m => FilePath -> m (Either String [FileBookmark])
|
||||||
readFileBookmarks fpath =
|
readFileBookmarks fpath =
|
||||||
A.eitherDecode' . fromStrict <$> readFile fpath
|
pure . A.eitherDecode' . fromStrict =<< readFile fpath
|
||||||
|
|
||||||
readFFBookmarks :: MonadIO m => FilePath -> m (Either String FFBookmarkNode)
|
|
||||||
readFFBookmarks fpath =
|
|
||||||
A.eitherDecode' . fromStrict <$> readFile fpath
|
|
||||||
|
|
||||||
exportFileBookmarks :: Key User -> FilePath -> DB ()
|
exportFileBookmarks :: Key User -> FilePath -> DB ()
|
||||||
exportFileBookmarks user fpath =
|
exportFileBookmarks user fpath = do
|
||||||
liftIO . A.encodeFile fpath =<< getFileBookmarks user
|
liftIO . A.encodeFile fpath =<< getFileBookmarks user
|
||||||
|
|
||||||
getFileBookmarks :: Key User -> DB [FileBookmark]
|
getFileBookmarks :: Key User -> DB [FileBookmark]
|
||||||
|
@ -474,127 +380,58 @@ getFileBookmarks user = do
|
||||||
marks <- allUserBookmarks user
|
marks <- allUserBookmarks user
|
||||||
pure $ fmap (\(bm, t) -> bookmarkTofileBookmark (entityVal bm) t) marks
|
pure $ fmap (\(bm, t) -> bookmarkTofileBookmark (entityVal bm) t) marks
|
||||||
|
|
||||||
data TagCloudMode
|
-- returns a list of pair of bookmark with tags merged into a string
|
||||||
= TagCloudModeTop Bool Int -- { mode: "top", value: 200 }
|
allUserBookmarks :: Key User -> DB [(Entity Bookmark, Text)]
|
||||||
| TagCloudModeLowerBound Bool Int -- { mode: "lowerBound", value: 20 }
|
allUserBookmarks user = do
|
||||||
| TagCloudModeRelated Bool [Tag]
|
bmarks <- bquery
|
||||||
| TagCloudModeNone
|
tags <- tquery
|
||||||
deriving (Show, Eq, Read, Generic)
|
let tagmap = MS.fromList tags
|
||||||
|
pure $ (\bm@(Entity bid _) -> (bm, findWithDefault mempty bid tagmap)) <$> bmarks
|
||||||
isExpanded :: TagCloudMode -> Bool
|
where
|
||||||
isExpanded (TagCloudModeTop e _) = e
|
bquery :: DB [Entity Bookmark]
|
||||||
isExpanded (TagCloudModeLowerBound e _) = e
|
bquery =
|
||||||
isExpanded (TagCloudModeRelated e _) = e
|
select $
|
||||||
isExpanded TagCloudModeNone = False
|
from $ \b -> do
|
||||||
|
where_ (b ^. BookmarkUserId E.==. val user)
|
||||||
instance FromJSON TagCloudMode where
|
orderBy [asc (b ^. BookmarkTime)]
|
||||||
parseJSON (Object o) =
|
pure b
|
||||||
case KM.lookup "mode" o of
|
tquery :: DB [(Key Bookmark, Text)]
|
||||||
Just (String "top") -> TagCloudModeTop <$> o .: "expanded" <*> o .: "value"
|
tquery =
|
||||||
Just (String "lowerBound") -> TagCloudModeLowerBound <$> o .: "expanded" <*> o .: "value"
|
fmap (\(tid, tags) -> (E.unValue tid, E.unValue tags)) <$>
|
||||||
Just (String "related") -> TagCloudModeRelated <$> o .: "expanded" <*> fmap words (o .: "value")
|
(select $
|
||||||
Just (String "none") -> pure TagCloudModeNone
|
from $ \t -> do
|
||||||
_ -> A.parseFail "bad parse"
|
where_ (t ^. BookmarkTagUserId E.==. val user)
|
||||||
parseJSON _ = A.parseFail "bad parse"
|
E.groupBy (t ^. BookmarkTagBookmarkId)
|
||||||
|
let tags = sqlite_group_concat (t ^. BookmarkTagTag) (E.val " ")
|
||||||
instance ToJSON TagCloudMode where
|
pure (t ^. BookmarkTagBookmarkId, tags))
|
||||||
toJSON (TagCloudModeTop e i) =
|
|
||||||
object [ "mode" .= String "top"
|
|
||||||
, "value" .= toJSON i
|
|
||||||
, "expanded" .= Bool e
|
|
||||||
]
|
|
||||||
toJSON (TagCloudModeLowerBound e i) =
|
|
||||||
object [ "mode" .= String "lowerBound"
|
|
||||||
, "value" .= toJSON i
|
|
||||||
, "expanded" .= Bool e
|
|
||||||
]
|
|
||||||
toJSON (TagCloudModeRelated e tags) =
|
|
||||||
object [ "mode" .= String "related"
|
|
||||||
, "value" .= String (unwords tags)
|
|
||||||
, "expanded" .= Bool e
|
|
||||||
]
|
|
||||||
toJSON TagCloudModeNone =
|
|
||||||
object [ "mode" .= String "none"
|
|
||||||
, "value" .= Null
|
|
||||||
, "expanded" .= Bool False
|
|
||||||
]
|
|
||||||
|
|
||||||
|
|
||||||
type Tag = Text
|
type Tag = Text
|
||||||
|
|
||||||
tagCountTop :: Key User -> Int -> DB [(Text, Int)]
|
|
||||||
tagCountTop user top =
|
|
||||||
sortOn (toLower . fst) .
|
|
||||||
fmap (bimap unValue unValue) <$>
|
|
||||||
( select $ do
|
|
||||||
t <- from (table @BookmarkTag)
|
|
||||||
where_ (t ^. BookmarkTagUserId ==. val user)
|
|
||||||
groupBy (lower_ $ t ^. BookmarkTagTag)
|
|
||||||
let countRows' = countRows
|
|
||||||
orderBy [desc countRows']
|
|
||||||
limit ((fromIntegral . toInteger) top)
|
|
||||||
pure (t ^. BookmarkTagTag, countRows')
|
|
||||||
)
|
|
||||||
|
|
||||||
tagCountLowerBound :: Key User -> Int -> DB [(Text, Int)]
|
|
||||||
tagCountLowerBound user lowerBound =
|
|
||||||
fmap (bimap unValue unValue) <$>
|
|
||||||
( select $ do
|
|
||||||
t <- from (table @BookmarkTag)
|
|
||||||
where_ (t ^. BookmarkTagUserId ==. val user)
|
|
||||||
groupBy (lower_ $ t ^. BookmarkTagTag)
|
|
||||||
let countRows' = countRows
|
|
||||||
orderBy [asc (t ^. BookmarkTagTag)]
|
|
||||||
having (countRows' >=. val lowerBound)
|
|
||||||
pure (t ^. BookmarkTagTag, countRows')
|
|
||||||
)
|
|
||||||
|
|
||||||
tagCountRelated :: Key User -> [Tag] -> DB [(Text, Int)]
|
|
||||||
tagCountRelated user tags =
|
|
||||||
fmap (bimap unValue unValue) <$>
|
|
||||||
( select $ do
|
|
||||||
t <- from (table @BookmarkTag)
|
|
||||||
where_ $
|
|
||||||
foldl (\expr tag ->
|
|
||||||
expr &&. exists ( do
|
|
||||||
u <- from (table @BookmarkTag)
|
|
||||||
where_ (u ^. BookmarkTagBookmarkId ==. t ^. BookmarkTagBookmarkId &&.
|
|
||||||
(u ^. BookmarkTagTag `like` val tag))))
|
|
||||||
(t ^. BookmarkTagUserId ==. val user)
|
|
||||||
tags
|
|
||||||
groupBy (lower_ $ t ^. BookmarkTagTag)
|
|
||||||
let countRows' = countRows
|
|
||||||
orderBy [asc $ lower_ $ (t ^. BookmarkTagTag)]
|
|
||||||
pure (t ^. BookmarkTagTag, countRows')
|
|
||||||
)
|
|
||||||
|
|
||||||
-- Notes
|
-- Notes
|
||||||
|
|
||||||
fileNoteToNote :: UserId -> FileNote -> IO Note
|
fileNoteToNote :: UserId -> FileNote -> IO Note
|
||||||
fileNoteToNote user FileNote {..} = do
|
fileNoteToNote user (FileNote {..} ) = do
|
||||||
slug <- mkNtSlug
|
slug <- mkNtSlug
|
||||||
pure $
|
pure $
|
||||||
Note
|
Note
|
||||||
{ noteUserId = user
|
user
|
||||||
, noteSlug = slug
|
slug
|
||||||
, noteLength = fileNoteLength
|
fileNoteLength
|
||||||
, noteTitle = fileNoteTitle
|
fileNoteTitle
|
||||||
, noteText = fileNoteText
|
fileNoteText
|
||||||
, noteIsMarkdown = False
|
False
|
||||||
, noteShared = False
|
False
|
||||||
, noteCreated = fileNoteCreatedAt
|
fileNoteCreatedAt
|
||||||
, noteUpdated = fileNoteUpdatedAt
|
fileNoteUpdatedAt
|
||||||
}
|
|
||||||
|
|
||||||
insertDirFileNotes :: Key User -> FilePath -> DB (Either String Int)
|
insertDirFileNotes :: Key User -> FilePath -> DB ()
|
||||||
insertDirFileNotes userId noteDirectory = do
|
insertDirFileNotes userId noteDirectory = do
|
||||||
mfnotes <- liftIO $ readFileNotes noteDirectory
|
mfnotes <- liftIO $ readFileNotes noteDirectory
|
||||||
case mfnotes of
|
case mfnotes of
|
||||||
Left e -> pure $ Left e
|
Left e -> print e
|
||||||
Right fnotes -> do
|
Right fnotes -> do
|
||||||
notes <- liftIO $ mapM (fileNoteToNote userId) fnotes
|
notes <- liftIO $ mapM (fileNoteToNote userId) fnotes
|
||||||
void $ mapM insertUnique notes
|
void $ mapM insertUnique notes
|
||||||
pure $ Right (length notes)
|
|
||||||
where
|
where
|
||||||
readFileNotes :: MonadIO m => FilePath -> m (Either String [FileNote])
|
readFileNotes :: MonadIO m => FilePath -> m (Either String [FileNote])
|
||||||
readFileNotes fdir = do
|
readFileNotes fdir = do
|
||||||
|
@ -613,7 +450,7 @@ instance FromJSON AccountSettingsForm where parseJSON = A.genericParseJSON gDefa
|
||||||
instance ToJSON AccountSettingsForm where toJSON = A.genericToJSON gDefaultFormOptions
|
instance ToJSON AccountSettingsForm where toJSON = A.genericToJSON gDefaultFormOptions
|
||||||
|
|
||||||
toAccountSettingsForm :: User -> AccountSettingsForm
|
toAccountSettingsForm :: User -> AccountSettingsForm
|
||||||
toAccountSettingsForm User {..} =
|
toAccountSettingsForm (User {..}) =
|
||||||
AccountSettingsForm
|
AccountSettingsForm
|
||||||
{ _privateDefault = userPrivateDefault
|
{ _privateDefault = userPrivateDefault
|
||||||
, _archiveDefault = userArchiveDefault
|
, _archiveDefault = userArchiveDefault
|
||||||
|
@ -621,7 +458,7 @@ toAccountSettingsForm User {..} =
|
||||||
}
|
}
|
||||||
|
|
||||||
updateUserFromAccountSettingsForm :: Key User -> AccountSettingsForm -> DB ()
|
updateUserFromAccountSettingsForm :: Key User -> AccountSettingsForm -> DB ()
|
||||||
updateUserFromAccountSettingsForm userId AccountSettingsForm {..} =
|
updateUserFromAccountSettingsForm userId (AccountSettingsForm {..}) = do
|
||||||
CP.update userId
|
CP.update userId
|
||||||
[ UserPrivateDefault CP.=. _privateDefault
|
[ UserPrivateDefault CP.=. _privateDefault
|
||||||
, UserArchiveDefault CP.=. _archiveDefault
|
, UserArchiveDefault CP.=. _archiveDefault
|
||||||
|
@ -650,111 +487,99 @@ instance ToJSON BookmarkForm where toJSON = A.genericToJSON gDefaultFormOptions
|
||||||
gDefaultFormOptions :: A.Options
|
gDefaultFormOptions :: A.Options
|
||||||
gDefaultFormOptions = A.defaultOptions { A.fieldLabelModifier = drop 1 }
|
gDefaultFormOptions = A.defaultOptions { A.fieldLabelModifier = drop 1 }
|
||||||
|
|
||||||
toBookmarkFormList :: [(Entity Bookmark, Maybe Text)] -> [BookmarkForm]
|
toBookmarkFormList :: [Entity Bookmark] -> [Entity BookmarkTag] -> [BookmarkForm]
|
||||||
toBookmarkFormList = fmap _toBookmarkForm'
|
toBookmarkFormList bs as = do
|
||||||
|
b <- bs
|
||||||
|
let bid = E.entityKey b
|
||||||
|
let btags = filter ((==) bid . bookmarkTagBookmarkId . E.entityVal) as
|
||||||
|
pure $ _toBookmarkForm (b, btags)
|
||||||
|
|
||||||
_toBookmarkForm :: (Entity Bookmark, [Entity BookmarkTag]) -> BookmarkForm
|
_toBookmarkForm :: (Entity Bookmark, [Entity BookmarkTag]) -> BookmarkForm
|
||||||
_toBookmarkForm (bm, tags) =
|
_toBookmarkForm (Entity bid Bookmark {..}, tags) =
|
||||||
_toBookmarkForm' (bm, Just $ unwords $ fmap (bookmarkTagTag . entityVal) tags)
|
|
||||||
|
|
||||||
_toBookmarkForm' :: (Entity Bookmark, Maybe Text) -> BookmarkForm
|
|
||||||
_toBookmarkForm' (Entity bid Bookmark {..}, tags) =
|
|
||||||
BookmarkForm
|
BookmarkForm
|
||||||
{ _url = bookmarkHref
|
{ _url = bookmarkHref
|
||||||
, _title = Just bookmarkDescription
|
, _title = Just bookmarkDescription
|
||||||
, _description = Just $ Textarea $ bookmarkExtended
|
, _description = Just $ Textarea $ bookmarkExtended
|
||||||
, _tags = Just $ fromMaybe "" tags
|
, _tags = Just $ unwords $ fmap (bookmarkTagTag . entityVal) tags
|
||||||
, _private = Just $ not bookmarkShared
|
, _private = Just $ not bookmarkShared
|
||||||
, _toread = Just bookmarkToRead
|
, _toread = Just $ bookmarkToRead
|
||||||
, _bid = Just $ unBookmarkKey $ bid
|
, _bid = Just $ unBookmarkKey $ bid
|
||||||
, _slug = Just bookmarkSlug
|
, _slug = Just $ bookmarkSlug
|
||||||
, _selected = Just bookmarkSelected
|
, _selected = Just $ bookmarkSelected
|
||||||
, _time = Just $ UTCTimeStr $ bookmarkTime
|
, _time = Just $ UTCTimeStr $ bookmarkTime
|
||||||
, _archiveUrl = bookmarkArchiveHref
|
, _archiveUrl = bookmarkArchiveHref
|
||||||
}
|
}
|
||||||
|
|
||||||
|
|
||||||
_toBookmark :: UserId -> BookmarkForm -> IO Bookmark
|
_toBookmark :: UserId -> BookmarkForm -> IO Bookmark
|
||||||
_toBookmark userId BookmarkForm {..} = do
|
_toBookmark userId BookmarkForm {..} = do
|
||||||
time <- liftIO getCurrentTime
|
time <- liftIO getCurrentTime
|
||||||
slug <- maybe mkBmSlug pure _slug
|
slug <- maybe mkBmSlug pure _slug
|
||||||
pure $
|
pure $
|
||||||
Bookmark
|
Bookmark
|
||||||
{ bookmarkUserId = userId
|
userId
|
||||||
, bookmarkSlug = slug
|
slug
|
||||||
, bookmarkHref = _url
|
_url
|
||||||
, bookmarkDescription = fromMaybe "" _title
|
(fromMaybe "" _title)
|
||||||
, bookmarkExtended = maybe "" unTextarea _description
|
(maybe "" unTextarea _description)
|
||||||
, bookmarkTime = maybe time unUTCTimeStr _time
|
(fromMaybe time (fmap unUTCTimeStr _time))
|
||||||
, bookmarkShared = maybe True not _private
|
(maybe True not _private)
|
||||||
, bookmarkToRead = Just True == _toread
|
(fromMaybe False _toread)
|
||||||
, bookmarkSelected = Just True == _selected
|
(fromMaybe False _selected)
|
||||||
, bookmarkArchiveHref = _archiveUrl
|
_archiveUrl
|
||||||
}
|
|
||||||
|
|
||||||
fetchBookmarkByUrl :: Key User -> Maybe Text -> DB (Maybe (Entity Bookmark, [Entity BookmarkTag]))
|
fetchBookmarkByUrl :: Key User -> Maybe Text -> DB (Maybe (Entity Bookmark, [Entity BookmarkTag]))
|
||||||
fetchBookmarkByUrl userId murl = runMaybeT do
|
fetchBookmarkByUrl userId murl = runMaybeT $ do
|
||||||
bmark <- MaybeT . getBy . UniqueUserHref userId =<< MaybeT (pure murl)
|
bmark <- MaybeT . getBy . UniqueUserHref userId =<< (MaybeT $ pure murl)
|
||||||
btags <- lift $ withTags (entityKey bmark)
|
btags <- lift $ withTags (entityKey bmark)
|
||||||
pure (bmark, btags)
|
pure (bmark, btags)
|
||||||
|
|
||||||
data UpsertResult a = Created a | Updated a | Failed String
|
data UpsertResult = Created | Updated
|
||||||
deriving (Show, Eq, Functor)
|
|
||||||
|
|
||||||
maybeUpsertResult :: UpsertResult a -> Maybe a
|
upsertBookmark:: Maybe (Key Bookmark) -> Bookmark -> [Text] -> DB (UpsertResult, Key Bookmark)
|
||||||
maybeUpsertResult (Created a) = Just a
|
upsertBookmark mbid bm tags = do
|
||||||
maybeUpsertResult (Updated a) = Just a
|
|
||||||
maybeUpsertResult _ = Nothing
|
|
||||||
|
|
||||||
upsertBookmark :: Key User -> Maybe (Key Bookmark) -> Bookmark -> [Text] -> DB (UpsertResult (Key Bookmark))
|
|
||||||
upsertBookmark userId mbid bm tags = do
|
|
||||||
res <- case mbid of
|
res <- case mbid of
|
||||||
Just bid ->
|
Just bid -> do
|
||||||
get bid >>= \case
|
get bid >>= \case
|
||||||
Just prev_bm | userId == bookmarkUserId prev_bm ->
|
Just prev_bm -> replaceBookmark bid prev_bm
|
||||||
replaceBookmark bid prev_bm
|
_ -> fail "not found"
|
||||||
Just _ -> pure (Failed "unauthorized")
|
Nothing -> do
|
||||||
_ -> pure (Failed "not found")
|
|
||||||
Nothing ->
|
|
||||||
getBy (UniqueUserHref (bookmarkUserId bm) (bookmarkHref bm)) >>= \case
|
getBy (UniqueUserHref (bookmarkUserId bm) (bookmarkHref bm)) >>= \case
|
||||||
Just (Entity bid prev_bm) -> replaceBookmark bid prev_bm
|
Just (Entity bid prev_bm) -> replaceBookmark bid prev_bm
|
||||||
_ -> Created <$> insert bm
|
_ -> (Created,) <$> insert bm
|
||||||
forM_ (maybeUpsertResult res) (insertTags (bookmarkUserId bm))
|
insertTags (bookmarkUserId bm) (snd res)
|
||||||
pure res
|
pure res
|
||||||
where
|
where
|
||||||
prepareReplace prev_bm =
|
prepareReplace prev_bm = do
|
||||||
if bookmarkHref bm /= bookmarkHref prev_bm
|
if (bookmarkHref bm /= bookmarkHref prev_bm)
|
||||||
then bm { bookmarkArchiveHref = Nothing }
|
then bm { bookmarkArchiveHref = Nothing }
|
||||||
else bm { bookmarkArchiveHref = bookmarkArchiveHref prev_bm }
|
else bm { bookmarkArchiveHref = bookmarkArchiveHref prev_bm }
|
||||||
replaceBookmark bid prev_bm = do
|
replaceBookmark bid prev_bm = do
|
||||||
replace bid (prepareReplace prev_bm)
|
replace bid (prepareReplace prev_bm)
|
||||||
deleteTags bid
|
deleteTags bid
|
||||||
pure (Updated bid)
|
pure (Updated, bid)
|
||||||
deleteTags bid =
|
deleteTags bid =
|
||||||
deleteWhere [BookmarkTagBookmarkId CP.==. bid]
|
deleteWhere [BookmarkTagBookmarkId ==. bid]
|
||||||
insertTags userId' bid' =
|
insertTags userId bid' =
|
||||||
for_ (zip [1 ..] tags) $
|
for_ (zip [1 ..] tags) $
|
||||||
\(i, tag) -> void $ insert $ BookmarkTag userId' tag bid' i
|
\(i, tag) -> void $ insert $ BookmarkTag userId tag bid' i
|
||||||
|
|
||||||
updateBookmarkArchiveUrl :: Key User -> Key Bookmark -> Maybe Text -> DB ()
|
updateBookmarkArchiveUrl :: Key User -> Key Bookmark -> Maybe Text -> DB ()
|
||||||
updateBookmarkArchiveUrl userId bid marchiveUrl =
|
updateBookmarkArchiveUrl userId bid marchiveUrl = do
|
||||||
updateWhere
|
updateWhere
|
||||||
[BookmarkUserId CP.==. userId, BookmarkId CP.==. bid]
|
[BookmarkUserId ==. userId, BookmarkId ==. bid]
|
||||||
[BookmarkArchiveHref CP.=. marchiveUrl]
|
[BookmarkArchiveHref CP.=. marchiveUrl]
|
||||||
|
|
||||||
upsertNote :: Key User -> Maybe (Key Note) -> Note -> DB (UpsertResult (Key Note))
|
upsertNote:: Maybe (Key Note) -> Note -> DB (UpsertResult, Key Note)
|
||||||
upsertNote userId mnid note =
|
upsertNote mnid bmark@Note{..} = do
|
||||||
case mnid of
|
case mnid of
|
||||||
Just nid -> do
|
Just nid -> do
|
||||||
get nid >>= \case
|
get nid >>= \case
|
||||||
Just note' -> do
|
Just _ -> do
|
||||||
when (userId /= noteUserId note')
|
replace nid bmark
|
||||||
(throwString "unauthorized")
|
pure (Updated, nid)
|
||||||
replace nid note
|
_ -> fail "not found"
|
||||||
pure (Updated nid)
|
|
||||||
_ -> throwString "not found"
|
|
||||||
Nothing -> do
|
Nothing -> do
|
||||||
Created <$> insert note
|
(Created,) <$> insert bmark
|
||||||
|
|
||||||
-- * FileBookmarks
|
-- * FileBookmarks
|
||||||
|
|
||||||
|
@ -779,10 +604,10 @@ instance FromJSON FileBookmark where
|
||||||
(o A..:? "selected") <*>
|
(o A..:? "selected") <*>
|
||||||
(o A..:? "archive_url") <*>
|
(o A..:? "archive_url") <*>
|
||||||
(o .: "tags")
|
(o .: "tags")
|
||||||
parseJSON _ = A.parseFail "bad parse"
|
parseJSON _ = fail "bad parse"
|
||||||
|
|
||||||
instance ToJSON FileBookmark where
|
instance ToJSON FileBookmark where
|
||||||
toJSON FileBookmark {..} =
|
toJSON (FileBookmark {..}) =
|
||||||
object
|
object
|
||||||
[ "href" .= toJSON fileBookmarkHref
|
[ "href" .= toJSON fileBookmarkHref
|
||||||
, "description" .= toJSON fileBookmarkDescription
|
, "description" .= toJSON fileBookmarkDescription
|
||||||
|
@ -820,10 +645,10 @@ instance FromJSON FileNote where
|
||||||
o .: "length" <*>
|
o .: "length" <*>
|
||||||
(readFileNoteTime =<< o .: "created_at") <*>
|
(readFileNoteTime =<< o .: "created_at") <*>
|
||||||
(readFileNoteTime =<< o .: "updated_at")
|
(readFileNoteTime =<< o .: "updated_at")
|
||||||
parseJSON _ = A.parseFail "bad parse"
|
parseJSON _ = fail "bad parse"
|
||||||
|
|
||||||
instance ToJSON FileNote where
|
instance ToJSON FileNote where
|
||||||
toJSON FileNote {..} =
|
toJSON (FileNote {..}) =
|
||||||
object
|
object
|
||||||
[ "id" .= toJSON fileNoteId
|
[ "id" .= toJSON fileNoteId
|
||||||
, "title" .= toJSON fileNoteTitle
|
, "title" .= toJSON fileNoteTitle
|
||||||
|
@ -834,7 +659,7 @@ instance ToJSON FileNote where
|
||||||
]
|
]
|
||||||
|
|
||||||
readFileNoteTime
|
readFileNoteTime
|
||||||
:: MonadFail m
|
:: Monad m
|
||||||
=> String -> m UTCTime
|
=> String -> m UTCTime
|
||||||
readFileNoteTime = parseTimeM True defaultTimeLocale "%F %T"
|
readFileNoteTime = parseTimeM True defaultTimeLocale "%F %T"
|
||||||
|
|
||||||
|
|
|
@ -12,8 +12,6 @@ import qualified Data.Aeson as A
|
||||||
import System.Entropy (getEntropy)
|
import System.Entropy (getEntropy)
|
||||||
import qualified Data.ByteString.Builder as BB
|
import qualified Data.ByteString.Builder as BB
|
||||||
import qualified Data.ByteString.Lazy as LBS
|
import qualified Data.ByteString.Lazy as LBS
|
||||||
import qualified Data.ByteString.Base64.URL as Base64Url
|
|
||||||
import qualified Crypto.Hash.SHA256 as SHA256
|
|
||||||
|
|
||||||
mkSlug :: Int -> IO T.Text
|
mkSlug :: Int -> IO T.Text
|
||||||
mkSlug size =
|
mkSlug size =
|
||||||
|
@ -60,18 +58,3 @@ hashPassword rawPassword = do
|
||||||
validatePasswordHash :: BCrypt -> T.Text -> Bool
|
validatePasswordHash :: BCrypt -> T.Text -> Bool
|
||||||
validatePasswordHash hash' pass = do
|
validatePasswordHash hash' pass = do
|
||||||
validatePassword (TE.encodeUtf8 (unBCrypt hash')) (TE.encodeUtf8 pass)
|
validatePassword (TE.encodeUtf8 (unBCrypt hash')) (TE.encodeUtf8 pass)
|
||||||
|
|
||||||
newtype ApiKey = ApiKey { unApiKey :: T.Text }
|
|
||||||
|
|
||||||
newtype HashedApiKey
|
|
||||||
= HashedApiKey T.Text
|
|
||||||
deriving stock (Eq, Ord, Show)
|
|
||||||
deriving newtype (PersistField, PersistFieldSql, A.FromJSON, A.ToJSON)
|
|
||||||
|
|
||||||
generateApiKey :: IO ApiKey
|
|
||||||
generateApiKey = do
|
|
||||||
bytes <- getEntropy 32
|
|
||||||
pure $ ApiKey $ Base64Url.encodeBase64 bytes
|
|
||||||
|
|
||||||
hashApiKey :: ApiKey -> HashedApiKey
|
|
||||||
hashApiKey = HashedApiKey . TE.decodeUtf8 . Base64Url.encodeBase64' . SHA256.hash . TE.encodeUtf8 . unApiKey
|
|
||||||
|
|
|
@ -2,8 +2,8 @@
|
||||||
|
|
||||||
module PathPiece where
|
module PathPiece where
|
||||||
|
|
||||||
import Data.Text (breakOn, splitOn)
|
import Data.Text (splitOn)
|
||||||
import qualified Data.Text as T (replace)
|
|
||||||
import Import.NoFoundation
|
import Import.NoFoundation
|
||||||
|
|
||||||
-- PathPiece
|
-- PathPiece
|
||||||
|
@ -11,25 +11,19 @@ import Import.NoFoundation
|
||||||
instance PathPiece UserNameP where
|
instance PathPiece UserNameP where
|
||||||
toPathPiece (UserNameP i) = "u:" <> i
|
toPathPiece (UserNameP i) = "u:" <> i
|
||||||
fromPathPiece s =
|
fromPathPiece s =
|
||||||
case breakOn ":" s of
|
case splitOn ":" s of
|
||||||
("u", "") -> Nothing
|
["u", ""] -> Nothing
|
||||||
("u", uname) -> Just $ UserNameP (drop 1 uname)
|
["u", uname] -> Just $ UserNameP uname
|
||||||
_ -> Nothing
|
_ -> Nothing
|
||||||
|
|
||||||
instance PathPiece TagsP where
|
instance PathPiece TagsP where
|
||||||
toPathPiece (TagsP tags) = "t:" <> intercalate "+" (fmap encodeTag tags)
|
toPathPiece (TagsP tags) = "t:" <> (intercalate "+" tags)
|
||||||
fromPathPiece s =
|
fromPathPiece s =
|
||||||
case breakOn ":" s of
|
case splitOn ":" s of
|
||||||
("t", "") -> Nothing
|
["t", ""] -> Nothing
|
||||||
("t", tags) -> Just $ (TagsP . fmap decodeTag . splitOn "+" . drop 1) tags
|
["t", tags] -> Just $ TagsP (splitOn "+" tags)
|
||||||
_ -> Nothing
|
_ -> Nothing
|
||||||
|
|
||||||
encodeTag :: Text -> Text
|
|
||||||
encodeTag = T.replace "+" "%2B"
|
|
||||||
|
|
||||||
decodeTag :: Text -> Text
|
|
||||||
decodeTag = T.replace "%2B" "+"
|
|
||||||
|
|
||||||
instance PathPiece SharedP where
|
instance PathPiece SharedP where
|
||||||
toPathPiece = \case
|
toPathPiece = \case
|
||||||
SharedAll -> ""
|
SharedAll -> ""
|
||||||
|
@ -51,9 +45,9 @@ instance PathPiece FilterP where
|
||||||
"unread" -> Just FilterUnread
|
"unread" -> Just FilterUnread
|
||||||
"untagged" -> Just FilterUntagged
|
"untagged" -> Just FilterUntagged
|
||||||
"starred" -> Just FilterStarred
|
"starred" -> Just FilterStarred
|
||||||
s -> case breakOn ":" s of
|
s -> case splitOn ":" s of
|
||||||
("b", "") -> Nothing
|
["b", ""] -> Nothing
|
||||||
("b", slug) -> Just $ FilterSingle (BmSlug (drop 1 slug))
|
["b", slug] -> Just $ FilterSingle (BmSlug slug)
|
||||||
_ -> Nothing
|
_ -> Nothing
|
||||||
|
|
||||||
|
|
||||||
|
|
|
@ -56,22 +56,16 @@ data AppSettings = AppSettings
|
||||||
, appAuthDummyLogin :: Bool
|
, appAuthDummyLogin :: Bool
|
||||||
-- ^ Indicate if auth dummy login should be enabled.
|
-- ^ Indicate if auth dummy login should be enabled.
|
||||||
|
|
||||||
, appArchiveSocksProxyHost :: Maybe Text
|
, appEkgHost :: Maybe Text
|
||||||
-- ^ Socks proxy host to use when making archive requests
|
-- ^ Host/interface the ekg server should bind to.
|
||||||
|
, appEkgPort :: Maybe Int
|
||||||
, appArchiveSocksProxyPort :: Maybe Int
|
-- ^ Port to listen on
|
||||||
-- ^ Socks proxy port to use when making archive requests
|
|
||||||
|
|
||||||
, appSourceCodeUri :: Maybe Text
|
, appSourceCodeUri :: Maybe Text
|
||||||
-- ^ Uri to app source code
|
-- ^ Uri to app source code
|
||||||
|
|
||||||
, appSSLOnly :: Bool
|
|
||||||
|
|
||||||
, appAllowNonHttpUrlSchemes :: Bool
|
|
||||||
}
|
}
|
||||||
|
|
||||||
instance FromJSON AppSettings where
|
instance FromJSON AppSettings where
|
||||||
parseJSON = withObject "AppSettings" \o -> do
|
parseJSON = withObject "AppSettings" $ \o -> do
|
||||||
let defaultDev =
|
let defaultDev =
|
||||||
#ifdef DEVELOPMENT
|
#ifdef DEVELOPMENT
|
||||||
True
|
True
|
||||||
|
@ -98,14 +92,10 @@ instance FromJSON AppSettings where
|
||||||
|
|
||||||
appAuthDummyLogin <- o .:? "auth-dummy-login" .!= dev
|
appAuthDummyLogin <- o .:? "auth-dummy-login" .!= dev
|
||||||
|
|
||||||
appArchiveSocksProxyHost <- o .:? "archive-socks-proxy-host"
|
appEkgHost <- o .:? "ekg-host"
|
||||||
appArchiveSocksProxyPort <- o .:? "archive-socks-proxy-port"
|
appEkgPort <- o .:? "ekg-port"
|
||||||
appSourceCodeUri <- o .:? "source-code-uri"
|
appSourceCodeUri <- o .:? "source-code-uri"
|
||||||
|
|
||||||
appSSLOnly <- fromMaybe False <$> o .:? "ssl-only"
|
|
||||||
|
|
||||||
appAllowNonHttpUrlSchemes <- fromMaybe False <$> o .:? "allow-non-http-url-schemes"
|
|
||||||
|
|
||||||
return AppSettings {..}
|
return AppSettings {..}
|
||||||
|
|
||||||
-- | Settings for 'widgetFile', such as which template languages to support and
|
-- | Settings for 'widgetFile', such as which template languages to support and
|
||||||
|
|
10
stack.yaml
10
stack.yaml
|
@ -1,3 +1,9 @@
|
||||||
resolver: lts-20.1
|
resolver: lts-14.3
|
||||||
|
# allow-newer: true
|
||||||
|
extra-deps:
|
||||||
|
- ekg-0.4.0.15
|
||||||
|
- ekg-json-0.1.0.6
|
||||||
|
- monad-metrics-0.2.1.4
|
||||||
|
- wai-middleware-metrics-0.2.4
|
||||||
packages:
|
packages:
|
||||||
- .
|
- '.'
|
||||||
|
|
|
@ -3,10 +3,38 @@
|
||||||
# For more information, please see the documentation at:
|
# For more information, please see the documentation at:
|
||||||
# https://docs.haskellstack.org/en/stable/lock_files
|
# https://docs.haskellstack.org/en/stable/lock_files
|
||||||
|
|
||||||
packages: []
|
packages:
|
||||||
|
- completed:
|
||||||
|
hackage: ekg-0.4.0.15@sha256:f35b2c6d80415314f84056afaba6e622bf8d90eb01d0504c87f04c64cb105e04,2030
|
||||||
|
pantry-tree:
|
||||||
|
size: 1495
|
||||||
|
sha256: f9f8f92d73fd4cc8efe37b5a3db009a8c195e590ab9f7d680582ca253123ab3a
|
||||||
|
original:
|
||||||
|
hackage: ekg-0.4.0.15
|
||||||
|
- completed:
|
||||||
|
hackage: ekg-json-0.1.0.6@sha256:4ff2e9cac213a5868ae8b4a7c72a16a9a76fac14d944ae819b3d838a9725569b,1050
|
||||||
|
pantry-tree:
|
||||||
|
size: 265
|
||||||
|
sha256: 77dde8082700d78a353b7e476e4457aaa41acf62b1b60dbdbb450dfd553cf9b5
|
||||||
|
original:
|
||||||
|
hackage: ekg-json-0.1.0.6
|
||||||
|
- completed:
|
||||||
|
hackage: monad-metrics-0.2.1.4@sha256:ec7be46f0693b1acb0d7cad114b33f418eb82447f3a6bc90b19f695ff3a6d718,1914
|
||||||
|
pantry-tree:
|
||||||
|
size: 457
|
||||||
|
sha256: 07d623e9b2ebf8c4a5f2210ff8117d53c6aab05bfe7ac2ecd4c990cba4046096
|
||||||
|
original:
|
||||||
|
hackage: monad-metrics-0.2.1.4
|
||||||
|
- completed:
|
||||||
|
hackage: wai-middleware-metrics-0.2.4@sha256:d6b6916acd41aaef4ca59a839d40a3a377f9df784ae49fd4c64926ae916b6ba2,2890
|
||||||
|
pantry-tree:
|
||||||
|
size: 330
|
||||||
|
sha256: 99366b831109417cd8e739fb45e9fd214cb79f28a507f8154e5528120042d0ac
|
||||||
|
original:
|
||||||
|
hackage: wai-middleware-metrics-0.2.4
|
||||||
snapshots:
|
snapshots:
|
||||||
- completed:
|
- completed:
|
||||||
sha256: b73b2b116143aea728c70e65c3239188998bac5bc3be56465813dacd74215dc5
|
size: 523878
|
||||||
size: 648424
|
url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/14/3.yaml
|
||||||
url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/20/1.yaml
|
sha256: 470c46c27746a48c7c50f829efc0cf00112787a7804ee4ac7a27754658f6d92c
|
||||||
original: lts-20.1
|
original: lts-14.3
|
||||||
|
|
|
@ -1,6 +1,38 @@
|
||||||
@media (prefers-color-scheme: dark) {
|
:root {
|
||||||
html, img, video, iframe { filter: invert(1); }
|
color-scheme: light dark; /* support color scheme */
|
||||||
body { background-color: white; }
|
--base03: #002b36;
|
||||||
|
--base02: #073642;
|
||||||
|
--base01: #586e75;
|
||||||
|
--base00: #657b83;
|
||||||
|
--base0: #839496;
|
||||||
|
--base1: #93a1a1;
|
||||||
|
--base2: #eee8d5;
|
||||||
|
--base3: #fdf6e3;
|
||||||
|
--yellow: #b58900;
|
||||||
|
--orange: #cb4b16;
|
||||||
|
--red: #dc322f;
|
||||||
|
--magenta: #d33682;
|
||||||
|
--violet: #6c71c4;
|
||||||
|
--blue: #268bd2;
|
||||||
|
--cyan: #2aa198;
|
||||||
|
--green: #859900;
|
||||||
|
--transparent: rgba(255,255,255,0);
|
||||||
|
|
||||||
|
/* --main-background: #00151b; /* 0.5 darker than #002b36; */
|
||||||
|
--main-background: var(--base03); /* 0.5 darker than #002b36; */
|
||||||
|
--main-foreground: var(--base1);
|
||||||
|
--second-foreground: var(--base0);
|
||||||
|
--reveal-background: var(--base02);
|
||||||
|
--soft-foreground: var(--base01);
|
||||||
|
--border-color: var(--base02);
|
||||||
|
--todo-txt: #000;
|
||||||
|
--color-h1: var(--cyan);
|
||||||
|
--color-h2: var(--green);
|
||||||
|
--color-h3: var(--yellow);
|
||||||
|
--color-h4: var(--orange);
|
||||||
|
--color-h5: var(--red);
|
||||||
|
--color-h6: var(--magenta);
|
||||||
|
--color-link: var(--magenta);
|
||||||
}
|
}
|
||||||
|
|
||||||
html {
|
html {
|
||||||
|
@ -10,8 +42,28 @@ html {
|
||||||
body {
|
body {
|
||||||
height: 102%;
|
height: 102%;
|
||||||
word-wrap: break-word;
|
word-wrap: break-word;
|
||||||
|
background-color: var(--main-background);
|
||||||
|
color: var(--main-foreground);
|
||||||
}
|
}
|
||||||
|
a {
|
||||||
|
color: var(--blue);
|
||||||
|
}
|
||||||
|
a:visited { color: var(--violet);}
|
||||||
|
|
||||||
|
a:hover, a:active, .top_menu a:hover {color: var(--magenta);}
|
||||||
|
.bg-white { background-color: var(--main-background); }
|
||||||
|
input, textarea {
|
||||||
|
background-color: var(--reveal-background);
|
||||||
|
color: var(--main-foreground);
|
||||||
|
border: solid 1px var(--border-color);
|
||||||
|
}
|
||||||
|
.gold { color: var(--yellow); }
|
||||||
|
.hover-orange:hover { color: var(--orange); }
|
||||||
|
button, .button {color: white;}
|
||||||
|
.bg-white input:focus, .bg-white textarea:focus {
|
||||||
|
border: solid 1px var(--blue);
|
||||||
|
box-shadow: none;
|
||||||
|
}
|
||||||
button {
|
button {
|
||||||
background:none;
|
background:none;
|
||||||
border:none;
|
border:none;
|
||||||
|
@ -23,42 +75,33 @@ button:focus {
|
||||||
outline: none;
|
outline: none;
|
||||||
}
|
}
|
||||||
|
|
||||||
|
|
||||||
[hidden] {
|
[hidden] {
|
||||||
display: none !important;
|
display: none !important
|
||||||
}
|
}
|
||||||
|
|
||||||
input::placeholder {
|
input::placeholder {
|
||||||
color: lightgray;
|
color: var(--soft-foreground);
|
||||||
}
|
}
|
||||||
|
|
||||||
input[type="text"],
|
|
||||||
input[type="url"],
|
|
||||||
input[type="password"],
|
|
||||||
textarea {
|
|
||||||
font-size: 16px;
|
|
||||||
}
|
|
||||||
|
|
||||||
.queryInput {
|
.queryInput {
|
||||||
width: 128px;
|
width: 128px;
|
||||||
padding: 0 22px 0 2px;
|
padding: 0 22px 0 2px;
|
||||||
border-radius: 3px;
|
border-radius: 3px;
|
||||||
border-style: solid;
|
border-style: solid;
|
||||||
border-width: 1px;
|
border-width: 1px;
|
||||||
border-color: gray;
|
border-color: var(--border-color);
|
||||||
height: 22px;
|
height: 22px;
|
||||||
line-height: 22px;
|
line-height: 22px;
|
||||||
transition: width 0.1s ease-in-out;
|
transition: width .1s ease-in-out
|
||||||
}
|
|
||||||
.queryInput.search-inactive {
|
|
||||||
}
|
}
|
||||||
|
.queryInput.search-inactive {}
|
||||||
.queryInput:focus {
|
.queryInput:focus {
|
||||||
width: 175px;
|
width: 175px;
|
||||||
}
|
}
|
||||||
.submitting .queryInput,
|
.submitting .queryInput,
|
||||||
.queryInput.search-active {
|
.queryInput.search-active {
|
||||||
border-color: #990;
|
border-color: var(--border-color);
|
||||||
border-width: 2px;
|
border-width: 2px;
|
||||||
background-color: #ff9;
|
background-color: var(--reveal-background);
|
||||||
width: 175px;
|
width: 175px;
|
||||||
}
|
}
|
||||||
.queryIcon {
|
.queryIcon {
|
||||||
|
@ -82,7 +125,7 @@ label {
|
||||||
right: 2px;
|
right: 2px;
|
||||||
}
|
}
|
||||||
.close-x {
|
.close-x {
|
||||||
stroke: gray;
|
stroke: var(--second-foreground);
|
||||||
fill: transparent;
|
fill: transparent;
|
||||||
stroke-linecap: round;
|
stroke-linecap: round;
|
||||||
stroke-width: 3;
|
stroke-width: 3;
|
||||||
|
@ -103,79 +146,47 @@ label {
|
||||||
}
|
}
|
||||||
|
|
||||||
.star button {
|
.star button {
|
||||||
transition: color 0.1s;
|
transition: color .1s;
|
||||||
}
|
}
|
||||||
.star.selected button {
|
.star.selected button {
|
||||||
color: #22a;
|
color:var(--magenta);
|
||||||
}
|
}
|
||||||
.edit_links button {
|
.edit_links button {
|
||||||
transition: color 0.1s ease-in;
|
transition: color .1s ease-in;
|
||||||
}
|
}
|
||||||
|
|
||||||
.tag {
|
.tag {
|
||||||
color: #a51;
|
color:var(--cyan);
|
||||||
line-height:190%;
|
line-height:190%;
|
||||||
display: inline-block;
|
|
||||||
}
|
|
||||||
.tag-include {
|
|
||||||
color: rgb(221, 221, 221);
|
|
||||||
line-height: 190%;
|
|
||||||
display: inline-block;
|
|
||||||
}
|
|
||||||
.tag-exclude {
|
|
||||||
color: rgb(255, 170, 170);
|
|
||||||
line-height: 190%;
|
|
||||||
display: inline-block;
|
|
||||||
}
|
}
|
||||||
|
|
||||||
.private {
|
.private { background:var(--reveal-background);border:1px solid var(--border-color); }
|
||||||
background: #ddd;
|
.unread { color:var(--yellow); }
|
||||||
border: 1px solid #d1d1d1;
|
.mark_read {color: var(--yellow);}
|
||||||
}
|
.flash { color:var(--green); }
|
||||||
.unread {
|
|
||||||
color: #b41;
|
|
||||||
}
|
|
||||||
.mark_read {
|
|
||||||
color: #a81;
|
|
||||||
}
|
|
||||||
.flash {
|
|
||||||
color: green;
|
|
||||||
background: #efe;
|
|
||||||
}
|
|
||||||
|
|
||||||
.top_menu {
|
.top_menu {
|
||||||
margin-top:6px;
|
margin-top:6px;
|
||||||
}
|
}
|
||||||
.top_menu a {
|
.top_menu a {
|
||||||
color: blue;
|
color: var(--blue);
|
||||||
}
|
}
|
||||||
.bookmarklet {
|
.bookmarklet {
|
||||||
padding:1px 2px 0px 2px;
|
padding:1px 2px 0px 2px;
|
||||||
}
|
}
|
||||||
|
|
||||||
.alert {
|
.alert {
|
||||||
background: #ced;
|
background:var(--reveal-background);
|
||||||
border: 1px solid #acc;
|
border:1px solid var(--border-color);
|
||||||
margin-bottom: 5px;
|
|
||||||
padding: 2px;
|
|
||||||
}
|
|
||||||
.alert.alert-err {
|
|
||||||
background-color: #ffdfdf
|
|
||||||
}
|
}
|
||||||
|
|
||||||
.edit_bookmark_form {
|
.edit_bookmark_form {color:var(--second-foreground);}
|
||||||
color: #888;
|
.edit_bookmark_form input {border:1px solid var(--border-color);}
|
||||||
}
|
.edit_bookmark_form textarea {border:1px solid var(--border-color);}
|
||||||
.edit_bookmark_form input {
|
|
||||||
border: 1px solid #ddd;
|
|
||||||
}
|
|
||||||
.edit_bookmark_form textarea {
|
|
||||||
border: 1px solid #ddd;
|
|
||||||
}
|
|
||||||
|
|
||||||
.nav-active {
|
.nav-active {
|
||||||
background: #ff8;
|
background-color: var(--reveal-background);
|
||||||
color: blue;
|
color: var(--yellow);
|
||||||
}
|
}
|
||||||
|
|
||||||
/* mobile device */
|
/* mobile device */
|
||||||
|
@ -184,7 +195,7 @@ label {
|
||||||
-webkit-text-size-adjust: none;
|
-webkit-text-size-adjust: none;
|
||||||
}
|
}
|
||||||
.display {
|
.display {
|
||||||
float: none;
|
float: none
|
||||||
}
|
}
|
||||||
}
|
}
|
||||||
|
|
||||||
|
@ -197,16 +208,17 @@ label {
|
||||||
}
|
}
|
||||||
|
|
||||||
.rdim {
|
.rdim {
|
||||||
opacity: 0.8;
|
opacity: .8;
|
||||||
transition: all 0.15s ease-in;
|
transition: all .15s ease-in;
|
||||||
}
|
}
|
||||||
.rdim:hover,
|
.rdim:hover,
|
||||||
.rdim:focus {
|
.rdim:focus {
|
||||||
opacity: 1;
|
opacity: 1;
|
||||||
transition: all 0.15s ease-in;
|
transition: all .15s ease-in;
|
||||||
}
|
}
|
||||||
.display .description > div p,
|
.display .description > div p,
|
||||||
.display .description > div pre {
|
.display .description > div pre
|
||||||
|
{
|
||||||
margin-top: 9px;
|
margin-top: 9px;
|
||||||
margin-bottom: 9px;
|
margin-bottom: 9px;
|
||||||
}
|
}
|
||||||
|
@ -230,11 +242,263 @@ label {
|
||||||
.display .description > div ul {
|
.display .description > div ul {
|
||||||
padding-left: 23px;
|
padding-left: 23px;
|
||||||
}
|
}
|
||||||
code,
|
code, pre {
|
||||||
pre {
|
|
||||||
font-size:13px;
|
font-size:13px;
|
||||||
}
|
}
|
||||||
|
|
||||||
#content:not([view-rendered]) .view-delay {
|
#content:not([view-rendered]) .view-delay {
|
||||||
display: none !important;
|
display: none !important
|
||||||
}
|
}
|
||||||
|
/* CSS to be used for HTML Org-mode export
|
||||||
|
Author: Yann Esposito
|
||||||
|
*/
|
||||||
|
|
||||||
|
:root {
|
||||||
|
--font-size: 12px;
|
||||||
|
--line-height: 14px;
|
||||||
|
}
|
||||||
|
/* Fonts */
|
||||||
|
body {
|
||||||
|
font-family: Menlo, Monaco, monospace;
|
||||||
|
font-size: var(--font-size);
|
||||||
|
line-height: var(--line-height);
|
||||||
|
}
|
||||||
|
code {
|
||||||
|
font-family: Menlo, Monaco, monospace;
|
||||||
|
}
|
||||||
|
pre, pre code {
|
||||||
|
font-family: Menlo, Monaco, monospace;
|
||||||
|
}
|
||||||
|
.todo, .done {
|
||||||
|
font-family: Menlo, Monaco, monospace;
|
||||||
|
}
|
||||||
|
/* Layout */
|
||||||
|
body {
|
||||||
|
margin: 0;
|
||||||
|
padding: 0;
|
||||||
|
border: 0;
|
||||||
|
hyphens: auto;
|
||||||
|
-webkit-hyphens: auto;
|
||||||
|
-moz-hyphens:auto;
|
||||||
|
-ms-hyphens:auto;
|
||||||
|
}
|
||||||
|
h1, h2, h3, h4, h5, h6, pre, code, blockquote, ol, ul, ol ol, ul ul, ul ol, ol
|
||||||
|
ul, li, p, section, header, footer {
|
||||||
|
float: none;
|
||||||
|
margin: 0;
|
||||||
|
padding: 0;
|
||||||
|
}
|
||||||
|
h1, h2, h3, h4, h5, h6, pre, code, blockquote, p, ul, ol, section, header,
|
||||||
|
figure {
|
||||||
|
margin-top: 1em;
|
||||||
|
margin-bottom: 1em;
|
||||||
|
}
|
||||||
|
figure {
|
||||||
|
margin: 1em 0px;
|
||||||
|
}
|
||||||
|
figure > img {
|
||||||
|
margin: 0px;
|
||||||
|
}
|
||||||
|
li {
|
||||||
|
position: relative;
|
||||||
|
display: block;
|
||||||
|
padding-left: 1.5em;
|
||||||
|
}
|
||||||
|
ul > li:before {
|
||||||
|
content: "– ";
|
||||||
|
opacity: 0.5;
|
||||||
|
float: left;
|
||||||
|
position: relative;
|
||||||
|
left: -1.5em;
|
||||||
|
text-align: right;
|
||||||
|
width: 0;
|
||||||
|
}
|
||||||
|
ol {
|
||||||
|
counter-reset: ol;
|
||||||
|
}
|
||||||
|
ol > li:before {
|
||||||
|
content: counter(ol) ". ";
|
||||||
|
counter-increment: ol;
|
||||||
|
float: left;
|
||||||
|
text-align: right;
|
||||||
|
position: relative;
|
||||||
|
left: -1.5em;
|
||||||
|
width: 0;
|
||||||
|
}
|
||||||
|
ol > li:nth-child(n+10) {
|
||||||
|
padding-left:28px;
|
||||||
|
}
|
||||||
|
ol > li:nth-child(n+10):before {
|
||||||
|
left: -28px;
|
||||||
|
}
|
||||||
|
img {
|
||||||
|
max-width: 100%;
|
||||||
|
max-height: 800px;
|
||||||
|
margin: 1em auto;
|
||||||
|
}
|
||||||
|
p > img, li > img {
|
||||||
|
max-height: 1em;
|
||||||
|
margin: 0;
|
||||||
|
vertical-align: middle;
|
||||||
|
}
|
||||||
|
table {
|
||||||
|
width: 100%;
|
||||||
|
margin: 1em 0;
|
||||||
|
border-collapse: collapse;
|
||||||
|
border: solid 1px;
|
||||||
|
display: block;
|
||||||
|
overflow: scroll;
|
||||||
|
}
|
||||||
|
td, th {
|
||||||
|
height: 1em;
|
||||||
|
padding: 0 10px;
|
||||||
|
text-align: left;
|
||||||
|
vertical-align: middle;
|
||||||
|
border-right: solid 1px;
|
||||||
|
border-left: solid 1px;
|
||||||
|
}
|
||||||
|
|
||||||
|
/* Markdown tricks */
|
||||||
|
h1 {
|
||||||
|
font-size: 1em;
|
||||||
|
}
|
||||||
|
h2 {
|
||||||
|
font-size: 1em;
|
||||||
|
}
|
||||||
|
h3 {
|
||||||
|
font-size: 1em;
|
||||||
|
}
|
||||||
|
h4 {
|
||||||
|
font-size: 1em;
|
||||||
|
}
|
||||||
|
h5 {
|
||||||
|
font-size: 1em;
|
||||||
|
}
|
||||||
|
h6 {
|
||||||
|
font-size: 1em;
|
||||||
|
}
|
||||||
|
h1::before {
|
||||||
|
content: "# ";
|
||||||
|
}
|
||||||
|
h2::before {
|
||||||
|
content: "## ";
|
||||||
|
}
|
||||||
|
h3::before {
|
||||||
|
content: "### ";
|
||||||
|
}
|
||||||
|
h4::before {
|
||||||
|
content: "#### ";
|
||||||
|
}
|
||||||
|
h5::before {
|
||||||
|
content: "##### ";
|
||||||
|
}
|
||||||
|
h6::before {
|
||||||
|
content: "###### ";
|
||||||
|
}
|
||||||
|
hr {
|
||||||
|
position: relative;
|
||||||
|
height: 1em;
|
||||||
|
font-size: 0;
|
||||||
|
line-height: 0;
|
||||||
|
overflow: hidden;
|
||||||
|
border: 0;
|
||||||
|
}
|
||||||
|
hr:after {
|
||||||
|
content: "----------------------------------------------------------------------------------------------------";
|
||||||
|
position: absolute;
|
||||||
|
top: 0;
|
||||||
|
left: 0;
|
||||||
|
width: 100%;
|
||||||
|
word-wrap: break-word;
|
||||||
|
}
|
||||||
|
pre { max-width: 100%; overflow: scroll; }
|
||||||
|
pre::after,pre::before {
|
||||||
|
content: "~~~~~~~~~";
|
||||||
|
display: block; }
|
||||||
|
pre::before {
|
||||||
|
content: "~~~~~~~~~ " attr(class);
|
||||||
|
}
|
||||||
|
pre code {
|
||||||
|
background: none;
|
||||||
|
}
|
||||||
|
blockquote {
|
||||||
|
margin-left: 0;
|
||||||
|
position: relative;
|
||||||
|
padding-left: 17px;
|
||||||
|
padding-left: 2ch;
|
||||||
|
overflow: hidden;
|
||||||
|
}
|
||||||
|
.notes *:first-child,
|
||||||
|
blockquote *:first-child {
|
||||||
|
margin-top: 0;
|
||||||
|
}
|
||||||
|
.notes *:last-child,
|
||||||
|
blockquote *:last-child {
|
||||||
|
margin-bottom: 0;
|
||||||
|
}
|
||||||
|
blockquote:after {
|
||||||
|
content: ">\A>\A>\A>\A>\A>\A>\A>\A>\A>\A>\A>\A>\A>\A>\A>\A>\A>\A>\A>\A>\A>\A>\A>\A>\A>\A>\A>\A>\A>\A>\A>\A>\A>\A>\A>\A>\A>\A>\A>\A>\A>\A>\A>\A>\A>\A>\A>\A>\A>\A>\A>\A>\A>\A>\A>\A>\A>\A>\A>\A>\A>\A>\A>\A>\A>\A>\A>\A>\A>\A>\A>\A>\A>\A>\A>\A>\A>\A>\A>\A>\A>\A>\A>\A>\A>\A>\A>\A>\A>\A>\A>\A>\A>\A>\A>\A>\A>\A>\A>";
|
||||||
|
white-space: pre;
|
||||||
|
position: absolute;
|
||||||
|
top: 0;
|
||||||
|
left: 0;
|
||||||
|
}
|
||||||
|
navigation {
|
||||||
|
font-weight: bold;
|
||||||
|
display: block;
|
||||||
|
margin: 10px 0;
|
||||||
|
}
|
||||||
|
navigation > a {
|
||||||
|
margin-right: 10px;
|
||||||
|
}
|
||||||
|
|
||||||
|
/* org mode ids and classes */
|
||||||
|
.figure {
|
||||||
|
margin-top: 1em;
|
||||||
|
margin-bottom: 1em;
|
||||||
|
}
|
||||||
|
#content,.content {
|
||||||
|
margin: 0 1em;
|
||||||
|
padding: 1px;
|
||||||
|
}
|
||||||
|
#content:first-child {
|
||||||
|
margin-top: 0;
|
||||||
|
}
|
||||||
|
.timestamp-wrapper {
|
||||||
|
font-size: 12px;
|
||||||
|
}
|
||||||
|
.todo, .done {
|
||||||
|
font-size: 12px;
|
||||||
|
font-weight: bold;
|
||||||
|
padding: 1px 1ex;
|
||||||
|
}
|
||||||
|
.article-date {
|
||||||
|
font-size: 0.8em;
|
||||||
|
font-style: italic;
|
||||||
|
float: right;
|
||||||
|
}
|
||||||
|
.footpara {
|
||||||
|
display: inline;
|
||||||
|
}
|
||||||
|
.footdef > sup {
|
||||||
|
vertical-align: middle;
|
||||||
|
}
|
||||||
|
.footdef > sup::after {
|
||||||
|
content: ": ";
|
||||||
|
}
|
||||||
|
.notes {
|
||||||
|
padding: 5px 10px;
|
||||||
|
}
|
||||||
|
.notes::before {
|
||||||
|
content: "☞";
|
||||||
|
float: left;
|
||||||
|
display: inline-block;
|
||||||
|
width: 1.5em;
|
||||||
|
}
|
||||||
|
.underline {
|
||||||
|
text-decoration: underline;
|
||||||
|
}
|
||||||
|
|
||||||
|
table, tr, td { border-color: transparent; }
|
||||||
|
.dark-gray { color: var(--second-foreground);}
|
||||||
|
.mid-gray { color: var(--second-foreground);}
|
||||||
|
|
|
@ -2,7 +2,7 @@ html {
|
||||||
box-sizing: border-box;
|
box-sizing: border-box;
|
||||||
}
|
}
|
||||||
[hidden] {
|
[hidden] {
|
||||||
display: none !important;
|
display: none !important
|
||||||
}
|
}
|
||||||
button {
|
button {
|
||||||
background:none;
|
background:none;
|
||||||
|
@ -13,46 +13,22 @@ button {
|
||||||
button:focus {
|
button:focus {
|
||||||
outline: none;
|
outline: none;
|
||||||
}
|
}
|
||||||
input[type="text"],
|
|
||||||
input[type="url"],
|
|
||||||
textarea {
|
|
||||||
font-size: 16px;
|
|
||||||
}
|
|
||||||
.alert {
|
.alert {
|
||||||
background:#ced;
|
background:#ced;
|
||||||
border:1px solid #acc;
|
border:1px solid #acc;
|
||||||
}
|
}
|
||||||
#addForm .alert {
|
|
||||||
margin-top: -6px;
|
|
||||||
}
|
|
||||||
.alert.alert-err {
|
|
||||||
background-color: #ffdfdf
|
|
||||||
}
|
|
||||||
form label {
|
form label {
|
||||||
margin: 0;
|
margin: 0;
|
||||||
vertical-align: middle;
|
vertical-align: middle;
|
||||||
display: table-cell;
|
display: table-cell;
|
||||||
padding: 2px 0;
|
padding: 2px 0;
|
||||||
}
|
}
|
||||||
li {
|
li { list-style-type: none; margin: 0; padding: 0; display: block;}
|
||||||
list-style-type: none;
|
|
||||||
margin: 0;
|
|
||||||
padding: 0;
|
|
||||||
display: block;
|
|
||||||
}
|
|
||||||
|
|
||||||
.when {
|
.when { color:#999}
|
||||||
color: #999;
|
.unread { color:#b41 }
|
||||||
}
|
a.unread { color:#b41 }
|
||||||
.unread {
|
a.bookmark_title { font-size:120%;}
|
||||||
color: #b41;
|
|
||||||
}
|
|
||||||
a.unread {
|
|
||||||
color: #b41;
|
|
||||||
}
|
|
||||||
a.bookmark_title {
|
|
||||||
font-size: 120%;
|
|
||||||
}
|
|
||||||
|
|
||||||
label {
|
label {
|
||||||
cursor: pointer;
|
cursor: pointer;
|
||||||
|
|
80
static/js/app.min.js
vendored
80
static/js/app.min.js
vendored
File diff suppressed because one or more lines are too long
Binary file not shown.
File diff suppressed because one or more lines are too long
Binary file not shown.
|
@ -14,11 +14,12 @@
|
||||||
<div .top_menu.fr>
|
<div .top_menu.fr>
|
||||||
|
|
||||||
$maybe userName <- musername
|
$maybe userName <- musername
|
||||||
<a .link href="@?{(AddViewR, [("next","back")])}">add url
|
$maybe currentroute <- mcurrentRoute
|
||||||
|
<a .link href="@?{(AddViewR, [("next",urlrender currentroute)])}">add url
|
||||||
<a .link href="@{AddNoteViewR (UserNameP userName)}">add note
|
<a .link href="@{AddNoteViewR (UserNameP userName)}">add note
|
||||||
<a .link href="@{NotesR (UserNameP userName)}">notes
|
<a .link href="@{NotesR (UserNameP userName)}">notes
|
||||||
<a .link href="@{AccountSettingsR}">settings
|
<a .link href="@{AccountSettingsR}">settings
|
||||||
<a .link onclick="PS.logoutE(event)()" href="@{AuthR LogoutR}">
|
<a .link onclick="PS['Main'].logoutE(event)()" href="@{AuthR LogoutR}">
|
||||||
log out
|
log out
|
||||||
$nothing
|
$nothing
|
||||||
<a .link href="@{AuthR LoginR}">
|
<a .link href="@{AuthR LoginR}">
|
||||||
|
|
|
@ -5,7 +5,7 @@
|
||||||
- (#{userName})
|
- (#{userName})
|
||||||
<div .fr>
|
<div .fr>
|
||||||
$maybe userName <- musername
|
$maybe userName <- musername
|
||||||
<a .link onclick="PS.logoutE(event)()" href="@{AuthR LogoutR}">
|
<a .link onclick="PS['Main'].logoutE(event)()" href="@{AuthR LogoutR}">
|
||||||
[log out]
|
[log out]
|
||||||
$nothing
|
$nothing
|
||||||
<a .link href="@{AuthR LoginR}">
|
<a .link href="@{AuthR LoginR}">
|
||||||
|
|
|
@ -1,7 +1,7 @@
|
||||||
<main #main_column .pv2.ph3.mh1>
|
<main #main_column .pv2.ph3.mh1>
|
||||||
<div .w-100.mw8.center>
|
<div .w-100.mw8.center>
|
||||||
<div .pa3>
|
<div .pa3>
|
||||||
<a .bookmarklet.link.ba.b--dotted.b--light-silver href="javascript:q=location.href;if(document.getSelection){d=document.getSelection();}else{d='';};p=document.title;void(open('@{AddViewR}?_hasdata&url='+encodeURIComponent(q)+'&description='+encodeURIComponent(d)+'&title='+encodeURIComponent(p),'Espial','toolbar=no,width=700,height=360'));">add url bookmarklet
|
<a .bookmarklet.link.ba.b--dotted.b--light-silver href="javascript:q=location.href;if(document.getSelection){d=document.getSelection();}else{d='';};p=document.title;void(open('@{AddViewR}?_hasdata&url='+encodeURIComponent(q)+'&description='+encodeURIComponent(d)+'&title='+encodeURIComponent(p),'Espial','toolbar=no,width=700,height=350'));">add url bookmarklet
|
||||||
|
|
||||||
<a .pa3 href="@{ChangePasswordR}">Change Password
|
<a .pa3 href="@{ChangePasswordR}">Change Password
|
||||||
|
|
||||||
|
|
|
@ -32,18 +32,8 @@ $maybe route <- mroute
|
||||||
<a .link.silver.hover-blue :filterp == FilterStarred:.nav-active
|
<a .link.silver.hover-blue :filterp == FilterStarred:.nav-active
|
||||||
href="@{UserFilterR unamep FilterStarred}">starred
|
href="@{UserFilterR unamep FilterStarred}">starred
|
||||||
<div .fr.f6.pr3.dib.mb2>
|
<div .fr.f6.pr3.dib.mb2>
|
||||||
$if sharedp == SharedPrivate
|
<a .link.gold.hover-orange
|
||||||
<a .link.gold.hover-orange href="@?{(UserFeedSharedR unamep SharedPrivate, catMaybes [mqueryp])}">RSS
|
href="@{UserFeedR unamep}">RSS
|
||||||
$elseif sharedp == SharedPublic
|
|
||||||
<a .link.gold.hover-orange href="@?{(UserFeedSharedR unamep SharedPublic, catMaybes [mqueryp])}">RSS
|
|
||||||
$elseif filterp == FilterUnread
|
|
||||||
<a .link.gold.hover-orange href="@?{(UserFeedFilterR unamep FilterUnread, catMaybes [mqueryp])}">RSS
|
|
||||||
$elseif filterp == FilterUntagged
|
|
||||||
<a .link.gold.hover-orange href="@?{(UserFeedFilterR unamep FilterUntagged, catMaybes [mqueryp])}">RSS
|
|
||||||
$elseif filterp == FilterStarred
|
|
||||||
<a .link.gold.hover-orange href="@?{(UserFeedFilterR unamep FilterStarred, catMaybes [mqueryp])}">RSS
|
|
||||||
$else
|
|
||||||
<a .link.gold.hover-orange href="@?{(UserFeedR unamep, catMaybes [mqueryp])}">RSS
|
|
||||||
|
|
||||||
<div .cf>
|
<div .cf>
|
||||||
|
|
||||||
|
@ -51,8 +41,6 @@ $maybe route <- mroute
|
||||||
|
|
||||||
<div .cf>
|
<div .cf>
|
||||||
|
|
||||||
<div ##{tagCloudRenderEl}>
|
|
||||||
|
|
||||||
<div ##{renderEl} .mt3>
|
<div ##{renderEl} .mt3>
|
||||||
|
|
||||||
<div .cf>
|
<div .cf>
|
||||||
|
|
|
@ -10,7 +10,7 @@ module TestImport
|
||||||
import Application (makeFoundation, makeLogWare)
|
import Application (makeFoundation, makeLogWare)
|
||||||
import ClassyPrelude as X hiding (delete, deleteBy, Handler)
|
import ClassyPrelude as X hiding (delete, deleteBy, Handler)
|
||||||
import Database.Persist as X hiding (get)
|
import Database.Persist as X hiding (get)
|
||||||
import Database.Persist.Sql (SqlPersistM, runSqlPersistMPool, rawExecute, rawSql, unSingle)
|
import Database.Persist.Sql (SqlPersistM, runSqlPersistMPool, rawExecute, rawSql, unSingle, connEscapeName)
|
||||||
import Foundation as X
|
import Foundation as X
|
||||||
import Model as X
|
import Model as X
|
||||||
import Test.Hspec as X
|
import Test.Hspec as X
|
||||||
|
@ -62,9 +62,8 @@ wipeDB app = do
|
||||||
|
|
||||||
flip runSqlPersistMPool pool $ do
|
flip runSqlPersistMPool pool $ do
|
||||||
tables <- getTables
|
tables <- getTables
|
||||||
-- sqlBackend <- ask
|
sqlBackend <- ask
|
||||||
-- let queries = map (\t -> "DELETE FROM " ++ (connEscapeName sqlBackend $ DBName t)) tables
|
let queries = map (\t -> "DELETE FROM " ++ (connEscapeName sqlBackend $ DBName t)) tables
|
||||||
let queries = map (\t -> "DELETE FROM " ++ t) tables
|
|
||||||
forM_ queries (\q -> rawExecute q [])
|
forM_ queries (\q -> rawExecute q [])
|
||||||
|
|
||||||
getTables :: DB [Text]
|
getTables :: DB [Text]
|
||||||
|
|
Loading…
Reference in a new issue