dark css mode

* Document needing to run 'stack build' after changing settings

* update readme

Co-authored-by: Jon Schoning <jonschoning@gmail.com>

.github/workflows/tests.yml

@@ -0,0 +1,36 @@
+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

.gitignore

@@ -29,3 +29,5 @@ tmp
 .cache
 tags
 purs/docset/purescript-local.docset/
+.ghc.environment.x86_64-linux-8.6.5
+.vscode

Makefile

@@ -1,3 +1,6 @@
+_DOCKER:=docker
+_DOCKER_COMPOSE:=docker compose
+
 .PHONY: clean build
 
 all: build
@@ -26,9 +29,8 @@ migrate-createdb:
 serve:
 	@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}')
-_EKG_ASSETS_PATH = $$(find ~/.stack -type d | grep ekg.*assets)
 
 docker-compose-build: build 
 	@rm -Rf dist && mkdir -p dist
@@ -36,22 +38,20 @@ docker-compose-build: build
 	@cp -R static dist
 	@rm -Rf dist/static/tmp
 	@cp -R config dist
-	@mkdir -p dist/ekg/assets
+	@$(_DOCKER_COMPOSE) build espial
-	@cp -R $(_EKG_ASSETS_PATH) dist/ekg
-	@docker-compose build espial
 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-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 espial
+	@$(_DOCKER_COMPOSE) pull espial
 docker-compose-push:
 	@docker tag localhost/espial:espial $(HUB_REPO)/espial:espial
-	@docker-compose push espial
+	@$(_DOCKER_COMPOSE) push espial
 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) sh
 
@@ -61,7 +61,7 @@ ifeq ($(_HUB_REPO),)
 	_HUB_REPO := "localhost"
 endif
 
-docker_espial = docker-compose exec espial
+docker_espial = $(_DOCKER_COMPOSE) exec espial
 
 clean:
 	@stack clean

README.md

@@ -8,13 +8,15 @@ 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.
 
+Also, see the android app for adding bookmarks via an Android Share intent https://github.com/jonschoning/espial-share-android
+
 ## demo server
 
 log in — username: demo  password: demo
 
 https://esp.ae8.org/u:demo
 
-![jpg](https://i.imgur.com/XikHLua.png)
+![jpg](https://i.imgur.com/jdnV93c.png)
 
 ## Docker Setup
 
@@ -43,25 +45,36 @@ see https://github.com/jonschoning/espial-docker
     stack exec migration -- createuser --conn espial.sqlite3 --userName myusername --userPassword myuserpassword
     ```
 
-5. Import a bookmark file for a user (optional)
+5. Import a pinboard 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. Start a production server:
+6. Import a firefox bookmark file for a user (optional)
 
     ```
-    stack exec espial -- +RTS -T
+    stack exec migration -- importfirefoxbookmarks --conn espial.sqlite3 --userName myusername --bookmarkFile firefox-bookmarks.json
     ```
 
-see `config/settings.yml` for changing default run-time parameters / environment variables
+7. Start a production server:
 
-default app http port: `3000`
+    ```
+    stack exec espial
+    ```
 
-default ekg http port: `8000`
+### Configuration
 
-ssl: use reverse proxy
+See `config/settings.yml` for changing default run-time parameters & environment variables.
+ - `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 
 
@@ -80,7 +93,7 @@ ssl: use reverse proxy
 
 - See `purs/` folder
 
-## Import Bookmark file format
+## Import Bookmark file format (pinboard compatible format)
 
 see `sample-bookmarks.json`, which contains a JSON array, each line containing a `FileBookmark` object. 
 

SECURITY.md

@@ -0,0 +1,5 @@
+# Security Policy
+
+## Reporting a Vulnerability
+
+Please report vulnerabilities to jonschoning@gmail.com

app/migration/Main.hs

@@ -12,25 +12,64 @@ import ClassyPrelude
 import Lens.Micro
 
 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
-  = CreateDB { conn :: Text}
+  = CreateDB { conn :: Text }
   | CreateUser { conn :: Text
                , userName :: Text
-               , userPassword :: Text
+               , userPassword :: Password
-               , userApiToken :: Maybe Text }
+               , privateDefault :: Maybe Bool
+               , archiveDefault :: Maybe Bool
+               , privacyLock :: Maybe Bool }
+  | CreateApiKey { conn :: Text
+                 , userName :: Text }
   | DeleteUser { conn :: Text
-               , userName :: Text}
+               , userName :: Text }
+  | DeleteApiKey { conn :: Text
+                 , userName :: Text }
   | ImportBookmarks { conn :: Text
                     , userName :: Text
-                    , bookmarkFile :: FilePath}
+                    , bookmarkFile :: FilePath }
+  | ImportFirefoxBookmarks { conn :: Text
+                    , userName :: Text
+                    , bookmarkFile :: FilePath }
   | ExportBookmarks { conn :: Text
                     , userName :: Text
-                    , bookmarkFile :: FilePath}
+                    , bookmarkFile :: FilePath }
   | ImportNotes { conn :: Text
                 , userName :: Text
-                , noteDirectory :: FilePath}
+                , noteDirectory :: FilePath }
-  | PrintMigrateDB { conn :: Text}
+  | PrintMigrateDB { conn :: Text }
   deriving (Generic, Show)
 
 instance ParseRecord MigrationOpts
@@ -39,54 +78,97 @@ main :: IO ()
 main = do
   args <- getRecord "Migrations"
   case args of
-    PrintMigrateDB conn ->
+    PrintMigrateDB {..} ->
       P.runSqlite conn dumpMigration
 
-    CreateDB conn -> do
+    CreateDB {..} -> do
       let connInfo = P.mkSqliteConnectionInfo conn
                      & set P.fkEnabled False
       P.runSqliteInfo connInfo runMigrations
 
-    CreateUser conn uname upass utoken ->
+    CreateUser{..} ->
       P.runSqlite conn $ do
-        hash' <- liftIO (hashPassword upass)
+        passwordText <- liftIO . fmap T.strip $ case userPassword of
+          PasswordText s -> pure s
+          PasswordFile f -> readFileUtf8 f
+        hash' <- liftIO (hashPassword passwordText)
         void $ P.upsertBy
