diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -2,6 +2,22 @@ Espial is an open-source, web-based bookmarking server. +It allows mutiple accounts, but currently intended for self-host scenarios. + +The bookmarks are stored in a sqlite3 database, for ease of deployment & maintenence. + +The easist way for logged-in users to add bookmarks, is with the "bookmarklet", found on the Settings page. + +## demo server + +log in — username: demo password: demo + +https://esp.ae8.org/u:demo + +![jpg](https://i.imgur.com/y8PE0Ul.png) + + + ## Haskell Setup 1. If you haven't already, [install Stack](https://haskell-lang.org/get-started) diff --git a/app/migration/Main.hs b/app/migration/Main.hs --- a/app/migration/Main.hs +++ b/app/migration/Main.hs @@ -5,7 +5,6 @@ import Types import Model import ModelCrypto -import Pretty import qualified Database.Persist as P import qualified Database.Persist.Sqlite as P @@ -21,41 +20,53 @@ , userPassword :: Text , userApiToken :: Maybe Text} | DeleteUser { conn :: Text - , userName :: Text - } + , userName :: Text} | ImportBookmarks { conn :: Text , userName :: Text , bookmarkFile :: FilePath} + | ImportNotes { conn :: Text + , userName :: Text + , noteDirectory :: FilePath} deriving (Generic, Show) instance ParseRecord MigrationOpts main :: IO () -main = - getRecord "Migrations" >>= - \case - CreateDB conn -> P.runSqlite conn runMigrations +main = do + args <- getRecord "Migrations" + case args of + + 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 () + P.runSqlite conn $ do + hash' <- liftIO (hashPassword upass) + void $ P.upsertBy + (UniqueUserName uname) + (User uname hash' utoken) + [UserPasswordHash P.=. hash', UserApiToken P.=. utoken] + 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" + P.runSqlite conn $ do + muser <- P.getBy (UniqueUserName uname) + case muser of + Nothing -> liftIO (print (uname ++ "not found")) + Just (P.Entity uid _) -> do + P.deleteCascade uid + pure () :: DB () + 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" + P.runSqlite conn $ do + muser <- P.getBy (UniqueUserName uname) + case muser of + Just (P.Entity uid _) -> insertFilePbPosts uid file + Nothing -> liftIO (print (uname ++ "not found")) + + ImportNotes conn uname dir -> + P.runSqlite conn $ do + muser <- P.getBy (UniqueUserName uname) + case muser of + Just (P.Entity uid _) -> insertDirPbNotes uid dir + Nothing -> liftIO (print (uname ++ "not found")) diff --git a/changelog.md b/changelog.md --- a/changelog.md +++ b/changelog.md @@ -1,3 +1,7 @@ +__v0.0.5__ + +add notes, ekg. update data fetches + __v0.0.3__ replaced jQuery and .julius scripts with PureScript-compiled static js file diff --git a/config/routes b/config/routes --- a/config/routes +++ b/config/routes @@ -5,12 +5,22 @@ /auth AuthR Auth getAuth +-- notes +!/#UserNameP/notes NotesR GET +!/#UserNameP/notes/#Int64 NoteR GET +!/#UserNameP/notes/add AddNoteViewR GET +!/api/note/#Int64 DeleteNoteR DELETE +!/api/note/add AddNoteR POST + -- user / HomeR GET !/#UserNameP UserR GET !/#UserNameP/#SharedP UserSharedR GET !/#UserNameP/#FilterP UserFilterR GET !/#UserNameP/#TagsP UserTagsR GET + +-- settings +!/#UserNameP/Settings UserSettingsR GET -- add /add AddViewR GET diff --git a/espial.cabal b/espial.cabal --- a/espial.cabal +++ b/espial.cabal @@ -2,10 +2,10 @@ -- -- see: https://github.com/sol/hpack -- --- hash: 8ef5bfe0c483801f3c3100cffc7bf1dbacace5b94ff965f13cef227a59e290c5 +-- hash: e4fdf7bcebff83a6ea6853b7aad42d28122ca511fc2dbf38d99cb1aac15181d1 name: espial -version: 0.0.4 +version: 0.0.5 synopsis: Espial is an open-source, web-based bookmarking server. description: . Espial is an open-source, web-based bookmarking server. @@ -59,8 +59,11 @@ templates/default-layout.hamlet templates/homepage.hamlet templates/login.hamlet + templates/note.hamlet + templates/notes.hamlet templates/pager.hamlet templates/popup-layout.hamlet + templates/user-settings.hamlet templates/user.hamlet source-repository head @@ -82,51 +85,57 @@ 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.11.1 && <2.0 + aeson >=0.11.1 , base >=4.8.2.0 && <4.9 || >=4.9.1.0 && <5 - , bcrypt >=0.0.8 && <0.0.12 - , bytestring >=0.9 && <0.11 + , bcrypt >=0.0.8 + , bytestring >=0.9 , 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 + , conduit >=1.0 , containers , data-default - , directory >=1.1 && <1.4 + , directory >=1.1 + , ekg + , ekg-core , esqueleto - , fast-logger >=2.2 && <2.5 + , fast-logger >=2.2 , file-embed , foreign-store - , hjsmin >=0.1 && <0.3 + , hjsmin >=0.1 , hscolour - , http-conduit >=2.1 && <2.3.2 - , iso8601-time >=0.1.3 && <0.2.0 - , monad-control >=0.3 && <1.1 - , monad-logger >=0.3 && <0.4 + , http-conduit >=2.1 + , iso8601-time >=0.1.3 + , microlens + , monad-control >=0.3 + , monad-logger >=0.3 + , monad-metrics , mtl - , persistent >=2.0 && <2.8.3 - , persistent-sqlite >=2.6.2 && <2.8.2 - , persistent-template >=2.0 && <2.8 + , persistent >=2.0 + , persistent-sqlite >=2.6.2 + , persistent-template >=2.0 + , pinboard , pretty-show , safe - , shakespeare >=2.0 && <2.1 + , shakespeare >=2.0 , template-haskell - , text >=0.11 && <2.0 + , text >=0.11 , 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.7 - , yesod-auth >=1.4.0 && <1.7 - , yesod-core >=1.4.30 && <1.7 - , yesod-form >=1.4.0 && <1.7 - , yesod-static >=1.4.0.3 && <1.7 + , wai-extra >=3.0 + , wai-logger >=2.2 + , wai-middleware-metrics + , warp >=3.0 + , yaml >=0.8 + , yesod >=1.4.3 + , yesod-auth >=1.4.0 + , yesod-core >=1.4.30 + , yesod-form >=1.4.0 + , yesod-static >=1.4.0.3 if (flag(dev)) || (flag(library-only)) ghc-options: -Wall -fwarn-tabs -O0 cpp-options: -DDEVELOPMENT @@ -139,6 +148,7 @@ Handler.Common Handler.Edit Handler.Home + Handler.Notes Handler.User Import Import.NoFoundation @@ -160,52 +170,58 @@ 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.11.1 && <2.0 + aeson >=0.11.1 , base >=4.8.2.0 && <4.9 || >=4.9.1.0 && <5 - , bcrypt >=0.0.8 && <0.0.12 - , bytestring >=0.9 && <0.11 + , bcrypt >=0.0.8 + , bytestring >=0.9 , 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 + , conduit >=1.0 , containers , data-default - , directory >=1.1 && <1.4 + , directory >=1.1 + , ekg + , ekg-core , espial , esqueleto - , fast-logger >=2.2 && <2.5 + , fast-logger >=2.2 , file-embed , foreign-store - , hjsmin >=0.1 && <0.3 + , hjsmin >=0.1 , hscolour - , http-conduit >=2.1 && <2.3.2 - , iso8601-time >=0.1.3 && <0.2.0 - , monad-control >=0.3 && <1.1 - , monad-logger >=0.3 && <0.4 + , http-conduit >=2.1 + , iso8601-time >=0.1.3 + , microlens + , monad-control >=0.3 + , monad-logger >=0.3 + , monad-metrics , mtl - , persistent >=2.0 && <2.8.3 - , persistent-sqlite >=2.6.2 && <2.8.2 - , persistent-template >=2.0 && <2.8 + , persistent >=2.0 + , persistent-sqlite >=2.6.2 + , persistent-template >=2.0 + , pinboard , pretty-show , safe - , shakespeare >=2.0 && <2.1 + , shakespeare >=2.0 , template-haskell - , text >=0.11 && <2.0 + , text >=0.11 , 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.7 - , yesod-auth >=1.4.0 && <1.7 - , yesod-core >=1.4.30 && <1.7 - , yesod-form >=1.4.0 && <1.7 - , yesod-static >=1.4.0.3 && <1.7 + , wai-extra >=3.0 + , wai-logger >=2.2 + , wai-middleware-metrics + , warp >=3.0 + , yaml >=0.8 + , yesod >=1.4.3 + , yesod-auth >=1.4.0 + , yesod-core >=1.4.30 + , yesod-form >=1.4.0 + , yesod-static >=1.4.0.3 if flag(library-only) buildable: False other-modules: @@ -220,53 +236,59 @@ 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.11.1 && <2.0 + aeson >=0.11.1 , base >=4.8.2.0 && <4.9 || >=4.9.1.0 && <5 - , bcrypt >=0.0.8 && <0.0.12 - , bytestring >=0.9 && <0.11 + , bcrypt >=0.0.8 + , bytestring >=0.9 , 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 + , conduit >=1.0 , containers , data-default - , directory >=1.1 && <1.4 + , directory >=1.1 + , ekg + , ekg-core , espial , esqueleto - , fast-logger >=2.2 && <2.5 + , fast-logger >=2.2 , file-embed , foreign-store - , hjsmin >=0.1 && <0.3 + , hjsmin >=0.1 , hscolour - , http-conduit >=2.1 && <2.3.2 - , iso8601-time >=0.1.3 && <0.2.0 - , monad-control >=0.3 && <1.1 - , monad-logger >=0.3 && <0.4 + , http-conduit >=2.1 + , iso8601-time >=0.1.3 + , microlens + , monad-control >=0.3 + , monad-logger >=0.3 + , monad-metrics , mtl , optparse-generic >=1.2.3 - , persistent >=2.0 && <2.8.3 - , persistent-sqlite >=2.6.2 && <2.8.2 - , persistent-template >=2.0 && <2.8 + , persistent >=2.0 + , persistent-sqlite >=2.6.2 + , persistent-template >=2.0 + , pinboard , pretty-show , safe - , shakespeare >=2.0 && <2.1 + , shakespeare >=2.0 , template-haskell - , text >=0.11 && <2.0 + , text >=0.11 , 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.7 - , yesod-auth >=1.4.0 && <1.7 - , yesod-core >=1.4.30 && <1.7 - , yesod-form >=1.4.0 && <1.7 - , yesod-static >=1.4.0.3 && <1.7 + , wai-extra >=3.0 + , wai-logger >=2.2 + , wai-middleware-metrics + , warp >=3.0 + , yaml >=0.8 + , yesod >=1.4.3 + , yesod-auth >=1.4.0 + , yesod-core >=1.4.30 + , yesod-form >=1.4.0 + , yesod-static >=1.4.0.3 if flag(library-only) buildable: False other-modules: @@ -281,54 +303,59 @@ 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.11.1 && <2.0 + aeson >=0.11.1 , base >=4.8.2.0 && <4.9 || >=4.9.1.0 && <5 - , bcrypt >=0.0.8 && <0.0.12 - , bytestring >=0.9 && <0.11 + , bcrypt >=0.0.8 + , bytestring >=0.9 , 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 + , conduit >=1.0 , containers , data-default - , directory >=1.1 && <1.4 + , directory >=1.1 + , ekg + , ekg-core , espial , esqueleto - , fast-logger >=2.2 && <2.5 + , fast-logger >=2.2 , file-embed , foreign-store - , hjsmin >=0.1 && <0.3 + , hjsmin >=0.1 , hscolour , hspec >=2.0.0 - , http-conduit >=2.1 && <2.3.2 - , iso8601-time >=0.1.3 && <0.2.0 + , http-conduit >=2.1 + , iso8601-time >=0.1.3 , microlens - , monad-control >=0.3 && <1.1 - , monad-logger >=0.3 && <0.4 + , monad-control >=0.3 + , monad-logger >=0.3 + , monad-metrics , mtl - , persistent >=2.0 && <2.8.3 - , persistent-sqlite >=2.6.2 && <2.8.2 - , persistent-template >=2.0 && <2.8 + , persistent >=2.0 + , persistent-sqlite >=2.6.2 + , persistent-template >=2.0 + , pinboard , pretty-show , safe - , shakespeare >=2.0 && <2.1 + , shakespeare >=2.0 , template-haskell - , text >=0.11 && <2.0 + , text >=0.11 , 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.7 - , yesod-auth >=1.4.0 && <1.7 - , yesod-core >=1.4.30 && <1.7 - , yesod-form >=1.4.0 && <1.7 - , yesod-static >=1.4.0.3 && <1.7 + , wai-extra >=3.0 + , wai-logger >=2.2 + , wai-middleware-metrics + , warp >=3.0 + , yaml >=0.8 + , yesod >=1.4.3 + , yesod-auth >=1.4.0 + , yesod-core >=1.4.30 + , yesod-form >=1.4.0 + , yesod-static >=1.4.0.3 , yesod-test other-modules: Handler.CommonSpec diff --git a/purs/src/App.purs b/purs/src/App.purs --- a/purs/src/App.purs +++ b/purs/src/App.purs @@ -2,6 +2,7 @@ import Prelude +import Data.Argonaut (Json) import Data.Array ((:)) import Data.Either (Either(..)) import Data.FormURLEncoded (FormURLEncoded) @@ -12,10 +13,12 @@ import Effect.Aff (Aff, launchAff) import Effect.Class (liftEffect) import Globals (app') -import Model (Bookmark, Bookmark'(..)) +import Model (Bookmark, Bookmark'(..), Note, Note'(..)) import Network.HTTP.Affjax (affjax, AffjaxResponse) import Network.HTTP.Affjax (defaultRequest) as AX +import Network.HTTP.Affjax.Request (Request(..)) import Network.HTTP.Affjax.Request as AXReq +import Network.HTTP.Affjax.Response (Response(..)) import Network.HTTP.Affjax.Response as AXRes import Network.HTTP.RequestHeader (RequestHeader(..)) import Simple.JSON as J @@ -32,7 +35,7 @@ toggleStar :: Int -> StarAction -> Aff Unit toggleStar bid action = do let path = "bm/" <> show bid <> "/" <> show action - void $ fetchUrlEnc POST path Nothing AXRes.ignore + void (fetchUrlEnc POST path Nothing AXRes.ignore) destroy :: Int -> Aff (AffjaxResponse Unit) destroy bid = @@ -45,15 +48,23 @@ editBookmark :: Bookmark -> Aff (AffjaxResponse Unit) editBookmark bm = do - fetchJson POST "api/add" (Just $ Bookmark' bm) AXRes.ignore + fetchJson POST "api/add" (Just (Bookmark' bm)) AXRes.ignore +editNote :: Note -> Aff (AffjaxResponse Json) +editNote bm = do + fetchJson POST "api/note/add" (Just (Note' bm)) AXRes.json + +destroyNote :: Int -> Aff (AffjaxResponse Unit) +destroyNote nid = do + fetchUrlEnc DELETE ("api/note/" <> show nid) Nothing AXRes.ignore + logoutE :: Event -> Effect Unit logoutE e = void <<< launchAff <<< logout =<< preventDefault e logout :: Unit -> Aff Unit logout u = do - void $ fetchUrl POST app.authRlogoutR [] Nothing AXRes.ignore - liftEffect $ window >>= location >>= reload + void (fetchUrl POST app.authRlogoutR [] Nothing AXRes.ignore) + liftEffect (window >>= location >>= reload) where app = app' u diff --git a/purs/src/Model.purs b/purs/src/Model.purs --- a/purs/src/Model.purs +++ b/purs/src/Model.purs @@ -18,5 +18,20 @@ } newtype Bookmark' = Bookmark' Bookmark -derive newtype instance rfI :: J.ReadForeign Bookmark' -derive newtype instance wfI :: J.WriteForeign Bookmark' +derive newtype instance bookmark_rfI :: J.ReadForeign Bookmark' +derive newtype instance bookmark_wfI :: J.WriteForeign Bookmark' + +type NoteId = Int + +type Note = + { id :: NoteId + , title :: String + , text :: String + , length :: Int + , created :: String + , updated :: String + } + +newtype Note' = Note' Note +derive newtype instance note_rfI :: J.ReadForeign Note' +derive newtype instance note_wfI :: J.WriteForeign Note' diff --git a/purs/src/User.purs b/purs/src/User.purs --- a/purs/src/User.purs +++ b/purs/src/User.purs @@ -1,17 +1,17 @@ module User where -import Model (Bookmark) -import Component.Add (addbmark) -import Component.BList (blist) - import Prelude +import Component.Add (addbmark) +import Component.BList (blist) +import Component.NList (nlist, nnote) import Data.Foldable (traverse_) import Effect (Effect) import Effect.Aff (Aff) import Effect.Class (liftEffect) import Halogen.Aff as HA import Halogen.VDom.Driver (runUI) +import Model (Bookmark, Note) import Web.DOM.Element (removeAttribute) import Web.DOM.ParentNode (QuerySelector(..)) import Web.HTML.HTMLElement (toElement) @@ -28,6 +28,19 @@ HA.runHalogenAff do HA.selectElement (QuerySelector renderElSelector) >>= traverse_ \el -> do runUI (addbmark bmark) unit el + +renderNotes :: String -> Array Note -> Effect Unit +renderNotes renderElSelector notes = do + HA.runHalogenAff do + HA.selectElement (QuerySelector renderElSelector) >>= traverse_ \el -> do + void $ runUI (nlist notes) unit el + showFooter + +renderNote :: String -> Note -> Effect Unit +renderNote renderElSelector note = do + HA.runHalogenAff do + HA.selectElement (QuerySelector renderElSelector) >>= traverse_ \el -> do + void $ runUI (nnote note) unit el showFooter :: Aff Unit showFooter = HA.selectElement (QuerySelector ".user_footer") >>= traverse_ \el -> diff --git a/src/Application.hs b/src/Application.hs --- a/src/Application.hs +++ b/src/Application.hs @@ -20,6 +20,7 @@ import Import import Yesod.Auth (getAuth) import Language.Haskell.TH.Syntax (qLocation) +import Lens.Micro import Network.Wai (Middleware) import Network.Wai.Middleware.Autohead import Network.Wai.Middleware.AcceptOverride @@ -34,6 +35,11 @@ import System.Log.FastLogger (defaultBufSize, newStdoutLoggerSet, toLogStr) +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! import Handler.Common @@ -41,6 +47,7 @@ import Handler.User import Handler.Add import Handler.Edit +import Handler.Notes mkYesodDispatch "App" resourcesApp @@ -48,6 +55,9 @@ makeFoundation appSettings = do appHttpManager <- newManager appLogger <- newStdoutLoggerSet defaultBufSize >>= makeYesodLogger + store <- EKG.newStore + EKG.registerGcMetrics store + appMetrics <- MM.initializeWith store appStatic <- (if appMutableStatic appSettings then staticDevel @@ -70,11 +80,13 @@ makeApplication foundation = do logWare <- makeLogWare foundation appPlain <- toWaiAppPlain foundation - return (logWare (makeMiddleware appPlain)) + let store = appMetrics foundation ^. MM.metricsStore + waiMetrics <- WM.registerWaiMetrics store + return (logWare (makeMiddleware waiMetrics appPlain)) -makeMiddleware :: Middleware -makeMiddleware = - acceptOverride . autohead . gzip def +makeMiddleware :: WM.WaiMetrics -> Middleware +makeMiddleware waiMetrics = + WM.metrics waiMetrics . acceptOverride . autohead . gzip def { gzipFiles = GzipPreCompressed GzipIgnore } . methodOverride @@ -117,6 +129,7 @@ foundation <- makeFoundation settings wsettings <- getDevSettings (warpSettings foundation) app <- makeApplication foundation + void $ forkEKG foundation return (wsettings, app) getAppSettings :: IO AppSettings @@ -126,12 +139,20 @@ develMain :: IO () develMain = develMainHelper getApplicationDev +forkEKG :: App -> IO EKG.Server +forkEKG foundation = + EKG.forkServerWith + (appMetrics foundation ^. MM.metricsStore) + "localhost" + 8000 + -- | The @main@ function for an executable running this site. appMain :: IO () appMain = do settings <- loadYamlSettingsArgs [configSettingsYmlValue] useEnv foundation <- makeFoundation settings app <- makeApplication foundation + void $ forkEKG foundation runSettings (warpSettings foundation) app getApplicationRepl :: IO (Int, App, Application) diff --git a/src/Foundation.hs b/src/Foundation.hs --- a/src/Foundation.hs +++ b/src/Foundation.hs @@ -13,21 +13,25 @@ import Yesod.Default.Util (addStaticContentExternal) import Yesod.Core.Types import Yesod.Auth.Message -import qualified Yesod.Core.Unsafe as Unsafe +import qualified Network.Wai as NW +import qualified Control.Monad.Metrics as MM import qualified Data.CaseInsensitive as CI import qualified Data.Text.Encoding as TE +import qualified Yesod.Core.Unsafe as Unsafe +deriving instance Typeable Route + data App = App { appSettings :: AppSettings , appStatic :: Static -- ^ Settings for static file serving. , appConnPool :: ConnectionPool -- ^ Database connection pool. , appHttpManager :: Manager , appLogger :: Logger - } + , appMetrics :: !MM.Metrics + } deriving (Typeable) mkYesodData "App" $(parseRoutesFile "config/routes") - -- YesodPersist instance YesodPersist App where @@ -51,7 +55,7 @@ 10080 -- min (7 days) "config/client_session_key.aes" - yesodMiddleware = defaultYesodMiddleware . defaultCsrfMiddleware + yesodMiddleware = metricsMiddleware . defaultYesodMiddleware . defaultCsrfMiddleware defaultLayout widget = do req <- getRequest @@ -60,6 +64,7 @@ mmsg <- getMessage musername <- maybeAuthUsername mcurrentRoute <- getCurrentRoute + void $ mapM (incrementRouteEKG req) mcurrentRoute pc <- widgetToPageContent $ do setTitle "Espial" addAppScripts @@ -93,6 +98,17 @@ isAuthorized (AuthR _) _ = pure Authorized isAuthorized _ _ = pure Authorized + defaultMessageWidget title body = do + setTitle title + toWidget [hamlet| +
+
+
+

