espial (empty) → 0.0.1
raw patch · 26 files changed
+1907/−0 lines, 26 filesdep +aesondep +basedep +bcrypt
Dependencies added: aeson, base, bcrypt, bytestring, case-insensitive, classy-prelude, classy-prelude-conduit, classy-prelude-yesod, conduit, containers, data-default, directory, espial, esqueleto, fast-logger, file-embed, foreign-store, hjsmin, hscolour, hspec, http-conduit, iso8601-time, microlens, monad-control, monad-logger, mtl, optparse-generic, persistent, persistent-sqlite, persistent-template, pretty-show, safe, shakespeare, template-haskell, text, time, transformers, unordered-containers, vector, wai, wai-extra, wai-logger, warp, yaml, yesod, yesod-auth, yesod-core, yesod-form, yesod-static, yesod-test
Files
- README.md +60/−0
- app/DevelMain.hs +99/−0
- app/main.hs +5/−0
- app/migration/Main.hs +61/−0
- changelog.md +3/−0
- espial.cabal +300/−0
- src/Application.hs +143/−0
- src/Foundation.hs +212/−0
- src/Handler/Add.hs +128/−0
- src/Handler/Common.hs +18/−0
- src/Handler/Edit.hs +62/−0
- src/Handler/Home.hs +12/−0
- src/Handler/User.hs +67/−0
- src/Import.hs +86/−0
- src/Import/NoFoundation.hs +21/−0
- src/Model.hs +250/−0
- src/ModelCrypto.hs +30/−0
- src/PathPiece.hs +54/−0
- src/Pretty.hs +15/−0
- src/Settings.hs +143/−0
- src/Settings/StaticFiles.hs +18/−0
- src/Types.hs +17/−0
- test/Handler/CommonSpec.hs +17/−0
- test/Handler/HomeSpec.hs +13/−0
- test/Spec.hs +1/−0
- test/TestImport.hs +72/−0
+ README.md view
@@ -0,0 +1,60 @@+# Espial++Espial is an open-source, web-based bookmarking server.++## Haskell Setup++1. If you haven't already, [install Stack](https://haskell-lang.org/get-started)+ * On POSIX systems, this is usually `curl -sSL https://get.haskellstack.org/ | sh`+2. Install the `yesod` command line tool: `stack install yesod-bin --install-ghc`++## Espial Setup++1. Build executables+ + ```+ stack build+ ```++2. Create the database++ ```+ stack exec migration -- createdb --conn espial.sqlite3+ ```++3. Create a user++ ```+ stack exec migration -- createuser --conn espial.sqlite3 --userName myusername --userPassword myuserpassword+ ```++4. Import a bookmark file for a user (optional)++ ```+ stack exec migration -- importbookmarks --conn espial.sqlite3 --userName myusername --bookmarkFile sample-bookmarks.json+ ```++5. Start a development server:++ ```+ stack exec -- yesod devel+ ```++6. Start a production server:++ ```+ stack exec espial+ ```++## Import Bookmark file format++see `sample-bookmarks.json`, which contains a JSON array, each line containing a `Post` object. ++example:++```+[ {"href":"http:\/\/mqtt.org\/","description":"MQTT","extended":"long description","time":"2018-02-25T21:22:42Z","shared":"yes","toread":"no","tags":"mqtt"}+, {"href":"http:\/\/mqtt.com\/","description":"MQTT","extended":"big description","time":"2019-02-25T21:22:42Z","shared":"yes","toread":"no","tags":"mqtt"}+]++```
+ app/DevelMain.hs view
@@ -0,0 +1,99 @@+-- | Running your app inside GHCi.+--+-- To start up GHCi for usage with Yesod, first make sure you are in dev mode:+--+-- > cabal configure -fdev+--+-- Note that @yesod devel@ automatically sets the dev flag.+-- Now launch the repl:+--+-- > cabal repl --ghc-options="-O0 -fobject-code"+--+-- To start your app, run:+--+-- > :l DevelMain+-- > DevelMain.update+--+-- You can also call @DevelMain.shutdown@ to stop the app+--+-- You will need to add the foreign-store package to your .cabal file.+-- It is very light-weight.+--+-- If you don't use cabal repl, you will need+-- to run the following in GHCi or to add it to+-- your .ghci file.+--+-- :set -DDEVELOPMENT+--+-- There is more information about this approach,+-- on the wiki: https://github.com/yesodweb/yesod/wiki/ghci++module DevelMain where++import Prelude+import Application (getApplicationRepl, shutdownApp)++import Control.Exception (finally)+import Control.Monad ((>=>))+import Control.Concurrent+import Data.IORef+import Foreign.Store+import Network.Wai.Handler.Warp+import GHC.Word++-- | Start or restart the server.+-- newStore is from foreign-store.+-- A Store holds onto some data across ghci reloads+update :: IO ()+update = do+ mtidStore <- lookupStore tidStoreNum+ case mtidStore of+ -- no server running+ Nothing -> do+ done <- storeAction doneStore newEmptyMVar+ tid <- start done+ _ <- storeAction (Store tidStoreNum) (newIORef tid)+ return ()+ -- server is already running+ Just tidStore -> restartAppInNewThread tidStore+ where+ doneStore :: Store (MVar ())+ doneStore = Store 0++ -- shut the server down with killThread and wait for the done signal+ restartAppInNewThread :: Store (IORef ThreadId) -> IO ()+ restartAppInNewThread tidStore = modifyStoredIORef tidStore $ \tid -> do+ killThread tid+ withStore doneStore takeMVar+ readStore doneStore >>= start+++ -- | Start the server in a separate thread.+ start :: MVar () -- ^ Written to when the thread is killed.+ -> IO ThreadId+ start done = do+ (port, site, app) <- getApplicationRepl+ forkIO (finally (runSettings (setPort port defaultSettings) app)+ -- Note that this implies concurrency+ -- between shutdownApp and the next app that is starting.+ -- Normally this should be fine+ (putMVar done () >> shutdownApp site))++-- | kill the server+shutdown :: IO ()+shutdown = do+ mtidStore <- lookupStore tidStoreNum+ case mtidStore of+ -- no server running+ Nothing -> putStrLn "no Yesod app running"+ Just tidStore -> do+ withStore tidStore $ readIORef >=> killThread+ putStrLn "Yesod app is shutdown"++tidStoreNum :: Word32+tidStoreNum = 1++modifyStoredIORef :: Store (IORef a) -> (a -> IO a) -> IO ()+modifyStoredIORef store f = withStore store $ \ref -> do+ v <- readIORef ref+ f v >>= writeIORef ref
+ app/main.hs view
@@ -0,0 +1,5 @@+import Prelude (IO)+import Application (appMain)++main :: IO ()+main = appMain
+ app/migration/Main.hs view
@@ -0,0 +1,61 @@+{-# OPTIONS_GHC -fno-warn-name-shadowing #-}++module Main where++import Types+import Model+import ModelCrypto+import Pretty++import qualified Database.Persist as P+import qualified Database.Persist.Sqlite as P++import ClassyPrelude++import Options.Generic++data MigrationOpts+ = CreateDB { conn :: Text}+ | CreateUser { conn :: Text+ , userName :: Text+ , userPassword :: Text+ , userApiToken :: Maybe Text}+ | DeleteUser { conn :: Text+ , userName :: Text+ }+ | ImportBookmarks { conn :: Text+ , userName :: Text+ , bookmarkFile :: FilePath}+ deriving (Generic, Show)++instance ParseRecord MigrationOpts++main :: IO ()+main =+ getRecord "Migrations" >>=+ \case+ CreateDB conn -> P.runSqlite conn runMigrations+ CreateUser conn uname upass utoken ->+ P.runSqlite conn $+ do hash' <- liftIO $ hashPassword upass+ user <-+ P.upsertBy+ (UniqueUserName uname)+ (User uname hash' utoken)+ [UserPasswordHash P.=. hash', UserApiToken P.=. utoken]+ liftIO $ cpprint user+ pure () :: DB ()+ DeleteUser conn uname ->+ P.runSqlite conn $+ do P.getBy (UniqueUserName uname) >>=+ \case+ Just (P.Entity uid _) -> do+ P.deleteCascade uid+ pure () :: DB ()+ Nothing -> liftIO $ print $ uname ++ "not found"+ ImportBookmarks conn uname file ->+ P.runSqlite conn $+ do P.getBy (UniqueUserName uname) >>=+ \case+ Just (P.Entity uid _) -> insertFileBookmarks uid file+ Nothing -> liftIO $ print $ uname ++ "not found"
+ changelog.md view
@@ -0,0 +1,3 @@+__v0.0.1__++init
+ espial.cabal view
@@ -0,0 +1,300 @@+-- This file has been generated from package.yaml by hpack version 0.28.2.+--+-- see: https://github.com/sol/hpack+--+-- hash: ff25235092634e69f772d5ca291191962a221d4a5a24272fe0eed62041fd9794++name: espial+version: 0.0.1+synopsis: Espial is an open-source, web-based bookmarking server.+description: .+ Espial is an open-source, web-based bookmarking server.+ - Yesod + sqlite3+ - multi-user (w/ privacy scopes)+ - tags, stars, editing, deleting +category: Web+homepage: https://github.com/jonschoning/espial+bug-reports: https://github.com/jonschoning/espial/issues+author: Jon Schoning+maintainer: jonschoning@gmail.com+copyright: Copyright (c) 2018 Jon Schoning+license: MIT+build-type: Simple+cabal-version: >= 1.10+extra-source-files:+ changelog.md+ README.md++source-repository head+ type: git+ location: git://github.com/jonschoning/espial.git++flag dev+ description: Turn on development settings, like auto-reload templates.+ manual: False+ default: False++flag library-only+ description: Build for use with "yesod devel"+ manual: False+ default: False++library+ hs-source-dirs:+ src+ default-extensions: BangPatterns CPP ConstraintKinds DeriveDataTypeable DeriveGeneric EmptyDataDecls FlexibleContexts FlexibleInstances GADTs GeneralizedNewtypeDeriving InstanceSigs LambdaCase MultiParamTypeClasses MultiWayIf NoImplicitPrelude OverloadedStrings QuasiQuotes RankNTypes RecordWildCards ScopedTypeVariables StandaloneDeriving TemplateHaskell TupleSections TypeFamilies TypeOperators ViewPatterns+ build-depends:+ aeson >=0.6 && <1.3+ , base >=4.8.2.0 && <4.9 || >=4.9.1.0 && <5+ , bcrypt >=0.0.8 && <0.0.11+ , bytestring >=0.9 && <0.11+ , case-insensitive+ , classy-prelude >=0.10.2+ , classy-prelude-conduit >=0.10.2+ , classy-prelude-yesod >=0.10.2 && <1.0 || >=1.1+ , conduit >=1.0 && <2.0+ , containers+ , data-default+ , directory >=1.1 && <1.4+ , esqueleto+ , fast-logger >=2.2 && <2.5+ , file-embed+ , foreign-store+ , hjsmin >=0.1 && <0.3+ , hscolour+ , http-conduit >=2.1 && <2.3+ , iso8601-time >=0.1.3 && <0.2.0+ , monad-control >=0.3 && <1.1+ , monad-logger >=0.3 && <0.4+ , mtl+ , persistent >=2.0 && <2.8+ , persistent-sqlite >=2.6.2 && <2.8+ , persistent-template >=2.0 && <2.8+ , pretty-show+ , safe+ , shakespeare >=2.0 && <2.1+ , template-haskell+ , text >=0.11 && <2.0+ , time+ , transformers >=0.2.2+ , unordered-containers+ , vector+ , wai+ , wai-extra >=3.0 && <3.1+ , wai-logger >=2.2 && <2.4+ , warp >=3.0 && <3.3+ , yaml >=0.8 && <0.9+ , yesod >=1.4.3 && <1.5+ , yesod-auth >=1.4.0 && <1.5+ , yesod-core >=1.4.30 && <1.5+ , yesod-form >=1.4.0 && <1.5+ , yesod-static >=1.4.0.3 && <1.6+ if (flag(dev)) || (flag(library-only))+ ghc-options: -Wall -fwarn-tabs -O0+ cpp-options: -DDEVELOPMENT+ else+ ghc-options: -Wall -fwarn-tabs -O2+ exposed-modules:+ Application+ Foundation+ Handler.Add+ Handler.Common+ Handler.Edit+ Handler.Home+ Handler.User+ Import+ Import.NoFoundation+ Model+ ModelCrypto+ PathPiece+ Pretty+ Settings+ Settings.StaticFiles+ Types+ other-modules:+ Paths_espial+ default-language: Haskell2010++executable espial+ main-is: main.hs+ hs-source-dirs:+ app+ default-extensions: BangPatterns CPP ConstraintKinds DeriveDataTypeable DeriveGeneric EmptyDataDecls FlexibleContexts FlexibleInstances GADTs GeneralizedNewtypeDeriving InstanceSigs LambdaCase MultiParamTypeClasses MultiWayIf NoImplicitPrelude OverloadedStrings QuasiQuotes RankNTypes RecordWildCards ScopedTypeVariables StandaloneDeriving TemplateHaskell TupleSections TypeFamilies TypeOperators ViewPatterns+ ghc-options: -threaded -rtsopts -with-rtsopts=-N+ build-depends:+ aeson >=0.6 && <1.3+ , base >=4.8.2.0 && <4.9 || >=4.9.1.0 && <5+ , bcrypt >=0.0.8 && <0.0.11+ , bytestring >=0.9 && <0.11+ , case-insensitive+ , classy-prelude >=0.10.2+ , classy-prelude-conduit >=0.10.2+ , classy-prelude-yesod >=0.10.2 && <1.0 || >=1.1+ , conduit >=1.0 && <2.0+ , containers+ , data-default+ , directory >=1.1 && <1.4+ , espial+ , esqueleto+ , fast-logger >=2.2 && <2.5+ , file-embed+ , foreign-store+ , hjsmin >=0.1 && <0.3+ , hscolour+ , http-conduit >=2.1 && <2.3+ , iso8601-time >=0.1.3 && <0.2.0+ , monad-control >=0.3 && <1.1+ , monad-logger >=0.3 && <0.4+ , mtl+ , persistent >=2.0 && <2.8+ , persistent-sqlite >=2.6.2 && <2.8+ , persistent-template >=2.0 && <2.8+ , pretty-show+ , safe+ , shakespeare >=2.0 && <2.1+ , template-haskell+ , text >=0.11 && <2.0+ , time+ , transformers >=0.2.2+ , unordered-containers+ , vector+ , wai+ , wai-extra >=3.0 && <3.1+ , wai-logger >=2.2 && <2.4+ , warp >=3.0 && <3.3+ , yaml >=0.8 && <0.9+ , yesod >=1.4.3 && <1.5+ , yesod-auth >=1.4.0 && <1.5+ , yesod-core >=1.4.30 && <1.5+ , yesod-form >=1.4.0 && <1.5+ , yesod-static >=1.4.0.3 && <1.6+ if flag(library-only)+ buildable: False+ other-modules:+ DevelMain+ Paths_espial+ default-language: Haskell2010++executable migration+ main-is: Main.hs+ hs-source-dirs:+ app/migration+ default-extensions: BangPatterns CPP ConstraintKinds DeriveDataTypeable DeriveGeneric EmptyDataDecls FlexibleContexts FlexibleInstances GADTs GeneralizedNewtypeDeriving InstanceSigs LambdaCase MultiParamTypeClasses MultiWayIf NoImplicitPrelude OverloadedStrings QuasiQuotes RankNTypes RecordWildCards ScopedTypeVariables StandaloneDeriving TemplateHaskell TupleSections TypeFamilies TypeOperators ViewPatterns+ ghc-options: -threaded -rtsopts -with-rtsopts=-N+ build-depends:+ aeson >=0.6 && <1.3+ , base >=4.8.2.0 && <4.9 || >=4.9.1.0 && <5+ , bcrypt >=0.0.8 && <0.0.11+ , bytestring >=0.9 && <0.11+ , case-insensitive+ , classy-prelude >=0.10.2+ , classy-prelude-conduit >=0.10.2+ , classy-prelude-yesod >=0.10.2 && <1.0 || >=1.1+ , conduit >=1.0 && <2.0+ , containers+ , data-default+ , directory >=1.1 && <1.4+ , espial+ , esqueleto+ , fast-logger >=2.2 && <2.5+ , file-embed+ , foreign-store+ , hjsmin >=0.1 && <0.3+ , hscolour+ , http-conduit >=2.1 && <2.3+ , iso8601-time >=0.1.3 && <0.2.0+ , monad-control >=0.3 && <1.1+ , monad-logger >=0.3 && <0.4+ , mtl+ , optparse-generic >=1.2.3+ , persistent >=2.0 && <2.8+ , persistent-sqlite >=2.6.2 && <2.8+ , persistent-template >=2.0 && <2.8+ , pretty-show+ , safe+ , shakespeare >=2.0 && <2.1+ , template-haskell+ , text >=0.11 && <2.0+ , time+ , transformers >=0.2.2+ , unordered-containers+ , vector+ , wai+ , wai-extra >=3.0 && <3.1+ , wai-logger >=2.2 && <2.4+ , warp >=3.0 && <3.3+ , yaml >=0.8 && <0.9+ , yesod >=1.4.3 && <1.5+ , yesod-auth >=1.4.0 && <1.5+ , yesod-core >=1.4.30 && <1.5+ , yesod-form >=1.4.0 && <1.5+ , yesod-static >=1.4.0.3 && <1.6+ if flag(library-only)+ buildable: False+ other-modules:+ Paths_espial+ default-language: Haskell2010++test-suite test+ type: exitcode-stdio-1.0+ main-is: Spec.hs+ hs-source-dirs:+ test+ default-extensions: BangPatterns CPP ConstraintKinds DeriveDataTypeable DeriveGeneric EmptyDataDecls FlexibleContexts FlexibleInstances GADTs GeneralizedNewtypeDeriving InstanceSigs LambdaCase MultiParamTypeClasses MultiWayIf NoImplicitPrelude OverloadedStrings QuasiQuotes RankNTypes RecordWildCards ScopedTypeVariables StandaloneDeriving TemplateHaskell TupleSections TypeFamilies TypeOperators ViewPatterns+ ghc-options: -Wall+ build-depends:+ aeson >=0.6 && <1.3+ , base >=4.8.2.0 && <4.9 || >=4.9.1.0 && <5+ , bcrypt >=0.0.8 && <0.0.11+ , bytestring >=0.9 && <0.11+ , case-insensitive+ , classy-prelude >=0.10.2+ , classy-prelude-conduit >=0.10.2+ , classy-prelude-yesod >=0.10.2 && <1.0 || >=1.1+ , conduit >=1.0 && <2.0+ , containers+ , data-default+ , directory >=1.1 && <1.4+ , espial+ , esqueleto+ , fast-logger >=2.2 && <2.5+ , file-embed+ , foreign-store+ , hjsmin >=0.1 && <0.3+ , hscolour+ , hspec >=2.0.0+ , http-conduit >=2.1 && <2.3+ , iso8601-time >=0.1.3 && <0.2.0+ , microlens+ , monad-control >=0.3 && <1.1+ , monad-logger >=0.3 && <0.4+ , mtl+ , persistent >=2.0 && <2.8+ , persistent-sqlite >=2.6.2 && <2.8+ , persistent-template >=2.0 && <2.8+ , pretty-show+ , safe+ , shakespeare >=2.0 && <2.1+ , template-haskell+ , text >=0.11 && <2.0+ , time+ , transformers >=0.2.2+ , unordered-containers+ , vector+ , wai+ , wai-extra >=3.0 && <3.1+ , wai-logger >=2.2 && <2.4+ , warp >=3.0 && <3.3+ , yaml >=0.8 && <0.9+ , yesod >=1.4.3 && <1.5+ , yesod-auth >=1.4.0 && <1.5+ , yesod-core >=1.4.30 && <1.5+ , yesod-form >=1.4.0 && <1.5+ , yesod-static >=1.4.0.3 && <1.6+ , yesod-test+ other-modules:+ Handler.CommonSpec+ Handler.HomeSpec+ TestImport+ Paths_espial+ default-language: Haskell2010
+ src/Application.hs view
@@ -0,0 +1,143 @@+{-# OPTIONS_GHC -fno-warn-orphans #-}++module Application+ ( getApplicationDev+ , appMain+ , develMain+ , makeFoundation+ , makeLogWare+ -- * for DevelMain+ , getApplicationRepl+ , shutdownApp+ -- * for GHCI+ , handler+ , db+ ) where++import Control.Monad.Logger (liftLoc, runLoggingT)+import Database.Persist.Sqlite+ (createSqlitePool, sqlDatabase, sqlPoolSize)+import Import+import Yesod.Auth (getAuth)+import Language.Haskell.TH.Syntax (qLocation)+import Network.Wai (Middleware)+import Network.Wai.Handler.Warp+ (Settings, defaultSettings, defaultShouldDisplayException,+ runSettings, setHost, setOnException, setPort, getPort)+import Network.Wai.Middleware.RequestLogger+ (Destination(Logger), IPAddrSource(..), OutputFormat(..),+ destination, mkRequestLogger, outputFormat)+import System.Log.FastLogger+ (defaultBufSize, newStdoutLoggerSet, toLogStr)++-- Import all relevant handler modules here.+-- Don't forget to add new modules to your cabal file!+import Handler.Common+import Handler.Home+import Handler.User+import Handler.Add+import Handler.Edit++mkYesodDispatch "App" resourcesApp++makeFoundation :: AppSettings -> IO App+makeFoundation appSettings = do+ appHttpManager <- newManager+ appLogger <- newStdoutLoggerSet defaultBufSize >>= makeYesodLogger+ appStatic <-+ (if appMutableStatic appSettings+ then staticDevel+ else static)+ (appStaticDir appSettings)+ let mkFoundation appConnPool = App { ..}+ tempFoundation = mkFoundation (error "connPool forced in tempFoundation")+ logFunc = messageLoggerSource tempFoundation appLogger+ pool <-+ flip runLoggingT logFunc $+ createSqlitePool+ (sqlDatabase (appDatabaseConf appSettings))+ (sqlPoolSize (appDatabaseConf appSettings))+ -- runLoggingT+ -- (runSqlPool runMigrations pool)+ -- logFunc+ return (mkFoundation pool)++makeApplication :: App -> IO Application+makeApplication foundation = do+ logWare <- makeLogWare foundation+ appPlain <- toWaiAppPlain foundation+ return (logWare (defaultMiddlewaresNoLogging appPlain))++makeLogWare :: App -> IO Middleware+makeLogWare foundation =+ mkRequestLogger+ def+ { outputFormat =+ if appDetailedRequestLogging (appSettings foundation)+ then Detailed True+ else Apache+ (if appIpFromHeader (appSettings foundation)+ then FromFallback+ else FromSocket)+ , destination = Logger (loggerSet (appLogger foundation))+ }++-- | Warp settings for the given foundation value.+warpSettings :: App -> Settings+warpSettings foundation =+ setPort (appPort (appSettings foundation)) $+ setHost (appHost (appSettings foundation)) $+ setOnException+ (\_req e ->+ when (defaultShouldDisplayException e) $+ messageLoggerSource+ foundation+ (appLogger foundation)+ $(qLocation >>= liftLoc)+ "yesod"+ LevelError+ (toLogStr $ "Exception from Warp: " ++ show e))+ defaultSettings++-- | For yesod devel, return the Warp settings and WAI Application.+getApplicationDev :: IO (Settings, Application)+getApplicationDev = do+ settings <- getAppSettings+ foundation <- makeFoundation settings+ wsettings <- getDevSettings (warpSettings foundation)+ app <- makeApplication foundation+ return (wsettings, app)++getAppSettings :: IO AppSettings+getAppSettings = loadYamlSettings [configSettingsYml] [] useEnv++-- | main function for use by yesod devel+develMain :: IO ()+develMain = develMainHelper getApplicationDev++-- | The @main@ function for an executable running this site.+appMain :: IO ()+appMain = do+ settings <- loadYamlSettingsArgs [configSettingsYmlValue] useEnv+ foundation <- makeFoundation settings+ app <- makeApplication foundation+ runSettings (warpSettings foundation) app++getApplicationRepl :: IO (Int, App, Application)+getApplicationRepl = do+ settings <- getAppSettings+ foundation <- makeFoundation settings+ wsettings <- getDevSettings (warpSettings foundation)+ app1 <- makeApplication foundation+ return (getPort wsettings, foundation, app1)++shutdownApp :: App -> IO ()+shutdownApp _ = return ()++-- | Run a handler+handler :: Handler a -> IO a+handler h = getAppSettings >>= makeFoundation >>= flip unsafeHandler h++-- | Run DB queries+db :: ReaderT SqlBackend (HandlerT App IO) a -> IO a+db = handler . runDB
+ src/Foundation.hs view
@@ -0,0 +1,212 @@+{-# OPTIONS_GHC -fno-warn-unused-matches #-}++module Foundation where++import Import.NoFoundation+import Database.Persist.Sql (ConnectionPool, runSqlPool)+import Text.Hamlet (hamletFile)+import Text.Jasmine (minifym)+import PathPiece()++-- import Yesod.Auth.Dummy++import Yesod.Default.Util (addStaticContentExternal)+import Yesod.Core.Types+import Yesod.Auth.Message+import qualified Yesod.Core.Unsafe as Unsafe+import qualified Data.CaseInsensitive as CI+import qualified Data.Text.Encoding as TE++data App = App+ { appSettings :: AppSettings+ , appStatic :: Static -- ^ Settings for static file serving.+ , appConnPool :: ConnectionPool -- ^ Database connection pool.+ , appHttpManager :: Manager+ , appLogger :: Logger+ }++mkYesodData "App" $(parseRoutesFile "config/routes")+++-- YesodPersist++instance YesodPersist App where+ type YesodPersistBackend App = SqlBackend+ runDB action = do+ master <- getYesod+ runSqlPool action (appConnPool master)++instance YesodPersistRunner App where+ getDBRunner = defaultGetDBRunner appConnPool++-- Yesod++instance Yesod App where+ approot = ApprootRequest $ \app req ->+ case appRoot (appSettings app) of+ Nothing -> getApprootText guessApproot app req+ Just root -> root++ makeSessionBackend _ = Just <$> defaultClientSessionBackend+ 10080 -- min (7 days)+ "config/client_session_key.aes"++ yesodMiddleware = defaultYesodMiddleware . defaultCsrfMiddleware++ defaultLayout widget = do+ req <- getRequest+ master <- getYesod+ urlrender <- getUrlRender+ mmsg <- getMessage+ musername <- maybeAuthUsername+ mcurrentRoute <- getCurrentRoute+ pc <- widgetToPageContent $ do+ setTitle "Espial"+ addAppScripts+ addStylesheet (StaticR css_main_css)+ $(widgetFile "default-layout")+ withUrlRenderer $(hamletFile "templates/default-layout-wrapper.hamlet")++ addStaticContent ext mime content = do+ master <- getYesod+ let staticDir = appStaticDir (appSettings master)+ addStaticContentExternal+ minifym+ genFileName+ staticDir+ (StaticR . flip StaticRoute [])+ ext+ mime+ content+ where+ genFileName lbs = "autogen-" ++ base64md5 lbs++ shouldLog app _source level =+ appShouldLogAll (appSettings app)+ || level == LevelWarn+ || level == LevelError+ makeLogger = return . appLogger++ authRoute _ = Just (AuthR LoginR)++ isAuthorized (AuthR _) _ = pure Authorized+ isAuthorized _ _ = pure Authorized++isAuthenticated :: Handler AuthResult+isAuthenticated = maybe AuthenticationRequired (const Authorized) <$> maybeAuthId++addAppScripts :: (MonadWidget m, HandlerSite m ~ App) => m ()+addAppScripts = do+ addScript (StaticR js_jquery_3_3_1_slim_min_js) + addScript (StaticR js_js_cookie_2_2_0_min_js)+ addScript (StaticR js_moment_min_js)+ toWidget $(juliusFile "templates/app.julius")+++-- popupLayout++popupLayout :: Maybe Widget -> Widget -> Handler Html+popupLayout malert widget = do+ req <- getRequest+ master <- getYesod+ mmsg <- getMessage+ musername <- maybeAuthUsername+ mcurrentRoute <- getCurrentRoute+ pc <- widgetToPageContent $ do+ addAppScripts+ addStylesheet (StaticR css_popup_css)+ $(widgetFile "popup-layout")+ withUrlRenderer $(hamletFile "templates/default-layout-wrapper.hamlet")++-- YesodAuth++instance YesodAuth App where+ type AuthId App = UserId+ authHttpManager = getHttpManager+ authPlugins _ = [dbAuthPlugin]+ authenticate = authenticateCreds+ loginDest = const HomeR+ logoutDest = const HomeR+ onLogin = maybeAuth >>= \case+ Nothing -> cpprint ("onLogin: could not find user" :: Text)+ Just (Entity _ uname) -> setSession userNameKey (userName uname)+ onLogout =+ deleteSession userNameKey+ redirectToReferer = const True++instance YesodAuthPersist App++-- session keys++maybeAuthUsername :: Handler (Maybe Text)+maybeAuthUsername = do+ lookupSession userNameKey++ultDestKey :: Text+ultDestKey = "_ULT"++userNameKey :: Text+userNameKey = "_UNAME"++-- dbAuthPlugin++dbAuthPluginName :: Text+dbAuthPluginName = "db"++dbAuthPlugin :: AuthPlugin App+dbAuthPlugin = AuthPlugin dbAuthPluginName dbDispatch dbLoginHandler+ where+ dbDispatch "POST" ["login"] = dbPostLoginR >>= sendResponse+ dbDispatch _ _ = notFound+ dbLoginHandler toParent = do+ req <- getRequest+ lookupSession ultDestKey >>= \case+ Just dest | "logout" `isInfixOf` dest -> deleteSession ultDestKey+ _ -> pure ()+ setTitle "Espial | Log In"+ $(widgetFile "login")++dbLoginR :: AuthRoute+dbLoginR = PluginR dbAuthPluginName ["login"]++dbPostLoginR :: AuthHandler master TypedContent+dbPostLoginR = do+ mresult <- lift $ runInputPostResult (dbLoginCreds+ <$> ireq textField "username"+ <*> ireq textField "password")+ case mresult of+ FormSuccess creds -> lift $ setCredsRedirect creds+ _ -> loginErrorMessageI LoginR InvalidUsernamePass+++dbLoginCreds :: Text -> Text -> Creds master+dbLoginCreds username password =+ Creds+ { credsPlugin = dbAuthPluginName+ , credsIdent = username+ , credsExtra = [("password", password)]+ }++authenticateCreds+ :: (AuthId master ~ UserId)+ => Creds master -> Handler (AuthenticationResult App)+authenticateCreds creds =+ runDB $+ authenticatePW+ (credsIdent creds)+ (fromMaybe "" (lookup "password" (credsExtra creds))) >>=+ \case+ Nothing -> pure (UserError InvalidUsernamePass)+ Just (Entity uid _) -> pure (Authenticated uid)++-- Util++instance RenderMessage App FormMessage where+ renderMessage _ _ = defaultFormMessage++instance HasHttpManager App where+ getHttpManager = appHttpManager++unsafeHandler :: App -> Handler a -> IO a+unsafeHandler = Unsafe.fakeHandlerGetLogger appLogger+
+ src/Handler/Add.hs view
@@ -0,0 +1,128 @@+{-# OPTIONS_GHC -fno-warn-unused-matches #-}++module Handler.Add where++import Import+import Database.Persist.Sql+import Data.List (nub)+import qualified Data.Time.ISO8601 as TI++getAddR :: Handler Html+getAddR = do+ userId <- requireAuthId++ murl <- lookupGetParam "url"+ mexisting <- runDB $ runMaybeT $ do+ bmark <- MaybeT . getBy . UniqueUserHref userId =<< (MaybeT $ pure murl)+ btags <- MaybeT $ Just <$> withTags (entityKey bmark)+ pure (bmark, btags)++ mgetdefs <- aFormToMaybeGetSuccess (mkAddAForm Nothing)++ (formWidget, _) <- generateFormPost $ renderTable $+ mkAddAForm (maybe mgetdefs (Just . toAddDefs) mexisting)++ viewAddWidget+ formWidget+ (mexisting $> $(widgetFile "add-exists-alert"))+ (maybe "url" (const "tags") murl :: Text)+ where+ toAddDefs :: (Entity Bookmark, [Entity BookmarkTag]) -> AddForm+ toAddDefs (Entity bid Bookmark {..}, tags) =+ AddForm+ { url = bookmarkHref+ , title = Just bookmarkDescription+ , description = Just $ Textarea $ bookmarkExtended+ , tags = Just $ unwords $ fmap (bookmarkTagTag . entityVal) tags+ , private = Just $ not bookmarkShared+ , toread = Just $ bookmarkToRead+ , bid = Nothing+ }++postAddR :: Handler Html+postAddR = do+ userId <- requireAuthId++ ((formResult, formWidget), _) <- runFormPost $ renderTable $ mkAddAForm Nothing++ case formResult of+ FormSuccess addForm -> do+ time <- liftIO getCurrentTime+ newBid <- runDB $ upsertDB+ (toSqlKey <$> bid addForm)+ (toBookmark userId time addForm)+ (maybe [] (nub . words) (tags addForm))+ lookupGetParam "next" >>= \case+ Just next -> redirect next+ Nothing -> popupLayout Nothing [whamlet| <div .alert> Add Successful </div> <script> window.close() </script> |]+ _ ->+ lookupGetParam "inline" >>= \case+ Just _ -> fail "invalid form"+ Nothing -> viewAddWidget formWidget Nothing "Tags"++ where+ toBookmark :: UserId -> UTCTime -> AddForm -> Bookmark+ toBookmark userId time AddForm {..} =+ Bookmark userId url+ (fromMaybe "" title)+ (maybe "" unTextarea description)+ time+ (maybe True not private)+ (fromMaybe False toread)+ False+ upsertDB :: Maybe (Key Bookmark) -> Bookmark -> [Text] -> DB (Key Bookmark)+ upsertDB mbid bookmark tags = do+ let userId = bookmarkUserId bookmark+ url = bookmarkHref bookmark+ bid' <- case mbid of+ Just bid -> do+ get bid >>= \case + Just bmark -> do+ replace bid bookmark+ update bid [BookmarkSelected =. bookmarkSelected bmark, BookmarkTime =. bookmarkTime bmark]+ deleteWhere [BookmarkTagBookmarkId ==. bid]+ pure bid+ Nothing -> fail "not found"+ Nothing -> do+ getBy (UniqueUserHref userId url) >>= \case+ Just (Entity bid _) -> deleteCascade bid+ _ -> pure ()+ insert bookmark+ forM_ (zip [1 ..] tags) $+ \(i, tag) -> void $ insert $ BookmarkTag userId tag bid' i+ pure bid'++-- add widget++viewAddWidget :: Widget -> Maybe Widget -> Text -> Handler Html+viewAddWidget formWidget mexists focusEl = do+ let submitText = (maybe "add bookmark" (const "update bookmark") mexists) :: Text+ popupLayout mexists $ do+ $(widgetFile "bm")+ $(widgetFile "add")++-- AddForm++data AddForm = AddForm+ { url :: Text+ , title :: Maybe Text+ , description :: Maybe Textarea+ , tags :: Maybe Text+ , private :: Maybe Bool+ , toread :: Maybe Bool+ , bid :: Maybe Int64+ } deriving (Show, Eq, Read, Generic)++mkAddAForm :: MonadHandlerForm m => Maybe AddForm -> AForm m AddForm+mkAddAForm defs = do+ AddForm+ <$> areq urlField (textAttrs $ named "url" "URL") (url <$> defs)+ <*> aopt textField (textAttrs $ named "title" "title") (title <$> defs)+ <*> aopt textareaField (textAreaAttrs $ named "description" "description") (description <$> defs)+ <*> aopt textField (textAttrs $ named "tags" "tags") (tags <$> defs)+ <*> aopt checkBoxField (named "private" "private") (private <$> defs)+ <*> aopt checkBoxField (named "toread" "read later") (toread <$> defs)+ <*> aopt hiddenField (named "bid" "") (bid <$> defs)+ where+ textAttrs = attr ("size", "70")+ textAreaAttrs = attrs [("cols", "70"), ("rows", "4")]
+ src/Handler/Common.hs view
@@ -0,0 +1,18 @@+-- | Common handler functions.+module Handler.Common where++import Data.FileEmbed (embedFile)+import Import++-- These handlers embed files in the executable at compile time to avoid a+-- runtime dependency, and for efficiency.++getFaviconR :: Handler TypedContent+getFaviconR = do cacheSeconds $ 60 * 5+ --cacheSeconds $ 60 * 60 * 24 * 30 -- cache for a month+ return $ TypedContent "image/x-icon"+ $ toContent $(embedFile "config/favicon.ico")++getRobotsR :: Handler TypedContent+getRobotsR = return $ TypedContent typePlain+ $ toContent $(embedFile "config/robots.txt")
+ src/Handler/Edit.hs view
@@ -0,0 +1,62 @@+{-# OPTIONS_GHC -fno-warn-unused-matches #-}++module Handler.Edit where++import Database.Persist.Sql++import Import++-- routes++deleteDeleteR :: Int64 -> Handler Html+deleteDeleteR bid = do+ userId <- requireAuthId+ runDB $ do+ let k_bid = toSqlKey bid+ void $ requireResource userId k_bid+ deleteCascade k_bid+ pure ""++postReadR :: Int64 -> Handler Html+postReadR bid = do+ userId <- requireAuthId+ runDB $ do+ let k_bid = toSqlKey bid+ bm <- requireResource userId k_bid+ update k_bid [BookmarkToRead =. False]+ pure ""++postStarR :: Int64 -> Handler Html+postStarR bid = _setSelected bid True++postUnstarR :: Int64 -> Handler Html+postUnstarR bid = _setSelected bid False++-- common++_setSelected :: Int64 -> Bool -> Handler Html+_setSelected bid selected = do+ userId <- requireAuthId+ runDB $ do+ let k_bid = toSqlKey bid+ bm <- requireResource userId k_bid+ update k_bid [BookmarkSelected =. selected]+ pure ""++requireResource :: UserId -> Key Bookmark -> DBM Handler Bookmark+requireResource userId k_bid =+ get404 k_bid >>= \case+ bmark | bookmarkUserId bmark == userId -> pure bmark+ _ -> notFound++-- EditForm++data EditForm = EditForm {} deriving (Show, Eq, Read, Generic)++instance FromJSON EditForm++mkEditIForm+ :: MonadHandlerForm m+ => FormInput m EditForm+mkEditIForm = do+ pure EditForm
+ src/Handler/Home.hs view
@@ -0,0 +1,12 @@+{-# OPTIONS_GHC -fno-warn-unused-matches #-}++module Handler.Home where++import Import++getHomeR :: Handler Html+getHomeR =+ maybeAuthUsername >>=+ \case+ Nothing -> redirect $ AuthR LoginR+ Just uname -> redirect $ UserR (UserNameP uname)
+ src/Handler/User.hs view
@@ -0,0 +1,67 @@+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# OPTIONS_GHC -fno-warn-unused-matches #-}+module Handler.User where++import Import+import Text.Read+import Database.Persist.Sql+import qualified Database.Esqueleto as E+import qualified Data.Time.ISO8601 as TI+++getUserR :: UserNameP -> Handler Html+getUserR uname@(UserNameP name) = do+ _getUser uname SharedAll FilterAll (TagsP [])++getUserSharedR :: UserNameP -> SharedP -> Handler Html+getUserSharedR uname sharedp =+ _getUser uname sharedp FilterAll (TagsP [])++getUserFilterR :: UserNameP -> FilterP -> Handler Html+getUserFilterR uname filterp =+ _getUser uname SharedAll filterp (TagsP [])++getUserTagsR :: UserNameP -> TagsP -> Handler Html+getUserTagsR uname pathtags =+ _getUser uname SharedAll FilterAll pathtags++_getUser :: UserNameP -> SharedP -> FilterP -> TagsP -> Handler Html+_getUser 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 = maybe False (== uname) mauthuname+ sharedp = if isowner then sharedp' else SharedPublic+ filterp = case filterp' of+ FilterSingle _ -> filterp'+ _ -> if isowner then filterp' else FilterAll+ (bcount, bmarks, alltags) <-+ runDB $+ do Entity userId _ <- getBy404 (UniqueUserName uname)+ (cnt, bm) <- bookmarksQuery userId sharedp filterp pathtags limit page+ tg <- tagsQuery bm+ pure (cnt, bm, tg)+ mroute <- getCurrentRoute + let pager = $(widgetFile "pager")+ let toTitle x = if null x then "[no title]" else x+ req <- getRequest+ defaultLayout $ do+ $(widgetFile "bm")+ $(widgetFile "user")++_lookupPagingParams :: Handler (Maybe Int64, Maybe Int64)+_lookupPagingParams = do+ cq <- fmap parseMaybe (lookupGetParam "count")+ cs <- fmap parseMaybe (lookupSession "count")+ mapM_ (setSession "count" . (pack . show)) cq+ pq <- fmap parseMaybe (lookupGetParam "page")+ pure (cq <|> cs, pq)+ where+ parseMaybe x = readMaybe . unpack =<< x
+ src/Import.hs view
@@ -0,0 +1,86 @@+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE OverloadedStrings #-}++module Import+ ( module Import+ ) where++import Foundation as Import+import Import.NoFoundation as Import++import qualified Data.ByteString.Char8 as B8+import qualified Data.Aeson as A++-- Forms++type MonadHandlerForm m = (RenderMessage App FormMessage, HandlerSite m ~ App, MonadHandler m)++type Form f = Html -> MForm Handler (FormResult f, Widget)++runInputPostJSONResult+ :: (FromJSON a, MonadHandlerForm m)+ => FormInput m a -> m (FormResult a)+runInputPostJSONResult form = do+ mct <- lookupHeader "content-type"+ case fmap (B8.takeWhile (/= ';')) mct of+ Just "application/json" ->+ parseJsonBody >>= \case+ A.Success a -> pure $ FormSuccess a+ A.Error e -> pure $ FormFailure [pack e]+ Just "application/x-www-form-urlencoded" ->+ runInputPostResult form+ _ -> pure FormMissing++runInputPostJSON+ :: (FromJSON a, MonadHandlerForm m)+ => FormInput m a -> m a+runInputPostJSON form =+ runInputPostJSONResult form >>=+ \case+ FormSuccess a -> pure a+ FormFailure e -> invalidArgs e+ FormMissing -> invalidArgs []++class MkIForm a where+ mkIForm :: MonadHandlerForm m => FormInput m a++aFormToMaybeGetSuccess+ :: MonadHandler f+ => AForm f a -> f (Maybe a)+aFormToMaybeGetSuccess =+ fmap maybeSuccess . fmap 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++maybeSuccess :: FormResult a -> Maybe a+maybeSuccess (FormSuccess a) = Just a+maybeSuccess _ = Nothing+++-- FieldSettings++named :: Text -> FieldSettings master -> FieldSettings master+named n f =+ f+ { fsName = Just n+ , fsId = Just n+ }++attr :: (Text,Text) -> FieldSettings master -> FieldSettings master+attr n f =+ f+ { fsAttrs = n : fsAttrs f+ }++attrs :: [(Text,Text)] -> FieldSettings master -> FieldSettings master+attrs n f =+ f+ { fsAttrs = n ++ fsAttrs f+ }++cls :: [Text] -> FieldSettings master -> FieldSettings master+cls n = attrs [("class", intercalate " " n)]
+ src/Import/NoFoundation.hs view
@@ -0,0 +1,21 @@+{-# LANGUAGE CPP #-}+{-# OPTIONS_GHC -fno-warn-unused-imports #-}++module Import.NoFoundation+ ( module Import+ ) where++import ClassyPrelude.Yesod as Import+import Control.Monad.Trans.Maybe as Import+import Settings as Import+import Settings.StaticFiles as Import+import Yesod.Auth as Import+import Yesod.Core.Types as Import (loggerSet)+import Yesod.Default.Config2 as Import+import Text.Julius as Import++import Model as Import+import ModelCrypto as Import+import Types as Import+import Pretty as Import+
+ src/Model.hs view
@@ -0,0 +1,250 @@+{-# OPTIONS_GHC -fno-warn-unused-imports #-}++module Model where++import qualified Data.Aeson as A++import Control.Monad.Writer hiding ((<>), mapM_)++import Types+import ModelCrypto+import Pretty+import ClassyPrelude.Yesod++import Control.Monad.Trans.Maybe+import Database.Esqueleto hiding ((==.))+import qualified Database.Esqueleto as E++-- Physical model++share [mkPersist sqlSettings, mkDeleteCascade sqlSettings, mkMigrate "migrateSchema"] [persistLowerCase| +User+ name Text+ passwordHash BCrypt+ apiToken Text Maybe+ UniqueUserName name+ deriving Show Eq Typeable Ord++Bookmark+ userId UserId+ href Text+ description Text+ extended Text+ time UTCTime+ shared Bool+ toRead Bool+ selected Bool+ UniqueUserHref userId href+ deriving Show Eq Typeable Ord++BookmarkTag+ userId UserId+ tag Text+ bookmarkId BookmarkId+ seq Int+ UniqueUserTagBookmarkId userId tag bookmarkId+ UniqueUserBookmarkIdTagSeq userId bookmarkId tag seq+ deriving Show Eq Typeable Ord+|]+++-- newtypes++newtype UserNameP =+ UserNameP { unUserNameP :: Text }+ deriving (Eq, Show, Read)++newtype TagsP =+ TagsP { unTagsP :: [Text] }+ deriving (Eq, Show, Read)++data SharedP+ = SharedAll+ | SharedPublic+ | SharedPrivate+ deriving (Eq, Show, Read)++data FilterP+ = FilterAll+ | FilterUnread+ | FilterUntagged+ | FilterStarred+ | FilterSingle Int64+ deriving (Eq, Show, Read)++newtype UnreadOnly =+ UnreadOnly { unUnreadOnly :: Bool }+ deriving (Eq, Show, Read)++type Limit = Int64+type Page = Int64++-- Migration++migrateAll :: Migration+migrateAll = migrateSchema >> migrateIndexes++dumpMigration :: DB ()+dumpMigration = printMigration migrateAll++runMigrations :: DB ()+runMigrations = runMigration migrateAll++toMigration :: [Text] -> Migration+toMigration = lift . tell . fmap (False ,)++migrateIndexes :: Migration+migrateIndexes =+ toMigration+ [ "CREATE INDEX IF NOT EXISTS idx_bookmark_time ON bookmark (user_id, time DESC)"+ , "CREATE INDEX IF NOT EXISTS idx_bookmark_tag_bookmark_id ON bookmark_tag (bookmark_id, id, tag, seq)"+ ]+++-- User++authenticatePW :: Text -> Text -> DB (Maybe (Entity User))+authenticatePW username password = do+ muser <- getBy (UniqueUserName username)+ case muser of+ Nothing -> pure Nothing+ Just e@(Entity _ user) -> + if passwordMatches (userPasswordHash user) (password)+ then pure $ Just e+ else pure $ Nothing++getUserByName :: UserNameP -> DB (Maybe (Entity User))+getUserByName (UserNameP uname) =+ return . headMay =<<+ (select $+ from $ \u -> do+ where_ (u ^. UserName E.==. val uname)+ pure u)++-- bookmarks++bookmarksQuery+ :: Key User+ -> SharedP+ -> FilterP+ -> [Tag]+ -> Limit+ -> Page+ -> DB (Int, [Entity Bookmark])+bookmarksQuery userId sharedp filterp tags limit' page =+ (,) -- total count+ <$> fmap (sum . fmap E.unValue)+ (select $+ from $ \b -> do+ _inner b+ pure $ E.countRows)+ -- paged data+ <*> (select $+ from $ \b -> do+ _inner b+ orderBy [desc (b ^. BookmarkTime)]+ limit limit'+ offset ((page - 1) * limit')+ pure b)+ where+ _inner b = do+ where_ $+ foldMap (\tag -> Endo $ (&&.) + (exists $ -- each tag becomes an exists constraint+ from $ \t ->+ where_ (t ^. BookmarkTagBookmarkId E.==. b ^. BookmarkId &&.+ (t ^. BookmarkTagTag E.==. val tag)))) tags+ `appEndo` (b ^. BookmarkUserId E.==. val userId)+ case sharedp of+ SharedAll -> pure ()+ SharedPublic -> where_ (b ^. BookmarkShared E.==. val True)+ SharedPrivate -> where_ (b ^. BookmarkShared E.==. val False)+ case filterp of+ FilterAll -> pure ()+ FilterUnread -> where_ (b ^. BookmarkToRead E.==. val True)+ FilterStarred -> where_ (b ^. BookmarkSelected E.==. val True)+ FilterSingle i -> where_ (b ^. BookmarkId E.==. val (toSqlKey i))+ FilterUntagged -> where_ $ notExists $ from (\t -> where_ $ t ^. BookmarkTagBookmarkId E.==. b ^. BookmarkId)++tagsQuery :: [Entity Bookmark] -> DB [Entity BookmarkTag]+tagsQuery bmarks =+ select $+ from $ \t -> do+ where_ (t ^. BookmarkTagBookmarkId `in_` valList (fmap entityKey bmarks))+ orderBy [asc (t ^. BookmarkTagSeq)]+ pure t++withTags :: Key Bookmark -> DB [Entity BookmarkTag]+withTags key = selectList [BookmarkTagBookmarkId ==. key] [Asc BookmarkTagSeq]++-- Bookmark Files++bookmarkEntityToTags :: Entity Bookmark -> [Tag] -> [BookmarkTag]+bookmarkEntityToTags (Entity {entityKey = bookmarkId+ ,entityVal = Bookmark {..}}) tags =+ fmap+ (\(i, tag) -> BookmarkTag bookmarkUserId tag bookmarkId i)+ (zip [1 ..] tags)+++postToBookmark :: UserId -> Post -> Bookmark+postToBookmark user Post {..} =+ Bookmark user postHref postDescription postExtended postTime postShared postToRead False+++insertFileBookmarks :: Key User -> FilePath -> DB ()+insertFileBookmarks userId bookmarkFile = do+ posts' <- liftIO $ readBookmarkFileJson bookmarkFile+ case posts' of+ Left e -> print e+ Right posts -> do+ void $ do+ let bookmarks = fmap (postToBookmark userId) posts+ bookmarkIds <- insertMany bookmarks+ insertMany_ $ concatMap (uncurry bookmarkEntityToTags)+ (zipWith3 (\k v p -> (Entity k v, postTags p)) bookmarkIds bookmarks posts)+ where+ readBookmarkFileJson :: MonadIO m => FilePath -> m (Either String [Post])+ readBookmarkFileJson fpath = pure . A.eitherDecode' . fromStrict =<< readFile fpath++type Tag = Text++data Post = Post+ { postHref :: !Text+ , postDescription :: !Text+ , postExtended :: !Text+ , postTime :: !UTCTime+ , postShared :: !Bool+ , postToRead :: !Bool+ , postTags :: [Tag]+ } deriving (Show, Eq, Ord, Typeable)++instance FromJSON Post where+ parseJSON (Object o) =+ Post <$> o .: "href" <*> o .: "description" <*> o .: "extended" <*>+ o .: "time" <*>+ (boolFromYesNo <$> o .: "shared") <*>+ (boolFromYesNo <$> o .: "toread") <*>+ (words <$> o .: "tags")+ parseJSON _ = fail "bad parse"++instance ToJSON Post where+ toJSON Post {..} =+ object+ [ "href" .= toJSON postHref+ , "description" .= toJSON postDescription+ , "extended" .= toJSON postExtended+ , "time" .= toJSON postTime+ , "shared" .= boolToYesNo postShared+ , "toread" .= boolToYesNo postToRead+ , "tags" .= unwords postTags+ ]++boolFromYesNo :: Text -> Bool+boolFromYesNo "yes" = True+boolFromYesNo _ = False++boolToYesNo :: Bool -> Text+boolToYesNo True = "yes"+boolToYesNo _ = "no"+
+ src/ModelCrypto.hs view
@@ -0,0 +1,30 @@++module ModelCrypto where++import Prelude++import Crypto.BCrypt as Import hiding (hashPassword)+import Database.Persist.Sql+import Safe (fromJustNote)+import qualified Data.Text as T+import qualified Data.Text.Encoding as TE++policy :: HashingPolicy+policy =+ HashingPolicy+ { preferredHashCost = 12+ , preferredHashAlgorithm = "$2a$"+ }++newtype BCrypt = BCrypt+ { unBCrypt :: T.Text+ } deriving (Eq, PersistField, PersistFieldSql, Show, Ord)++hashPassword :: T.Text -> IO BCrypt+hashPassword rawPassword = do+ mPassword <- hashPasswordUsingPolicy policy $ TE.encodeUtf8 rawPassword+ return $ BCrypt $ TE.decodeUtf8 $ fromJustNote "Invalid hashing policy" mPassword++passwordMatches :: BCrypt -> T.Text -> Bool+passwordMatches hash' pass =+ validatePassword (TE.encodeUtf8 $ unBCrypt hash') (TE.encodeUtf8 pass)
+ src/PathPiece.hs view
@@ -0,0 +1,54 @@+{-# OPTIONS_GHC -fno-warn-orphans #-}++module PathPiece where+ +import Data.Text (splitOn)++import Import.NoFoundation++-- PathPiece++instance PathPiece UserNameP where+ toPathPiece (UserNameP i) = "u:" <> i+ fromPathPiece s =+ case splitOn ":" s of+ ["u", ""] -> Nothing+ ["u", uname] -> Just $ UserNameP uname+ _ -> Nothing++instance PathPiece TagsP where+ toPathPiece (TagsP tags) = "t:" <> (intercalate "+" tags)+ fromPathPiece s =+ case splitOn ":" s of+ ["t", ""] -> Nothing+ ["t", tags] -> Just $ TagsP (splitOn "+" tags)+ _ -> Nothing++instance PathPiece SharedP where+ toPathPiece = \case+ SharedAll -> ""+ SharedPublic -> "public"+ SharedPrivate -> "private"+ fromPathPiece = \case+ "public" -> Just SharedPublic+ "private" -> Just SharedPrivate+ _ -> Nothing++instance PathPiece FilterP where+ toPathPiece = \case+ FilterAll -> ""+ FilterUnread -> "unread"+ FilterUntagged -> "untagged"+ FilterStarred -> "starred"+ FilterSingle bid -> "b:" <> (pack . show) bid+ fromPathPiece = \case+ "unread" -> Just FilterUnread+ "untagged" -> Just FilterUntagged+ "starred" -> Just FilterStarred+ s -> case splitOn ":" s of+ ["b", ""] -> Nothing+ ["b", sbid] ->+ case readMay sbid of+ Just bid -> Just $ FilterSingle bid+ _ -> Nothing+ _ -> Nothing
+ src/Pretty.hs view
@@ -0,0 +1,15 @@+module Pretty where+ +import Text.Show.Pretty (ppShow)+import Language.Haskell.HsColour+import Language.Haskell.HsColour.Colourise+import ClassyPrelude++cpprint :: (MonadIO m, Show a) => a -> m ()+cpprint = putStrLn . pack . hscolour TTY defaultColourPrefs False False "" False . ppShow++cprint :: (MonadIO m, Show a) => a -> m ()+cprint = putStrLn . pack . hscolour TTY defaultColourPrefs False False "" False . show++pprint :: (MonadIO m, Show a) => a -> m ()+pprint = putStrLn . pack . ppShow
+ src/Settings.hs view
@@ -0,0 +1,143 @@+-- | Settings are centralized, as much as possible, into this file. This+-- includes database connection settings, static file locations, etc.+-- In addition, you can configure a number of different aspects of Yesod+-- by overriding methods in the Yesod typeclass. That instance is+-- declared in the Foundation.hs file.+module Settings where++import ClassyPrelude.Yesod+import qualified Control.Exception as Exception+import Data.Aeson (Result (..), fromJSON, withObject, (.!=),+ (.:?))+import Data.FileEmbed (embedFile)+import Data.Yaml (decodeEither')+import Database.Persist.Sqlite (SqliteConf)+import Language.Haskell.TH.Syntax (Exp, Name, Q)+import Network.Wai.Handler.Warp (HostPreference)+import Yesod.Default.Config2 (applyEnvValue, configSettingsYml)+import Yesod.Default.Util (WidgetFileSettings, widgetFileNoReload,+ widgetFileReload)++-- | Runtime settings to configure this application. These settings can be+-- loaded from various sources: defaults, environment variables, config files,+-- theoretically even a database.+data AppSettings = AppSettings+ { appStaticDir :: String+ -- ^ Directory from which to serve static files.+ , appDatabaseConf :: SqliteConf+ -- ^ Configuration settings for accessing the database.+ , appRoot :: Maybe Text+ -- ^ Base for all generated URLs. If @Nothing@, determined+ -- from the request headers.+ , appHost :: HostPreference+ -- ^ Host/interface the server should bind to.+ , appPort :: Int+ -- ^ Port to listen on+ , appIpFromHeader :: Bool+ -- ^ Get the IP address from the header when logging. Useful when sitting+ -- behind a reverse proxy.++ , appDetailedRequestLogging :: Bool+ -- ^ Use detailed request logging system+ , appShouldLogAll :: Bool+ -- ^ Should all log messages be displayed?+ , appReloadTemplates :: Bool+ -- ^ Use the reload version of templates+ , appMutableStatic :: Bool+ -- ^ Assume that files in the static dir may change after compilation+ , appSkipCombining :: Bool+ -- ^ Perform no stylesheet/script combining++ -- Example app-specific configuration values.+ , appCopyright :: Text+ -- ^ Copyright text to appear in the footer of the page+ , appAnalytics :: Maybe Text+ -- ^ Google Analytics code++ , appAuthDummyLogin :: Bool+ -- ^ Indicate if auth dummy login should be enabled.+ }++instance FromJSON AppSettings where+ parseJSON = withObject "AppSettings" $ \o -> do+ let defaultDev =+#ifdef DEVELOPMENT+ True+#else+ False+#endif+ appStaticDir <- o .: "static-dir"+ appDatabaseConf <- o .: "database"+ appRoot <- o .:? "approot"+ appHost <- fromString <$> o .: "host"+ appPort <- o .: "port"+ appIpFromHeader <- o .: "ip-from-header"++ dev <- o .:? "development" .!= defaultDev++ appDetailedRequestLogging <- o .:? "detailed-logging" .!= dev+ appShouldLogAll <- o .:? "should-log-all" .!= dev+ appReloadTemplates <- o .:? "reload-templates" .!= dev+ appMutableStatic <- o .:? "mutable-static" .!= dev+ appSkipCombining <- o .:? "skip-combining" .!= dev++ appCopyright <- o .: "copyright"+ appAnalytics <- o .:? "analytics"++ appAuthDummyLogin <- o .:? "auth-dummy-login" .!= dev++ return AppSettings {..}++-- | Settings for 'widgetFile', such as which template languages to support and+-- default Hamlet settings.+--+-- For more information on modifying behavior, see:+--+-- https://github.com/yesodweb/yesod/wiki/Overriding-widgetFile+widgetFileSettings :: WidgetFileSettings+widgetFileSettings = def++-- | How static files should be combined.+combineSettings :: CombineSettings+combineSettings = def++-- The rest of this file contains settings which rarely need changing by a+-- user.++widgetFile :: String -> Q Exp+widgetFile = (if appReloadTemplates compileTimeAppSettings+ then widgetFileReload+ else widgetFileNoReload)+ widgetFileSettings++-- | Raw bytes at compile time of @config/settings.yml@+configSettingsYmlBS :: ByteString+configSettingsYmlBS = $(embedFile configSettingsYml)++-- | @config/settings.yml@, parsed to a @Value@.+configSettingsYmlValue :: Value+configSettingsYmlValue = either Exception.throw id+ $ decodeEither' configSettingsYmlBS++-- | A version of @AppSettings@ parsed at compile time from @config/settings.yml@.+compileTimeAppSettings :: AppSettings+compileTimeAppSettings =+ case fromJSON $ applyEnvValue False mempty configSettingsYmlValue of+ Error e -> error e+ Success settings -> settings++-- The following two functions can be used to combine multiple CSS or JS files+-- at compile time to decrease the number of http requests.+-- Sample usage (inside a Widget):+--+-- > $(combineStylesheets 'StaticR [style1_css, style2_css])++combineStylesheets :: Name -> [Route Static] -> Q Exp+combineStylesheets = combineStylesheets'+ (appSkipCombining compileTimeAppSettings)+ combineSettings++combineScripts :: Name -> [Route Static] -> Q Exp+combineScripts = combineScripts'+ (appSkipCombining compileTimeAppSettings)+ combineSettings
+ src/Settings/StaticFiles.hs view
@@ -0,0 +1,18 @@+module Settings.StaticFiles where++import Settings (appStaticDir, compileTimeAppSettings)+import Yesod.Static (staticFiles)++-- This generates easy references to files in the static directory at compile time,+-- giving you compile-time verification that referenced files exist.+-- Warning: any files added to your static directory during run-time can't be+-- accessed this way. You'll have to use their FilePath or URL to access them.+--+-- For example, to refer to @static/js/script.js@ via an identifier, you'd use:+--+-- js_script_js+--+-- If the identifier is not available, you may use:+--+-- StaticFile ["js", "script.js"] []+staticFiles (appStaticDir compileTimeAppSettings)
+ src/Types.hs view
@@ -0,0 +1,17 @@+module Types where++import ClassyPrelude.Yesod++type ControlIO m = (MonadIO m, MonadBaseControl IO m)++type DBM m a =+ (ControlIO m, MonadThrow m, Monad m) => SqlPersistT m a++type DBH m a = (DBM m a)++type DB a = forall m. DBM m a++type DBVal val =+ ( PersistEntity val+ , PersistEntityBackend val ~ SqlBackend+ , PersistStore (PersistEntityBackend val))
+ test/Handler/CommonSpec.hs view
@@ -0,0 +1,17 @@+module Handler.CommonSpec (spec) where++import TestImport++spec :: Spec+spec = withApp $ do+ describe "robots.txt" $ do+ it "gives a 200" $ do+ get RobotsR+ statusIs 200+ it "has correct User-agent" $ do+ get RobotsR+ bodyContains "User-agent: *"+ describe "favicon.ico" $ do+ it "gives a 200" $ do+ get FaviconR+ statusIs 200
+ test/Handler/HomeSpec.hs view
@@ -0,0 +1,13 @@+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE OverloadedStrings #-}+module Handler.HomeSpec (spec) where++import TestImport++spec :: Spec+spec = withApp $ do++ describe "Homepage" $ do+ it "loads the index and checks it looks right" $ do+ get HomeR+ statusIs 200
+ test/Spec.hs view
@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}
+ test/TestImport.hs view
@@ -0,0 +1,72 @@+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE FlexibleContexts #-}+module TestImport+ ( module TestImport+ , module X+ ) where++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 Foundation as X+import Model as X+import Test.Hspec as X+import Yesod.Default.Config2 (useEnv, loadYamlSettings)+import Yesod.Auth as X+import Yesod.Test as X+import Yesod.Core.Unsafe (fakeHandlerGetLogger)++-- Wiping the database+import Database.Persist.Sqlite (sqlDatabase, mkSqliteConnectionInfo, fkEnabled, createSqlitePoolFromInfo)+import Control.Monad.Logger (runLoggingT)+import Lens.Micro (set)+import Settings (appDatabaseConf)+import Yesod.Core (messageLoggerSource)+import Types++runDB :: SqlPersistM a -> YesodExample App a+runDB query = do+ pool <- fmap appConnPool getTestYesod+ liftIO $ runSqlPersistMPool query pool++runHandler :: Handler a -> YesodExample App a+runHandler handler = do+ app <- getTestYesod+ fakeHandlerGetLogger appLogger app handler++withApp :: SpecWith (TestApp App) -> Spec+withApp = before $ do+ settings <- loadYamlSettings+ ["config/test-settings.yml", "config/settings.yml"]+ []+ useEnv+ foundation <- makeFoundation settings+ wipeDB foundation+ logWare <- liftIO $ makeLogWare foundation+ return (foundation, logWare)++-- This function will truncate all of the tables in your database.+-- 'withApp' calls it before each test, creating a clean environment for each+-- spec to run in.+wipeDB :: App -> IO ()+wipeDB app = do+ let logFunc = messageLoggerSource app (appLogger app)++ let dbName = sqlDatabase $ appDatabaseConf $ appSettings app+ connInfo = set fkEnabled False $ mkSqliteConnectionInfo dbName++ pool <- runLoggingT (createSqlitePoolFromInfo connInfo 1) logFunc++ flip runSqlPersistMPool pool $ do+ tables <- getTables+ sqlBackend <- ask+ let queries = map (\t -> "DELETE FROM " ++ (connEscapeName sqlBackend $ DBName t)) tables+ forM_ queries (\q -> rawExecute q [])++getTables :: DB [Text]+getTables = do+ tables <- rawSql "SELECT name FROM sqlite_master WHERE type = 'table';" []+ return (fmap unSingle tables)