-          (UniqueUserName uname)
+          (UniqueUserName userName)
-          (User uname hash' utoken False False False)
+          (User userName hash' Nothing False False False)
           [ UserPasswordHash P.=. hash'
-          , UserApiToken P.=. utoken
+          , UserPrivateDefault P.=. fromMaybe False privateDefault
-          , UserPrivateDefault P.=. False
+          , UserArchiveDefault P.=. fromMaybe False archiveDefault
-          , UserArchiveDefault P.=. False
+          , UserPrivacyLock P.=. fromMaybe False privacyLock
-          , UserPrivacyLock P.=. False
           ]
         pure () :: DB ()
 
-    DeleteUser conn uname ->
+    CreateApiKey {..} ->
       P.runSqlite conn $ do
-        muser <- P.getBy (UniqueUserName uname)
+        apiKey@(ApiKey plainKey) <- liftIO generateApiKey
+        muser <- P.getBy (UniqueUserName userName)
         case muser of
-          Nothing -> liftIO (print (uname ++ "not found"))
+          Nothing -> liftIO (print (userName ++ " not found"))
           Just (P.Entity uid _) -> do
-            P.deleteCascade uid
+            -- API key is only displayed once after creation,
+            -- 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 ()
 
-    ImportBookmarks conn uname file ->
+    ExportBookmarks {..} ->
       P.runSqlite conn $ do
-        muser <- P.getBy (UniqueUserName uname)
+        muser <- P.getBy (UniqueUserName userName)
         case muser of
-          Just (P.Entity uid _) -> insertFileBookmarks uid file
+          Just (P.Entity uid _) -> exportFileBookmarks uid bookmarkFile
-          Nothing -> liftIO (print (uname ++ "not found"))
+          Nothing -> liftIO (print (userName ++ "not found"))
 
-    ExportBookmarks conn uname file ->
+    ImportBookmarks {..} ->
       P.runSqlite conn $ do
-        muser <- P.getBy (UniqueUserName uname)
+        muser <- P.getBy (UniqueUserName userName)
         case muser of
-          Just (P.Entity uid _) -> exportFileBookmarks uid file
+          Just (P.Entity uid _) -> do
-          Nothing -> liftIO (print (uname ++ "not found"))
+            result <- insertFileBookmarks uid bookmarkFile
+            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
-        muser <- P.getBy (UniqueUserName uname)
+        muser <- P.getBy (UniqueUserName userName)
         case muser of
-          Just (P.Entity uid _) -> insertDirFileNotes uid dir
+          Just (P.Entity uid _) -> do
-          Nothing -> liftIO (print (uname ++ "not found"))
+            result <- insertFFBookmarks uid bookmarkFile
+            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"))

changelog.md

@@ -1,3 +1,25 @@
+__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__
 

config/routes

@@ -8,6 +8,7 @@
 -- notes
 !/#UserNameP/notes NotesR GET
 !/#UserNameP/notes/add AddNoteViewR GET
+!/notes/add AddNoteSlimViewR GET
 !/#UserNameP/notes/feed.xml NotesFeedR GET
 !/#UserNameP/notes/#NtSlug NoteR GET
 !/api/note/add AddNoteR POST
@@ -19,7 +20,11 @@
 !/#UserNameP/#SharedP UserSharedR GET
 !/#UserNameP/#FilterP UserFilterR GET
 !/#UserNameP/#TagsP UserTagsR 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 AccountSettingsR GET
@@ -32,6 +37,11 @@ api/accountSettings EditAccountSettingsR POST
 /add AddViewR GET
 api/add AddR POST
 
+-- api
+api/lookuptitle LookupTitleR POST
+api/tagcloud UserTagCloudR POST
+api/tagcloudmode UserTagCloudModeR POST
+
 -- edit
 /bm/#Int64 DeleteR DELETE
 /bm/#Int64/read ReadR POST
@@ -39,4 +49,4 @@ api/add AddR POST
 /bm/#Int64/unstar UnstarR POST
 
 -- doc
-/docs/search DocsSearchR GET
+/docs/search DocsSearchR GET

config/settings.yml

@@ -18,8 +18,8 @@ ip-from-header: "_env:IP_FROM_HEADER:false"
 # Optional values with the following production defaults.
 # In development, they default to the inverse.
 #
-# detailed-logging: false
+detailed-logging: "_env:DETAILED_LOGGING" # false
-# should-log-all: false
+should-log-all: "_env:SHOULD_LOG_ALL" # false
 # reload-templates: false
 # mutable-static: false
 # skip-combining: false
@@ -37,7 +37,11 @@ database:
 copyright: Insert copyright statement here
 #analytics: UA-YOURCODE
 
-ekg-host:       "_env:EKG_HOST:0.0.0.0"
+archive-socks-proxy-host: "_env:ARCHIVE_SOCKS_PROXY_HOST"
-ekg-port:       "_env:EKG_PORT:8000"
+archive-socks-proxy-port: "_env:ARCHIVE_SOCKS_PROXY_PORT"
 
-source-code-uri: "https://github.com/jonschoning/espial"
+source-code-uri: "_env: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"

docker-compose.yml

@@ -7,10 +7,16 @@ services:
       dockerfile: ../Dockerfile
     ports:
       - "3000:3000"
-      - "8000:8000"
     volumes:
       - '$APPDATA:/app/data'
+    network_mode: host
     environment:
       - IP_FROM_HEADER=true
       - SQLITE_DATABASE=/app/data/espial.sqlite3
-      - ekg_datadir=ekg
+      # - SSL_ONLY=false
+      # - 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

espial.cabal

@@ -1,13 +1,11 @@
 cabal-version: 1.12
 
--- This file has been generated from package.yaml by hpack version 0.31.2.
+-- This file has been generated from package.yaml by hpack version 0.35.0.
 --
 -- see: https://github.com/sol/hpack
---
--- hash: da944088abb7ae887d67efd710c100bdbd5587072c6ddcfdc5d05392e7509d85
 
 name:           espial
-version:        0.0.8
+version:        0.0.15
 synopsis:       Espial is an open-source, web-based bookmarking server.
 description:    .
                 Espial is an open-source, web-based bookmarking server.
@@ -64,7 +62,6 @@ extra-source-files:
     purs/src/App.purs
     purs/src/Globals.js
     purs/src/Globals.purs
-    purs/src/Main.js
     purs/src/Main.purs
     purs/src/Marked.js
     purs/src/Marked.purs
@@ -79,6 +76,7 @@ extra-source-files:
     purs/src/Component/NNote.purs
     purs/src/Component/RawHtml.js
     purs/src/Component/RawHtml.purs
+    purs/src/Component/TagCloud.purs
     purs/test/Main.purs
 
 source-repository head
@@ -122,48 +120,86 @@ library
       Paths_espial
   hs-source-dirs:
       src
-  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
+  default-extensions:
+      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:
       aeson >=1.4
     , attoparsec
     , base >=4.8.2.0 && <4.9 || >=4.9.1.0 && <5
+    , base64
     , bcrypt >=0.0.8
     , blaze-html >=0.9 && <1.0
-    , bytestring >=0.9 && <0.11
+    , bytestring >=0.9 && <0.14
     , case-insensitive
     , classy-prelude >=1.4 && <1.6
     , classy-prelude-conduit >=1.4 && <1.6
     , classy-prelude-yesod >=1.4 && <1.6
     , conduit >=1.0 && <2.0
+    , connection
     , containers
+    , cryptohash-sha256
     , data-default
     , directory >=1.1 && <1.4
-    , ekg
-    , ekg-core
     , entropy
     , esqueleto
-    , fast-logger >=2.2 && <2.5
+    , fast-logger >=2.2 && <4
     , file-embed
     , foreign-store
     , hjsmin >=0.1 && <0.3
     , hscolour
+    , html-entities
     , http-api-data >=0.3.4
     , http-client
-    , http-client-tls >=0.3 && <0.4
+    , http-client-tls ==0.3.*
-    , http-conduit >=2.3 && <2.4
+    , http-conduit ==2.3.*
     , http-types
     , iso8601-time >=0.1.3
     , microlens
-    , monad-logger >=0.3 && <0.4
+    , monad-logger ==0.3.*
-    , monad-metrics
     , mtl
     , parser-combinators
-    , persistent >=2.8 && <2.10
+    , persistent >=2.8 && <2.14
     , persistent-sqlite >=2.6.2
-    , persistent-template >=2.5 && <2.9
+    , persistent-template >=2.5 && <2.13
     , pretty-show
     , safe
-    , shakespeare >=2.0 && <2.1
+    , shakespeare ==2.0.*
     , template-haskell
     , text >=0.11 && <2.0
     , time
@@ -171,23 +207,22 @@ library
     , unordered-containers
     , vector
     , wai
-    , wai-extra >=3.0 && <3.1
+    , wai-extra >=3.0 && <3.2
-    , wai-logger >=2.2 && <2.4
+    , wai-logger
-    , wai-middleware-metrics
+    , warp >=3.0 && <3.4
-    , warp >=3.0 && <3.3
     , yaml >=0.8 && <0.12
-    , yesod >=1.6 && <1.7
+    , yesod >=1.6 && <1.8
-    , yesod-auth >=1.6 && <1.7
+    , yesod-auth >=1.6 && <1.8
-    , yesod-core >=1.6 && <1.7
+    , yesod-core >=1.6 && <1.8
-    , yesod-form >=1.6 && <1.7
+    , yesod-form >=1.6 && <1.8
-    , yesod-newsfeed >=1.6 && <1.7
+    , yesod-newsfeed >=1.6 && <1.8
-    , yesod-static >=1.6 && <1.7
+    , yesod-static >=1.6 && <1.8
+  default-language: Haskell2010
   if (flag(dev)) || (flag(library-only))
     ghc-options: -Wall -fwarn-tabs -O0
     cpp-options: -DDEVELOPMENT
   else
     ghc-options: -Wall -fwarn-tabs -O2
-  default-language: Haskell2010
 
 executable espial
   main-is: main.hs
@@ -196,50 +231,88 @@ executable espial
       Paths_espial
   hs-source-dirs:
       app
-  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
+  default-extensions:
+      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
   build-depends:
       aeson >=1.4
     , attoparsec
     , base >=4.8.2.0 && <4.9 || >=4.9.1.0 && <5
+    , base64
     , bcrypt >=0.0.8
     , blaze-html >=0.9 && <1.0
-    , bytestring >=0.9 && <0.11
+    , bytestring >=0.9 && <0.14
     , case-insensitive
     , classy-prelude >=1.4 && <1.6
     , classy-prelude-conduit >=1.4 && <1.6
     , classy-prelude-yesod >=1.4 && <1.6
     , conduit >=1.0 && <2.0
+    , connection
     , containers
+    , cryptohash-sha256
     , data-default
     , directory >=1.1 && <1.4
-    , ekg
-    , ekg-core
     , entropy
     , espial
     , esqueleto
-    , fast-logger >=2.2 && <2.5
+    , fast-logger >=2.2 && <4
     , file-embed
     , foreign-store
     , hjsmin >=0.1 && <0.3
     , hscolour
+    , html-entities
     , http-api-data >=0.3.4
     , http-client
-    , http-client-tls >=0.3 && <0.4
+    , http-client-tls ==0.3.*
-    , http-conduit >=2.3 && <2.4
+    , http-conduit ==2.3.*
     , http-types
     , iso8601-time >=0.1.3
     , microlens
-    , monad-logger >=0.3 && <0.4
+    , monad-logger ==0.3.*
-    , monad-metrics
     , mtl
     , parser-combinators
-    , persistent >=2.8 && <2.10
+    , persistent >=2.8 && <2.14
     , persistent-sqlite >=2.6.2
-    , persistent-template >=2.5 && <2.9
+    , persistent-template >=2.5 && <2.13
     , pretty-show
     , safe
-    , shakespeare >=2.0 && <2.1
+    , shakespeare ==2.0.*
     , template-haskell
     , text >=0.11 && <2.0
     , time
@@ -247,20 +320,19 @@ executable espial
     , unordered-containers
     , vector
     , wai
-    , wai-extra >=3.0 && <3.1
+    , wai-extra >=3.0 && <3.2
-    , wai-logger >=2.2 && <2.4
+    , wai-logger
-    , wai-middleware-metrics
+    , warp >=3.0 && <3.4
-    , warp >=3.0 && <3.3
     , yaml >=0.8 && <0.12
-    , yesod >=1.6 && <1.7
+    , yesod >=1.6 && <1.8
-    , yesod-auth >=1.6 && <1.7
+    , yesod-auth >=1.6 && <1.8
-    , yesod-core >=1.6 && <1.7
+    , yesod-core >=1.6 && <1.8
-    , yesod-form >=1.6 && <1.7
+    , yesod-form >=1.6 && <1.8
-    , yesod-newsfeed >=1.6 && <1.7
+    , yesod-newsfeed >=1.6 && <1.8
-    , yesod-static >=1.6 && <1.7
+    , yesod-static >=1.6 && <1.8
+  default-language: Haskell2010
   if flag(library-only)
     buildable: False
-  default-language: Haskell2010
 
 executable migration
   main-is: Main.hs
@@ -268,51 +340,90 @@ executable migration
       Paths_espial
   hs-source-dirs:
       app/migration
-  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
+  default-extensions:
+      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
   build-depends:
       aeson >=1.4
     , attoparsec
     , base >=4.8.2.0 && <4.9 || >=4.9.1.0 && <5
+    , base64
     , bcrypt >=0.0.8
     , blaze-html >=0.9 && <1.0
-    , bytestring >=0.9 && <0.11
+    , bytestring >=0.9 && <0.14
     , case-insensitive
     , classy-prelude >=1.4 && <1.6
     , classy-prelude-conduit >=1.4 && <1.6
     , classy-prelude-yesod >=1.4 && <1.6
     , conduit >=1.0 && <2.0
+    , connection
     , containers
+    , cryptohash-sha256
     , data-default
     , directory >=1.1 && <1.4
-    , ekg
-    , ekg-core
     , entropy
     , espial
     , esqueleto
-    , fast-logger >=2.2 && <2.5
+    , fast-logger >=2.2 && <4
     , file-embed
     , foreign-store
     , hjsmin >=0.1 && <0.3
     , hscolour
+    , html-entities
     , http-api-data >=0.3.4
     , http-client
-    , http-client-tls >=0.3 && <0.4
+    , http-client-tls ==0.3.*
-    , http-conduit >=2.3 && <2.4
+    , http-conduit ==2.3.*
     , http-types
     , iso8601-time >=0.1.3
     , microlens
-    , monad-logger >=0.3 && <0.4
+    , monad-logger ==0.3.*
-    , monad-metrics
     , mtl
+    , optparse-applicative
     , optparse-generic >=1.2.3
     , parser-combinators
-    , persistent >=2.8 && <2.10
+    , persistent >=2.8 && <2.14
     , persistent-sqlite >=2.6.2
-    , persistent-template >=2.5 && <2.9
+    , persistent-template >=2.5 && <2.13
     , pretty-show
     , safe
-    , shakespeare >=2.0 && <2.1
+    , shakespeare ==2.0.*
     , template-haskell
     , text >=0.11 && <2.0
     , time
@@ -320,20 +431,19 @@ executable migration
     , unordered-containers
     , vector
     , wai
-    , wai-extra >=3.0 && <3.1
+    , wai-extra >=3.0 && <3.2
-    , wai-logger >=2.2 && <2.4
+    , wai-logger
-    , wai-middleware-metrics
+    , warp >=3.0 && <3.4
-    , warp >=3.0 && <3.3
     , yaml >=0.8 && <0.12
-    , yesod >=1.6 && <1.7
+    , yesod >=1.6 && <1.8
-    , yesod-auth >=1.6 && <1.7
+    , yesod-auth >=1.6 && <1.8
-    , yesod-core >=1.6 && <1.7
+    , yesod-core >=1.6 && <1.8
-    , yesod-form >=1.6 && <1.7
+    , yesod-form >=1.6 && <1.8
-    , yesod-newsfeed >=1.6 && <1.7
+    , yesod-newsfeed >=1.6 && <1.8
-    , yesod-static >=1.6 && <1.7
+    , yesod-static >=1.6 && <1.8
+  default-language: Haskell2010
   if flag(library-only)
     buildable: False
-  default-language: Haskell2010
 
 test-suite test
   type: exitcode-stdio-1.0
@@ -345,51 +455,89 @@ test-suite test
       Paths_espial
   hs-source-dirs:
       test
-  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
+  default-extensions:
+      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
   build-depends:
       aeson >=1.4
     , attoparsec
     , base >=4.8.2.0 && <4.9 || >=4.9.1.0 && <5
+    , base64
     , bcrypt >=0.0.8
     , blaze-html >=0.9 && <1.0
-    , bytestring >=0.9 && <0.11
+    , bytestring >=0.9 && <0.14
     , case-insensitive
     , classy-prelude >=1.4 && <1.6
     , classy-prelude-conduit >=1.4 && <1.6
     , classy-prelude-yesod >=1.4 && <1.6
     , conduit >=1.0 && <2.0
+    , connection
     , containers
+    , cryptohash-sha256
     , data-default
     , directory >=1.1 && <1.4
-    , ekg
-    , ekg-core
     , entropy
     , espial
     , esqueleto
-    , fast-logger >=2.2 && <2.5
+    , fast-logger >=2.2 && <4
     , file-embed
     , foreign-store
     , hjsmin >=0.1 && <0.3
     , hscolour
     , hspec >=2.0.0
+    , html-entities
     , http-api-data >=0.3.4
     , http-client
-    , http-client-tls >=0.3 && <0.4
+    , http-client-tls ==0.3.*
-    , http-conduit >=2.3 && <2.4
+    , http-conduit ==2.3.*
     , http-types
     , iso8601-time >=0.1.3
     , microlens
-    , monad-logger >=0.3 && <0.4
+    , monad-logger ==0.3.*
-    , monad-metrics
     , mtl
     , parser-combinators
-    , persistent >=2.8 && <2.10
+    , persistent >=2.8 && <2.14
     , persistent-sqlite >=2.6.2
-    , persistent-template >=2.5 && <2.9
+    , persistent-template >=2.5 && <2.13
     , pretty-show
     , safe
-    , shakespeare >=2.0 && <2.1
+    , shakespeare ==2.0.*
     , template-haskell
     , text >=0.11 && <2.0
     , time
@@ -397,16 +545,15 @@ test-suite test
     , unordered-containers
     , vector
     , wai
-    , wai-extra >=3.0 && <3.1
+    , wai-extra >=3.0 && <3.2
-    , wai-logger >=2.2 && <2.4
+    , wai-logger
-    , wai-middleware-metrics
+    , warp >=3.0 && <3.4
-    , warp >=3.0 && <3.3
     , yaml >=0.8 && <0.12
-    , yesod >=1.6 && <1.7
+    , yesod >=1.6 && <1.8
-    , yesod-auth >=1.6 && <1.7
+    , yesod-auth >=1.6 && <1.8
-    , yesod-core >=1.6 && <1.7
+    , yesod-core >=1.6 && <1.8
-    , yesod-form >=1.6 && <1.7
+    , yesod-form >=1.6 && <1.8
-    , yesod-newsfeed >=1.6 && <1.7
+    , yesod-newsfeed >=1.6 && <1.8
-    , yesod-static >=1.6 && <1.7
+    , yesod-static >=1.6 && <1.8
     , yesod-test
   default-language: Haskell2010

espial.code-workspace

@@ -0,0 +1,11 @@
+{
+	"folders": [
+		{
+			"path": "."
+		},
+		{
+			"path": "purs"
+		}
+	],
+	"settings": {}
+}

package.yaml

@@ -1,6 +1,6 @@
 name:    espial
 synopsis: Espial is an open-source, web-based bookmarking server.
-version: "0.0.8"
+version: "0.0.15"
 description: ! '
 
   Espial is an open-source, web-based bookmarking server.
@@ -42,11 +42,13 @@ extra-source-files:
 
 default-extensions:
 - BangPatterns
+- BlockArguments
 - CPP
 - ConstraintKinds
 - DataKinds
 - DeriveDataTypeable
 - DeriveGeneric
+- DerivingStrategies      
 - EmptyDataDecls
 - FlexibleContexts
 - FlexibleInstances
@@ -61,6 +63,7 @@ default-extensions:
 - OverloadedStrings
 - PolyKinds
 - PolymorphicComponents
+- PartialTypeSignatures
 - QuasiQuotes
 - Rank2Types
 - RankNTypes
@@ -73,6 +76,7 @@ default-extensions:
 - TypeFamilies
 - TypeOperators
 - TypeSynonymInstances
+- UndecidableInstances
 - ViewPatterns
 
 dependencies:
@@ -81,37 +85,34 @@ dependencies:
 # See: https://ghc.haskell.org/trac/ghc/ticket/12130
 - base >=4.8.2.0 && <4.9 || >=4.9.1.0 && <5
 
-- yesod >=1.6 && <1.7
+- yesod >=1.6 && <1.8
-- yesod-core >=1.6 && <1.7
+- yesod-core >=1.6 && <1.8
-- yesod-auth >=1.6 && <1.7
+- yesod-auth >=1.6 && <1.8
-- yesod-static >=1.6 && <1.7
+- yesod-static >=1.6 && <1.8
-- yesod-form >=1.6 && <1.7
+- yesod-form >=1.6 && <1.8
-- yesod-newsfeed >= 1.6 && < 1.7
+- yesod-newsfeed >= 1.6 && < 1.8
 - classy-prelude >=1.4 && <1.6
 - classy-prelude-conduit >=1.4 && <1.6
 - classy-prelude-yesod >=1.4 && <1.6
-- bytestring >=0.9 && <0.11
+- bytestring >=0.9 && <0.14
 - text >=0.11 && <2.0
-- persistent >=2.8 && <2.10
+- persistent >=2.8 && <2.14
-# - persistent-postgresql >=2.8 && <2.9
 - blaze-html >= 0.9 && < 1.0
-- persistent-template >=2.5 && <2.9
+- persistent-template >=2.5 && <2.13
 - template-haskell
 - shakespeare >=2.0 && <2.1
 - hjsmin >=0.1 && <0.3
-# - monad-control >=0.3 && <1.1
+- wai-extra >=3.0 && <3.2
-- wai-extra >=3.0 && <3.1
 - yaml >=0.8 && <0.12
 - http-client-tls >=0.3 && <0.4
 - http-conduit >=2.3 && <2.4
 - directory >=1.1 && <1.4
-- warp >=3.0 && <3.3
+- warp >=3.0 && <3.4
 - data-default
-# - aeson >=0.6 && <1.4
 - conduit >=1.0 && <2.0
 - monad-logger >=0.3 && <0.4
-- fast-logger >=2.2 && <2.5
+- fast-logger >=2.2 && <4
-- wai-logger >=2.2 && <2.4
+- wai-logger
 - file-embed
 - safe
 - unordered-containers
@@ -126,8 +127,6 @@ dependencies:
 - attoparsec
 - bcrypt >= 0.0.8
 - entropy
-- ekg
-- ekg-core
 - esqueleto
 - hscolour
 - http-api-data >= 0.3.4
@@ -135,13 +134,15 @@ dependencies:
 - http-types
 - iso8601-time >=0.1.3
 - microlens
-- monad-metrics
 - mtl
 - persistent-sqlite >=2.6.2
 - pretty-show
 - transformers >= 0.2.2
-- wai-middleware-metrics
 - parser-combinators
+- html-entities
+- connection
+- base64
+- cryptohash-sha256
 
 # The library contains all of our application code. The executable
 # defined below is just a thin wrapper.
@@ -186,6 +187,7 @@ executables:
     dependencies:
       - espial
       - optparse-generic >= 1.2.3
+      - optparse-applicative
 
 # Test suite
 tests:

purs/Makefile

@@ -1,30 +1,32 @@
 .PHONY: clean build
 
-all: build
+all: bundle
 
 install: 
-	spago install
+	@npm run spago install
 
 build: 
-	@spago build
+	@npm run spago build
-	@spago bundle-app --to dist/bundle.js
+
-	@npm run parcel-build
+bundle: build
+	@npm run esbuild-bundle
+	@npm run esbuild-bundle-min
 	@rm -f dist/*.gz
 	@gzip -k dist/app.min.js.map
 	@gzip -k dist/app.min.js
 	@find dist -type f -printf "%kK\\t%h/%f\\n" | sort -k 2
-	@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 ../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.gz ../static/js/app.min.js.map.gz
 
 docs:
 	@rm -Rf generated-docs
-	@purs docs ".spago/*/*/src/**/*.purs" --format html
+	@npm run purs -- docs ".spago/*/*/src/**/*.purs" --format html
 
 docset: docs
 	@(cd docset; python3 ./gen-docset.py)
 clean:
 	rm -f dist/*
 
-# inotifywait -m -r -q -e close_write --format '%T %w%f' --timefmt '%T' src | while read FILE; do echo $FILE; make; done
+# inotifywait -m -r -q -e close_write --format '%T %w%f' --timefmt '%T' src | while read FILE; do echo $FILE; make build; done

purs/docset/gen-docset.py

@@ -12,7 +12,7 @@ from html import unescape
 from bs4 import BeautifulSoup
 
 class Generator:
-	GENERATED_DOCS = '../generated-docs'
+	GENERATED_DOCS = '../generated-docs/html'
 	OUTPUT = 'purescript-local.docset'
 
 	def documents_path(self, *paths):

purs/package.json

@@ -2,17 +2,21 @@
   "name": "espial",
   "private": true,
   "scripts": {
+    "spago": "spago",
+    "purs": "purs",
     "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",
-    "parcel-build": "parcel build dist/bundle.js --out-file dist/app.min.js --public-url /static/js/"
+    "esbuild-bundle": "esbuild ./output/Main/index.js --bundle --format=iife --global-name=PS --target=chrome58,firefox57,edge18 --outfile=dist/app.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": {
-    "purescript": "^0.13.3",
+    "esbuild": "^0.15.12",
-    "spago": "^0.10.0",
+    "purescript": "^0.15.6",
-    "marked": "^0.7.0",
+    "spago": "0.20.9"
-    "moment": "^2.24.0",
-    "parcel-bundler": "^1.12.3",
-    "terser": "^4.0.0"
   },
-  "dependencies": {}
+  "dependencies": {
+    "dompurify": "^2.4.0",
+    "marked": "^4.1.1",
+    "moment": "^2.29.4"
+  }
 }

purs/packages.dhall

@@ -1,11 +1,42 @@
-let mkPackage =
+{-
-      https://raw.githubusercontent.com/purescript/package-sets/psc-0.13.3-20190818/src/mkPackage.dhall sha256:0b197efa1d397ace6eb46b243ff2d73a3da5638d8d0ac8473e8e4a8fc528cf57
+### Overriding/Patching a package
+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 =
-      https://raw.githubusercontent.com/purescript/package-sets/psc-0.13.3-20190818/src/packages.dhall sha256:c95c4a8b8033a48a350106b759179f68a695c7ea2208228c522866fd43814dc8
+      https://raw.githubusercontent.com/purescript/package-sets/psc-0.15.4-20221026/src/packages.dhall
+        sha256:8dc0b394f5861bb0136f652f3f826a88eaffb2bc0ecf0251468ed668102f5d0c
 
-let overrides = {=}
+in  upstream
-
+  with simple-json =
-let additions = {=}
+    { dependencies =
-
+      [ "arrays"
-in  upstream // overrides // additions
+      , "exceptions"
+      , "foreign"
+      , "foreign-object"
+      , "nullable"
+      , "prelude"
+      , "record"
+      , "typelevel-prelude"
+      , "variant"
+      ]
+    , repo = "https://github.com/justinwoo/purescript-simple-json.git"
+    , version = "v9.0.0"
+    }

purs/spago.dhall

@@ -1,26 +1,41 @@
-{ sources =
+{ sources = [ "src/**/*.purs", "test/**/*.purs" ]
-    [ "src/**/*.purs", "test/**/*.purs" ]
+, name = "espial"
-, name =
-    "espial"
 , dependencies =
-    [ "aff"
+  [ "aff"
-    , "simple-json"
+  , "affjax"
-    , "affjax"
+  , "affjax-web"
-    , "argonaut"
+  , "argonaut"
-    , "arrays"
+  , "arrays"
-    , "console"
+  , "console"
-    , "debug"
+  , "const"
-    , "effect"
+  , "dom-indexed"
-    , "either"
+  , "effect"
-    , "functions"
+  , "either"
-    , "halogen"
+  , "foldable-traversable"
-    , "prelude"
+  , "foreign"
-    , "psci-support"
+  , "foreign-object"
-    , "strings"
+  , "form-urlencoded"
-    , "transformers"
+  , "functions"
-    , "web-html"
+  , "halogen"
-    , "profunctor-lenses"
+  , "http-methods"
-    ]
+  , "integers"
-, packages =
+  , "js-uri"
-    ./packages.dhall
+  , "maybe"
+  , "media-types"
+  , "newtype"
+  , "nullable"
+  , "numbers"
+  , "partial"
+  , "prelude"
+  , "profunctor-lenses"
+  , "simple-json"
+  , "strings"
+  , "transformers"
+  , "tuples"
+  , "web-dom"
+  , "web-events"
+  , "web-html"
+  , "web-xhr"
+  ]
+, packages = ./packages.dhall
 }

purs/src/App.purs

@@ -2,15 +2,16 @@ module App where
 
 import Prelude
 
-import Affjax (Response, ResponseFormatError)
+import Affjax.Web (Response, Error)
-import Affjax (defaultRequest) as AX
+import Affjax.Web (defaultRequest) as AX
-import Affjax as Ax
+import Affjax.Web as Ax
 import Affjax.RequestBody as AXReq
 import Affjax.RequestHeader (RequestHeader(..))
 import Affjax.ResponseFormat as AXRes
-import Data.Argonaut (Json)
+import Affjax.StatusCode (StatusCode(..))
+import Data.Argonaut (decodeJson)
 import Data.Array ((:))
-import Data.Either (Either(..))
+import Data.Either (Either(..), hush)
 import Data.FormURLEncoded (FormURLEncoded)
 import Data.HTTP.Method (Method(..))
 import Data.Maybe (Maybe(..))
@@ -18,7 +19,7 @@ import Data.MediaType.Common (applicationFormURLEncoded, applicationJSON)
 import Effect.Aff (Aff)
 import Effect.Class (liftEffect)
 import Globals (app')
-import Model (Bookmark, Bookmark'(..), Note, Note'(..), AccountSettings, AccountSettings'(..))
+import Model (Bookmark, Bookmark'(..), Note, Note'(..), AccountSettings, AccountSettings'(..), TagCloudMode, TagCloudMode'(..), TagCloud)
 import Simple.JSON as J
 import Web.HTML (window)
 import Web.HTML.Location (reload)
@@ -34,28 +35,46 @@ toggleStar bid action = do
   let path = "bm/" <> show bid <> "/" <> show action
   void (fetchUrlEnc POST path Nothing AXRes.ignore)
 
-destroy :: Int -> Aff (Response (Either ResponseFormatError Unit))
+destroy :: Int -> Aff (Either Error (Response Unit))
 destroy bid =
   fetchUrlEnc DELETE ("bm/" <> show bid) Nothing AXRes.ignore
 
-markRead :: Int -> Aff (Response (Either ResponseFormatError Unit))
+markRead :: Int -> Aff (Either Error (Response Unit))
 markRead bid = do
   let path = "bm/" <> show bid <> "/read"
   fetchUrlEnc POST path Nothing AXRes.ignore
 
-editBookmark :: Bookmark -> Aff (Response (Either ResponseFormatError Unit))
+editBookmark :: Bookmark -> Aff (Either Error (Response String))
 editBookmark bm =  do
-    fetchJson POST "api/add" (Just (Bookmark' bm)) AXRes.ignore
+    fetchJson POST "api/add" (Just (Bookmark' bm)) AXRes.string
 
-editNote :: Note -> Aff (Response (Either ResponseFormatError Json))
+editNote :: Note -> Aff (Either Error (Response String))
 editNote bm =  do
-    fetchJson POST "api/note/add" (Just (Note' bm)) AXRes.json
+    fetchJson POST "api/note/add" (Just (Note' bm)) AXRes.string
 
-destroyNote :: Int -> Aff (Response (Either ResponseFormatError Unit))
+lookupTitle :: Bookmark -> Aff (Maybe String)
+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
   fetchUrlEnc DELETE ("api/note/" <> show nid) Nothing AXRes.ignore
 
-editAccountSettings :: AccountSettings -> Aff (Response (Either ResponseFormatError Unit))
+editAccountSettings :: AccountSettings -> Aff (Either Error (Response Unit))
 editAccountSettings us =  do
     fetchJson POST "api/accountSettings" (Just (AccountSettings' us)) AXRes.ignore
 
@@ -73,7 +92,7 @@ fetchJson
   -> String
   -> Maybe b
   -> AXRes.ResponseFormat a
-  -> Aff (Response (Either ResponseFormatError a))
+  -> Aff (Either Error (Response a))
 fetchJson method path content rt =
     fetchPath method path [ContentType applicationJSON] (AXReq.string <<< J.writeJSON <$> content) rt
 
@@ -83,7 +102,7 @@ fetchUrlEnc
   -> String
   -> Maybe FormURLEncoded
   -> AXRes.ResponseFormat a
-  -> Aff (Response (Either ResponseFormatError a))
+  -> Aff (Either Error (Response a))
 fetchUrlEnc method path content rt =
     fetchPath method path [ContentType applicationFormURLEncoded] (AXReq.FormURLEncoded <$> content) rt
 
@@ -94,7 +113,7 @@ fetchPath
   -> Array RequestHeader
   -> Maybe AXReq.RequestBody
   -> AXRes.ResponseFormat a
-  -> Aff (Response (Either ResponseFormatError a))
+  -> Aff (Either Error (Response a))
 fetchPath method path headers content rt =
     fetchUrl method ((app' unit).homeR <> path) headers content rt
 
@@ -105,7 +124,7 @@ fetchUrl
   -> Array RequestHeader
   -> Maybe AXReq.RequestBody
   -> AXRes.ResponseFormat a
-  -> Aff (Response (Either ResponseFormatError a))
+  -> Aff (Either Error (Response a))
 fetchUrl method url headers content rt =
   Ax.request
     AX.defaultRequest

purs/src/Component/AccountSettings.purs

@@ -4,14 +4,12 @@ import Prelude hiding (div)
 
 import App (editAccountSettings)
 import Data.Lens (Lens', lens, use, (%=))
-import Data.Maybe (Maybe(..))
 import Effect.Aff (Aff)
-import Globals (app')
 import Halogen as H
-import Halogen.HTML (HTML, div, input, text)
+import Halogen.HTML (div, input, text)
 import Halogen.HTML.Elements (label)
 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 Util (class_)
 import Web.Event.Event (Event)
@@ -34,7 +32,7 @@ data EditField
 
 
 -- | The bookmark component definition.
-usetting :: forall q i o. AccountSettings -> H.Component HTML q i o Aff
+usetting :: forall q i o. AccountSettings -> H.Component q i o Aff
 usetting u' =
   H.mkComponent
     { initialState: const (mkState u')
@@ -42,7 +40,6 @@ usetting u' =
     , eval: H.mkEval $ H.defaultEval { handleAction = handleAction }
     }
   where
-  app = app' unit
 
   mkState u =
     { us: u
@@ -53,27 +50,27 @@ usetting u' =
     div [ class_ "settings-form" ]
     [ div [ class_ "fw7 mb2"] [ text "Account Settings" ]
     , 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) ]
       , label [ for "archiveDefault", class_ "lh-copy" ]
         [ text "Archive Non-Private Bookmarks (archive.li)" ]
       ]
     , 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) ]
       , label [ for "privateDefault", class_ "lh-copy"  ]
         [ text "Default new bookmarks to Private" ]
       ]
     , 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) ]
       , label [ for "privacyLock", class_ "lh-copy"  ]
         [ text "Privacy Lock (Private Account)" ]
       ]
     ]
     where
-      editField :: forall a. (a -> EditField) -> a -> Maybe UAction
+      editField :: forall a. (a -> EditField) -> a -> UAction
-      editField f = Just <<< UEditField <<< f
+      editField f = UEditField <<< f
 
   handleAction :: UAction -> H.HalogenM UState UAction () o Aff Unit
   handleAction (UEditField f) = do
@@ -84,6 +81,6 @@ usetting u' =
     us <- use _us
     void $ H.liftAff (editAccountSettings us)
 
-  handleAction (USubmit e) = do
+  handleAction (USubmit _) = do
     us <- use _us
     void $ H.liftAff (editAccountSettings us)

purs/src/Component/Add.purs

@@ -2,32 +2,36 @@ module Component.Add where
 
 import Prelude hiding (div)
 
-import App (destroy, editBookmark)
+import Affjax (printError)
-import Data.Array (drop, foldMap)
+import Affjax.StatusCode (StatusCode(..))
+import App (destroy, editBookmark, lookupTitle)
+import Data.Either (Either(..))
 import Data.Lens (Lens', lens, use, (%=), (.=))
-import Data.Maybe (Maybe(..), maybe)
+import Data.Maybe (Maybe(..), fromMaybe, isJust, maybe)
 import Data.Monoid (guard)
-import Data.String (null)
+import Data.String (Pattern(..), null, stripPrefix)
-import Data.String (split) as S
-import Data.String.Pattern (Pattern(..))
 import Data.Tuple (fst, snd)
 import Effect.Aff (Aff)
 import Effect.Class (liftEffect)
-import Globals (app', closeWindow, mmoment8601)
+import Effect.Console (log)
+import Globals (closeWindow, mmoment8601)
 import Halogen as H
-import Halogen.HTML (HTML, br_, button, div, form, input, label, p, span, table, tbody_, td, td_, text, textarea, tr_)
+import Halogen.HTML (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.Properties (autofocus, ButtonType(..), InputType(..), autocomplete, checked, for, id_, name, required, rows, title, type_, value)
+import Halogen.HTML.Properties (ButtonType(..), InputType(..), autocomplete, autofocus, checked, disabled, for, id, name, required, rows, title, type_, value)
 import Model (Bookmark)
-import Util (_curQuerystring, _loc, _lookupQueryStringValue, attr, class_, ifElseH, whenH)
+import Util (_curQuerystring, _loc, _doc, _lookupQueryStringValue, attr, class_, ifElseH, whenH)
 import Web.Event.Event (Event, preventDefault)
 import Web.HTML (window)
-import Web.HTML.Location (setHref)
+import Web.HTML.HTMLDocument (referrer)
+import Web.HTML.Location (setHref, origin)
+import DOM.HTML.Indexed.AutocompleteType (AutocompleteType(..))
 
 data BAction
   = BEditField EditField
   | BEditSubmit Event
   | BDeleteAsk Boolean
+  | BLookupTitle
   | BDestroy
 
 data EditField
@@ -42,7 +46,9 @@ type BState =
   { bm :: Bookmark
   , edit_bm :: Bookmark
   , deleteAsk :: Boolean
+  , loading :: Boolean
   , destroyed :: Boolean
+  , apiError :: Maybe String
   }
 
 _bm :: Lens' BState Bookmark
@@ -51,7 +57,10 @@ _bm = lens _.bm (_ { bm = _ })
 _edit_bm :: Lens' BState Bookmark
 _edit_bm = lens _.edit_bm (_ { edit_bm = _ })
 
-addbmark :: forall q i o. Bookmark -> H.Component HTML q i o Aff
+_apiError :: Lens' BState (Maybe String)
+_apiError = lens _.apiError (_ { apiError = _ })
+
+addbmark :: forall q i o. Bookmark -> H.Component q i o Aff
 addbmark b' =
   H.mkComponent
     { initialState: const (mkState b')
@@ -59,59 +68,64 @@ addbmark b' =
     , eval: H.mkEval $ H.defaultEval { handleAction = handleAction }
     }
   where
-  app = app' unit
 
   mkState b =
     { bm: b
     , edit_bm: b
     , deleteAsk: false
     , destroyed: false
+    , loading: false
+    , apiError: Nothing
     }
 
   render :: forall m. BState -> H.ComponentHTML BAction () m
-  render s@{ bm, edit_bm } =
+  render s@{ bm, edit_bm, apiError } =
     ifElseH (not s.destroyed)
       display_edit
       display_destroyed
    where
      display_edit _ =
-       form [ onSubmit (Just <<< BEditSubmit) ]
+       form [ onSubmit BEditSubmit ]
        [ table [ class_ "w-100" ]
          [ tbody_
            [ tr_
              [ td [ class_ "w1" ] [ ]
              , td_ [ whenH (bm.bid > 0)
-                       display_exists
+                       display_exists,
+                     whenH (isJust apiError)
+                       (alert_notification (fromMaybe "" apiError))
                    ]
              ]
            , tr_
              [ 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_
              [ td_ [ label [ for "title" ] [ text "title" ] ]
-             , td_ [ input [ type_ InputText , id_ "title", class_ "w-100 mv1" , name "title"
+             , td [class_ "flex"]
-                           , value (edit_bm.title) , onValueChange (editField Etitle)] ]
+                  [ input [ type_ InputText , id "title", class_ "w-100 mv1 flex-auto" , name "title" , 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_
              [ 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)] ]
              ]
            , tr_
              [ td_ [ label [ for "tags" ] [ text "tags" ] ]
-             , td_ [ input [ type_ InputText , id_ "tags", class_ "w-100 mv1" , name "tags", autocomplete false, attr "autocapitalize" "off", autofocus (not $ null bm.url)
+             , td_ [ input [ type_ InputText , id "tags", class_ "w-100 mv1" , name "tags", autocomplete AutocompleteOff, attr "autocapitalize" "off", autofocus (not $ null bm.url)
                            , value (edit_bm.tags) , onValueChange (editField Etags)] ]
              ]
            , tr_
              [ 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)] ]
              ]
            , tr_
              [ 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)] ]
              ]
            , tr_
@@ -130,32 +144,46 @@ addbmark b' =
          [ text (maybe " " fst mmoment) ]
        , div [ class_ "edit_links dib ml1" ]
          [ div [ class_ "delete_link di" ]
-           [ button ([ type_ ButtonButton, onClick \_ -> Just (BDeleteAsk true), class_ "delete" ] <> guard s.deleteAsk [ attr "hidden" "hidden" ]) [ text "delete" ]
+           [ button ([ type_ ButtonButton, onClick \_ -> BDeleteAsk true, class_ "delete" ] <> guard s.deleteAsk [ attr "hidden" "hidden" ]) [ text "delete" ]
            , span ([ class_ "confirm red" ] <> guard (not s.deleteAsk) [ attr "hidden" "hidden" ])
-             [ button [ type_ ButtonButton, onClick \_ -> Just (BDeleteAsk false)] [ text "cancel / " ]
+             [ button [ type_ ButtonButton, onClick \_ -> BDeleteAsk false] [ text "cancel / " ]
-             , button [ type_ ButtonButton, onClick \_ -> Just BDestroy, class_ "red" ] [ text "destroy" ]
+             , button [ type_ ButtonButton, onClick \_ -> 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"]
 
-     editField :: forall a. (a -> EditField) -> a -> Maybe BAction
+     editField :: forall a. (a -> EditField) -> a -> BAction
-     editField f = Just <<< BEditField <<< f
+     editField f = BEditField <<< f
      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 (BDeleteAsk e) = do
     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
     bid <- H.gets _.bm.bid
     void $ H.liftAff (destroy bid)
     H.modify_ (_ { destroyed = true })
+
   handleAction (BEditField f) = do
     _edit_bm %= case f of
       Eurl e -> _ { url = e }
@@ -164,14 +192,29 @@ addbmark b' =
       Etags e -> _ { tags = e }
       Eprivate e -> _ { private = e }
       Etoread e -> _ { toread = e }
+
   handleAction (BEditSubmit e) = do
-    H.liftEffect (preventDefault e)
+    liftEffect (preventDefault e)
     edit_bm <- use _edit_bm 
-    void $ H.liftAff (editBookmark edit_bm)
+    _apiError .= Nothing
-    _bm .= edit_bm
+    H.liftAff (editBookmark edit_bm) >>= case _ of
-    loc <- liftEffect _loc
+      Left affErr -> do
-    win <- liftEffect window
+        _apiError .= Just (printError affErr)
-    qs <- liftEffect _curQuerystring
+        liftEffect $ log (printError affErr)
-    case _lookupQueryStringValue qs "next" of
+      Right { status: StatusCode s } | s >= 200 && s < 300 -> do
-      Just n -> liftEffect (setHref n loc)
+        _bm .= edit_bm
-      _ -> liftEffect (closeWindow win)
+        qs <- liftEffect $ _curQuerystring
+        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 $
+            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)

purs/src/Component/BList.purs

@@ -1,39 +1,38 @@
-module Component.BList where
+module Component.BList where
-
+
-import Prelude
+import Prelude
-
+
-import Component.BMark (BMessage(..), BSlot, bmark)
+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
+
-
+type ChildSlots =
-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
+    , render
-    , render
+    , eval: H.mkEval $ H.defaultEval { handleAction = handleAction }
-    , eval: H.mkEval $ H.defaultEval { handleAction = handleAction }
+    }
-    }
+  where
-  where
+
-
+  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
+    H.modify_ (filter (\b -> b.bid /= bid))
-    H.modify_ (filter (\b -> b.bid /= bid))

purs/src/Component/BMark.purs

@@ -1,244 +1,286 @@
-module Component.BMark where
+module Component.BMark where
-
+
-import Prelude hiding (div)
+import Prelude hiding (div)
-
+
-import App (StarAction(..), destroy, editBookmark, markRead, toggleStar)
+import Affjax (printError)
-import Component.Markdown as Markdown
+import Affjax.StatusCode (StatusCode(..))
-import Data.Const (Const)
+import App (StarAction(..), destroy, editBookmark, markRead, toggleStar, lookupTitle)
-import Data.Lens (Lens', lens, use, (%=), (.=))
+import Component.Markdown as Markdown
-import Data.Maybe (Maybe(..), fromMaybe, isJust)
+import Data.Const (Const)
-import Data.Monoid (guard)
+import Data.Either (Either(..))
-import Data.Nullable (toMaybe)
+import Data.Lens (Lens', lens, use, (%=), (.=))
-import Data.String (null, split, take) as S
+import Data.Maybe (Maybe(..), fromMaybe, isJust)
-import Data.String.Pattern (Pattern(..))
+import Data.Monoid (guard)
-import Data.Symbol (SProxy(..))
+import Data.Nullable (toMaybe)
-import Effect.Aff (Aff)
+import Data.String (null, split, take, replaceAll) as S
-import Globals (app')
+import Data.String.Pattern (Pattern(..), Replacement(..))
-import Halogen as H
+import Effect.Aff (Aff)
-import Halogen.HTML (HTML, a, br_, button, div, div_, form, input, label, span, text, textarea)
+import Effect.Class (liftEffect)
-import Halogen.HTML as HH
+import Effect.Class.Console (log)
-import Halogen.HTML.Events (onSubmit, onValueChange, onChecked, onClick)
+import Globals (app', setFocus, toLocaleDateString)
-import Halogen.HTML.Properties (ButtonType(..), InputType(..), autocomplete, checked, for, href, id_, name, required, rows, target, title, type_, value)
+import Halogen as H
-import Model (Bookmark)
+import Halogen.HTML (a, br_, button, div, div_, form, input, label, span, text, textarea)
-import Util (attr, class_, fromNullableStr, ifElseH, whenH, whenA)
+import Halogen.HTML as HH
-import Web.Event.Event (Event, preventDefault)
+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)
--- | UI Events
+import Model (Bookmark)
-data BAction
+import Type.Proxy (Proxy(..))
-  = BStar Boolean
+import Util (attr, class_, encodeTag, fromNullableStr, ifElseH, whenA, whenH)
-  | BDeleteAsk Boolean
+import Web.Event.Event (Event, preventDefault)
-  | BDestroy
+import DOM.HTML.Indexed.AutocompleteType (AutocompleteType(..))
-  | BEdit Boolean
+
-  | BEditField EditField
+-- | UI Events
-  | BEditSubmit Event
+data BAction
-  | BMarkRead
+  = BStar Boolean
-
+  | BDeleteAsk Boolean
--- | FormField Edits
+  | BLookupTitle
-data EditField
+  | BDestroy
-  = Eurl String
+  | BEdit Boolean
-  | Etitle String
+  | BEditField EditField
-  | Edescription String
+  | BEditSubmit Event
-  | Etags String
+  | BMarkRead
-  | Eprivate Boolean
+
-  | Etoread Boolean
+-- | FormField Edits
-
+data EditField
--- | Messages to parent
+  = Eurl String
-data BMessage
+  | Etitle String
-  = BNotifyRemove
+  | Edescription String
-
+  | Etags String
-type BSlot = H.Slot (Const Void) BMessage
+  | Eprivate Boolean
-
+  | Etoread Boolean
-type BState =
+
-  { bm :: Bookmark
+-- | Messages to parent
-  , edit_bm :: Bookmark
+data BMessage
-  , deleteAsk:: Boolean
+  = BNotifyRemove
-  , edit :: Boolean
+
-  }
+type BSlot = H.Slot (Const Void) BMessage
-
+
-_bm :: Lens' BState Bookmark
+type BState =
-_bm = lens _.bm (_ { bm = _ })
+  { bm :: Bookmark
-
+  , edit_bm :: Bookmark
-_edit_bm :: Lens' BState Bookmark
+  , deleteAsk:: Boolean
-_edit_bm = lens _.edit_bm (_ { edit_bm = _ })
+  , edit :: Boolean
-
+  , loading :: Boolean
-_edit :: Lens' BState Boolean
+  , apiError :: Maybe String
-_edit = lens _.edit (_ { edit = _ })
+  }
-
+
-_markdown = SProxy :: SProxy "markdown"
+_bm :: Lens' BState Bookmark
-
+_bm = lens _.bm (_ { bm = _ })
-type ChildSlots =
+
-  ( markdown :: Markdown.Slot Unit
+_edit_bm :: Lens' BState Bookmark
-  )
+_edit_bm = lens _.edit_bm (_ { edit_bm = _ })
-
+
-bmark :: forall q i. Bookmark -> H.Component HTML q i BMessage Aff
+_edit :: Lens' BState Boolean
-bmark b' =
+_edit = lens _.edit (_ { edit = _ })
-  H.mkComponent
+
-    { initialState: const (mkState b')
+_apiError :: Lens' BState (Maybe String)
-    , render
+_apiError = lens _.apiError (_ { apiError = _ })
-    , eval: H.mkEval $ H.defaultEval { handleAction = handleAction }
+
-    }
+_markdown = Proxy :: Proxy "markdown"
-  where
+
-  app = app' unit
+type ChildSlots =
-
+  ( markdown :: Markdown.Slot Unit
-  mkState b =
+  )
-    { bm: b
+
-    , edit_bm: b
+bmark :: forall q i. Bookmark -> H.Component q i BMessage Aff
-    , deleteAsk: false
+bmark b' =
-    , edit: false
+  H.mkComponent
-    }
+    { initialState: const (mkState b')
-
+    , render
-  render :: BState -> H.ComponentHTML BAction ChildSlots Aff
+    , eval: H.mkEval $ H.defaultEval { handleAction = handleAction }
-  render s@{ bm, edit_bm } =
+    }
-    div [ id_ (show bm.bid) , class_ ("bookmark w-100 mw7 pa1 mb3" <> guard bm.private " private")] $
+  where
-      [ whenH app.dat.isowner
+  app = app' unit
-          star
+
-      , ifElseH s.edit
+  mkState b =
-          display_edit
+    { bm: b
-          display
+    , edit_bm: b
-      ]
+    , deleteAsk: false
-
+    , edit: false
-    where
+    , loading: false
-
+    , apiError: Nothing
-     star _ =
+    }
-       div [ class_ ("star fl pointer" <> guard bm.selected " selected") ]
+
-       [ button [ class_ "moon-gray", onClick \_ -> Just (BStar (not bm.selected)) ] [ text "✭" ] ]
+  render :: BState -> H.ComponentHTML BAction ChildSlots Aff
-
+  render s@{ bm, edit_bm, apiError } =
-     display _ =
+    div [ id (show bm.bid) , class_ ("bookmark w-100 mw7 pa1 mb3" <> guard bm.private " private")] $
-        div [ class_ "display" ] $
+      [ whenH app.dat.isowner
-        [ a [ href bm.url, target "_blank", class_ ("link f5 lh-title" <> guard bm.toread " unread")]
+          star
-          [ text $ if S.null bm.title then "[no title]" else bm.title ]
+      , ifElseH s.edit
-        , br_
+          display_edit
-        , a [ href bm.url , class_ "link f7 gray hover-blue" ] [ text bm.url ]
+          display
-        , a [ href (fromMaybe ("http://archive.is/" <> bm.url) (toMaybe bm.archiveUrl))
+      ]
-            , class_ ("link f7 gray hover-blue ml2" <> (guard (isJust (toMaybe bm.archiveUrl)) " green"))
+
-            , target "_blank", title "archive link"]
+    where
-            [ if isJust (toMaybe bm.archiveUrl) then text "☑" else text "☐" ]
+
-        , br_
+     star _ =
-        , div [ class_ "description mt1 mid-gray" ] [ HH.slot _markdown unit Markdown.component bm.description absurd ]
+       div [ class_ ("star fl pointer" <> guard bm.selected " selected") ]
-        , div [ class_ "tags" ] $
+       [ button [ class_ "moon-gray", onClick \_ -> BStar (not bm.selected) ] [ text "✭" ] ]
-              whenA (not (S.null bm.tags)) $ \_ ->
+
-                map (\tag -> a [ class_ ("link tag mr1" <> guard (S.take 1 tag == ".") " private")
+     display _ =
-                             , href (linkToFilterTag tag) ]
+        div [ class_ "display" ] $
-                             [ text tag ])
+        [ a [ href bm.url, target "_blank", class_ ("link f5 lh-title" <> guard bm.toread " unread")]
-                (S.split (Pattern " ") bm.tags)
+          [ text $ if S.null bm.title then "[no title]" else bm.title ]
-              
+        , br_
-        , a [ class_ "link f7 dib gray w4", href (linkToFilterSingle bm.slug) ]
+        , a [ href bm.url , class_ "link f7 gray hover-blue" ] [ text bm.url ]
-          [ text shtime ]
+        , a [ href (fromMaybe ("http://archive.is/" <> bm.url) (toMaybe bm.archiveUrl))
-
+            , class_ ("link f7 gray hover-blue ml2" <> (guard (isJust (toMaybe bm.archiveUrl)) " green"))
-        -- links
+            , target "_blank", title "archive link"]
-        , whenH app.dat.isowner $ \_ ->
+            [ if isJust (toMaybe bm.archiveUrl) then text "☑" else text "☐" ]
-            div [ class_ "edit_links di" ]
+        , br_
-            [ button [ type_ ButtonButton, onClick \_ -> Just (BEdit true), class_ "edit light-silver hover-blue" ] [ text "edit  " ]
+        , div [ class_ "description mt1 mid-gray" ] [ HH.slot _markdown unit Markdown.component bm.description absurd ]
-            , div [ class_ "delete_link di" ]
+        , div [ class_ "tags" ] $
-              [ button [ type_ ButtonButton, onClick \_ -> Just (BDeleteAsk true), class_ ("delete light-silver hover-blue" <> guard s.deleteAsk " dn") ] [ text "delete" ]
+              whenA (not (S.null bm.tags)) $ \_ ->
-              , span ([ class_ ("confirm red" <> guard (not s.deleteAsk) " dn") ] )
+                map (\tag -> a [ class_ ("link tag mr1" <> guard (S.take 1 tag == ".") " private")
-                [ button [ type_ ButtonButton, onClick \_ -> Just (BDeleteAsk false)] [ text "cancel / " ]
+                             , href (linkToFilterTag tag) ]
-                , button [ type_ ButtonButton, onClick \_ -> Just BDestroy, class_ "red" ] [ text "destroy" ]
+                             [ text tag ])
-                ] 
+                (S.split (Pattern " ") bm.tags)
-              ]
+              
-            ]
+        , a [ class_ "link f7 dib gray w4", href (linkToFilterSingle bm.slug), title shdatetime ]
-        , whenH app.dat.isowner $ \_ ->
+          [ text shdate ]
-            div [ class_ "read di" ] $
+
-              guard bm.toread
+        -- links
-              [ text "  "
+        , whenH app.dat.isowner $ \_ ->
-              , button [ onClick \_ -> Just BMarkRead, class_ "mark_read" ] [ text "mark as read"]
+            div [ class_ "edit_links di" ]
-              ]
+            [ button [ type_ ButtonButton, onClick \_ -> BEdit true, class_ "edit light-silver hover-blue" ] [ text "edit  " ]
-        ]
+            , div [ class_ "delete_link di" ]
-       
+              [ button [ type_ ButtonButton, onClick \_ -> BDeleteAsk true, class_ ("delete light-silver hover-blue" <> guard s.deleteAsk " dn") ] [ text "delete" ]
-
+              , span ([ class_ ("confirm red" <> guard (not s.deleteAsk) " dn") ] )
-     display_edit _ =
+                [ button [ type_ ButtonButton, onClick \_ -> BDeleteAsk false] [ text "cancel / " ]
-       div [ class_ "edit_bookmark_form pa2 pt0 bg-white" ] $
+                , button [ type_ ButtonButton, onClick \_ -> BDestroy, class_ "red" ] [ text "destroy" ]
-       [ form [ onSubmit (Just <<< BEditSubmit) ]
+                ] 
-         [ div_ [ text "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) ]
+        , whenH app.dat.isowner $ \_ ->
-         , br_
+            div [ class_ "read di" ] $
-         , div_ [ text "title" ]
+              guard bm.toread
-         , input [ type_ InputText , class_ "title w-100 mb2 pt1 f7 edit_form_input" , name "title"
+              [ text "  "
-                 , value (edit_bm.title) , onValueChange (editField Etitle) ]
+              , button [ onClick \_ -> BMarkRead, class_ "mark_read" ] [ text "mark as read"]
-         , br_
+              ]
-         , div_ [ text "description" ]
+        ]
-         , textarea [ class_ "description w-100 mb1 pt1 f7 edit_form_input" , name "description", rows 5
+       
-                    , value (edit_bm.description) , onValueChange (editField Edescription) ]
+
-         , br_
+     display_edit _ =
-         , div [ id_ "tags_input_box"]
+       div [ class_ "edit_bookmark_form pa2 pt0 bg-white" ] $
-           [ div_ [ text "tags" ]
+       [ whenH (isJust apiError)
-             , input [ type_ InputText , class_ "tags w-100 mb1 pt1 f7 edit_form_input" , name "tags"
+              (alert_notification (fromMaybe "" apiError))
-                     , autocomplete false, attr "autocapitalize" "off"
+       , form [ onSubmit BEditSubmit ]
-                     , value (edit_bm.tags) , onValueChange (editField Etags) ]
+         [ div_ [ text "url" ]
-             , br_
+         , input [ type_ InputUrl , class_ "url w-100 mb2 pt1 edit_form_input" , required true , name "url"
-           ]
+                 , value (edit_bm.url) , onValueChange (editField Eurl) ]
-         , div [ class_ "edit_form_checkboxes mv3"]
+         , div_ [ text "title" ]
-           [ input [ type_ InputCheckbox , class_ "private pointer" , id_ "edit_private", name "private"
+         , div [class_ "flex"]
-                   , checked (edit_bm.private) , onChecked (editField Eprivate) ]
+               [input [ type_ InputText , class_ "title w-100 mb2 pt1 edit_form_input" , name "title"
-           , text " "
+                      , value (edit_bm.title) , onValueChange (editField Etitle) ]
-           , label [ for "edit_private" , class_ "mr2" ] [ text "private" ]
+               , 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" ]
-           , text " "
+               ]
-           , input [ type_ InputCheckbox , class_ "toread pointer" , id_ "edit_toread", name "toread"
+         , div_ [ text "description" ]
-                   , checked (edit_bm.toread) , onChecked (editField Etoread) ]
+         , textarea [ class_ "description w-100 mb1 pt1 edit_form_input" , name "description", rows 5
-           , text " "
+                    , value (edit_bm.description) , onValueChange (editField Edescription) ]
-           , label [ for "edit_toread" ] [ text "to-read" ]
+         , div [ id "tags_input_box"]
-           , br_
+           [ div_ [ text "tags" ]
-           ]
+             , input [ id (tagid edit_bm), type_ InputText , class_ "tags w-100 mb1 pt1 edit_form_input" , name "tags"
-         , input [ type_ InputSubmit , class_ "mr1 pv1 ph2 dark-gray ba b--moon-gray bg-near-white pointer rdim" , value "save" ]
+                     , autocomplete AutocompleteOff, attr "autocapitalize" "off"
-         , text " "
+                     , value (edit_bm.tags) , onValueChange (editField Etags) ]
-         , input [ type_ InputReset , class_ "pv1 ph2 dark-gray ba b--moon-gray bg-near-white pointer rdim" , value "cancel"
+           ]
-                 , onClick \_ -> Just (BEdit false) ]
+         , div [ class_ "edit_form_checkboxes mv3"]
-         ]
+           [ input [ type_ InputCheckbox , class_ "private pointer" , id "edit_private", name "private"
-       ]
+                   , checked (edit_bm.private) , onChecked (editField Eprivate) ]
-       
+           , text " "
-
+           , label [ for "edit_private" , class_ "mr2" ] [ text "private" ]
-     editField :: forall a. (a -> EditField) -> a -> Maybe BAction
+           , text " "
-     editField f = Just <<< BEditField <<< f
+           , input [ type_ InputCheckbox , class_ "toread pointer" , id "edit_toread", name "toread"
-     linkToFilterSingle slug = fromNullableStr app.userR <> "/b:" <> slug
+                   , checked (edit_bm.toread) , onChecked (editField Etoread) ]
-     linkToFilterTag tag = fromNullableStr app.userR <> "/t:" <> tag
+           , text " "
-     shtime = S.take 16 bm.time `append` "Z"
+           , label [ for "edit_toread" ] [ text "to-read" ]
-
+           ]
-  handleAction :: BAction -> H.HalogenM BState BAction ChildSlots BMessage Aff Unit
+         , input [ type_ InputSubmit , class_ "mr1 pv1 ph2 dark-gray ba b--moon-gray bg-near-white pointer rdim" , value "save" ]
-
+         , text " "
-  -- | Star
+         , input [ type_ InputReset , class_ "pv1 ph2 dark-gray ba b--moon-gray bg-near-white pointer rdim" , value "cancel"
-  handleAction (BStar e) = do
+                 , onClick \_ -> BEdit false ]
-    bm <- use _bm
+         ]
-    H.liftAff (toggleStar bm.bid (if e then Star else UnStar))
+       ]
-    _bm %= _ { selected = e }
+       
-    _edit_bm %= _ { selected = e }
+     alert_notification alert_text _ = 
-
+       div [ class_ "alert alert-err" ] [ text alert_text ]
-  -- | Delete
+
-  handleAction (BDeleteAsk e) = do
+     editField :: forall a. (a -> EditField) -> a -> BAction
-    H.modify_ (_ { deleteAsk = e })
+     editField f = BEditField <<< f
-
+     linkToFilterSingle slug = fromNullableStr app.userR <> "/b:" <> slug
-  -- | Destroy
+     linkToFilterTag tag = fromNullableStr app.userR <> "/t:" <> encodeTag tag 
-  handleAction (BDestroy) = do
+     shdate = toLocaleDateString bm.time 
-    bm <- use _bm
+     shdatetime = S.take 16 bm.time `append` "Z"
-    void $ H.liftAff (destroy bm.bid)
+
-    H.raise BNotifyRemove
+  tagid bm = show bm.bid <> "_tags"
-
+
-  -- | Mark Read
+  handleAction :: BAction -> H.HalogenM BState BAction ChildSlots BMessage Aff Unit
-  handleAction (BMarkRead) = do
+
-    bm <- use _bm
+  -- | Star
-    void (H.liftAff (markRead bm.bid))
+  handleAction (BStar e) = do
-    _bm %= _ { toread = false }
+    bm <- use _bm
-
+    H.liftAff (toggleStar bm.bid (if e then Star else UnStar))
-  -- | Start/Stop Editing
+    _bm %= _ { selected = e }
-  handleAction (BEdit e) = do
+    _edit_bm %= _ { selected = e }
-    bm <- use _bm
+
-    _edit_bm .= bm
+  -- | Delete
-    _edit .= e
+  handleAction (BDeleteAsk e) = do
-
+    H.modify_ (_ { deleteAsk = e })
-  -- | Update Form Field 
+
-  handleAction (BEditField f) = do
+  -- | Destroy
-    _edit_bm %= case f of
+  handleAction (BDestroy) = do
-      Eurl e -> _ { url = e }
+    bm <- use _bm
-      Etitle e -> _ { title = e }
+    void $ H.liftAff (destroy bm.bid)
-      Edescription e -> _ { description = e }
+    H.raise BNotifyRemove
-      Etags e -> _ { tags = e }
+
-      Eprivate e -> _ { private = e }
+  -- | Mark Read
-      Etoread e -> _ { toread = e }
+  handleAction (BMarkRead) = do
-
+    bm <- use _bm
-  -- | Submit
+    void (H.liftAff (markRead bm.bid))
-  handleAction (BEditSubmit e) = do
+    _bm %= _ { toread = false }
-    H.liftEffect (preventDefault e)
+
-    edit_bm <- use _edit_bm
+  -- | Start/Stop Editing
-    void $ H.liftAff (editBookmark edit_bm)
+  handleAction (BEdit e) = do
-    _bm .= edit_bm
+    bm <- use _bm
-    _edit .= false
+    _edit_bm .= bm
+    _edit .= e
+    _apiError .= Nothing
+    H.liftEffect $
+      when e
+        (setFocus (tagid bm)) 
+
+  -- | Update Form Field 
+  handleAction (BEditField f) = do
+    _edit_bm %= case f of
+      Eurl e -> _ { url = e }
+      Etitle e -> _ { title = e }
+      Edescription e -> _ { description = e }
+      Etags e -> _ { tags = e }
+      Eprivate e -> _ { private = 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
+  handleAction (BEditSubmit e) = do
+    H.liftEffect (preventDefault e)
+    edit_bm <- use _edit_bm
+    _apiError .= Nothing
+    let edit_bm' = edit_bm { tags = S.replaceAll (Pattern ",") (Replacement " ") edit_bm.tags }
+    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
+      Right res -> do
+        _apiError .= Just (res.body)
+        liftEffect $ log (res.body)

purs/src/Component/Markdown.purs

@@ -5,10 +5,9 @@ import Data.Const (Const)
 import Effect.Aff (Aff)
 import Foreign.Marked (marked)
 import Halogen as H
-import Halogen.HTML as HH
 import Prelude (Void)
 
 type Slot = H.Slot (Const Void) Void
 
-component :: forall q o. H.Component HH.HTML q String o Aff
+component :: forall q o. H.Component q String o Aff
 component = RH.mkComponent marked

purs/src/Component/NList.purs

@@ -12,7 +12,7 @@ import Globals (app', mmoment8601)
 import Halogen as H
 import Halogen.HTML (a, br_, div, text)
 import Halogen.HTML as HH
-import Halogen.HTML.Properties (href, id_, title)
+import Halogen.HTML.Properties (href, id, title)
 import Model (Note, NoteSlug)
 import Util (class_, fromNullableStr)
 
@@ -27,7 +27,7 @@ type NLState =
   }
 
 
-nlist :: forall q i o. Array Note -> H.Component HH.HTML q i o Aff
+nlist :: forall q i o. Array Note -> H.Component q i o Aff
 nlist st' =
   H.mkComponent
     { initialState: const (mkState st')
@@ -45,11 +45,11 @@ nlist st' =
     }
 
   render :: NLState -> H.ComponentHTML NLAction () Aff
-  render st@{ notes } =
+  render { notes } =
     HH.div_ (map renderNote notes)
     where
       renderNote note =
-        div [ id_ (show note.id)
+        div [ id (show note.id)
             , class_ ("note w-100 mw7 pa1 mb2"
                      <> if note.shared then "" else " private")] $
            [ div [ class_ "display" ] $

purs/src/Component/NNote.purs

@@ -2,29 +2,35 @@ module Component.NNote where
 
 import Prelude hiding (div)
 
+import Affjax (printError)
+import Affjax.StatusCode (StatusCode(..))
 import App (destroyNote, editNote)
 import Component.Markdown as Markdown
 import Data.Array (drop, foldMap)
 import Data.Either (Either(..))
 import Data.Lens (Lens', lens, use, (%=), (.=))
-import Data.Maybe (Maybe(..), maybe)
+import Data.Maybe (Maybe(..), fromMaybe, isJust, maybe)
 import Data.Monoid (guard)
 import Data.String (null, split) as S
+import Data.String (null, stripPrefix)
 import Data.String.Pattern (Pattern(..))
 import Data.Tuple (fst, snd)
 import Effect.Aff (Aff)
 import Effect.Class (liftEffect)
-import Globals (app', mmoment8601)
+import Effect.Console (log)
+import Globals (app', mmoment8601, setFocus, closeWindow)
 import Halogen as H
 import Halogen.HTML (br_, button, div, form, input, label, p, span, text, textarea)
 import Halogen.HTML as HH
 import Halogen.HTML.Events (onChecked, onClick, onSubmit, onValueChange)
-import Halogen.HTML.Properties (ButtonType(..), InputType(..), checked, for, id_, name, rows, title, type_, value)
+import Halogen.HTML.Properties (ButtonType(..), InputType(..), autofocus, checked, for, id, name, rows, title, type_, value)
 import Model (Note)
-import Util (_loc, class_, fromNullableStr, ifElseH, whenH)
+import Type.Proxy (Proxy(..))
+import Util (_curQuerystring, _doc, _loc, _lookupQueryStringValue, class_, fromNullableStr, ifElseH, whenH)
 import Web.Event.Event (Event, preventDefault)
-import Web.HTML.Location (setHref)
+import Web.HTML (window)
-import Data.Symbol (SProxy(..))
+import Web.HTML.HTMLDocument (referrer)
+import Web.HTML.Location (origin, setHref)
 
 data NAction
   = NNop
@@ -40,6 +46,7 @@ type NState =
   , deleteAsk :: Boolean
   , edit :: Boolean
   , destroyed :: Boolean
+  , apiError :: Maybe String
   }
 
 _note :: Lens' NState Note
@@ -51,6 +58,9 @@ _edit_note = lens _.edit_note (_ { edit_note = _ })
 _edit :: Lens' NState Boolean
 _edit = lens _.edit (_ { edit = _ })
 
+_apiError :: Lens' NState (Maybe String)
+_apiError = lens _.apiError (_ { apiError = _ })
+
 -- | FormField Edits
 data EditField
   = Etitle String
@@ -58,13 +68,13 @@ data EditField
   | EisMarkdown Boolean
   | Eshared Boolean
 
-_markdown = SProxy :: SProxy "markdown"
+_markdown = Proxy :: Proxy "markdown"
 
 type ChildSlots =
   ( markdown :: Markdown.Slot Unit
   )
 
-nnote :: forall q i o. Note -> H.Component HH.HTML q i o Aff
+nnote :: forall q i o. Note -> H.Component q i o Aff
 nnote st' =
   H.mkComponent
     { initialState: const (mkState st')
@@ -80,10 +90,11 @@ nnote st' =
     , deleteAsk: false
     , edit: note'.id <= 0
     , destroyed: false
+    , apiError: Nothing
     }
 
   render :: NState -> H.ComponentHTML NAction ChildSlots Aff
-  render st@{ note, edit_note } =
+  render st@{ note, edit_note, apiError } =
     ifElseH st.destroyed
        display_destroyed
        (const (ifElseH st.edit
@@ -92,7 +103,7 @@ nnote st' =
     where
 
       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_ ("link f5 lh-title")]
                [ text $ if S.null note.title then "[no title]" else note.title ]
@@ -110,12 +121,12 @@ nnote st' =
              ]
            , whenH app.dat.isowner $ \_ ->
                div [ class_ "edit_links db mt3" ]
-                 [ button [ type_ ButtonButton, onClick \_ -> Just (NEdit true), class_ "edit light-silver hover-blue" ] [ text "edit  " ]
+                 [ button [ type_ ButtonButton, onClick \_ -> NEdit true, class_ "edit light-silver hover-blue" ] [ text "edit  " ]
                  , div [ class_ "delete_link di" ]
-                   [ button [ type_ ButtonButton, onClick \_ -> Just (NDeleteAsk true), class_ ("delete light-silver hover-blue" <> guard st.deleteAsk " dn") ] [ text "delete" ]
+                   [ button [ type_ ButtonButton, onClick \_ -> NDeleteAsk true, class_ ("delete light-silver hover-blue" <> guard st.deleteAsk " dn") ] [ text "delete" ]
                    , span ([ class_ ("confirm red" <> guard (not st.deleteAsk) " dn") ] )
-                     [ button [ type_ ButtonButton, onClick \_ -> Just (NDeleteAsk false)] [ text "cancel / " ]
+                     [ button [ type_ ButtonButton, onClick \_ -> NDeleteAsk false] [ text "cancel / " ]
-                     , button [ type_ ButtonButton, onClick \_ -> Just NDestroy, class_ "red" ] [ text "destroy" ]
+                     , button [ type_ ButtonButton, onClick \_ -> NDestroy, class_ "red" ] [ text "destroy" ]
                      ]
                    ]
                  ]
@@ -123,25 +134,27 @@ nnote st' =
            ]
 
       renderNote_edit _ =
-        form [ onSubmit (Just <<< NEditSubmit) ]
+        form [ onSubmit NEditSubmit ]
-          [ p [ class_ "mt2 mb1"] [ text "title:" ]
+          [ whenH (isJust apiError)
-          , input [ type_ InputText , class_ "title w-100 mb1 pt1 f7 edit_form_input" , name "title"
+              (alert_notification (fromMaybe "" apiError))
-                  , value (edit_note.title) , onValueChange (editField Etitle)
+          , p [ class_ "mt2 mb1"] [ text "title:" ]
+          , 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_
           , p [ class_ "mt2 mb1"] [ text "description:" ]
-          , textarea [ class_ "description w-100 mb1 pt1 f7 edit_form_input" , name "text", rows 30
+          , textarea [ id (notetextid edit_note), class_ "description w-100 mb1 pt1 edit_form_input" , name "text", rows 25
                      , value (edit_note.text) , onValueChange (editField Etext)
             ]
           , 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) ]
              , text " "
              , label [ for "edit_ismarkdown" , class_ "mr2" ] [ text "use markdown?" ]
              , br_
             ]
           , 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) ]
             , text " "
             , label [ for "edit_shared" , class_ "mr2" ] [ text "public?" ]
@@ -154,20 +167,24 @@ nnote st' =
           , input [ type_ InputReset
                   , class_ "pv1 ph2 dark-gray ba b--moon-gray bg-near-white pointer rdim"
                   , value "cancel"
-                  , onClick \_ -> Just (NEdit false)
+                  , onClick \_ -> NEdit false
                   ]
           ]
 
       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
-      editField :: forall a. (a -> EditField) -> a -> Maybe NAction
+      editField :: forall a. (a -> EditField) -> a -> NAction
-      editField f = Just <<< NEditField <<< f
+      editField f = NEditField <<< f
       toTextarea input =
         S.split (Pattern "\n") input
         # foldMap (\x -> [br_, text x])
         # drop 1
 
+  notetextid note = show note.id <> "_text"
 
   handleAction :: NAction -> H.HalogenM NState NAction ChildSlots o Aff Unit
   handleAction (NNop) = pure unit
@@ -195,18 +212,38 @@ nnote st' =
     note <- use _note
     _edit_note .= note
     _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
   handleAction (NEditSubmit e) = do
     H.liftEffect (preventDefault e)
     edit_note <- use _edit_note
-    res <- H.liftAff (editNote edit_note)
+    _apiError .= Nothing
-    case res.body of
+    H.liftAff (editNote edit_note) >>= case _ of
-      Left err -> pure unit
+      Left affErr -> do
-      Right r -> do
+        _apiError .= Just (printError affErr)
-        if (edit_note.id == 0)
+        liftEffect $ log (printError affErr)
-          then do
+      Right { status: StatusCode s } | s >= 200 && s < 300 -> do
-            liftEffect (setHref (fromNullableStr app.noteR) =<< _loc)
+        qs <- liftEffect _curQuerystring
-          else do
+        doc <- liftEffect $ _doc
-            _note .= edit_note
+        ref <- liftEffect $ referrer doc
-            _edit .= false
+        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
+                   _note .= edit_note
+                   _edit .= false
+      Right res -> do
+        _apiError .= Just (res.body)
+        liftEffect $ log (res.body)

purs/src/Component/RawHtml.js

@@ -1,5 +1,5 @@
 // use at your own risk!
-exports.unsafeSetInnerHTML = function(element) {
+export const unsafeSetInnerHTML = function(element) {
   return function(html) {
     return function() {
       element.innerHTML = html;

purs/src/Component/RawHtml.purs

@@ -19,6 +19,7 @@ data Action i
   = SetInnerHTML
   | Receive (Input i)
 
+type Input :: forall k. k -> k
 type Input i = i
 
 type State i =
@@ -26,10 +27,10 @@ type State i =
   , inputval :: Input i
   }
 
-component :: forall q o. H.Component HH.HTML q (Input String) o Aff
+component :: forall q o. H.Component q (Input String) o Aff
 component = mkComponent RawHTML
 
-mkComponent :: forall q i o. (Input i -> RawHTML) -> H.Component HH.HTML q (Input i) o Aff
+mkComponent :: forall q i o. (Input i -> RawHTML) -> H.Component q (Input i) o Aff
 mkComponent toRawHTML =
   H.mkComponent
     { initialState: \inputval -> { elRef: H.RefLabel "inputval", inputval } 
@@ -53,7 +54,7 @@ mkComponent toRawHTML =
       mel <- H.getHTMLElementRef elRef
       for_ mel \el -> do  
         { inputval } <- H.get
-        H.liftAff $ forkAff $ makeAff \cb -> do
+        H.liftAff $ forkAff $ makeAff \_ -> do
           liftEffect $ unsafeSetInnerHTML el (toRawHTML inputval)
           mempty
       pure unit

purs/src/Component/TagCloud.purs

@@ -0,0 +1,173 @@
+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)

purs/src/Globals.js

@@ -1,67 +1,59 @@
-"use strict";
+"use strict";
-
+
-var moment = require("moment");
+import moment from 'moment'
-
+
-exports._app = function() {
+export const _app = function() {
-  return app;
+  return app;
-}
+}
-
+
-exports._closest = function(just, nothing, selector, el) {
+export const _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);
-  } else {
+  } else {
-    return nothing;
+    return nothing;
-  }
+  }
-}
+}
-
+
-exports._innerHtml = function(el) {
+export const _createFormData = function(formElement) {
-  return el.innerHTML;
+  return new FormData(formElement);
-}
+}
-
+
-exports._setInnerHtml = function(content, el) {
+export const _createFormString = function(formElement) {
-  el.innerHTML = content;
+  return new URLSearchParams(new FormData(formElement)).toString()
-  return el;
+}
-}
+
-
+export const _createFormArray = function(formElement) {
-exports._createFormData = function(formElement) {
+  return Array.from(new FormData(formElement));
-  return new FormData(formElement);
+}
-}
+
-
+export const _moment8601 = function(tuple, s) {
-exports._createFormString = function(formElement) {
+  var m = moment(s, moment.ISO_8601);
-  return new URLSearchParams(new FormData(formElement)).toString()
+  var s1 = m.fromNow();
-}
+  var s2 = m.format('MMMM D YYYY, h:mm a') + " (" + m.format() + ") ";
-
+  return tuple(s1)(s2);
-exports._createFormArray = function(formElement) {
+}
-  return Array.from(new FormData(formElement));
+
-}
+export const _mmoment8601 = function(just, nothing, tuple, s) {
-
+  try {
-exports._getDataAttribute = function(name, el) {
+    var m = moment(s, moment.ISO_8601);
-  return el.dataset[name];
+    var s1 = m.fromNow();
-}
+    var s2 = m.format('MMMM D YYYY, h:mm a') + " (" + m.format() + ") ";
-
+    return just(tuple(s1)(s2));
-exports._setDataAttribute = function(name, value, el) {
+  } catch (error) {
-  return el.dataset[name] = value;
+    return nothing
-}
+  }
-
+}
-exports._moment8601 = function(tuple, s) {
+
-  var m = moment(s, moment.ISO_8601);
+export const _closeWindow = function (window) {
-  var s1 = m.fromNow();
+  window.close();
-  var s2 = m.format('MMMM D YYYY, h:mm a') + " (" + m.format() + ") ";
+};
-  return tuple(s1)(s2);
+
-}
+export const _setFocus = function(elemId) {
-
+    document.getElementById(elemId).focus();
-exports._mmoment8601 = function(just, nothing, tuple, s) {
+};
-  try {
+
-    var m = moment(s, moment.ISO_8601);
+
-    var s1 = m.fromNow();
+export const _toLocaleDateString = function(dateString) {
-    var s2 = m.format('MMMM D YYYY, h:mm a') + " (" + m.format() + ") ";
+  return new Date(dateString).toLocaleDateString(undefined, {dateStyle: 'medium'}) 
-    return just(tuple(s1)(s2));
+}
-  } catch (error) {
-    return nothing
-  }
-}
-
-exports._closeWindow = function (window) {
-  window.close();
-};

purs/src/Globals.purs

@@ -1,97 +1,87 @@
-module Globals where
+module Globals where
-
+
-import Data.Function.Uncurried
+import Data.Maybe (Maybe(..))
-
+import Data.Newtype (class Newtype)
-import Data.Maybe (Maybe(..))
+import Data.Nullable (Nullable)
-import Data.Nullable (Nullable, toMaybe)
+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 Model (Bookmark)
+import Effect.Uncurried (EffectFn1, EffectFn2, EffectFn4, runEffectFn1, runEffectFn2, runEffectFn4)
-import Prelude (Unit, pure, ($))
+import Model (Bookmark)
-import Web.DOM (Element, Node)
+import Prelude (Unit)
-import Web.HTML (HTMLElement, HTMLFormElement, Window)
+import Web.DOM (Node)
-import Web.XHR.FormData (FormData)
+import Web.HTML (HTMLFormElement, Window)
-import Data.Newtype (class Newtype)
+import Web.XHR.FormData (FormData)
-
+
-type App =
+type App =
-    { csrfHeaderName :: String
+    { csrfHeaderName :: String
-    , csrfCookieName :: String
+    , csrfCookieName :: String
-    , csrfParamName :: String
+    , csrfParamName :: String
-    , csrfToken :: String
+    , csrfToken :: String
-    , homeR :: String
+    , homeR :: String
-    , authRlogoutR :: String
+    , authRlogoutR :: String
-    , userR :: Nullable String
+    , userR :: Nullable String
-    , noteR :: Nullable String
+    , noteR :: Nullable String
-    , dat :: AppData
+    , dat :: AppData
-    }
+    }
-
+
-type AppData =
+type AppData =
-  { bmarks :: Array Bookmark
+  { bmarks :: Array Bookmark
-  , bmark :: Bookmark
+  , bmark :: Bookmark
-  , isowner :: Boolean
+  , isowner :: Boolean
-  }
+  }
-
+
-foreign import _app :: Fn0 App
+foreign import _app :: Fn0 App
-
+
-app' :: Unit -> App
+app' :: Unit -> App
-app' _ = runFn0 _app
+app' _ = runFn0 _app
-
+
-foreign import _closest :: forall a. Fn4 (a -> Maybe a) (Maybe a) String Node (Maybe Node)
+foreign import _closest :: forall a. EffectFn4 (a -> Maybe a) (Maybe a) String Node (Maybe Node)
-
+
-closest :: String -> Node -> Effect (Maybe Node)
+closest :: String -> Node -> Effect (Maybe Node)
-closest selector node = pure $ runFn4 _closest Just Nothing selector node 
+closest selector node = runEffectFn4 _closest Just Nothing selector node 
-
+
-foreign import _moment8601 :: Fn2 (String -> String -> Tuple String String) String (Tuple String String)
+foreign import _moment8601 :: EffectFn2 (String -> String -> Tuple String String) String (Tuple String String)
-
+
-moment8601 :: String -> Effect (Tuple String String)
+moment8601 :: String -> Effect (Tuple String String)
-moment8601 s = pure $ runFn2 _moment8601 Tuple s
+moment8601 s = runEffectFn2 _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
+foreign import _createFormData :: Fn1 HTMLFormElement FormData
-
+
-innerHtml :: HTMLElement -> Effect String
+createFormData :: HTMLFormElement -> FormData
-innerHtml n = pure $ runFn1 _innerHtml n
+createFormData f = runFn1 _createFormData f
-
+
-foreign import _setInnerHtml :: Fn2 String HTMLElement HTMLElement
+foreign import _createFormString :: Fn1 HTMLFormElement String
-
+
-setInnerHtml :: String -> HTMLElement -> Effect HTMLElement
+createFormString :: HTMLFormElement -> String
-setInnerHtml c n = pure $ runFn2 _setInnerHtml c n
+createFormString f = runFn1 _createFormString f
-
+
-foreign import _createFormData :: Fn1 HTMLFormElement FormData
+
-
+foreign import _createFormArray :: Fn1 HTMLFormElement (Array (Array String))
-createFormData :: HTMLFormElement -> FormData
+
-createFormData f = runFn1 _createFormData f
+createFormArray :: HTMLFormElement -> (Array (Array String))
-
+createFormArray f = runFn1 _createFormArray f
-foreign import _createFormString :: Fn1 HTMLFormElement String
+
-
+foreign import _closeWindow :: EffectFn1 Window Unit
-createFormString :: HTMLFormElement -> String
+
-createFormString f = runFn1 _createFormString f
+closeWindow :: Window -> Effect Unit
-
+closeWindow win = runEffectFn1 _closeWindow win
-
+
-foreign import _createFormArray :: Fn1 HTMLFormElement (Array (Array String))
+newtype RawHTML = RawHTML String
-
+
-createFormArray :: HTMLFormElement -> (Array (Array String))
+derive instance newtypeRawHTML :: Newtype RawHTML _
-createFormArray f = runFn1 _createFormArray f
+
-
+foreign import _setFocus :: EffectFn1 String Unit
-foreign import _getDataAttribute :: Fn2 String Element (Nullable String)
+
-
+setFocus :: String -> Effect Unit
-getDataAttribute :: String -> Element -> Effect (Maybe String)
+setFocus s = runEffectFn1 _setFocus s
-getDataAttribute k n = pure $ toMaybe $ runFn2 _getDataAttribute k n
+
-
+foreign import _toLocaleDateString :: Fn1 String String
-foreign import _setDataAttribute :: Fn3 String String Element Unit
+
-
+toLocaleDateString :: String -> String
-setDataAttribute :: String -> String -> Element -> Effect Unit
+toLocaleDateString s = runFn1 _toLocaleDateString s
-setDataAttribute k v n = pure $ runFn3 _setDataAttribute k v n
-
-foreign import _closeWindow :: Fn1 Window Unit
-
-closeWindow :: Window -> Effect Unit
-closeWindow win = pure $ runFn1 _closeWindow win
-
-newtype RawHTML = RawHTML String
-
-derive instance newtypeRawHTML :: Newtype RawHTML _

purs/src/Main.js

@@ -1,5 +0,0 @@
-"use strict";
-
-exports._mainImpl = function() {
-  return window.PS = PS;
-}

purs/src/Main.purs

@@ -1,68 +1,70 @@
-module Main where
+module Main where
-
+
-import Prelude
+import Prelude
-
+
-import App (logout)
+import App (logout)
-import Component.Add (addbmark)
+import Component.AccountSettings (usetting)
-import Component.BList (blist)
+import Component.Add (addbmark)
-import Component.NList (nlist)
+import Component.BList (blist)
-import Component.NNote (nnote)
+import Component.NList (nlist)
-import Component.AccountSettings (usetting)
+import Component.NNote (nnote)
-import Data.Foldable (traverse_)
+import Component.TagCloud (tagcloudcomponent)
-import Effect (Effect)
+import Data.Foldable (traverse_)
-import Effect.Aff (Aff, launchAff)
+import Effect (Effect)
-import Effect.Class (liftEffect)
+import Effect.Aff (Aff, launchAff)
-import Halogen.Aff as HA
+import Effect.Class (liftEffect)
-import Halogen.VDom.Driver (runUI)
+import Halogen.Aff as HA
-import Model (Bookmark, Note, AccountSettings)
+import Halogen.VDom.Driver (runUI)
-import Web.DOM.Element (setAttribute)
+import Model (AccountSettings, Bookmark, Note, TagCloudMode, tagCloudModeToF)
-import Web.DOM.ParentNode (QuerySelector(..))
+import Web.DOM.Element (setAttribute)
-import Web.Event.Event (Event, preventDefault)
+import Web.DOM.ParentNode (QuerySelector(..))
-import Web.HTML.HTMLElement (toElement)
+import Web.Event.Event (Event, preventDefault)
-
+import Web.HTML.HTMLElement (toElement)
-foreign import _mainImpl :: Effect Unit
+
-
+logoutE :: Event -> Effect Unit
-main :: Effect Unit
+logoutE e = void <<< launchAff <<< logout =<< preventDefault e
-main = _mainImpl
+
-
+renderBookmarks :: String -> Array Bookmark -> Effect Unit
-logoutE :: Event -> Effect Unit
+renderBookmarks renderElSelector bmarks = do
-logoutE e = void <<< launchAff <<< logout =<< preventDefault e
+  HA.runHalogenAff do
-
+    HA.selectElement (QuerySelector renderElSelector) >>= traverse_ \el -> do
-renderBookmarks :: String -> Array Bookmark -> Effect Unit
+      void $ runUI (blist bmarks) unit el
-renderBookmarks renderElSelector bmarks = do
+      viewRendered
-  HA.runHalogenAff do
+
-    HA.selectElement (QuerySelector renderElSelector) >>= traverse_ \el -> do
+renderTagCloud :: String -> TagCloudMode -> Effect Unit
-      void $ runUI (blist bmarks) unit el
+renderTagCloud renderElSelector tagCloudMode = do
-      viewRendered
+  HA.runHalogenAff do
-
+    HA.selectElement (QuerySelector renderElSelector) >>= traverse_ \el -> do
-renderAddForm :: String -> Bookmark -> Effect Unit
+      void $ runUI (tagcloudcomponent (tagCloudModeToF tagCloudMode)) unit el
-renderAddForm renderElSelector bmark = do
+
-  HA.runHalogenAff do
+renderAddForm :: String -> Bookmark -> Effect Unit
-    HA.selectElement (QuerySelector renderElSelector) >>= traverse_ \el -> do
+renderAddForm renderElSelector bmark = do
-      void $ runUI (addbmark bmark) unit el
+  HA.runHalogenAff do
-      viewRendered
+    HA.selectElement (QuerySelector renderElSelector) >>= traverse_ \el -> do
-
+      void $ runUI (addbmark bmark) unit el
-renderNotes :: String -> Array Note -> Effect Unit
+      viewRendered
-renderNotes renderElSelector notes = do
+
-  HA.runHalogenAff do
+renderNotes :: String -> Array Note -> Effect Unit
-    HA.selectElement (QuerySelector renderElSelector) >>= traverse_ \el -> do
+renderNotes renderElSelector notes = do
-      void $ runUI (nlist notes) unit el
+  HA.runHalogenAff do
-      viewRendered
+    HA.selectElement (QuerySelector renderElSelector) >>= traverse_ \el -> do
-
+      void $ runUI (nlist notes) unit el
-renderNote :: String -> Note -> Effect Unit
+      viewRendered
-renderNote renderElSelector note = do
+
-  HA.runHalogenAff do
+renderNote :: String -> Note -> Effect Unit
-    HA.selectElement (QuerySelector renderElSelector) >>= traverse_ \el -> do
+renderNote renderElSelector note = do
-      void $ runUI (nnote note) unit el
+  HA.runHalogenAff do
-      viewRendered
+    HA.selectElement (QuerySelector renderElSelector) >>= traverse_ \el -> do
-
+      void $ runUI (nnote note) unit el
-renderAccountSettings :: String -> AccountSettings -> Effect Unit
+      viewRendered
-renderAccountSettings renderElSelector accountSettings = do
+
-  HA.runHalogenAff do
+renderAccountSettings :: String -> AccountSettings -> Effect Unit
-    HA.selectElement (QuerySelector renderElSelector) >>= traverse_ \el -> do
+renderAccountSettings renderElSelector accountSettings = do
-      void $ runUI (usetting accountSettings) unit el
+  HA.runHalogenAff do
-      viewRendered
+    HA.selectElement (QuerySelector renderElSelector) >>= traverse_ \el -> do
-
+      void $ runUI (usetting accountSettings) unit el
-viewRendered :: Aff Unit
+      viewRendered
-viewRendered = HA.selectElement (QuerySelector "#content") >>= traverse_ \el ->
+
-  liftEffect $ setAttribute "view-rendered" "" (toElement el) 
+viewRendered :: Aff Unit
+viewRendered = HA.selectElement (QuerySelector "#content") >>= traverse_ \el ->
+  liftEffect $ setAttribute "view-rendered" "" (toElement el) 

purs/src/Marked.js

@@ -1,11 +1,12 @@
-var marked = require("marked");
+import { marked } from 'marked';
+import DOMPurify from "dompurify"
 
 marked.setOptions({
   pedantic: false,
   gfm: true
 });
 
-exports.markedImpl = function(str) {
+export const markedImpl = function(str) {
   if (!str) return "";
-  return marked(str);
+  return DOMPurify.sanitize(marked.parse(str));
 };

purs/src/Model.purs

@@ -1,54 +1,129 @@
-module Model where
+module Model where
-
+
-import Data.Nullable (Nullable)
+import Control.Monad.Except (runExcept)
-import Simple.JSON as J
+import Data.Array (intercalate)
-
+import Data.Either (hush)
-type BookmarkId = Int
+import Data.Maybe (fromMaybe)
-type TagId = Int
+import Data.Nullable (Nullable)
-
+import Data.String (Pattern(..), split)
-type Bookmark =
+import Foreign (Foreign, readInt, readString, unsafeToForeign)
-  { url :: String
+import Foreign.Object (Object)
-  , title :: String
+import Prelude (class Eq, pure, ($), (<$>))
-  , description :: String
+import Simple.JSON as J
-  , tags :: String
+
-  , private :: Boolean
+type BookmarkId = Int
-  , toread :: Boolean
+type TagId = Int
-  , bid :: BookmarkId
+
-  , slug :: String
+type Bookmark =
-  , selected :: Boolean
+  { url :: String
-  , time :: String
+  , title :: String
-  , archiveUrl :: Nullable String
+  , description :: String
-  }
+  , tags :: String
-
+  , private :: Boolean
-newtype Bookmark' = Bookmark' Bookmark
+  , toread :: Boolean
-derive newtype instance bookmark_rfI :: J.ReadForeign Bookmark'
+  , bid :: BookmarkId
-derive newtype instance bookmark_wfI :: J.WriteForeign Bookmark'
+  , slug :: String
-
+  , selected :: Boolean
-type NoteId = Int
+  , time :: String
-type NoteSlug = String
+  , archiveUrl :: Nullable String
-
+  }
-type Note =
+
-  { id :: NoteId
+newtype Bookmark' = Bookmark' Bookmark
-  , slug :: NoteSlug
+derive newtype instance J.ReadForeign Bookmark'
-  , title :: String
+derive newtype instance J.WriteForeign Bookmark'
-  , text :: String
+
-  , length :: Int
+type NoteId = Int
-  , isMarkdown :: Boolean
+type NoteSlug = String
-  , shared :: Boolean
+
-  , created :: String
+type Note =
-  , updated :: String
+  { id :: NoteId
-  }
+  , slug :: NoteSlug
-
+  , title :: String
-newtype Note' = Note' Note
+  , text :: String
-derive newtype instance note_rfI :: J.ReadForeign Note'
+  , length :: Int
-derive newtype instance note_wfI :: J.WriteForeign Note'
+  , isMarkdown :: Boolean
-
+  , shared :: Boolean
-type AccountSettings =
+  , created :: String
-  { archiveDefault :: Boolean
+  , updated :: String
-  , privateDefault :: Boolean
+  }
-  , privacyLock :: Boolean
+
-  }
+newtype Note' = Note' Note
-
+derive newtype instance J.ReadForeign Note'
-newtype AccountSettings' = AccountSettings' AccountSettings
+derive newtype instance J.WriteForeign Note'
-derive newtype instance usersettings_rfI :: J.ReadForeign AccountSettings'
+
-derive newtype instance usersettings_wfI :: J.WriteForeign AccountSettings'
+type AccountSettings =
+  { archiveDefault :: Boolean
+  , privateDefault :: Boolean
+  , privacyLock :: Boolean
+  }
+
+newtype AccountSettings' = AccountSettings' AccountSettings
+derive newtype instance J.ReadForeign AccountSettings'
+derive newtype instance 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

purs/src/Util.purs

@@ -1,142 +1,155 @@
-module Util where
+module Util where
-
+
-import Prelude
+import Prelude
-
+
-import Control.Monad.Maybe.Trans (MaybeT(..))
+import Control.Monad.Maybe.Trans (MaybeT(..))
-import Data.Array (filter, find, mapMaybe)
+import Data.Array (filter, find, mapMaybe)
-import Data.Foldable (for_)
+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.Tuple (Tuple(..), fst, snd)
+import Data.String as S
-import Effect (Effect)
+import Data.Tuple (Tuple(..), fst, snd)
-import Global.Unsafe (unsafeDecodeURIComponent)
+import Effect (Effect)
-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 Partial.Unsafe (unsafePartial)
+import JSURI (decodeURIComponent, encodeURIComponent)
-import Web.DOM (Element, Node)
+import Partial.Unsafe (unsafePartial)
-import Web.DOM.Document (toNonElementParentNode)
+import Web.DOM (Element, Node)
-import Web.DOM.Element (fromNode, toParentNode)
+import Web.DOM.Document (toNonElementParentNode)
-import Web.DOM.NodeList (toArray)
+import Web.DOM.Element (fromNode, toParentNode)
-import Web.DOM.NonElementParentNode (getElementById)
+import Web.DOM.NodeList (toArray)
-import Web.DOM.ParentNode (QuerySelector(..), querySelector, querySelectorAll)
+import Web.DOM.NonElementParentNode (getElementById)
-import Web.HTML (HTMLDocument, Location, window)
+import Web.DOM.ParentNode (QuerySelector(..), querySelector, querySelectorAll)
-import Web.HTML.HTMLDocument (body) as HD
+import Web.HTML (HTMLDocument, Location, window)
-import Web.HTML.HTMLDocument (toDocument)
+import Web.HTML.HTMLDocument (body) as HD
-import Web.HTML.HTMLElement (HTMLElement)
+import Web.HTML.HTMLDocument (toDocument)
-import Web.HTML.HTMLElement (fromElement) as HE
+import Web.HTML.HTMLElement (HTMLElement)
-import Web.HTML.Location (search)
+import Web.HTML.HTMLElement (fromElement) as HE
-import Web.HTML.Window (document, location)
+import Web.HTML.Location (search)
-  
+import Web.HTML.Window (document, location)
--- Halogen
+
-
+unsafeDecode :: String -> String
-class_ :: forall r i. String -> HP.IProp ( "class" :: String | r) i
+unsafeDecode str = unsafePartial $ fromJust $ decodeURIComponent str
-class_ = HP.class_ <<< HH.ClassName
+  
-
+-- Halogen
-attr :: forall r i. String -> String -> HP.IProp r i
+
-attr a = HP.attr (HH.AttrName a)
+class_ :: forall r i. String -> HP.IProp ( "class" :: String | r) i
-
+class_ = HP.class_ <<< HH.ClassName
--- Util
+
-
+attr :: forall r i. String -> String -> HP.IProp r i
-_queryBoth :: forall a. Tuple String Element -> Tuple String Element -> (Element -> Element -> Effect a) -> Effect Unit
+attr a = HP.attr (HH.AttrName a)
-_queryBoth (Tuple qa ea) (Tuple qb eb) f = do
+
-   ma <- _querySelector qa ea
+-- Util
-   mb <- _querySelector qb eb
+
-   for_ ma \a -> 
+_queryBoth :: forall a. Tuple String Element -> Tuple String Element -> (Element -> Element -> Effect a) -> Effect Unit
-     for_ mb \b ->
+_queryBoth (Tuple qa ea) (Tuple qb eb) f = do
-       f a b
+   ma <- _querySelector qa ea
-
+   mb <- _querySelector qb eb
-_queryBoth' :: forall a. Tuple String Element -> Tuple String Element -> (Element -> Array Node -> Effect a) -> Effect Unit
+   for_ ma \a -> 
-_queryBoth' (Tuple qa ea) (Tuple qb eb) f = do
+     for_ mb \b ->
-   ma <- _querySelector qa ea
+       f a b
-   bs <- _querySelectorAll qb eb
+
-   for_ ma \a -> 
+_queryBoth' :: forall a. Tuple String Element -> Tuple String Element -> (Element -> Array Node -> Effect a) -> Effect Unit
-     f a bs
+_queryBoth' (Tuple qa ea) (Tuple qb eb) f = do
-
+   ma <- _querySelector qa ea
-_queryBoth'' :: forall a. Tuple String Element -> Tuple String Element -> (Array Node -> Array Node -> Effect a) -> Effect a
+   bs <- _querySelectorAll qb eb
-_queryBoth'' (Tuple qa ea) (Tuple qb eb) f = do
+   for_ ma \a -> 
-   as <- _querySelectorAll qa ea
+     f a bs
-   bs <- _querySelectorAll qb eb
+
-   f as bs
+_queryBoth'' :: forall a. Tuple String Element -> Tuple String Element -> (Array Node -> Array Node -> Effect a) -> Effect a
-
+_queryBoth'' (Tuple qa ea) (Tuple qb eb) f = do
-_querySelector :: String -> Element -> Effect (Maybe Element)
+   as <- _querySelectorAll qa ea
-_querySelector s n = querySelector (QuerySelector s) (toParentNode n)
+   bs <- _querySelectorAll qb eb
-
+   f as bs
-_querySelectorAll :: String -> Element -> Effect (Array Node)
+
-_querySelectorAll s n = toArray =<< querySelectorAll (QuerySelector s) (toParentNode n)
+_querySelector :: String -> Element -> Effect (Maybe Element)
-
+_querySelector s n = querySelector (QuerySelector s) (toParentNode n)
-_fromNode :: Node -> Element
+
-_fromNode e = unsafePartial $ fromJust (fromNode e)
+_querySelectorAll :: String -> Element -> Effect (Array Node)
-
+_querySelectorAll s n = toArray =<< querySelectorAll (QuerySelector s) (toParentNode n)
-_fromElement :: Element -> HTMLElement
+
-_fromElement e = unsafePartial $ fromJust (HE.fromElement e)
+_fromNode :: Node -> Element
-
+_fromNode e = unsafePartial $ fromJust (fromNode e)
-_getElementById :: String -> HTMLDocument -> Effect (Maybe Element)
+
-_getElementById s = getElementById s <<< toNonElementParentNode <<< toDocument
+_fromElement :: Element -> HTMLElement
-
+_fromElement e = unsafePartial $ fromJust (HE.fromElement e)
-_doc :: Effect HTMLDocument
+
-_doc = document =<< window 
+_getElementById :: String -> HTMLDocument -> Effect (Maybe Element)
-
+_getElementById s = getElementById s <<< toNonElementParentNode <<< toDocument
-_loc :: Effect Location
+
-_loc = location =<< window 
+_doc :: Effect HTMLDocument
-
+_doc = document =<< window 
-type QueryStringArray = Array (Tuple String (Maybe String))
+
-
+_loc :: Effect Location
-_curQuerystring :: Effect QueryStringArray
+_loc = location =<< window 
-_curQuerystring = do
+
-  loc <- _loc
+type QueryStringArray = Array (Tuple String (Maybe String))
-  srh <- search loc
+
-  pure $ _parseQueryString srh
+_curQuerystring :: Effect QueryStringArray
-
+_curQuerystring = do
-_parseQueryString :: String -> QueryStringArray
+  loc <- _loc
-_parseQueryString srh = do
+  srh <- search loc
-  let qs = let srh' = take 1 srh in if (srh' == "#" || srh' == "?") then drop 1 srh else srh
+  pure $ _parseQueryString srh
-  mapMaybe go $ (filter (_ /= "") <<< split (Pattern "&")) qs
+
-  where
+_parseQueryString :: String -> QueryStringArray
-    decode = unsafeDecodeURIComponent <<< replaceAll (Pattern "+") (Replacement " ")
+_parseQueryString srh = do
-    go kv =
+  let qs = let srh' = take 1 srh in if (srh' == "#" || srh' == "?") then drop 1 srh else srh
-      case split (Pattern "=") kv of
+  mapMaybe go $ (filter (_ /= "") <<< split (Pattern "&")) qs
-        [k] -> Just (Tuple (decode k) Nothing)
+  where
-        [k, v] -> Just (Tuple (decode k) (Just (decode v)))
+    decode = unsafeDecode <<< replaceAll (Pattern "+") (Replacement " ")
-        _ -> Nothing
+    go kv =
-
+      case split (Pattern "=") kv of
-_lookupQueryStringValue :: QueryStringArray -> String -> Maybe String
+        [k] -> Just (Tuple (decode k) Nothing)
-_lookupQueryStringValue qs k = do
+        [k, v] -> Just (Tuple (decode k) (Just (decode v)))
-  join $ map snd $ find ((_ == k) <<< fst) qs
+        _ -> Nothing
-
+
-_body :: Effect HTMLElement
+_lookupQueryStringValue :: QueryStringArray -> String -> Maybe String
-_body = unsafePartial $ pure <<< fromJust =<< HD.body =<< _doc
+_lookupQueryStringValue qs k = do
-
+  join $ map snd $ find ((_ == k) <<< fst) qs
-_mt :: forall a. Effect (Maybe a) -> MaybeT Effect a
+
-_mt = MaybeT
+_body :: Effect HTMLElement
-
+_body = unsafePartial $ pure <<< fromJust =<< HD.body =<< _doc
-_mt_pure :: forall a. Maybe a -> MaybeT Effect a
+
-_mt_pure = MaybeT <<< pure
+_mt :: forall a. Effect (Maybe a) -> MaybeT Effect a
-
+_mt = MaybeT
-dummyAttr :: forall r i. HP.IProp r i
+
-dummyAttr = HP.attr (HH.AttrName "data-dummy") ""
+_mt_pure :: forall a. Maybe a -> MaybeT Effect a
-
+_mt_pure = MaybeT <<< pure
-whenP :: forall r i. Boolean -> HP.IProp r i -> HP.IProp r i
+
-whenP b p = if b then p else dummyAttr
+encodeTag :: String -> String
-
+encodeTag = fromMaybe "" <<< encodeURIComponent <<< replaceAll (Pattern "+") (Replacement "%2B")
-maybeP :: forall a r i. Maybe a -> (a -> HP.IProp r i) -> HP.IProp r i
+
-maybeP m p = maybe dummyAttr p m
+dummyAttr :: forall r i. HP.IProp r i
-  
+dummyAttr = HP.attr (HH.AttrName "data-dummy") ""
-whenC :: Boolean -> ClassName -> ClassName
+
-whenC b c = if b then c else ClassName ""
+whenP :: forall r i. Boolean -> HP.IProp r i -> HP.IProp r i
-
+whenP b p = if b then p else dummyAttr
-whenH :: forall p i. Boolean -> (Unit -> HH.HTML p i) -> HH.HTML p i
+
-whenH b k = if b then k unit else HH.text ""
+maybeP :: forall a r i. Maybe a -> (a -> HP.IProp r i) -> HP.IProp r i
-
+maybeP m p = maybe dummyAttr p m
-whenA :: forall t. Boolean -> (Unit -> Array t) -> Array t
+  
-whenA b k = if b then k unit else []
+whenC :: Boolean -> ClassName -> ClassName
-
+whenC b c = if b then c else ClassName ""
-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
+whenH :: forall p i. Boolean -> (Unit -> HH.HTML p i) -> HH.HTML p i
-
+whenH b k = if b then k unit else HH.text ""
-maybeH :: forall a p i. Maybe a -> (a -> HH.HTML p i) -> HH.HTML p i
+
-maybeH m k = maybe (HH.text "") k m
+whenA :: forall t. Boolean -> (Unit -> Array t) -> Array t
-
+whenA b k = if b then k unit else []
-fromNullableStr :: Nullable String -> String
+
-fromNullableStr = fromMaybe "" <<< toMaybe
+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
+
+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 m k = maybe (HH.text "") k m
+
+fromNullableStr :: Nullable String -> String
+fromNullableStr = fromMaybe "" <<< toMaybe
+
+monthNames :: Array String
+monthNames = ["january", "february", "march", "april", "may", "june", "july", "august", "september", "october", "november", "december"]

src/Application.hs

@@ -1,4 +1,5 @@
 {-# OPTIONS_GHC -fno-warn-orphans #-}
+{-# OPTIONS_GHC -fno-warn-partial-type-signatures #-}
 
 module Application
   ( getApplicationDev
@@ -15,7 +16,7 @@ module Application
   ) where
 
 import           Control.Monad.Logger (liftLoc, runLoggingT)
-import           Database.Persist.Sqlite (createSqlitePool, runSqlPool, sqlDatabase, sqlPoolSize)
+import           Database.Persist.Sqlite (ConnectionPool, mkSqliteConnectionInfo, createSqlitePoolFromInfo, fkEnabled, runSqlPool, sqlDatabase, sqlPoolSize)
 import           Import
 import           Language.Haskell.TH.Syntax (qLocation)
 import           Lens.Micro
@@ -28,12 +29,6 @@ import           Network.Wai.Middleware.Gzip
 import           Network.Wai.Middleware.MethodOverride
 import           Network.Wai.Middleware.RequestLogger (Destination(Logger), IPAddrSource(..), OutputFormat(..), destination, mkRequestLogger, outputFormat)
 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.
 -- Don't forget to add new modules to your cabal file!
@@ -52,38 +47,37 @@ makeFoundation :: AppSettings -> IO App
 makeFoundation appSettings = do
   appHttpManager <- getGlobalManager
   appLogger <- newStdoutLoggerSet defaultBufSize >>= makeYesodLogger
-  store <- EKG.newStore
-  EKG.registerGcMetrics store
-  appMetrics <- MM.initializeWith store
   appStatic <-
     (if appMutableStatic appSettings
        then staticDevel
        else static)
       (appStaticDir appSettings)
-  let mkFoundation appConnPool = App { ..}
+  let mkFoundation appConnPool = App {..}
       tempFoundation = mkFoundation (error "connPool forced in tempFoundation")
       logFunc = messageLoggerSource tempFoundation appLogger
-  pool <-
+  pool <- mkPool logFunc True
-    flip runLoggingT logFunc $
+  poolMigrations <- mkPool logFunc False
-    createSqlitePool
+  runLoggingT (runSqlPool runMigrations poolMigrations) logFunc
-      (sqlDatabase (appDatabaseConf appSettings))
-      (sqlPoolSize (appDatabaseConf appSettings))
-  runLoggingT
-    (runSqlPool runMigrations pool)
-    logFunc
   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 foundation = do
   logWare <- makeLogWare foundation
   appPlain <- toWaiAppPlain foundation
-  let store = appMetrics foundation ^. MM.metricsStore
+  return (logWare (makeMiddleware appPlain))
-  waiMetrics <- WM.registerWaiMetrics store
-  return (logWare (makeMiddleware waiMetrics appPlain))
 
-makeMiddleware :: WM.WaiMetrics -> Middleware
+makeMiddleware :: Middleware
-makeMiddleware waiMetrics =
+makeMiddleware =
-  WM.metrics waiMetrics .
   acceptOverride .
   autohead .
   gzip def {gzipFiles = GzipPreCompressed GzipIgnore} .
@@ -127,7 +121,6 @@ getApplicationDev = do
   foundation <- makeFoundation settings
   wsettings <- getDevSettings (warpSettings foundation)
   app <- makeApplication foundation
-  forkEKG foundation
   return (wsettings, app)
 
 getAppSettings :: IO AppSettings
@@ -137,23 +130,12 @@ getAppSettings = loadYamlSettings [configSettingsYml] [] useEnv
 develMain :: IO ()
 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.
 appMain :: IO ()
 appMain = do
   settings <- loadYamlSettingsArgs [configSettingsYmlValue] useEnv
   foundation <- makeFoundation settings
   app <- makeApplication foundation
-  forkEKG foundation
   runSettings (warpSettings foundation) app
 
 getApplicationRepl :: IO (Int, App, Application)

src/Foundation.hs

@@ -1,251 +1,265 @@
-{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE DeriveGeneric #-}
-{-# LANGUAGE StandaloneDeriving #-}
+{-# LANGUAGE StandaloneDeriving #-}
-{-# OPTIONS_GHC -fno-warn-unused-matches #-}
+{-# LANGUAGE NamedFieldPuns #-}
-
+{-# OPTIONS_GHC -fno-warn-unused-matches #-}
-module Foundation where
+
-
+module Foundation where
-import Import.NoFoundation
+
-import Database.Persist.Sql (ConnectionPool, runSqlPool)
+import Import.NoFoundation
-import Text.Hamlet          (hamletFile)
+import Database.Persist.Sql (ConnectionPool, runSqlPool)
-import Text.Jasmine         (minifym)
+import Text.Hamlet          (hamletFile)
-import PathPiece()
+import PathPiece()
-
+
--- import Yesod.Auth.Dummy
+import Yesod.Core.Types
-
+import Yesod.Auth.Message
-import Yesod.Default.Util   (addStaticContentExternal)
+import qualified Data.CaseInsensitive as CI
-import Yesod.Core.Types
+import qualified Data.Text.Encoding as TE
-import Yesod.Auth.Message
+import qualified Yesod.Core.Unsafe as Unsafe
-import qualified Network.Wai as NW
+import qualified Network.Wai as Wai
-import qualified Control.Monad.Metrics as MM
+
-import qualified Data.CaseInsensitive as CI
+data App = App
-import qualified Data.Text.Encoding as TE
+    { appSettings    :: AppSettings
-import qualified Yesod.Core.Unsafe as Unsafe
+    , appStatic      :: Static -- ^ Settings for static file serving.
-
+    , appConnPool    :: ConnectionPool -- ^ Database connection pool.
-data App = App
+    , appHttpManager :: Manager
-    { appSettings    :: AppSettings
+    , appLogger      :: Logger
-    , appStatic      :: Static -- ^ Settings for static file serving.
+    } deriving (Typeable)
-    , appConnPool    :: ConnectionPool -- ^ Database connection pool.
+
-    , appHttpManager :: Manager
+mkYesodData "App" $(parseRoutesFile "config/routes")
-    , appLogger      :: Logger
+
-    , appMetrics     :: !MM.Metrics
+deriving instance Typeable Route 
-    } deriving (Typeable)
+deriving instance Generic (Route App)
-
+
-mkYesodData "App" $(parseRoutesFile "config/routes")
+-- YesodPersist
-
+
-deriving instance Typeable Route 
+instance YesodPersist App where
-deriving instance Generic (Route App)
+    type YesodPersistBackend App = SqlBackend
-
+    runDB action = do
--- YesodPersist
+        master <- getYesod
-
+        runSqlPool action (appConnPool master)
-instance YesodPersist App where
+
-    type YesodPersistBackend App = SqlBackend
+instance YesodPersistRunner App where
-    runDB action = do
+    getDBRunner = defaultGetDBRunner appConnPool
-        master <- getYesod
+
-        runSqlPool action (appConnPool master)
+session_timeout_minutes :: Int
-
+session_timeout_minutes = 10080 -- (7 days)
-instance YesodPersistRunner App where
+
-    getDBRunner = defaultGetDBRunner appConnPool
+-- Yesod
-
+
--- Yesod
+instance Yesod App where
-
+    approot = ApprootRequest \app req ->
-instance Yesod App where
+        case appRoot (appSettings app) of
-    approot = ApprootRequest $ \app req ->
+            Nothing -> getApprootText guessApproot app req
-        case appRoot (appSettings app) of
+            Just root -> root
-            Nothing -> getApprootText guessApproot app req
+
-            Just root -> root
+    makeSessionBackend :: App -> IO (Maybe SessionBackend)
-
+    makeSessionBackend App {appSettings} = do
-    makeSessionBackend _ = Just <$> defaultClientSessionBackend
+      backend <-
-        10080 -- min (7 days)
+        defaultClientSessionBackend
-        "config/client_session_key.aes"
+          session_timeout_minutes
-
+          "config/client_session_key.aes"
-    yesodMiddleware = metricsMiddleware . defaultYesodMiddleware . defaultCsrfMiddleware
+      maybeSSLOnly $ pure (Just backend)
-
+      where
-    defaultLayout widget = do
+        maybeSSLOnly =
-        req <- getRequest
+          if appSSLOnly appSettings
-        master <- getYesod
+            then sslOnlySessions
-        urlrender <- getUrlRender
+            else id
-        mmsg <- getMessage
+
-        musername <- maybeAuthUsername
+    yesodMiddleware :: HandlerFor App res -> HandlerFor App res
-        muser <- (fmap.fmap) snd maybeAuthPair
+    yesodMiddleware = customMiddleware . defaultYesodMiddleware . customCsrfMiddleware
-        mcurrentRoute <- getCurrentRoute
+      where
-        void $ mapM (incrementRouteEKG req) mcurrentRoute
+        customCsrfMiddleware handler = do
-        let msourceCodeUri = appSourceCodeUri (appSettings master)
+          maybeRoute <- getCurrentRoute
-        pc <- widgetToPageContent $ do
+          dontCheckCsrf <- case maybeRoute of
-            setTitle "Espial"
+            -- `maybeAuthId` checks for the validity of the Authorization
-            addAppScripts
+            -- header anyway, but it is still a good idea to limit this
-            addStylesheet (StaticR css_tachyons_min_css)
+            -- flexibility to designated routes.
-            addStylesheet (StaticR css_main_css)
+            -- For the time being, `AddR` is the only route that accepts an
-            $(widgetFile "default-layout")
+            -- authentication token.
-        withUrlRenderer $(hamletFile "templates/default-layout-wrapper.hamlet")
+            Just AddR -> isJust <$> lookupHeader "Authorization"
-
+            _ -> pure False
-    addStaticContent ext mime content = do
+          (if dontCheckCsrf then id else defaultCsrfMiddleware) handler
-        master <- getYesod
+
-        let staticDir = appStaticDir (appSettings master)
+        customMiddleware handler = do
-        addStaticContentExternal
+          addHeader "X-Frame-Options" "DENY"
-            minifym
+          yesod <- getYesod
-            genFileName
+          (if appSSLOnly (appSettings yesod)
-            staticDir
+             then sslOnlyMiddleware session_timeout_minutes
-            (StaticR . flip StaticRoute [])
+             else id) handler
-            ext
+
-            mime
+    defaultLayout widget = do
-            content
+        req <- getRequest
-      where
+        master <- getYesod
-        genFileName lbs = "autogen-" ++ base64md5 lbs
+        urlrender <- getUrlRender
-
+        mmsg <- getMessage
-    shouldLogIO app _source level =
+        musername <- maybeAuthUsername
-        pure $ appShouldLogAll (appSettings app) || level == LevelWarn || level == LevelError
+        muser <- (fmap.fmap) snd maybeAuthPair
-    makeLogger = return . appLogger
+        let msourceCodeUri = appSourceCodeUri (appSettings master)
-
+        pc <- widgetToPageContent do
-    authRoute _ = Just (AuthR LoginR)
+            setTitle "Espial"
-
+            addAppScripts
-    isAuthorized (AuthR _) _ = pure Authorized
+            addStylesheet (StaticR css_tachyons_min_css)
-    isAuthorized _ _ = pure Authorized
+            addStylesheet (StaticR css_main_css)
-
+            $(widgetFile "default-layout")
-    defaultMessageWidget title body = do
+        withUrlRenderer $(hamletFile "templates/default-layout-wrapper.hamlet")
-      setTitle title
+
-      toWidget [hamlet|
+    shouldLogIO app _source level =
-        <main .pv2.ph3.mh1>
+        pure $ appShouldLogAll (appSettings app) || level == LevelWarn || level == LevelError
-          <div .w-100.mw8.center>
+    makeLogger = return . appLogger
-            <div .pa3.bg-near-white>
+
-              <h1>#{title}
+    authRoute _ = Just (AuthR LoginR)
-              ^{body}
+
-      |]
+    isAuthorized (AuthR _) _ = pure Authorized
-
+    isAuthorized _ _ = pure Authorized
-
+
-isAuthenticated :: Handler AuthResult
+    defaultMessageWidget title body = do
-isAuthenticated = maybeAuthId >>= \case
+      setTitle title
-                    Just authId -> pure Authorized
+      toWidget [hamlet|
-                    _ -> pure $ AuthenticationRequired
+        <main .pv2.ph3.mh1>
-
+          <div .w-100.mw8.center>
-addAppScripts :: (MonadWidget m, HandlerSite m ~ App) => m ()
+            <div .pa3.bg-near-white>
-addAppScripts = do
+              <h1>#{title}
-  addScript (StaticR js_app_min_js) 
+              ^{body}
-
+      |]
-
+
--- popupLayout
+
-
+isAuthenticated :: Handler AuthResult
-popupLayout :: Widget -> Handler Html
+isAuthenticated = maybeAuthId >>= \case
-popupLayout widget = do
+                    Just authId -> pure Authorized
-    req <- getRequest
+                    _ -> pure $ AuthenticationRequired
-    master <- getYesod
+
-    mmsg <- getMessage
+addAppScripts :: (MonadWidget m, HandlerSite m ~ App) => m ()
-    musername <- maybeAuthUsername
+addAppScripts = do
-    let msourceCodeUri = appSourceCodeUri (appSettings master)
+  addScript (StaticR js_app_min_js) 
-    pc <- widgetToPageContent $ do
+
-      addAppScripts
+
-      addStylesheet (StaticR css_tachyons_min_css)
+-- popupLayout
-      addStylesheet (StaticR css_popup_css)
+
-      $(widgetFile "popup-layout")
+popupLayout :: Widget -> Handler Html
-    withUrlRenderer $(hamletFile "templates/default-layout-wrapper.hamlet")
+popupLayout widget = do
-
+    req <- getRequest
-
+    master <- getYesod
-metricsMiddleware :: Handler a -> Handler a
+    mmsg <- getMessage
-metricsMiddleware handler = do
+    musername <- maybeAuthUsername
-  req <- getRequest
+    let msourceCodeUri = appSourceCodeUri (appSettings master)
-  mcurrentRoute <- getCurrentRoute
+    pc <- widgetToPageContent do
-  void $ mapM (incrementRouteEKG req) mcurrentRoute
+      addAppScripts
-  handler
+      addStylesheet (StaticR css_tachyons_min_css)
-
+      addStylesheet (StaticR css_popup_css)
-
+      $(widgetFile "popup-layout")
-incrementRouteEKG :: YesodRequest -> Route App -> Handler ()
+    withUrlRenderer $(hamletFile "templates/default-layout-wrapper.hamlet")
-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
+  authPlugins _ = [dbAuthPlugin]
-  -- authHttpManager = getHttpManager
+  authenticate = authenticateCreds
-  authPlugins _ = [dbAuthPlugin]
+  loginDest = const HomeR
-  authenticate = authenticateCreds
+  logoutDest = const HomeR
-  loginDest = const HomeR
+  onLogin = maybeAuth >>= \case
-  logoutDest = const HomeR
+    Nothing -> cpprint ("onLogin: could not find user" :: Text)
-  onLogin = maybeAuth >>= \case
+    Just (Entity _ uname) -> setSession userNameKey (userName uname)
-    Nothing -> cpprint ("onLogin: could not find user" :: Text)
+  onLogout =
-    Just (Entity _ uname) -> setSession userNameKey (userName uname)
+    deleteSession userNameKey
-  onLogout =
+  redirectToReferer = const True
-    deleteSession userNameKey
+  maybeAuthId = do
-  redirectToReferer = const True
+    req <- waiRequest
-
+    let mAuthHeader = lookup "Authorization" (Wai.requestHeaders req)
-instance YesodAuthPersist App
+        extractKey = stripPrefix "ApiKey " . TE.decodeUtf8
-
+    case mAuthHeader of
-instance MM.MonadMetrics Handler where
+      Just authHeader ->
-  getMetrics = pure . appMetrics =<< getYesod 
+        case extractKey authHeader of
-
+          Just apiKey -> do
--- session keys
+            user <- liftHandler $ runDB $ getApiKeyUser (ApiKey apiKey)
-
+            let userId = entityKey <$> user
-maybeAuthUsername :: Handler (Maybe Text)
+            pure userId
-maybeAuthUsername = do
+          -- Since we disable CSRF middleware in the presence of Authorization
-  lookupSession userNameKey
+          -- header, we need to explicitly check for the validity of the header
-
+          -- content. Otherwise, a dummy Authorization header with garbage input
-ultDestKey :: Text
+          -- could be provided to circumvent CSRF token requirement, making the app
-ultDestKey = "_ULT"
+          -- vulnerable to CSRF attacks.
-
+          Nothing -> pure Nothing
-userNameKey :: Text
+      _ -> defaultMaybeAuthId
-userNameKey = "_UNAME"
+
-
+instance YesodAuthPersist App
--- dbAuthPlugin
+
-
+-- session keys
-dbAuthPluginName :: Text
+
-dbAuthPluginName = "db"
+maybeAuthUsername :: Handler (Maybe Text)
-
+maybeAuthUsername = do
-dbAuthPlugin :: AuthPlugin App
+  lookupSession userNameKey
-dbAuthPlugin = AuthPlugin dbAuthPluginName dbDispatch dbLoginHandler
+
-  where
+ultDestKey :: Text
-    dbDispatch "POST" ["login"] = dbPostLoginR >>= sendResponse
+ultDestKey = "_ULT"
-    dbDispatch _ _ = notFound
+
-    dbLoginHandler toParent = do
+userNameKey :: Text
-      req <- getRequest
+userNameKey = "_UNAME"
-      lookupSession ultDestKey >>= \case
+
-        Just dest | "logout" `isInfixOf` dest -> deleteSession ultDestKey
+-- dbAuthPlugin
-        _ -> pure ()
+
-      setTitle "Espial | Log In"
+dbAuthPluginName :: Text
-      $(widgetFile "login")
+dbAuthPluginName = "db"
-
+
-dbLoginR :: AuthRoute
+dbAuthPlugin :: AuthPlugin App
-dbLoginR = PluginR dbAuthPluginName ["login"]
+dbAuthPlugin = AuthPlugin dbAuthPluginName dbDispatch dbLoginHandler
-
+  where
-dbPostLoginR ::  AuthHandler master TypedContent
+    dbDispatch :: Text -> [Text] -> AuthHandler App TypedContent
-dbPostLoginR = do
+    dbDispatch "POST" ["login"] = dbPostLoginR >>= sendResponse
-  mresult <- runInputPostResult (dbLoginCreds
+    dbDispatch _ _ = notFound
-               <$> ireq textField "username"
+    dbLoginHandler toParent = do
-               <*> ireq textField "password")
+      req <- getRequest
-  case mresult of
+      lookupSession ultDestKey >>= \case
-    FormSuccess creds -> setCredsRedirect creds
+        Just dest | "logout" `isInfixOf` dest -> deleteSession ultDestKey
-    _ -> loginErrorMessageI LoginR InvalidUsernamePass
+        _ -> pure ()
-
+      setTitle "Espial | Log In"
-dbLoginCreds :: Text -> Text -> Creds master
+      $(widgetFile "login")
-dbLoginCreds username password =
+
-  Creds
+dbLoginR :: AuthRoute
-  { credsPlugin = dbAuthPluginName
+dbLoginR = PluginR dbAuthPluginName ["login"]
-  , credsIdent = username
+
-  , credsExtra = [("password", password)]
+dbPostLoginR ::  AuthHandler master TypedContent
-  }
+dbPostLoginR = do
-
+  mresult <- runInputPostResult (dbLoginCreds
-authenticateCreds ::
+               <$> ireq textField "username"
-     (MonadHandler m, HandlerSite m ~ App)
+               <*> ireq textField "password")
-  => Creds App
+  case mresult of
-  -> m (AuthenticationResult App)
+    FormSuccess creds -> setCredsRedirect creds
-authenticateCreds Creds {..} = do
+    _ -> loginErrorMessageI LoginR InvalidUsernamePass
-  muser <-
+
-    case credsPlugin of
+dbLoginCreds :: Text -> Text -> Creds master
-      p | p == dbAuthPluginName -> liftHandler $ runDB $
+dbLoginCreds username password =
-        join <$> mapM (authenticatePassword credsIdent) (lookup "password" credsExtra)
+  Creds
-      _ -> pure Nothing
+  { credsPlugin = dbAuthPluginName
-  case muser of
+  , credsIdent = username
-    Nothing -> pure (UserError InvalidUsernamePass)
+  , credsExtra = [("password", password)]
-    Just (Entity uid _) -> pure (Authenticated uid)
+  }
-
+
--- Util
+authenticateCreds ::
-
+     (MonadHandler m, HandlerSite m ~ App)
-instance RenderMessage App FormMessage where
+  => Creds App
-    renderMessage :: App -> [Lang] -> FormMessage -> Text
+  -> m (AuthenticationResult App)
-    renderMessage _ _ = defaultFormMessage
+authenticateCreds Creds {..} = do
-
+  muser <-
-instance HasHttpManager App where
+    case credsPlugin of
-    getHttpManager :: App -> Manager
+      p | p == dbAuthPluginName -> liftHandler $ runDB $
-    getHttpManager = appHttpManager
+        join <$> mapM (\pwd -> authenticatePassword credsIdent pwd) (lookup "password" credsExtra)
-
+      _ -> pure Nothing
-unsafeHandler :: App -> Handler a -> IO a
+  case muser of
-unsafeHandler = Unsafe.fakeHandlerGetLogger appLogger
+    Nothing -> pure (UserError InvalidUsernamePass)
-
+    Just (Entity uid _) -> pure (Authenticated uid)
+
+-- Util
+
+instance RenderMessage App FormMessage where
+    renderMessage :: App -> [Lang] -> FormMessage -> Text
+    renderMessage _ _ = defaultFormMessage
+
+instance HasHttpManager App where
+    getHttpManager :: App -> Manager
+    getHttpManager = appHttpManager
+
+unsafeHandler :: App -> Handler a -> IO a
+unsafeHandler = Unsafe.fakeHandlerGetLogger appLogger
+

src/Generic.hs

@@ -2,11 +2,12 @@ module Generic where
 
 import GHC.Generics
 import ClassyPrelude.Yesod
+import Data.Kind (Type)
 
 constrName :: (HasConstructor (Rep a), Generic a)=> a -> String
 constrName = genericConstrName . from 
 
-class HasConstructor (f :: * -> *) where
+class HasConstructor (f :: Type -> Type) where
   genericConstrName :: f x -> String
 
 instance HasConstructor f => HasConstructor (D1 c f) where

src/Handler/AccountSettings.hs

@@ -8,14 +8,14 @@ getAccountSettingsR = do
   (_, user) <- requireAuthPair
   let accountSettingsEl = "accountSettings" :: Text
   let accountSettings = toAccountSettingsForm user
-  defaultLayout $ do
+  defaultLayout do
     $(widgetFile "user-settings")
     toWidgetBody [julius|
         app.userR = "@{UserR (UserNameP $ userName user)}";
         app.dat.accountSettings = #{ toJSON accountSettings } || []; 
     |]
     toWidget [julius|
-      PS['Main'].renderAccountSettings('##{rawJS accountSettingsEl}')(app.dat.accountSettings)();
+      PS.renderAccountSettings('##{rawJS accountSettingsEl}')(app.dat.accountSettings)();
     |]
 
 postEditAccountSettingsR :: Handler ()
@@ -34,17 +34,23 @@ getChangePasswordR = do
 
 postChangePasswordR :: Handler Html
 postChangePasswordR = do
-  userId <- requireAuthId
+  (userId, user) <- requireAuthPair
-  mauthuname <- maybeAuthUsername
+  runInputPostResult ((,) <$> ireq textField "oldpassword" <*> ireq textField "newpassword") >>= \case
-  mresult <- runInputPostResult ((,) <$> ireq textField "oldpassword" <*> ireq textField "newpassword")
+    FormSuccess (old, new) -> do
-  case (mauthuname, mresult) of
+      runDB (authenticatePassword (userName user) old) >>= \case
-    (Just uname, FormSuccess (old, new)) -> do
+        Nothing -> setMessage "Incorrect Old Password"
-      muser <- runDB (authenticatePassword uname old)
+        Just _ -> validateNewPassword new >>= \case
-      case muser of
+          Just newValid -> do
-        Just _ -> do 
+            newHash <- liftIO (hashPassword newValid)
-          new' <- liftIO (hashPassword new)
+            void $ runDB (update userId [UserPasswordHash CP.=. newHash])
-          void $ runDB (update userId [UserPasswordHash CP.=. new'])
+            setMessage "Password Changed Successfully"
-          setMessage "Password Changed Successfully"
+          _ -> pure ()
-        _ -> setMessage "Incorrect Old Password"
     _ -> setMessage "Missing Required Fields"
   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

src/Handler/Add.hs

@@ -1,67 +1,90 @@
-module Handler.Add where
+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
-getAddViewR :: Handler Html
+
-getAddViewR = do
+getAddViewR :: Handler Html
-  userId <- requireAuthId
+getAddViewR = do
-
+  userId <- requireAuthId
-  murl <- lookupGetParam "url"
+
-  mformdb <- runDB (pure . fmap _toBookmarkForm =<< fetchBookmarkByUrl userId murl)
+  murl <- lookupGetParam "url"
-  formurl <- bookmarkFormUrl
+  mBookmarkDb <- runDB (fetchBookmarkByUrl userId murl)
-
+  let mformdb = fmap _toBookmarkForm mBookmarkDb 
-  let renderEl = "addForm" :: Text
+  formurl <- bookmarkFormUrl
-
+
-  popupLayout $ do
+  let renderEl = "addForm" :: Text
-    toWidget [whamlet|
+
-      <div id="#{ renderEl }">
+  popupLayout do
-    |]
+    toWidget [whamlet|
-    toWidgetBody [julius|
+      <div id="#{ renderEl }">
-      app.dat.bmark = #{ toJSON (fromMaybe formurl mformdb) }; 
+    |]
-    |]
+    toWidgetBody [julius|
-    toWidget [julius|
+      app.dat.bmark = #{ toJSON (fromMaybe formurl mformdb) }; 
-      PS['Main'].renderAddForm('##{rawJS renderEl}')(app.dat.bmark)();
+    |]
-    |]
+    toWidget [julius|
-
+      PS.renderAddForm('##{rawJS renderEl}')(app.dat.bmark)();
-bookmarkFormUrl :: Handler BookmarkForm
+    |]
-bookmarkFormUrl = do
+
-  Entity _ user <- requireAuth
+bookmarkFormUrl :: Handler BookmarkForm
-  BookmarkForm
+bookmarkFormUrl = do
-    <$> (lookupGetParam "url" >>= pure . fromMaybe "")
+  Entity _ user <- requireAuth
-    <*> (lookupGetParam "title")
+  url <- lookupGetParam "url" <&> fromMaybe ""
-    <*> (lookupGetParam "description" >>= pure . fmap Textarea)
+  title <- lookupGetParam "title"
-    <*> (lookupGetParam "tags")
+  description <- lookupGetParam "description" <&> fmap Textarea
-    <*> (lookupGetParam "private" >>= pure . fmap parseChk <&> (<|> Just (userPrivateDefault user)))
+  tags <- lookupGetParam "tags"
-    <*> (lookupGetParam "toread" >>= pure . fmap parseChk)
+  private <- lookupGetParam "private" <&> fmap parseChk <&> (<|> Just (userPrivateDefault user))
-    <*> pure Nothing
+  toread <- lookupGetParam "toread" <&> fmap parseChk
-    <*> pure Nothing
+  pure $
-    <*> pure Nothing
+    BookmarkForm
-    <*> pure Nothing
+    { _url = url
-    <*> pure Nothing
+    , _title = title
-  where
+    , _description = description
-    parseChk s = s == "yes" || s == "on"
+    , _tags = tags
-
+    , _private = private
--- API
+    , _toread = toread
-
+    , _bid = Nothing
-postAddR :: Handler ()
+    , _slug = Nothing
-postAddR = do
+    , _selected = Nothing
-  bookmarkForm <- requireCheckJsonBody
+    , _time = Nothing
-  _handleFormSuccess bookmarkForm >>= \case
+    , _archiveUrl = Nothing
-    (Created, bid) -> sendStatusJSON created201 bid
+    }
-    (Updated, _) -> sendResponseStatus noContent204 ()
+  where
-
+    parseChk s = s == "yes" || s == "on" || s == "true" || s == "1"
-_handleFormSuccess :: BookmarkForm -> Handler (UpsertResult, Key Bookmark)
+
-_handleFormSuccess bookmarkForm = do
+-- API
-  (userId, user) <- requireAuthPair
+
-  bm <- liftIO $ _toBookmark userId bookmarkForm
+postAddR :: Handler Text
-  (res, kbid) <- runDB (upsertBookmark userId mkbid bm tags)
+postAddR = do
-  whenM (shouldArchiveBookmark user kbid) $
+  bookmarkForm <- requireCheckJsonBody
-    void $ async (archiveBookmarkUrl kbid (unpack (bookmarkHref bm)))
+  _handleFormSuccess bookmarkForm >>= \case
-  pure (res, kbid)
+    Created bid -> sendStatusJSON created201 bid
-  where
+    Updated _ -> sendResponseStatus noContent204 ()
-    mkbid = BookmarkKey <$> _bid bookmarkForm
+    Failed s -> sendResponseStatus status400 s
-    tags = maybe [] (nub . words) (_tags bookmarkForm)
+
+_handleFormSuccess :: BookmarkForm -> Handler (UpsertResult (Key Bookmark))
+_handleFormSuccess bookmarkForm = do
+  (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
+      res <- runDB (upsertBookmark userId mkbid bm tags)
+      forM_ (maybeUpsertResult res) $ \kbid ->
+        whenM (shouldArchiveBookmark user kbid) $
+        void $ async (archiveBookmarkUrl kbid (unpack (bookmarkHref bm)))
+      pure res
+
+postLookupTitleR :: Handler ()
+postLookupTitleR = do
+  void requireAuthId
+  bookmarkForm <- (requireCheckJsonBody :: Handler BookmarkForm)
+  fetchPageTitle (unpack (_url bookmarkForm)) >>= \case
+    Left _ -> sendResponseStatus noContent204 ()
+    Right title -> sendResponseStatus ok200 title

src/Handler/Archive.hs

@@ -2,7 +2,9 @@ module Handler.Archive where
 
 import Import
 import Data.Function ((&))
-import qualified Data.Attoparsec.ByteString.Char8 as AP
+import Data.Char (ord)
+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.Lazy as LBS
 import qualified Data.ByteString.Char8 as BS8
@@ -10,45 +12,56 @@ import qualified Network.HTTP.Client as NH
 import qualified Network.HTTP.Client.TLS as NH
 import qualified Network.HTTP.Types.Status as NH
 import qualified Web.FormUrlEncoded as WH
-import qualified Control.Monad.Metrics as MM
+import HTMLEntities.Decoder (htmlEncodedText)
+import Data.Text.Lazy.Builder (toLazyText)
+import Network.Wai (requestHeaderHost)
+import qualified Network.Connection as NC
 
 shouldArchiveBookmark :: User -> Key Bookmark -> Handler Bool
-shouldArchiveBookmark user kbid = do
+shouldArchiveBookmark user kbid =
   runDB (get kbid) >>= \case
-    Nothing -> pure False
+  Nothing -> pure False
-    Just bm -> do
+
-      pure $
+  Just bm -> do
-        (isNothing $ bookmarkArchiveHref bm) &&
+    pure $
-        (bookmarkShared bm)
+      isNothing (bookmarkArchiveHref bm) &&
-        && not (_isArchiveBlacklisted bm)
+      bookmarkShared bm
-        && not (userPrivacyLock user)
+      && not (_isArchiveBlacklisted bm)
-        && 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 kbid url =
   (_fetchArchiveSubmitInfo >>= \case
     Left e -> do
-      MM.increment "archive.fetchSubmitId_noparse"
       $(logError) (pack e)
     Right submitInfo ->  do
         userId <- requireAuthId
-        let req = _buildArchiveSubmitRequest submitInfo url
+        req <- _buildArchiveSubmitRequest submitInfo url
-        MM.increment "archive.submit"  
+        manager <- getArchiveManager
-        res <- liftIO $ NH.httpLbs req  =<< NH.getGlobalManager
+        res <- liftIO $ NH.httpLbs req manager
         let status = NH.responseStatus res
-        MM.increment ("archive.submit_status_" <> (pack.show) (NH.statusCode status)) 
+        let updateArchiveUrl url' = runDB $ updateBookmarkArchiveUrl userId kbid $ Just url'
-        let updateArchiveUrl = runDB . updateBookmarkArchiveUrl userId kbid . Just
             headers = NH.responseHeaders res
         case status of
           s | s == NH.status200 ->
             for_ (lookup "Refresh" headers >>= _parseRefreshHeaderUrl) updateArchiveUrl
-          s | s == NH.status302 -> 
+          s | s == NH.status302 || s == NH.status307 ->
             for_ (lookup "Location" headers) (updateArchiveUrl . decodeUtf8)
           _ -> $(logError) (pack (show res)))
   `catch` (\(e::SomeException) -> ($(logError) $ (pack.show) e) >> throwIO e)
 
 _isArchiveBlacklisted :: Bookmark -> Bool
-_isArchiveBlacklisted (Bookmark {..}) =
+_isArchiveBlacklisted Bookmark {..} =
   [ "hulu"
   , "livestream"
   , "netflix"
@@ -64,43 +77,73 @@ _isArchiveBlacklisted (Bookmark {..}) =
 _parseRefreshHeaderUrl :: ByteString -> Maybe Text
 _parseRefreshHeaderUrl h = do
   let u = BS8.drop 1 $ BS8.dropWhile (/= '=') h
-  if (not (null u))
+  if not (null u)
     then Just $ decodeUtf8 u
     else Nothing
 
-_buildArchiveSubmitRequest :: (String, String) -> String -> NH.Request
-_buildArchiveSubmitRequest (action, submitId) href =
-  NH.parseRequest_ ("POST " <> action) & \r ->
-    r { NH.requestHeaders =
-        [ ("User-Agent", _archiveUserAgent)
-        , ("Content-Type", "application/x-www-form-urlencoded")
-        ]
-      , NH.requestBody = NH.RequestBodyLBS $ WH.urlEncodeAsForm ((
-        [ ("submitid" , submitId)
-        , ("url", href)
-        ]) :: [(String, String)])
-      , NH.redirectCount = 0
-      }
-
 _fetchArchiveSubmitInfo :: Handler (Either String (String , String))
 _fetchArchiveSubmitInfo = do
-  MM.increment "archive.fetchSubmitId"  
+  req <- buildRequest "https://archive.li/"
-  res <- liftIO $ NH.httpLbs buildSubmitRequest =<< NH.getGlobalManager
+  manager <- getArchiveManager
-  MM.increment ("archive.fetchSubmitId_status_" <> (pack.show) (NH.statusCode (NH.responseStatus res))) 
+  res <- liftIO $ NH.httpLbs req manager
   let body = LBS.toStrict (responseBody res)
-      action = _parseSubstring (AP.string "action=\"") (AP.notChar '"') body
+      action = _parseSubstring (AP8.string "action=\"") (AP8.notChar '"') body
-      submitId = _parseSubstring (AP.string "submitid\" value=\"") (AP.notChar '"') body
+      submitId = _parseSubstring (AP8.string "submitid\" value=\"") (AP8.notChar '"') body
-  pure $ (,) <$> action <*> submitId
+  if statusCode (responseStatus res) == 200
-  where
+    then pure $ (,) <$> action <*> submitId
-    buildSubmitRequest =
+    else pure $ Left $ "Invalid statusCode: " <> show (responseStatus res)
-      NH.parseRequest_ "https://archive.li/" & \r ->
-        r {NH.requestHeaders = [("User-Agent", _archiveUserAgent)]}
 
-_archiveUserAgent :: ByteString
-_archiveUserAgent = "espial"
 
-_parseSubstring :: AP.Parser ByteString -> AP.Parser Char -> BS.ByteString -> Either String String
+_parseSubstring :: AP8.Parser ByteString -> AP8.Parser Char -> BS.ByteString -> Either String String
-_parseSubstring start inner res = do
+_parseSubstring start inner = AP8.parseOnly (skipAnyTill start >> AP8.many1 inner)
-  (flip AP.parseOnly) res (skipAnyTill start >> AP.many1 inner)
   where
-    skipAnyTill end = go where go = end *> pure () <|> AP.anyChar *> go
+    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
+    }
+
+buildRequest :: String -> Handler Request
+buildRequest url = do
+  ua <- _archiveUserAgent
+  pure $ NH.parseRequest_ url & \r ->
+    r { NH.requestHeaders =
+          [ ("Cache-Control", "max-age=0")
+          , ("User-Agent", ua)
+          ]
+      }
+
+_archiveUserAgent :: Handler ByteString
+_archiveUserAgent = do
+  mHost <- requestHeaderHost . reqWaiRequest <$> getRequest
+  pure $ "espial-" <> maybe "" (BS8.takeWhile (/= ':')) mHost
+

src/Handler/Common.hs

@@ -5,6 +5,7 @@ import Import
 
 import Data.FileEmbed (embedFile)
 import Text.Read
+import Data.Aeson as A
 
 -- These handlers embed files in the executable at compile time to avoid a
 -- runtime dependency, and for efficiency.
@@ -21,11 +22,49 @@ getRobotsR = return $ TypedContent typePlain
 
 
 lookupPagingParams :: Handler (Maybe Int64, Maybe Int64)
-lookupPagingParams = do
+lookupPagingParams =
-  cq <- fmap parseMaybe (lookupGetParam "count")
+  (,)
-  cs <- fmap parseMaybe (lookupSession "count")
+  <$> getUrlSessionParam "count"
-  for_ cq (setSession "count" . (pack . show)) 
+  <*> getUrlParam "page"
-  pq <- fmap parseMaybe (lookupGetParam "page")
+
-  pure (cq <|> cs, pq)
+getUrlParam :: (Read a) => Text -> Handler (Maybe a)
+getUrlParam name = do
+  fmap parseMaybe (lookupGetParam name)
   where
     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
+
+

src/Handler/Docs.hs

@@ -5,5 +5,5 @@ module Handler.Docs where
 import Import
 
 getDocsSearchR :: Handler Html
-getDocsSearchR = popupLayout $
+getDocsSearchR = popupLayout
   $(widgetFile "docs-search")

src/Handler/Edit.hs

@@ -11,16 +11,16 @@ import Import
 deleteDeleteR :: Int64 -> Handler Html
 deleteDeleteR bid = do
   userId <- requireAuthId
-  runDB $ do
+  runDB do
     let k_bid = BookmarkKey bid
     _ <- requireResource userId k_bid
-    deleteCascade k_bid
+    delete k_bid
   return ""
 
 postReadR :: Int64 -> Handler Html
 postReadR bid = do
   userId <- requireAuthId
-  runDB $ do
+  runDB do
     let k_bid = BookmarkKey bid
     _ <- requireResource userId k_bid
     update k_bid [BookmarkToRead =. False]
@@ -37,7 +37,7 @@ postUnstarR bid = _setSelected bid False
 _setSelected :: Int64 -> Bool -> Handler Html
 _setSelected bid selected = do
   userId <- requireAuthId
-  runDB $ do
+  runDB do
     let k_bid = BookmarkKey bid
     bm <- requireResource userId k_bid
     update k_bid [BookmarkSelected =. selected]

src/Handler/Notes.hs

@@ -1,4 +1,5 @@
 {-# OPTIONS_GHC -fno-warn-unused-matches #-}
+{-# LANGUAGE TupleSections #-}
 module Handler.Notes where
 
 import Import
@@ -6,8 +7,8 @@ import Handler.Common (lookupPagingParams)
 import qualified Data.Aeson as A
 import qualified Data.Text as T
 import           Yesod.RssFeed
-import           Text.Blaze.Html (toHtml)
 import qualified Text.Blaze.Html5 as H
+import qualified Network.Wai.Internal as W
 
 getNotesR :: UserNameP -> Handler Html
 getNotesR unamep@(UserNameP uname) = do
@@ -17,9 +18,9 @@ getNotesR unamep@(UserNameP uname) = do
   mquery <- lookupGetParam queryp
   let limit = maybe 20 fromIntegral limit'
       page  = maybe 1  fromIntegral page'
-      mqueryp = fmap (\q -> (queryp, q)) mquery
+      mqueryp = fmap (queryp,) mquery
-      isowner = maybe False (== uname) mauthuname
+      isowner = Just uname == mauthuname
-  (bcount, notes) <- runDB $ do
+  (bcount, notes) <- runDB do
     Entity userId user <- getBy404 (UniqueUserName uname)
     let sharedp = if isowner then SharedAll else SharedPublic
     when (not isowner && userPrivacyLock user)
@@ -27,7 +28,7 @@ getNotesR unamep@(UserNameP uname) = do
     getNoteList userId mquery sharedp limit page
   req <- getRequest
   mroute <- getCurrentRoute
-  defaultLayout $ do
+  defaultLayout do
     rssLink (NotesFeedR unamep) "feed"
     let pager = $(widgetFile "pager")
         search = $(widgetFile "search")
@@ -39,14 +40,14 @@ getNotesR unamep@(UserNameP uname) = do
         app.dat.isowner = #{ isowner };
     |]
     toWidget [julius|
-      PS['Main'].renderNotes('##{rawJS renderEl}')(app.dat.notes)();
+      PS.renderNotes('##{rawJS renderEl}')(app.dat.notes)();
     |]
 
 getNoteR :: UserNameP -> NtSlug -> Handler Html
 getNoteR unamep@(UserNameP uname) slug = do
   mauthuname <- maybeAuthUsername
   let renderEl = "note" :: Text
-      isowner = maybe False (== uname) mauthuname
+      isowner = Just uname == mauthuname
   note <-
     runDB $
     do Entity userId user <- getBy404 (UniqueUserName uname)
@@ -55,7 +56,7 @@ getNoteR unamep@(UserNameP uname) slug = do
        when (not isowner && (userPrivacyLock user || (not . noteShared . entityVal) note))
          (redirect (AuthR LoginR))
        pure note
-  defaultLayout $ do
+  defaultLayout do
     $(widgetFile "note")
     toWidgetBody [julius|
         app.userR = "@{UserR unamep}";
@@ -63,40 +64,47 @@ getNoteR unamep@(UserNameP uname) slug = do
         app.dat.isowner = #{ isowner };
     |]
     toWidget [julius|
-      PS['Main'].renderNote('##{rawJS renderEl}')(app.dat.note)();
+      PS.renderNote('##{rawJS renderEl}')(app.dat.note)();
     |]
 
+getAddNoteSlimViewR :: Handler Html
+getAddNoteSlimViewR = do
+  Entity userId user <- requireAuth
+  getAddNoteViewR (UserNameP (userName user))
+
 getAddNoteViewR :: UserNameP -> Handler Html
 getAddNoteViewR unamep@(UserNameP uname) = do
   userId <- requireAuthId
+  note <- liftIO . _toNote userId =<< noteFormUrl
   let renderEl = "note" :: Text
-  note <- liftIO $ Entity (NoteKey 0) <$> _toNote userId (NoteForm Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing)
+      enote = Entity (NoteKey 0) note
-  defaultLayout $ do
+  defaultLayout do
     $(widgetFile "note")
     toWidgetBody [julius|
         app.userR = "@{UserR unamep}";
-        app.noteR = "@{NoteR unamep (noteSlug (entityVal note))}";
+        app.noteR = "@{NoteR unamep (noteSlug (entityVal enote))}";
-        app.dat.note = #{ toJSON note } || [];
+        app.dat.note = #{ toJSON enote } || [];
     |]
     toWidget [julius|
-      PS['Main'].renderNote('##{rawJS renderEl}')(app.dat.note)();
+      PS.renderNote('##{rawJS renderEl}')(app.dat.note)();
     |]
 
 deleteDeleteNoteR :: Int64 -> Handler Html
 deleteDeleteNoteR nid = do
   userId <- requireAuthId
-  runDB $ do
+  runDB do
     let k_nid = NoteKey nid
     _ <- requireResource userId k_nid
-    deleteCascade k_nid
+    delete k_nid
   return ""
 
-postAddNoteR :: Handler ()
+postAddNoteR :: Handler Text
 postAddNoteR = do
   noteForm <- requireCheckJsonBody
   _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 k_nid = do
@@ -105,7 +113,7 @@ requireResource userId k_nid = do
     then return nnote
     else notFound
 
-_handleFormSuccess :: NoteForm -> Handler (UpsertResult, Key Note)
+_handleFormSuccess :: NoteForm -> Handler (UpsertResult (Key Note))
 _handleFormSuccess noteForm = do
   userId <- requireAuthId
   note <- liftIO $ _toNote userId noteForm
@@ -130,30 +138,51 @@ instance ToJSON NoteForm where toJSON = A.genericToJSON gNoteFormOptions
 gNoteFormOptions :: A.Options
 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 {..} = do
   time <- liftIO getCurrentTime
   slug <- maybe mkNtSlug pure _slug
   pure $
     Note
-      userId
+    { noteUserId = userId
-      slug
+    , noteSlug = slug
-      (length _text)
+    , noteLength = length _text
-      (fromMaybe "" _title)
+    , noteTitle = fromMaybe "" _title
-      (maybe "" unTextarea _text)
+    , noteText = maybe "" unTextarea _text
-      (fromMaybe False _isMarkdown)
+    , noteIsMarkdown = Just True == _isMarkdown
-      (fromMaybe False _shared)
+    , noteShared = Just True == _shared
-      (fromMaybe time (fmap unUTCTimeStr _created))
+    , noteCreated = maybe time unUTCTimeStr _created
-      (fromMaybe time (fmap unUTCTimeStr _updated))
+    , noteUpdated = maybe time unUTCTimeStr _updated
+    }
 
-noteToRssEntry :: UserNameP -> Entity Note -> FeedEntry (Route App)
+noteToRssEntry :: (Route App -> Text) -> UserNameP -> Entity Note -> FeedEntry Text
-noteToRssEntry usernamep (Entity entryId entry) =
+noteToRssEntry render usernamep (Entity entryId entry) =
-  FeedEntry { feedEntryLink = NoteR usernamep (noteSlug entry)
+  FeedEntry
-            , feedEntryUpdated = (noteUpdated entry)
+  { feedEntryLink = render $ NoteR usernamep (noteSlug entry)
-            , feedEntryTitle = (noteTitle entry)
+  , feedEntryUpdated = noteUpdated entry
-            , feedEntryContent =  (toHtml (noteText entry))
+  , feedEntryTitle = noteTitle entry
-            , feedEntryEnclosure = Nothing
+  , feedEntryContent = toHtml (noteText entry)
-            }
+  , feedEntryEnclosure = Nothing
+  , feedEntryCategories = []
+  }
 
 getNotesFeedR :: UserNameP -> Handler RepRss
 getNotesFeedR unamep@(UserNameP uname) = do
@@ -162,23 +191,37 @@ getNotesFeedR unamep@(UserNameP uname) = do
   mquery <- lookupGetParam "query"
   let limit = maybe 20 fromIntegral limit'
       page  = maybe 1   fromIntegral page'
-      isowner = maybe False (== uname) mauthuname
+      isowner = Just uname == mauthuname
-  (_, notes) <- runDB $ do
+      sharedp = if isowner then SharedAll else SharedPublic
+  (_, notes) <- runDB do
       Entity userId user <- getBy404 (UniqueUserName uname)
       when (not isowner && userPrivacyLock user)
         (redirect (AuthR LoginR))
-      getNoteList userId mquery SharedPublic limit page
+      getNoteList userId mquery sharedp limit page
+  render <- getUrlRender
   let (descr :: Html) = toHtml $ H.text (uname <> " notes")
-      entries = map (noteToRssEntry unamep) notes
+      entries = map (noteToRssEntry render unamep) notes
   updated <- case maximumMay (map feedEntryUpdated entries) of
-                Nothing -> liftIO $ getCurrentTime
+                Nothing -> liftIO getCurrentTime
                 Just m ->  return m
-  rssFeed $ Feed (uname <> " notes")
+  (feedLinkSelf, feedLinkHome) <- getFeedLinkSelf
-    (NotesFeedR unamep)
+  rssFeedText $
-    (NotesR unamep)
+    Feed
-    uname
+    { feedTitle = uname <> " notes"
-    descr
+    , feedLinkSelf = feedLinkSelf
-    "en"
+    , feedLinkHome = feedLinkHome
-    updated
+    , feedAuthor = uname
-    Nothing
+    , feedDescription = descr
-    entries
+    , feedLanguage = "en"
+    , 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)

src/Handler/User.hs

@@ -1,106 +1,172 @@
-{-# OPTIONS_GHC -fno-warn-unused-matches #-}
+{-# OPTIONS_GHC -fno-warn-unused-matches #-}
-module Handler.User where
+{-# LANGUAGE TupleSections #-}
-
+module Handler.User where
-import qualified Data.Text as T
+
-import           Handler.Common (lookupPagingParams)
+import qualified Data.Text as T
-import           Import
+import           Handler.Common
-import           Text.Blaze.Html (toHtml)
+import           Import
-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
-getUserR :: UserNameP -> Handler Html
+import qualified Network.Wai.Internal as W
-getUserR uname@(UserNameP name) = do
+
-  _getUser uname SharedAll FilterAll (TagsP [])
+getUserR :: UserNameP -> Handler Html
-
+getUserR uname=
-getUserSharedR :: UserNameP -> SharedP -> Handler Html
+  _getUser uname SharedAll FilterAll (TagsP [])
-getUserSharedR uname sharedp =
+
-  _getUser uname sharedp FilterAll (TagsP [])
+getUserSharedR :: UserNameP -> SharedP -> Handler Html
-
+getUserSharedR uname sharedp =
-getUserFilterR :: UserNameP -> FilterP -> Handler Html
+  _getUser uname sharedp FilterAll (TagsP [])
-getUserFilterR uname filterp =
+
-  _getUser uname SharedAll filterp (TagsP [])
+getUserFilterR :: UserNameP -> FilterP -> Handler Html
-
+getUserFilterR uname filterp =
-getUserTagsR :: UserNameP -> TagsP -> Handler Html
+  _getUser uname SharedAll filterp (TagsP [])
-getUserTagsR uname pathtags =
+
-  _getUser uname SharedAll FilterAll pathtags
+getUserTagsR :: UserNameP -> TagsP -> Handler Html
-
+getUserTagsR uname = _getUser uname SharedAll FilterAll
-_getUser :: UserNameP -> SharedP -> FilterP -> TagsP -> Handler Html
+
-_getUser unamep@(UserNameP uname) sharedp' filterp' (TagsP pathtags) = do
+_getUser :: UserNameP -> SharedP -> FilterP -> TagsP -> Handler Html
-  mauthuname <- maybeAuthUsername
+_getUser unamep@(UserNameP uname) sharedp' filterp' (TagsP pathtags) = do
-  (limit', page') <- lookupPagingParams
+  mauthuname <- maybeAuthUsername
-  let limit = maybe 120 fromIntegral limit'
+  (limit', page') <- lookupPagingParams
-      page  = maybe 1   fromIntegral page'
+  let limit = maybe 120 fromIntegral limit'
-      isowner = maybe False (== uname) mauthuname
+      page  = maybe 1   fromIntegral page'
-      sharedp = if isowner then sharedp' else SharedPublic
+      isowner = Just uname == mauthuname
-      filterp = case filterp' of
+      sharedp = if isowner then sharedp' else SharedPublic
-        FilterSingle _ -> filterp'
+      filterp = case filterp' of
-        _ -> if isowner then filterp' else FilterAll
+        FilterSingle _ -> filterp'
-      isAll = filterp == FilterAll && sharedp == SharedAll && pathtags == []
+        _ -> if isowner then filterp' else FilterAll
-      queryp = "query" :: Text
+      isAll = filterp == FilterAll && sharedp == SharedAll && null pathtags
-  mquery <- lookupGetParam queryp
+      queryp = "query" :: Text
-  let mqueryp = fmap (\q -> (queryp, q)) mquery
+  mquery <- lookupGetParam queryp
-  (bcount, bmarks, alltags) <-
+  let mqueryp = fmap (queryp,) mquery
-    runDB $
+  (bcount, btmarks) <- runDB $ do
-    do Entity userId user <- getBy404 (UniqueUserName uname)
+       Entity userId user <- getBy404 (UniqueUserName uname)
-       when (not isowner && userPrivacyLock user)
+       when (not isowner && userPrivacyLock user)
-         (redirect (AuthR LoginR))
+         (redirect (AuthR LoginR))
-       (cnt, bm) <- bookmarksQuery userId sharedp filterp pathtags mquery limit page
+       bookmarksTagsQuery userId sharedp filterp pathtags mquery limit page
-       tg <- tagsQuery bm
+  when (bcount == 0) (case filterp of FilterSingle _ -> notFound; _ -> pure ())
-       pure (cnt, bm, tg)
+  mroute <- getCurrentRoute
-  when (bcount == 0) (case filterp of FilterSingle _ -> notFound; _ -> pure ())
+  tagCloudMode <- getTagCloudMode isowner pathtags
-  mroute <- getCurrentRoute
+  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 bmarks alltags } || [];
+        app.dat.bmarks = #{ toJSON $ toBookmarkFormList btmarks } || [];
-        app.dat.isowner = #{ isowner };
+        app.dat.isowner = #{ isowner };
-        app.userR = "@{UserR unamep}";
+        app.userR = "@{UserR unamep}";
-    |]
+        app.tagCloudMode = #{ toJSON $ tagCloudMode } || {};
-    toWidget [julius|
+    |]
-      PS['Main'].renderBookmarks('##{rawJS renderEl}')(app.dat.bmarks)();
+    toWidget [julius|
-    |]
+      setTimeout(() => {
-
+        PS.renderBookmarks('##{rawJS renderEl}')(app.dat.bmarks)();
-bookmarkToRssEntry :: Entity Bookmark -> FeedEntry Text
+      }, 0);
-bookmarkToRssEntry (Entity entryId entry) =
+      setTimeout(() => {
-  FeedEntry { feedEntryLink = (bookmarkHref entry)
+        PS.renderTagCloud('##{rawJS tagCloudRenderEl}')(app.tagCloudMode)();
-            , feedEntryUpdated = (bookmarkTime entry)
+      }, 0);
-            , feedEntryTitle = (bookmarkDescription entry)
+    |]
-            , feedEntryContent =  (toHtml (bookmarkExtended entry))
+
-            , feedEntryEnclosure = Nothing
+-- Form
-            }
+
-
+postUserTagCloudR :: Handler ()
-getUserFeedR :: UserNameP -> Handler RepRss
+postUserTagCloudR = do
-getUserFeedR unamep@(UserNameP uname) = do
+  userId <- requireAuthId
-  mauthuname <- maybeAuthUsername
+  mode <- requireCheckJsonBody
-  (limit', page') <- lookupPagingParams
+  _updateTagCloudMode mode
-  let limit = maybe 120 fromIntegral limit'
+  tc <- runDB $ case mode of
-      page  = maybe 1   fromIntegral page'
+    TagCloudModeTop _ n -> tagCountTop userId n
-      queryp = "query" :: Text
+    TagCloudModeLowerBound _ n -> tagCountLowerBound userId n
-      isowner = maybe False (== uname) mauthuname
+    TagCloudModeRelated _ tags ->  tagCountRelated userId tags
-  mquery <- lookupGetParam queryp
+    TagCloudModeNone -> notFound
-  (_, bmarks) <-
+  sendStatusJSON ok200 (Map.fromList tc :: Map.Map Text Int)
-    runDB $
+
-    do Entity userId user <- getBy404 (UniqueUserName uname)
+postUserTagCloudModeR :: Handler ()
-       when (not isowner && userPrivacyLock user)
+postUserTagCloudModeR = do
-         (redirect (AuthR LoginR))
+  userId <- requireAuthId
-       bookmarksQuery userId SharedPublic FilterAll [] mquery limit page
+  mode <- requireCheckJsonBody
-  let (descr :: Html) = toHtml $ H.text ("Bookmarks saved by " <> uname)
+  _updateTagCloudMode mode
-      entries = map bookmarkToRssEntry bmarks
+
-  updated <- case maximumMay (map feedEntryUpdated entries) of
+_updateTagCloudMode :: TagCloudMode -> Handler ()
-                Nothing -> liftIO $ getCurrentTime
+_updateTagCloudMode mode =
-                Just m ->  return m
+  case mode of
-  render <- getUrlRender
+    TagCloudModeTop _ _ -> setTagCloudMode mode
-  rssFeedText $ Feed ("espial " <> uname)
+    TagCloudModeLowerBound _ _ -> setTagCloudMode mode
-                     (render (UserFeedR unamep))
+    TagCloudModeRelated _ _ -> setTagCloudMode mode
-                     (render (UserR unamep))
+    TagCloudModeNone -> notFound
-                     uname
+
-                     descr
+bookmarkToRssEntry :: (Entity Bookmark, Maybe Text) -> FeedEntry Text
-                     "en"
+bookmarkToRssEntry (Entity entryId entry, tags) =
-                     updated
+  FeedEntry
-                     Nothing
+  { feedEntryLink = bookmarkHref entry
-                     entries
+  , feedEntryUpdated = bookmarkTime entry
+  , feedEntryTitle = bookmarkDescription entry
+  , feedEntryContent = toHtml (bookmarkExtended entry)
+  , feedEntryCategories = map (EntryCategory Nothing Nothing) (maybe [] words tags)
+  , feedEntryEnclosure = Nothing
+  }
+
+getUserFeedR :: UserNameP -> Handler RepRss
+getUserFeedR unamep = 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
+  (limit', page') <- lookupPagingParams
+  let limit = maybe 120 fromIntegral limit'
+      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
+  mquery <- lookupGetParam queryp
+  (_, btmarks) <- runDB $ do
+       Entity userId user <- getBy404 (UniqueUserName uname)
+       when (not isowner && userPrivacyLock user)
+         (redirect (AuthR LoginR))
+       bookmarksTagsQuery userId sharedp filterp pathtags mquery limit page
+  let (descr :: Html) = toHtml $ H.text ("Bookmarks saved by " <> uname)
+      entries = map bookmarkToRssEntry btmarks
+  updated <- case maximumMay (map feedEntryUpdated entries) of
+                Nothing -> liftIO getCurrentTime
+                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
+      let rawRequest = reqWaiRequest request
+          feedLinkSelf = render HomeR <> (T.drop 1 (decodeUtf8 (W.rawPathInfo rawRequest <> W.rawQueryString rawRequest)))
+          feedLinkHome = render (UserR unamep)
+      pure (feedLinkSelf, feedLinkHome)

src/Import.hs

@@ -48,13 +48,13 @@ aFormToMaybeGetSuccess
   :: MonadHandler f
   => AForm f a -> f (Maybe a)
 aFormToMaybeGetSuccess =
-  fmap maybeSuccess . fmap fst . runFormGet . const . fmap fst . aFormToForm
+  fmap (maybeSuccess . fst) . runFormGet . const . fmap fst . aFormToForm
 
 aFormToMaybePostSuccess
   :: MonadHandlerForm f
   => AForm f a -> f (Maybe a)
 aFormToMaybePostSuccess =
-  fmap maybeSuccess . fmap fst . runFormPostNoToken . const . fmap fst . aFormToForm
+  fmap (maybeSuccess . fst) . runFormPostNoToken . const . fmap fst . aFormToForm
 
 maybeSuccess :: FormResult a -> Maybe a
 maybeSuccess (FormSuccess a) = Just a
@@ -83,4 +83,4 @@ attrs n f =
   }
 
 cls :: [Text] -> FieldSettings master -> FieldSettings master
-cls n = attrs [("class", intercalate " " n)]
+cls n = attrs [("class", unwords n)]

src/ModelCustom.hs

@@ -12,6 +12,8 @@ import qualified Data.Aeson as A
 import System.Entropy (getEntropy)
 import qualified Data.ByteString.Builder as BB
 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 size =
@@ -58,3 +60,18 @@ hashPassword rawPassword = do
 validatePasswordHash :: BCrypt -> T.Text -> Bool
 validatePasswordHash hash' pass = do
   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

src/PathPiece.hs

@@ -1,55 +1,61 @@
-{-# OPTIONS_GHC -fno-warn-orphans #-}
+{-# OPTIONS_GHC -fno-warn-orphans #-}
-
+
-module PathPiece where
+module PathPiece where
-  
+  
-import Data.Text (splitOn)
+import Data.Text (breakOn, splitOn)
-
+import qualified Data.Text as T (replace)
-import Import.NoFoundation
+import Import.NoFoundation
-
+
--- PathPiece
+-- PathPiece
-
+
-instance PathPiece UserNameP where
+instance PathPiece UserNameP where
-  toPathPiece (UserNameP i) = "u:" <> i
+  toPathPiece (UserNameP i) = "u:" <> i
-  fromPathPiece s =
+  fromPathPiece s =
-    case splitOn ":" s of
+    case breakOn ":" s of
-      ["u", ""] -> Nothing
+      ("u", "") -> Nothing
-      ["u", uname] -> Just $ UserNameP uname
+      ("u", uname) -> Just $ UserNameP (drop 1 uname)
-      _ -> Nothing
+      _ -> Nothing
-
+
-instance PathPiece TagsP where
+instance PathPiece TagsP where
-  toPathPiece (TagsP tags) = "t:" <> (intercalate "+" tags)
+  toPathPiece (TagsP tags) = "t:" <> intercalate "+" (fmap encodeTag tags)
-  fromPathPiece s =
+  fromPathPiece s =
-    case splitOn ":" s of
+    case breakOn ":" s of
-      ["t", ""] -> Nothing
+      ("t", "") -> Nothing
-      ["t", tags] -> Just $ TagsP (splitOn "+" tags)
+      ("t", tags) -> Just $ (TagsP . fmap decodeTag . splitOn "+" . drop 1) tags
-      _ -> Nothing
+      _ -> Nothing
-
+
-instance PathPiece SharedP where
+encodeTag :: Text -> Text
-  toPathPiece = \case
+encodeTag = T.replace "+" "%2B"
-    SharedAll -> ""
+
-    SharedPublic -> "public"
+decodeTag :: Text -> Text
-    SharedPrivate -> "private"
+decodeTag = T.replace "%2B" "+"
-  fromPathPiece = \case
+
-    "public" -> Just SharedPublic
+instance PathPiece SharedP where
-    "private" -> Just SharedPrivate
+  toPathPiece = \case
-    _ -> Nothing
+    SharedAll -> ""
-
+    SharedPublic -> "public"
-instance PathPiece FilterP where
+    SharedPrivate -> "private"
-  toPathPiece = \case
+  fromPathPiece = \case
-    FilterAll -> ""
+    "public" -> Just SharedPublic
-    FilterUnread -> "unread"
+    "private" -> Just SharedPrivate
-    FilterUntagged -> "untagged"
+    _ -> Nothing
-    FilterStarred -> "starred"
+
-    FilterSingle slug -> "b:" <> unBmSlug slug
+instance PathPiece FilterP where
-  fromPathPiece = \case
+  toPathPiece = \case
-    "unread" -> Just FilterUnread
+    FilterAll -> ""
-    "untagged" -> Just FilterUntagged
+    FilterUnread -> "unread"
-    "starred" -> Just FilterStarred
+    FilterUntagged -> "untagged"
-    s -> case splitOn ":" s of
+    FilterStarred -> "starred"
-        ["b", ""] -> Nothing
+    FilterSingle slug -> "b:" <> unBmSlug slug
-        ["b", slug] -> Just $ FilterSingle (BmSlug slug)
+  fromPathPiece = \case
-        _ -> Nothing
+    "unread" -> Just FilterUnread
-
+    "untagged" -> Just FilterUntagged
-
+    "starred" -> Just FilterStarred
-deriving instance PathPiece NtSlug 
+    s -> case breakOn ":" s of
-deriving instance PathPiece BmSlug 
+        ("b", "") -> Nothing
+        ("b", slug) -> Just $ FilterSingle (BmSlug (drop 1 slug))
+        _ -> Nothing
+
+
+deriving instance PathPiece NtSlug 
+deriving instance PathPiece BmSlug 

src/Settings.hs

@@ -56,16 +56,22 @@ data AppSettings = AppSettings
     , appAuthDummyLogin         :: Bool
     -- ^ Indicate if auth dummy login should be enabled.
 
-    , appEkgHost                :: Maybe Text
+    , appArchiveSocksProxyHost   :: Maybe Text
-    -- ^ Host/interface the ekg server should bind to.
+    -- ^ Socks proxy host to use when making archive requests
-    , appEkgPort                :: Maybe Int
+
-    -- ^ Port to listen on
+    , appArchiveSocksProxyPort   :: Maybe Int
+    -- ^ Socks proxy port to use when making archive requests
+
     , appSourceCodeUri                :: Maybe Text
     -- ^ Uri to app source code
+
+    , appSSLOnly :: Bool
+
+    , appAllowNonHttpUrlSchemes :: Bool
     }
 
 instance FromJSON AppSettings where
-    parseJSON = withObject "AppSettings" $ \o -> do
+    parseJSON = withObject "AppSettings" \o -> do
         let defaultDev =
 #ifdef DEVELOPMENT
                 True
@@ -92,9 +98,13 @@ instance FromJSON AppSettings where
 
         appAuthDummyLogin         <- o .:? "auth-dummy-login"      .!= dev
 
-        appEkgHost                <- o .:? "ekg-host"
+        appArchiveSocksProxyHost   <- o .:? "archive-socks-proxy-host"
-        appEkgPort                <- o .:? "ekg-port"
+        appArchiveSocksProxyPort   <- o .:? "archive-socks-proxy-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 {..}
 

stack.yaml

@@ -1,9 +1,3 @@
-resolver: lts-14.3
+resolver: lts-20.1
-# 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:
-- '.'
+- .

stack.yaml.lock

@@ -3,38 +3,10 @@
 # For more information, please see the documentation at:
 #   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:
 - completed:
-    size: 523878
+    sha256: b73b2b116143aea728c70e65c3239188998bac5bc3be56465813dacd74215dc5
-    url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/14/3.yaml
+    size: 648424
-    sha256: 470c46c27746a48c7c50f829efc0cf00112787a7804ee4ac7a27754658f6d92c
+    url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/20/1.yaml
-  original: lts-14.3
+  original: lts-20.1

static/css/main.css

@@ -1,194 +1,240 @@
-html {
+@media (prefers-color-scheme: dark) {
-    height: 102%;
+    html, img, video, iframe { filter: invert(1);  }
-}
+    body { background-color: white; }
-
+}
-body {
+
-    height: 102%;
+html {
-    word-wrap: break-word;
+    height: 102%;
-}
+}
-
+
-button {
+body {
-    background:none;
+    height: 102%;
-    border:none; 
+    word-wrap: break-word;
-    padding:0;
+}
-    cursor:pointer;
+
-}
+button {
-
+    background: none;
-button:focus {
+    border: none;
-    outline: none;
+    padding: 0;
-}
+    cursor: pointer;
-
+}
-
+
-[hidden] {
+button:focus {
-    display: none !important
+    outline: none;
-}
+}
-input::placeholder {
+
-   color: lightgray 
+[hidden] {
-}
+    display: none !important;
-.queryInput {
+}
-    width: 128px;
+
-    padding: 0 22px 0 2px;
+input::placeholder {
-    border-radius: 3px;
+    color: lightgray;
-    border-style: solid;
+}
-    border-width: 1px;
+
-    border-color: gray;
+input[type="text"],
-    height: 22px;
+input[type="url"],
-    line-height: 22px;
+input[type="password"],
-    transition: width .1s ease-in-out
+textarea {
-}
+    font-size: 16px;
-.queryInput.search-inactive {}
+}
-.queryInput:focus {
+
-    width: 175px;
+.queryInput {
-}
+    width: 128px;
-.submitting .queryInput,
+    padding: 0 22px 0 2px;
-.queryInput.search-active {
+    border-radius: 3px;
-    border-color: #990;
+    border-style: solid;
-    border-width: 2px;
+    border-width: 1px;
-    background-color: #FF9;
+    border-color: gray;
-    width: 175px;
+    height: 22px;
-}
+    line-height: 22px;
-.queryIcon {
+    transition: width 0.1s ease-in-out;
-    position: absolute;
+}
-    right: 0;
+.queryInput.search-inactive {
-    top:1px;
+}
-    cursor:pointer;
+.queryInput:focus {
-    width:20px;
+    width: 175px;
-    height: 20px;
+}
-    fill: currentColor;
+.submitting .queryInput,
-}
+.queryInput.search-active {
-label {
+    border-color: #990;
-    cursor: pointer;
+    border-width: 2px;
-}
+    background-color: #ff9;
-.close-x-wrap {
+    width: 175px;
-  float: left;
+}
-  width: 17px;
+.queryIcon {
-  height: 17px;
+    position: absolute;
-  top: 2px;
+    right: 0;
-  position: relative;
+    top: 1px;
-  right: 2px; 
+    cursor: pointer;
-}
+    width: 20px;
-.close-x {
+    height: 20px;
-  stroke: gray;
+    fill: currentColor;
-  fill: transparent;
+}
-  stroke-linecap: round;
+label {
-  stroke-width: 3;
+    cursor: pointer;
-}
+}
-.query-info-icon {
+.close-x-wrap {
-  position: absolute;
+    float: left;
-  top: 0px;
+    width: 17px;
-  right: -18px;
+    height: 17px;
-  text-decoration: none;
+    top: 2px;
-  font-size: 12px;
+    position: relative;
-  padding: 0 8px 8px 0;
+    right: 2px;
-}
+}
-.star {
+.close-x {
-    margin-left:-20px;
+    stroke: gray;
-    font-size:1.2em;
+    fill: transparent;
-    position:relative;
+    stroke-linecap: round;
-    top:-2px;
+    stroke-width: 3;
-}
+}
-
+.query-info-icon {
-.star button { 
+    position: absolute;
-    transition: color .1s;
+    top: 0px;
-}
+    right: -18px;
-.star.selected button { 
+    text-decoration: none;
-    color:#22a; 
+    font-size: 12px;
-}
+    padding: 0 8px 8px 0;
-.edit_links button {
+}
-    transition: color .1s ease-in;
+.star {
-}
+    margin-left: -20px;
-
+    font-size: 1.2em;
-.tag {
+    position: relative;
-    color:#a51;
+    top: -2px;
-    line-height:190%;
+}
-}
+
-
+.star button {
-.private { background:#ddd;border:1px solid #d1d1d1; }
+    transition: color 0.1s;
-.unread { color:#b41 }
+}
-.mark_read {color: #a81;}
+.star.selected button {
-.flash { color:green;background:#efe }
+    color: #22a;
-
+}
-.top_menu { 
+.edit_links button {
-    margin-top:6px;
+    transition: color 0.1s ease-in;
-}
+}
-.top_menu a {
+
-    color: blue;
+.tag {
-}
+    color: #a51;
-.bookmarklet { 
+    line-height: 190%;
-    padding:1px 2px 0px 2px;
+    display: inline-block;
-}
+}
-
+.tag-include {
-.alert { 
+    color: rgb(221, 221, 221);
-    background:#ced;
+    line-height: 190%;
-    border:1px solid #acc; 
+    display: inline-block;
-}
+}
-
+.tag-exclude {
-.edit_bookmark_form {color:#888;}
+    color: rgb(255, 170, 170);
-.edit_bookmark_form input {border:1px solid #ddd;}
+    line-height: 190%;
-.edit_bookmark_form textarea {border:1px solid #ddd;}
+    display: inline-block;
-
+}
-.nav-active {
+
-    background:#ff8;
+.private {
-    color:blue;
+    background: #ddd;
-}
+    border: 1px solid #d1d1d1;
-
+}
-/* mobile device */
+.unread {
-@media only screen and (max-width : 750px) {
+    color: #b41;
-    body { 
+}
-        -webkit-text-size-adjust: none; 
+.mark_read {
-    }
+    color: #a81;
-    .display {
+}
-        float: none
+.flash {
-    }
+    color: green;
-}
+    background: #efe;
-
+}
-@media only screen and (max-width : 500px) {
+
-    .filters {
+.top_menu {
-        clear: both;
+    margin-top: 6px;
-        position: relative;
+}
-        top: 2px;
+.top_menu a {
-    }
+    color: blue;
-}
+}
-
+.bookmarklet {
-.rdim {
+    padding: 1px 2px 0px 2px;
-  opacity: .8;
+}
-  transition: all .15s ease-in;
+
-}
+.alert {
-.rdim:hover,
+    background: #ced;
-.rdim:focus {
+    border: 1px solid #acc;
-  opacity: 1;
+    margin-bottom: 5px;
-  transition: all .15s ease-in;
+    padding: 2px;
-}
+}
-.display .description > div p,
+.alert.alert-err {
-.display .description > div pre
+    background-color: #ffdfdf
-{
+}
-  margin-top: 9px;
+
-  margin-bottom: 9px;
+.edit_bookmark_form {
-}
+    color: #888;
-.display .description > div > *:first-child {
+}
-  margin-top: 2px;
+.edit_bookmark_form input {
-}
+    border: 1px solid #ddd;
-.display .description > div > *:last-child {
+}
-  margin-bottom: 2px;
+.edit_bookmark_form textarea {
-}
+    border: 1px solid #ddd;
-.display .description > div > ol li p {
+}
-  margin-top: 0;
+
-  margin-bottom: 0;
+.nav-active {
-}
+    background: #ff8;
-.display .description > div > ul li p {
+    color: blue;
-  margin-top: 0;
+}
-  margin-bottom: 0;
+
-}
+/* mobile device */
-.display .description > div ol {
+@media only screen and (max-width: 750px) {
-  padding-left: 23px; 
+    body {
-}
+        -webkit-text-size-adjust: none;
-.display .description > div ul {
+    }
-  padding-left: 23px; 
+    .display {
-}
+        float: none;
-code, pre {
+    }
-    font-size:13px;
+}
-}
+
-
+@media only screen and (max-width: 500px) {
-#content:not([view-rendered]) .view-delay {
+    .filters {
-    display: none !important
+        clear: both;
-}
+        position: relative;
+        top: 2px;
+    }
+}
+
+.rdim {
+    opacity: 0.8;
+    transition: all 0.15s ease-in;
+}
+.rdim:hover,
+.rdim:focus {
+    opacity: 1;
+    transition: all 0.15s ease-in;
+}
+.display .description > div p,
+.display .description > div pre {
+    margin-top: 9px;
+    margin-bottom: 9px;
+}
+.display .description > div > *:first-child {
+    margin-top: 2px;
+}
+.display .description > div > *:last-child {
+    margin-bottom: 2px;
+}
+.display .description > div > ol li p {
+    margin-top: 0;
+    margin-bottom: 0;
+}
+.display .description > div > ul li p {
+    margin-top: 0;
+    margin-bottom: 0;
+}
+.display .description > div ol {
+    padding-left: 23px;
+}
+.display .description > div ul {
+    padding-left: 23px;
+}
+code,
+pre {
+    font-size: 13px;
+}
+
+#content:not([view-rendered]) .view-delay {
+    display: none !important;
+}

static/css/popup.css

@@ -1,34 +1,58 @@
 html {
-  box-sizing: border-box;
+    box-sizing: border-box;
 }
 [hidden] {
-    display: none !important
+    display: none !important;
 }
 button {
-    background:none;
+    background: none;
-    border:none; 
+    border: none;
-    padding:0;
+    padding: 0;
-    cursor:pointer;
+    cursor: pointer;
 }
 button:focus {
     outline: none;
 }
-.alert { 
+input[type="text"],
-    background:#ced;
+input[type="url"],
-    border:1px solid #acc; 
+textarea {
+    font-size: 16px;
 }
-form label { 
+.alert {
+    background: #ced;
+    border: 1px solid #acc;
+}
+#addForm .alert {
+    margin-top: -6px;
+}
+.alert.alert-err {
+    background-color: #ffdfdf
+}
+form label {
     margin: 0;
     vertical-align: middle;
     display: table-cell;
     padding: 2px 0;
 }
-li { list-style-type: none; margin: 0; padding: 0; display: block;} 
+li {
+    list-style-type: none;
+    margin: 0;
+    padding: 0;
+    display: block;
+}
 
-.when { color:#999}
+.when {
-.unread { color:#b41 }
+    color: #999;
-a.unread { color:#b41 }
+}
-a.bookmark_title { font-size:120%;}
+.unread {
+    color: #b41;
+}
+a.unread {
+    color: #b41;
+}
+a.bookmark_title {
+    font-size: 120%;
+}
 
 label {
     cursor: pointer;

templates/default-layout-wrapper.hamlet

@@ -1,38 +1,38 @@
-$newline never
+$newline never
-\<!doctype html>
+\<!doctype html>
-\<!--[if lt IE 7]> <html class="no-js ie6 oldie" lang="en"> <![endif]-->
+\<!--[if lt IE 7]> <html class="no-js ie6 oldie" lang="en"> <![endif]-->
-\<!--[if IE 7]>    <html class="no-js ie7 oldie" lang="en"> <![endif]-->
+\<!--[if IE 7]>    <html class="no-js ie7 oldie" lang="en"> <![endif]-->
-\<!--[if IE 8]>    <html class="no-js ie8 oldie" lang="en"> <![endif]-->
+\<!--[if IE 8]>    <html class="no-js ie8 oldie" lang="en"> <![endif]-->
-\<!--[if gt IE 8]><!-->
+\<!--[if gt IE 8]><!-->
-<html class="no-js" lang="en"> <!--<![endif]-->
+<html class="no-js" lang="en"> <!--<![endif]-->
-  <head>
+  <head>
-    <meta charset="UTF-8">
+    <meta charset="UTF-8">
-
+
-    <title>#{pageTitle pc}
+    <title>#{pageTitle pc}
-    <meta name="description" content="Espial is an open-source, web-based bookmarking server.">
+    <meta name="description" content="Espial is an open-source, web-based bookmarking server.">
-    <meta name="robots" content="noindex, nofollow, noodp, noydir">
+    <meta name="robots" content="noindex, nofollow, noodp, noydir">
-    <meta name="viewport" content="width=device-width,initial-scale=1">
+    <meta name="viewport" content="width=device-width,initial-scale=1">
-    $maybe sourceCodeUri <- msourceCodeUri
+    $maybe sourceCodeUri <- msourceCodeUri
-      <meta name="source" content="#{ sourceCodeUri }">
+      <meta name="source" content="#{ sourceCodeUri }">
-
+
-    ^{pageHead pc}
+    ^{pageHead pc}
-
+
-    \<!--[if lt IE 9]>
+    \<!--[if lt IE 9]>
-    \<script src="@{StaticR js_html5shiv_min_js}"></script>
+    \<script src="@{StaticR js_html5shiv_min_js}"></script>
-    \<![endif]-->
+    \<![endif]-->
-
+
-    <script>document.documentElement.className = document.documentElement.className.replace(/\bno-js\b/, 'js');
+    <script>document.documentElement.className = document.documentElement.className.replace(/\bno-js\b/, 'js');
-    <script src="@{StaticR js_js_cookie_2_2_0_min_js}">
+    <script src="@{StaticR js_js_cookie_2_2_0_min_js}">
-    <script>
+    <script>
-      var app =
+      var app =
-        { csrfHeaderName: "#{ TE.decodeUtf8 $ CI.foldedCase defaultCsrfHeaderName }"
+        { csrfHeaderName: "#{ TE.decodeUtf8 $ CI.foldedCase defaultCsrfHeaderName }"
-        , csrfParamName: "#{ defaultCsrfParamName }"
+        , csrfParamName: "#{ defaultCsrfParamName }"
-        , csrfCookieName: "#{ TE.decodeUtf8 defaultCsrfCookieName }"
+        , csrfCookieName: "#{ TE.decodeUtf8 defaultCsrfCookieName }"
-        , csrfToken: Cookies.get("#{ TE.decodeUtf8 defaultCsrfCookieName }")
+        , csrfToken: Cookies.get("#{ TE.decodeUtf8 defaultCsrfCookieName }")
-        , homeR: "@{ HomeR }"
+        , homeR: "@{ HomeR }"
-        , authRlogoutR: "@{ AuthR LogoutR }"
+        , authRlogoutR: "@{ AuthR LogoutR }"
-        , userFilterRFilterSingle: ""
+        , userFilterRFilterSingle: ""
-        , dat: {bmarks : [], bmark: {}, isowner: false, notes: []}
+        , dat: {bmarks : [], bmark: {}, isowner: false, notes: []}
-        };
+        };
-  <body .f6.dark-gray.helvetica>
+  <body .f6.dark-gray.helvetica>
-    ^{pageBody pc}
+    ^{pageBody pc}

templates/default-layout.hamlet

@@ -14,12 +14,11 @@
       <div .top_menu.fr>
 
         $maybe userName <- musername
-          $maybe currentroute <- mcurrentRoute
+          <a .link href="@?{(AddViewR, [("next","back")])}">add url&nbsp;&nbsp;
-            <a .link href="@?{(AddViewR, [("next",urlrender currentroute)])}">add url&nbsp;&nbsp;
+          <a .link href="@{AddNoteViewR (UserNameP userName)}">add note&nbsp;&nbsp;
-            <a .link href="@{AddNoteViewR (UserNameP userName)}">add note&nbsp;&nbsp;
+          <a .link href="@{NotesR (UserNameP userName)}">notes&nbsp;&nbsp;
-            <a .link href="@{NotesR (UserNameP userName)}">notes&nbsp;&nbsp;
+          <a .link href="@{AccountSettingsR}">settings&nbsp;&nbsp;
-            <a .link href="@{AccountSettingsR}">settings&nbsp;&nbsp;
+          <a .link onclick="PS.logoutE(event)()" href="@{AuthR LogoutR}">
-            <a .link onclick="PS['Main'].logoutE(event)()" href="@{AuthR LogoutR}">
               log out
         $nothing
           <a .link href="@{AuthR LoginR}">

templates/popup-layout.hamlet

@@ -5,7 +5,7 @@
       - (#{userName})
   <div .fr>
     $maybe userName <- musername
-      <a .link onclick="PS['Main'].logoutE(event)()" href="@{AuthR LogoutR}">
+      <a .link onclick="PS.logoutE(event)()" href="@{AuthR LogoutR}">
         [log out]
     $nothing
       <a .link href="@{AuthR LoginR}">

templates/user-settings.hamlet

@@ -1,7 +1,7 @@
 <main #main_column .pv2.ph3.mh1>
   <div .w-100.mw8.center>
     <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=350'));">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=360'));">add url bookmarklet
 
     <a .pa3 href="@{ChangePasswordR}">Change Password
 

templates/user.hamlet

@@ -1,59 +1,71 @@
-$maybe route <- mroute
+$maybe route <- mroute
-  <main #main_column .pv2.ph3.mh1>
+  <main #main_column .pv2.ph3.mh1>
-    <div .w-100.mw8.center>
+    <div .w-100.mw8.center>
-      <div .fr.nt1 style="margin-bottom:.7rem">
+      <div .fr.nt1 style="margin-bottom:.7rem">
-        ^{search}
+        ^{search}
-      <div .di>
+      <div .di>
-        <div .fl.pr3.dib.mb2>
+        <div .fl.pr3.dib.mb2>
-          <b>
+          <b>
-            <a .link href="@{UserR unamep}">#{uname}
+            <a .link href="@{UserR unamep}">#{uname}
-            $forall tag <- pathtags
+            $forall tag <- pathtags
-              \  + #
+              \  + #
-              <a .link href="@{UserTagsR unamep (TagsP [tag])}">#{tag}
+              <a .link href="@{UserTagsR unamep (TagsP [tag])}">#{tag}
-        <div .fl.pr3.dib.mb2>
+        <div .fl.pr3.dib.mb2>
-          <span .f7.silver>#{bcount}</span>
+          <span .f7.silver>#{bcount}</span>
-        $if isowner
+        $if isowner
-          <div .fl.pr3.dib.mb2>
+          <div .fl.pr3.dib.mb2>
-            <a .link.silver.hover-blue :isAll:.nav-active 
+            <a .link.silver.hover-blue :isAll:.nav-active 
-               href="@{UserR unamep}">all
+               href="@{UserR unamep}">all
-            ‧  
+            ‧  
-            <a .link.silver.hover-blue :sharedp == SharedPrivate:.nav-active 
+            <a .link.silver.hover-blue :sharedp == SharedPrivate:.nav-active 
-               href="@{UserSharedR unamep SharedPrivate}">private
+               href="@{UserSharedR unamep SharedPrivate}">private
-            ‧  
+            ‧  
-            <a .link.silver.hover-blue :sharedp == SharedPublic:.nav-active 
+            <a .link.silver.hover-blue :sharedp == SharedPublic:.nav-active 
-               href="@{UserSharedR unamep SharedPublic}">public
+               href="@{UserSharedR unamep SharedPublic}">public
-            ‧  
+            ‧  
-            <a .link.silver.hover-blue :filterp == FilterUnread:.nav-active 
+            <a .link.silver.hover-blue :filterp == FilterUnread:.nav-active 
-               href="@{UserFilterR unamep FilterUnread}">unread
+               href="@{UserFilterR unamep FilterUnread}">unread
-            ‧  
+            ‧  
-            <a .link.silver.hover-blue :filterp == FilterUntagged:.nav-active 
+            <a .link.silver.hover-blue :filterp == FilterUntagged:.nav-active 
-               href="@{UserFilterR unamep FilterUntagged}">untagged
+               href="@{UserFilterR unamep FilterUntagged}">untagged
-            ‧  
+            ‧  
-            <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>
-            <a .link.gold.hover-orange
+          $if sharedp == SharedPrivate
-               href="@{UserFeedR unamep}">RSS
+            <a .link.gold.hover-orange href="@?{(UserFeedSharedR unamep SharedPrivate, catMaybes [mqueryp])}">RSS
-  
+          $elseif sharedp == SharedPublic
-      <div .cf>
+            <a .link.gold.hover-orange href="@?{(UserFeedSharedR unamep SharedPublic, catMaybes [mqueryp])}">RSS
-      
+          $elseif filterp == FilterUnread
-      ^{pager}
+            <a .link.gold.hover-orange href="@?{(UserFeedFilterR unamep FilterUnread, catMaybes [mqueryp])}">RSS
-  
+          $elseif filterp == FilterUntagged
-      <div .cf>
+            <a .link.gold.hover-orange href="@?{(UserFeedFilterR unamep FilterUntagged, catMaybes [mqueryp])}">RSS
-  
+          $elseif filterp == FilterStarred
-      <div ##{renderEl} .mt3>
+            <a .link.gold.hover-orange href="@?{(UserFeedFilterR unamep FilterStarred, catMaybes [mqueryp])}">RSS
-  
+          $else
-      <div .cf>
+            <a .link.gold.hover-orange href="@?{(UserFeedR unamep, catMaybes [mqueryp])}">RSS
-  
+  
-      <div .user_footer.view-delay>
+      <div .cf>
-        ^{pager}
+      
-  
+      ^{pager}
-        $if (fromIntegral bcount >= limit) || (page > 1)
+  
-          <div .dib.ml5>
+      <div .cf>
-            <span .silver.mr1>per page:
+  
-            <a .link.light-silver :limit == 20:.nav-active href="@?{(route, catMaybes [Just ("count", "20"), mqueryp])}"‧>20</a> ‧ 
+      <div ##{tagCloudRenderEl}>
-            <a .link.light-silver :limit == 40:.nav-active href="@?{(route, catMaybes [Just ("count", "40"), mqueryp])}"‧>40</a> ‧ 
+
-            <a .link.light-silver :limit == 80:.nav-active href="@?{(route, catMaybes [Just ("count", "80"), mqueryp])}"‧>80</a> ‧ 
+      <div ##{renderEl} .mt3>
-            <a .link.light-silver :limit == 120:.nav-active href="@?{(route, catMaybes [Just ("count", "120"), mqueryp])}"‧>120</a> ‧ 
+  
-            <a .link.light-silver :limit == 160:.nav-active href="@?{(route, catMaybes [Just ("count", "160"), mqueryp])}"‧>160</a>
+      <div .cf>
-  
+  
+      <div .user_footer.view-delay>
+        ^{pager}
+  
+        $if (fromIntegral bcount >= limit) || (page > 1)
+          <div .dib.ml5>
+            <span .silver.mr1>per page:
+            <a .link.light-silver :limit == 20:.nav-active href="@?{(route, catMaybes [Just ("count", "20"), mqueryp])}"‧>20</a> ‧ 
+            <a .link.light-silver :limit == 40:.nav-active href="@?{(route, catMaybes [Just ("count", "40"), mqueryp])}"‧>40</a> ‧ 
+            <a .link.light-silver :limit == 80:.nav-active href="@?{(route, catMaybes [Just ("count", "80"), mqueryp])}"‧>80</a> ‧ 
+            <a .link.light-silver :limit == 120:.nav-active href="@?{(route, catMaybes [Just ("count", "120"), mqueryp])}"‧>120</a> ‧ 
+            <a .link.light-silver :limit == 160:.nav-active href="@?{(route, catMaybes [Just ("count", "160"), mqueryp])}"‧>160</a>
+  

test/TestImport.hs

@@ -10,7 +10,7 @@ module TestImport
 import Application           (makeFoundation, makeLogWare)
 import ClassyPrelude         as X hiding (delete, deleteBy, Handler)
 import Database.Persist      as X hiding (get)
-import Database.Persist.Sql  (SqlPersistM, runSqlPersistMPool, rawExecute, rawSql, unSingle, connEscapeName)
+import Database.Persist.Sql  (SqlPersistM, runSqlPersistMPool, rawExecute, rawSql, unSingle)
 import Foundation            as X
 import Model                 as X
 import Test.Hspec            as X
@@ -62,8 +62,9 @@ wipeDB app = do
 
     flip runSqlPersistMPool pool $ do
         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 [])
 
 getTables :: DB [Text]