#{title} + ^{body} + |] + + isAuthenticated :: Handler AuthResult isAuthenticated = maybeAuthId >>= \case Just authId -> pure Authorized @@ -112,7 +128,6 @@ master <- getYesod mmsg <- getMessage musername <- maybeAuthUsername - mcurrentRoute <- getCurrentRoute pc <- widgetToPageContent $ do addAppScripts addStylesheet (StaticR css_tachyons_min_css) @@ -120,6 +135,44 @@ $(widgetFile "popup-layout") withUrlRenderer $(hamletFile "templates/default-layout-wrapper.hamlet") + +metricsMiddleware :: Handler a -> Handler a +metricsMiddleware handler = do + req <- getRequest + mcurrentRoute <- getCurrentRoute + void $ mapM (incrementRouteEKG req) mcurrentRoute + handler + + +incrementRouteEKG :: YesodRequest -> Route App -> Handler () +incrementRouteEKG req = MM.increment . (\r -> "route." <> r <> "." <> method) . routeToConstr + where method = decodeUtf8 $ NW.requestMethod $ reqWaiRequest req + +routeToConstr :: Route App -> Text +routeToConstr = \case + StaticR _ -> "StaticR" + FaviconR -> "FaviconR" + RobotsR -> "RobotsR" + AuthR _ -> "AuthR" + HomeR -> "HomeR" + UserR _ -> "UserR" + UserSharedR _ _ -> "UserSharedR" + UserFilterR _ _ -> "UserFilterR" + UserTagsR _ _ -> "UserTagsR" + AddViewR -> "AddViewR" + AddR -> "AddR" + DeleteR _ -> "DeleteR" + ReadR _ -> "ReadR" + StarR _ -> "StarR" + UnstarR _ -> "UnstarR" + NotesR _ -> "NotesR" + NoteR _ _ -> "NoteR" + DeleteNoteR _ -> "DeleteNoteR" + AddNoteR -> "AddNoteR" + AddNoteViewR _ -> "AddNoteViewR" + UserSettingsR _ -> "UserSettingsR" + + -- YesodAuth instance YesodAuth App where @@ -138,6 +191,9 @@ instance YesodAuthPersist App +instance MM.MonadMetrics Handler where + getMetrics = asks appMetrics + -- session keys maybeAuthUsername :: Handler (Maybe Text) @@ -177,7 +233,7 @@ <$> ireq textField "username" <*> ireq textField "password") case mresult of - FormSuccess creds -> lift $ setCredsRedirect creds + FormSuccess creds -> lift (setCredsRedirect creds) _ -> loginErrorMessageI LoginR InvalidUsernamePass @@ -191,13 +247,13 @@ authenticateCreds :: (AuthId master ~ UserId) - => Creds master -> Handler (AuthenticationResult App) -authenticateCreds creds = - runDB $ - authenticatePW - (credsIdent creds) - (fromMaybe "" (lookup "password" (credsExtra creds))) >>= - \case + => Creds master + -> Handler (AuthenticationResult App) +authenticateCreds creds = do + muser <- runDB (authenticatePassword + (credsIdent creds) + (fromMaybe "" (lookup "password" (credsExtra creds)))) + case muser of Nothing -> pure (UserError InvalidUsernamePass) Just (Entity uid _) -> pure (Authenticated uid) diff --git a/src/Handler/Add.hs b/src/Handler/Add.hs --- a/src/Handler/Add.hs +++ b/src/Handler/Add.hs @@ -13,25 +13,24 @@ userId <- requireAuthId murl <- lookupGetParam "url" - mexisting <- runDB (fetchBookmarkByUrl userId murl) - let mexisting' = fmap _toBookmarkDefs mexisting - mgetdefs <- mGetBookmarkForm - - let bmarkJson = preEscapedToMarkup (toJsonText (fromMaybe mgetdefs mexisting')) + mformdb <- runDB (pure . fmap _toBookmarkForm =<< fetchBookmarkByUrl userId murl) + formurl <- bookmarkFormUrl let renderEl = "addForm" :: Text popupLayout $ do toWidget [whamlet|
-