yogsototh/espial
1
0
Fork 0
Code Issues Pull requests Packages Projects Releases Wiki Activity

upgrade to lts-17.15

Browse source
This commit is contained in:
Jon Schoning 2021-06-11 00:40:44 -05:00 committed by Yann Esposito (Yogsototh)
parent 398ab95b34
commit 02a55aedba
Signed by untrusted user who does not match committer: yogsototh
GPG key ID: 7B19A4C650D59646
8 changed files with 58 additions and 104 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

36
espial.cabal
View file

@ -4,10 +4,10 @@ cabal-version: 1.12
-- --
-- see: https://github.com/sol/hpack -- see: https://github.com/sol/hpack
-- --
-- hash: 7535921358f6f30b353ed1ea8a7bfff26aa471228add3c6392836563ee7fc58d -- hash: 6f3e508b4528e0e41eab58d1f0830dc3917d04d50226e7dba709392b50db0c96
name: espial name: espial
version: 0.0.8 version: 0.0.9
synopsis: Espial is an open-source, web-based bookmarking server. synopsis: Espial is an open-source, web-based bookmarking server.
description: . description: .
Espial is an open-source, web-based bookmarking server. Espial is an open-source, web-based bookmarking server.
@ -123,7 +123,7 @@ library
Paths_espial Paths_espial
hs-source-dirs: hs-source-dirs:
src src
default-extensions: BangPatterns BlockArguments CPP ConstraintKinds DataKinds DeriveDataTypeable DeriveGeneric DerivingStrategies 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 UndecidableInstances 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: build-depends:
aeson >=1.4 aeson >=1.4
, attoparsec , attoparsec
@ -158,9 +158,9 @@ library
, monad-logger >=0.3 && <0.4 , monad-logger >=0.3 && <0.4
, mtl , mtl
, parser-combinators , parser-combinators
, persistent >=2.8 && <2.11 , persistent >=2.8 && <2.12
, persistent-sqlite >=2.6.2 , persistent-sqlite >=2.6.2
, persistent-template >=2.5 && <2.9 , persistent-template >=2.5 && <2.10
, pretty-show , pretty-show
, safe , safe
, shakespeare >=2.0 && <2.1 , shakespeare >=2.0 && <2.1
@ -171,7 +171,7 @@ library
, unordered-containers , unordered-containers
, vector , vector
, wai , wai
, wai-extra >=3.0 && <3.1 , wai-extra >=3.0 && <3.2
, wai-logger >=2.2 && <2.4 , wai-logger >=2.2 && <2.4
, warp >=3.0 && <3.4 , warp >=3.0 && <3.4
, yaml >=0.8 && <0.12 , yaml >=0.8 && <0.12
@ -195,7 +195,7 @@ executable espial
Paths_espial Paths_espial
hs-source-dirs: hs-source-dirs:
app app
default-extensions: BangPatterns BlockArguments CPP ConstraintKinds DataKinds DeriveDataTypeable DeriveGeneric DerivingStrategies 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 UndecidableInstances 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 ghc-options: -threaded -rtsopts -with-rtsopts=-N
build-depends: build-depends:
aeson >=1.4 aeson >=1.4
@ -232,9 +232,9 @@ executable espial
, monad-logger >=0.3 && <0.4 , monad-logger >=0.3 && <0.4
, mtl , mtl
, parser-combinators , parser-combinators
, persistent >=2.8 && <2.11 , persistent >=2.8 && <2.12
, persistent-sqlite >=2.6.2 , persistent-sqlite >=2.6.2
, persistent-template >=2.5 && <2.9 , persistent-template >=2.5 && <2.10
, pretty-show , pretty-show
, safe , safe
, shakespeare >=2.0 && <2.1 , shakespeare >=2.0 && <2.1
@ -245,7 +245,7 @@ executable espial
, unordered-containers , unordered-containers
, vector , vector
, wai , wai
, wai-extra >=3.0 && <3.1 , wai-extra >=3.0 && <3.2
, wai-logger >=2.2 && <2.4 , wai-logger >=2.2 && <2.4
, warp >=3.0 && <3.4 , warp >=3.0 && <3.4
, yaml >=0.8 && <0.12 , yaml >=0.8 && <0.12
@ -265,7 +265,7 @@ executable migration
Paths_espial Paths_espial
hs-source-dirs: hs-source-dirs:
app/migration app/migration
default-extensions: BangPatterns BlockArguments CPP ConstraintKinds DataKinds DeriveDataTypeable DeriveGeneric DerivingStrategies 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 UndecidableInstances 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 ghc-options: -threaded -rtsopts -with-rtsopts=-N
build-depends: build-depends:
aeson >=1.4 aeson >=1.4
@ -303,9 +303,9 @@ executable migration
, mtl , mtl
, optparse-generic >=1.2.3 , optparse-generic >=1.2.3
, parser-combinators , parser-combinators
, persistent >=2.8 && <2.11 , persistent >=2.8 && <2.12
, persistent-sqlite >=2.6.2 , persistent-sqlite >=2.6.2
, persistent-template >=2.5 && <2.9 , persistent-template >=2.5 && <2.10
, pretty-show , pretty-show
, safe , safe
, shakespeare >=2.0 && <2.1 , shakespeare >=2.0 && <2.1
@ -316,7 +316,7 @@ executable migration
, unordered-containers , unordered-containers
, vector , vector
, wai , wai
, wai-extra >=3.0 && <3.1 , wai-extra >=3.0 && <3.2
, wai-logger >=2.2 && <2.4 , wai-logger >=2.2 && <2.4
, warp >=3.0 && <3.4 , warp >=3.0 && <3.4
, yaml >=0.8 && <0.12 , yaml >=0.8 && <0.12
@ -340,7 +340,7 @@ test-suite test
Paths_espial Paths_espial
hs-source-dirs: hs-source-dirs:
test test
default-extensions: BangPatterns BlockArguments CPP ConstraintKinds DataKinds DeriveDataTypeable DeriveGeneric DerivingStrategies 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 UndecidableInstances 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 ghc-options: -Wall
build-depends: build-depends:
aeson >=1.4 aeson >=1.4
@ -378,9 +378,9 @@ test-suite test
, monad-logger >=0.3 && <0.4 , monad-logger >=0.3 && <0.4
, mtl , mtl
, parser-combinators , parser-combinators
, persistent >=2.8 && <2.11 , persistent >=2.8 && <2.12
, persistent-sqlite >=2.6.2 , persistent-sqlite >=2.6.2
, persistent-template >=2.5 && <2.9 , persistent-template >=2.5 && <2.10
, pretty-show , pretty-show
, safe , safe
, shakespeare >=2.0 && <2.1 , shakespeare >=2.0 && <2.1
@ -391,7 +391,7 @@ test-suite test
, unordered-containers , unordered-containers
, vector , vector
, wai , wai
, wai-extra >=3.0 && <3.1 , wai-extra >=3.0 && <3.2
, wai-logger >=2.2 && <2.4 , wai-logger >=2.2 && <2.4
, warp >=3.0 && <3.4 , warp >=3.0 && <3.4
, yaml >=0.8 && <0.12 , yaml >=0.8 && <0.12

16
package.yaml
View file

@ -1,6 +1,6 @@
name: espial name: espial
synopsis: Espial is an open-source, web-based bookmarking server. synopsis: Espial is an open-source, web-based bookmarking server.
version: "0.0.8" version: "0.0.9"
description: ! ' description: ! '
Espial is an open-source, web-based bookmarking server. Espial is an open-source, web-based bookmarking server.
@ -63,6 +63,7 @@ default-extensions:
- OverloadedStrings - OverloadedStrings
- PolyKinds - PolyKinds
- PolymorphicComponents - PolymorphicComponents
- PartialTypeSignatures
- QuasiQuotes - QuasiQuotes
- Rank2Types - Rank2Types
- RankNTypes - RankNTypes
@ -95,22 +96,19 @@ dependencies:
- classy-prelude-yesod >=1.4 && <1.6 - classy-prelude-yesod >=1.4 && <1.6
- bytestring >=0.9 && <0.11 - bytestring >=0.9 && <0.11
- text >=0.11 && <2.0 - text >=0.11 && <2.0
- persistent >=2.8 && <2.11 - persistent >=2.8 && <2.12
# - persistent-postgresql >=2.8 && <2.9
- blaze-html >= 0.9 && < 1.0 - blaze-html >= 0.9 && < 1.0
- persistent-template >=2.5 && <2.9 - persistent-template >=2.5 && <2.10
- template-haskell - template-haskell
- shakespeare >=2.0 && <2.1 - shakespeare >=2.0 && <2.1
- hjsmin >=0.1 && <0.3 - 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 - yaml >=0.8 && <0.12
- http-client-tls >=0.3 && <0.4 - http-client-tls >=0.3 && <0.4
- http-conduit >=2.3 && <2.4 - http-conduit >=2.3 && <2.4
- directory >=1.1 && <1.4 - directory >=1.1 && <1.4
- warp >=3.0 && <3.4 - warp >=3.0 && <3.4
- data-default - data-default
# - aeson >=0.6 && <1.4
- conduit >=1.0 && <2.0 - conduit >=1.0 && <2.0
- monad-logger >=0.3 && <0.4 - monad-logger >=0.3 && <0.4
- fast-logger >=2.2 && <4 - fast-logger >=2.2 && <4
@ -129,8 +127,6 @@ dependencies:
- attoparsec - attoparsec
- bcrypt >= 0.0.8 - bcrypt >= 0.0.8
- entropy - entropy
# - ekg
# - ekg-core
- esqueleto - esqueleto
- hscolour - hscolour
- http-api-data >= 0.3.4 - http-api-data >= 0.3.4
@ -138,12 +134,10 @@ dependencies:
- http-types - http-types
- iso8601-time >=0.1.3 - iso8601-time >=0.1.3
- microlens - microlens
# - monad-metrics
- mtl - mtl
- persistent-sqlite >=2.6.2 - persistent-sqlite >=2.6.2
- pretty-show - pretty-show
- transformers >= 0.2.2 - transformers >= 0.2.2
# - wai-middleware-metrics
- parser-combinators - parser-combinators
- html-entities - html-entities
- connection - connection

51
src/Application.hs
View file

@ -1,4 +1,5 @@
{-# OPTIONS_GHC -fno-warn-orphans #-} {-# OPTIONS_GHC -fno-warn-orphans #-}
{-# OPTIONS_GHC -fno-warn-partial-type-signatures #-}
module Application module Application
( getApplicationDev ( getApplicationDev
@ -15,10 +16,10 @@ module Application
) where ) where
import Control.Monad.Logger (liftLoc, runLoggingT) 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 Import
import Language.Haskell.TH.Syntax (qLocation) import Language.Haskell.TH.Syntax (qLocation)
-- import Lens.Micro import Lens.Micro
import Network.HTTP.Client.TLS import Network.HTTP.Client.TLS
import Network.Wai (Middleware) import Network.Wai (Middleware)
import Network.Wai.Handler.Warp (Settings, defaultSettings, defaultShouldDisplayException, runSettings, setHost, setOnException, setPort, getPort) import Network.Wai.Handler.Warp (Settings, defaultSettings, defaultShouldDisplayException, runSettings, setHost, setOnException, setPort, getPort)
@ -29,11 +30,6 @@ import Network.Wai.Middleware.MethodOverride
import Network.Wai.Middleware.RequestLogger (Destination(Logger), IPAddrSource(..), OutputFormat(..), destination, mkRequestLogger, outputFormat) import Network.Wai.Middleware.RequestLogger (Destination(Logger), IPAddrSource(..), OutputFormat(..), destination, mkRequestLogger, outputFormat)
import System.Log.FastLogger (defaultBufSize, newStdoutLoggerSet, toLogStr) import System.Log.FastLogger (defaultBufSize, newStdoutLoggerSet, toLogStr)
-- import qualified Control.Monad.Metrics as MM
-- import qualified Network.Wai.Metrics as WM
-- import qualified System.Metrics as EKG
-- import qualified System.Remote.Monitoring as EKG
-- Import all relevant handler modules here. -- Import all relevant handler modules here.
-- Don't forget to add new modules to your cabal file! -- Don't forget to add new modules to your cabal file!
import Handler.Common import Handler.Common
@ -51,38 +47,37 @@ makeFoundation :: AppSettings -> IO App
makeFoundation appSettings = do makeFoundation appSettings = do
appHttpManager <- getGlobalManager appHttpManager <- getGlobalManager
appLogger <- newStdoutLoggerSet defaultBufSize >>= makeYesodLogger appLogger <- newStdoutLoggerSet defaultBufSize >>= makeYesodLogger
-- store <- EKG.newStore
-- EKG.registerGcMetrics store
-- appMetrics <- MM.initializeWith store
appStatic <- appStatic <-
(if appMutableStatic appSettings (if appMutableStatic appSettings
then staticDevel then staticDevel
else static) else static)
(appStaticDir appSettings) (appStaticDir appSettings)
let mkFoundation appConnPool = App { ..} let mkFoundation appConnPool = App {..}
tempFoundation = mkFoundation (error "connPool forced in tempFoundation") tempFoundation = mkFoundation (error "connPool forced in tempFoundation")
logFunc = messageLoggerSource tempFoundation appLogger logFunc = messageLoggerSource tempFoundation appLogger
pool <- 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) return (mkFoundation pool)
where
mkPool :: _ -> Bool -> IO ConnectionPool
mkPool logFunc isFkEnabled =
flip runLoggingT logFunc $ do
let dbPath = sqlDatabase (appDatabaseConf appSettings)
poolSize = sqlPoolSize (appDatabaseConf appSettings)
connInfo = mkSqliteConnectionInfo dbPath &
set fkEnabled isFkEnabled
createSqlitePoolFromInfo connInfo poolSize
makeApplication :: App -> IO Application makeApplication :: App -> IO Application
makeApplication foundation = do makeApplication foundation = do
logWare <- makeLogWare foundation logWare <- makeLogWare foundation
appPlain <- toWaiAppPlain foundation appPlain <- toWaiAppPlain foundation
-- let store = appMetrics foundation ^. MM.metricsStore
-- waiMetrics <- WM.registerWaiMetrics store
return (logWare (makeMiddleware appPlain)) return (logWare (makeMiddleware appPlain))
makeMiddleware :: Middleware makeMiddleware :: Middleware
makeMiddleware = makeMiddleware =
-- WM.metrics waiMetrics .
acceptOverride . acceptOverride .
autohead . autohead .
gzip def {gzipFiles = GzipPreCompressed GzipIgnore} . gzip def {gzipFiles = GzipPreCompressed GzipIgnore} .
@ -126,7 +121,6 @@ getApplicationDev = do
foundation <- makeFoundation settings foundation <- makeFoundation settings
wsettings <- getDevSettings (warpSettings foundation) wsettings <- getDevSettings (warpSettings foundation)
app <- makeApplication foundation app <- makeApplication foundation
-- forkEKG foundation
return (wsettings, app) return (wsettings, app)
getAppSettings :: IO AppSettings getAppSettings :: IO AppSettings
@ -136,23 +130,12 @@ getAppSettings = loadYamlSettings [configSettingsYml] [] useEnv
develMain :: IO () develMain :: IO ()
develMain = develMainHelper getApplicationDev develMain = develMainHelper getApplicationDev
-- forkEKG :: App -> IO ()
-- forkEKG foundation =
-- let settings = appSettings foundation in
-- for_ (appEkgHost settings) \ekgHost ->
-- for_ (appEkgPort settings) \ekgPort ->
-- EKG.forkServerWith
-- (appMetrics foundation ^. MM.metricsStore)
-- (encodeUtf8 ekgHost)
-- ekgPort
-- | The @main@ function for an executable running this site. -- | The @main@ function for an executable running this site.
appMain :: IO () appMain :: IO ()
appMain = do appMain = do
settings <- loadYamlSettingsArgs [configSettingsYmlValue] useEnv settings <- loadYamlSettingsArgs [configSettingsYmlValue] useEnv
foundation <- makeFoundation settings foundation <- makeFoundation settings
app <- makeApplication foundation app <- makeApplication foundation
-- forkEKG foundation
runSettings (warpSettings foundation) app runSettings (warpSettings foundation) app
getApplicationRepl :: IO (Int, App, Application) getApplicationRepl :: IO (Int, App, Application)

23
src/Foundation.hs
View file

@ -10,13 +10,9 @@ import Text.Hamlet (hamletFile)
import Text.Jasmine (minifym) import Text.Jasmine (minifym)
import PathPiece() import PathPiece()
-- import Yesod.Auth.Dummy
import Yesod.Default.Util (addStaticContentExternal) import Yesod.Default.Util (addStaticContentExternal)
import Yesod.Core.Types import Yesod.Core.Types
import Yesod.Auth.Message import Yesod.Auth.Message
-- import qualified Network.Wai as NW
-- import qualified Control.Monad.Metrics as MM
import qualified Data.CaseInsensitive as CI import qualified Data.CaseInsensitive as CI
import qualified Data.Text.Encoding as TE import qualified Data.Text.Encoding as TE
import qualified Yesod.Core.Unsafe as Unsafe import qualified Yesod.Core.Unsafe as Unsafe
@ -27,7 +23,6 @@ data App = App
, appConnPool :: ConnectionPool -- ^ Database connection pool. , appConnPool :: ConnectionPool -- ^ Database connection pool.
, appHttpManager :: Manager , appHttpManager :: Manager
, appLogger :: Logger , appLogger :: Logger
-- , appMetrics :: !MM.Metrics
} deriving (Typeable) } deriving (Typeable)
mkYesodData "App" $(parseRoutesFile "config/routes") mkYesodData "App" $(parseRoutesFile "config/routes")
@ -58,7 +53,6 @@ instance Yesod App where
10080 -- min (7 days) 10080 -- min (7 days)
"config/client_session_key.aes" "config/client_session_key.aes"
-- yesodMiddleware = metricsMiddleware . defaultYesodMiddleware . defaultCsrfMiddleware
yesodMiddleware = defaultYesodMiddleware . defaultCsrfMiddleware yesodMiddleware = defaultYesodMiddleware . defaultCsrfMiddleware
defaultLayout widget = do defaultLayout widget = do
@ -69,7 +63,6 @@ instance Yesod App where
musername <- maybeAuthUsername musername <- maybeAuthUsername
muser <- (fmap.fmap) snd maybeAuthPair muser <- (fmap.fmap) snd maybeAuthPair
mcurrentRoute <- getCurrentRoute mcurrentRoute <- getCurrentRoute
-- void $ mapM (incrementRouteEKG req) mcurrentRoute
let msourceCodeUri = appSourceCodeUri (appSettings master) let msourceCodeUri = appSourceCodeUri (appSettings master)
pc <- widgetToPageContent do pc <- widgetToPageContent do
setTitle "Espial" setTitle "Espial"
@ -140,23 +133,10 @@ popupLayout widget = do
withUrlRenderer $(hamletFile "templates/default-layout-wrapper.hamlet") withUrlRenderer $(hamletFile "templates/default-layout-wrapper.hamlet")
-- metricsMiddleware :: Handler a -> Handler a
-- metricsMiddleware handler = do
-- req <- getRequest
-- mcurrentRoute <- getCurrentRoute
-- void $ mapM (incrementRouteEKG req) mcurrentRoute
-- handler
-- incrementRouteEKG :: YesodRequest -> Route App -> Handler ()
-- incrementRouteEKG req = MM.increment . (\r -> "route." <> r <> "." <> method) . pack . constrName
-- where method = decodeUtf8 $ NW.requestMethod $ reqWaiRequest req
-- YesodAuth -- YesodAuth
instance YesodAuth App where instance YesodAuth App where
type AuthId App = UserId type AuthId App = UserId
-- authHttpManager = getHttpManager
authPlugins _ = [dbAuthPlugin] authPlugins _ = [dbAuthPlugin]
authenticate = authenticateCreds authenticate = authenticateCreds
loginDest = const HomeR loginDest = const HomeR
@ -170,9 +150,6 @@ instance YesodAuth App where
instance YesodAuthPersist App instance YesodAuthPersist App
-- instance MM.MonadMetrics Handler where
-- getMetrics = pure . appMetrics =<< getYesod
-- session keys -- session keys
maybeAuthUsername :: Handler (Maybe Text) maybeAuthUsername :: Handler (Maybe Text)

8
src/Handler/Archive.hs
View file

@ -12,7 +12,6 @@ import qualified Network.HTTP.Client as NH
import qualified Network.HTTP.Client.TLS as NH import qualified Network.HTTP.Client.TLS as NH
import qualified Network.HTTP.Types.Status as NH import qualified Network.HTTP.Types.Status as NH
import qualified Web.FormUrlEncoded as WH import qualified Web.FormUrlEncoded as WH
-- import qualified Control.Monad.Metrics as MM
import HTMLEntities.Decoder (htmlEncodedText) import HTMLEntities.Decoder (htmlEncodedText)
import Data.Text.Lazy.Builder (toLazyText) import Data.Text.Lazy.Builder (toLazyText)
import Network.Wai (requestHeaderHost) import Network.Wai (requestHeaderHost)
@ -44,16 +43,13 @@ archiveBookmarkUrl :: Key Bookmark -> String -> Handler ()
archiveBookmarkUrl kbid url = archiveBookmarkUrl kbid url =
(_fetchArchiveSubmitInfo >>= \case (_fetchArchiveSubmitInfo >>= \case
Left e -> do Left e -> do
-- MM.increment "archive.fetchSubmitId_noparse"
$(logError) (pack e) $(logError) (pack e)
Right submitInfo -> do Right submitInfo -> do
userId <- requireAuthId userId <- requireAuthId
req <- _buildArchiveSubmitRequest submitInfo url req <- _buildArchiveSubmitRequest submitInfo url
-- MM.increment "archive.submit"
manager <- getArchiveManager manager <- getArchiveManager
res <- liftIO $ NH.httpLbs req manager res <- liftIO $ NH.httpLbs req manager
let status = NH.responseStatus res let status = NH.responseStatus res
-- MM.increment ("archive.submit_status_" <> (pack.show) (NH.statusCode status))
let updateArchiveUrl = runDB . updateBookmarkArchiveUrl userId kbid . Just let updateArchiveUrl = runDB . updateBookmarkArchiveUrl userId kbid . Just
headers = NH.responseHeaders res headers = NH.responseHeaders res
case status of case status of
@ -87,11 +83,9 @@ _parseRefreshHeaderUrl h = do
_fetchArchiveSubmitInfo :: Handler (Either String (String , String)) _fetchArchiveSubmitInfo :: Handler (Either String (String , String))
_fetchArchiveSubmitInfo = do _fetchArchiveSubmitInfo = do
-- MM.increment "archive.fetchSubmitId"
req <- buildRequest "https://archive.li/" req <- buildRequest "https://archive.li/"
manager <- getArchiveManager manager <- getArchiveManager
res <- liftIO $ NH.httpLbs req manager res <- liftIO $ NH.httpLbs req manager
-- MM.increment ("archive.fetchSubmitId_status_" <> (pack.show) (NH.statusCode (NH.responseStatus res)))
let body = LBS.toStrict (responseBody res) let body = LBS.toStrict (responseBody res)
action = _parseSubstring (AP8.string "action=\"") (AP8.notChar '"') body action = _parseSubstring (AP8.string "action=\"") (AP8.notChar '"') body
submitId = _parseSubstring (AP8.string "submitid\" value=\"") (AP8.notChar '"') body submitId = _parseSubstring (AP8.string "submitid\" value=\"") (AP8.notChar '"') body
@ -110,13 +104,11 @@ _parseSubstring start inner res = do
fetchPageTitle :: String -> Handler (Either String Text) fetchPageTitle :: String -> Handler (Either String Text)
fetchPageTitle url = fetchPageTitle url =
do do
-- MM.increment "fetchPageTitle"
req <- buildRequest url req <- buildRequest url
res <- liftIO $ NH.httpLbs req =<< NH.getGlobalManager res <- liftIO $ NH.httpLbs req =<< NH.getGlobalManager
let body = LBS.toStrict (responseBody res) let body = LBS.toStrict (responseBody res)
pure (decodeHtmlBs <$> parseTitle body) pure (decodeHtmlBs <$> parseTitle body)
`catch` (\(e :: SomeException) -> do `catch` (\(e :: SomeException) -> do
-- MM.increment "fetchPageTitle.error"
$(logError) $ (pack . show) e $(logError) $ (pack . show) e
pure (Left (show e))) pure (Left (show e)))
where where

10
src/Model.hs
View file

@ -12,7 +12,7 @@ import qualified Data.List.NonEmpty as NE
import qualified Data.Time.ISO8601 as TI import qualified Data.Time.ISO8601 as TI
import qualified Data.Time.Clock.POSIX as TI import qualified Data.Time.Clock.POSIX as TI
import qualified Database.Esqueleto as E import qualified Database.Esqueleto as E
import Database.Esqueleto.Internal.Sql as E import qualified Database.Esqueleto.Internal.Internal as E (exists, unsafeSqlFunction)
import qualified Data.Time as TI import qualified Data.Time as TI
import ClassyPrelude.Yesod hiding ((||.)) import ClassyPrelude.Yesod hiding ((||.))
import Control.Monad.Trans.Maybe import Control.Monad.Trans.Maybe
@ -188,7 +188,7 @@ bookmarksQuery userId sharedp filterp tags mquery limit' page =
_whereClause b = do _whereClause b = do
where_ $ where_ $
foldl (\expr tag -> foldl (\expr tag ->
expr &&. (exists $ -- each tag becomes an exists constraint expr &&. (E.exists $ -- each tag becomes an exists constraint
from \t -> from \t ->
where_ (t ^. BookmarkTagBookmarkId E.==. b ^. BookmarkId &&. where_ (t ^. BookmarkTagBookmarkId E.==. b ^. BookmarkId &&.
(t ^. BookmarkTagTag `E.like` val tag)))) (t ^. BookmarkTagTag `E.like` val tag))))
@ -217,7 +217,7 @@ bookmarksQuery userId sharedp filterp tags mquery limit' page =
(toLikeB BookmarkHref term) ||. (toLikeB BookmarkHref term) ||.
(toLikeB BookmarkDescription term) ||. (toLikeB BookmarkDescription term) ||.
(toLikeB BookmarkExtended term) ||. (toLikeB BookmarkExtended term) ||.
(exists $ from (\t -> where_ $ (E.exists $ from (\t -> where_ $
(t ^. BookmarkTagBookmarkId E.==. b ^. BookmarkId) &&. (t ^. BookmarkTagBookmarkId E.==. b ^. BookmarkId) &&.
(t ^. BookmarkTagTag `E.like` (wild term)))) (t ^. BookmarkTagTag `E.like` (wild term))))
p_onefield = p_url <|> p_title <|> p_description <|> p_tags <|> p_after <|> p_before p_onefield = p_url <|> p_title <|> p_description <|> p_tags <|> p_after <|> p_before
@ -225,7 +225,7 @@ bookmarksQuery userId sharedp filterp tags mquery limit' page =
p_url = "url:" *> fmap (toLikeB BookmarkHref) P.takeText p_url = "url:" *> fmap (toLikeB BookmarkHref) P.takeText
p_title = "title:" *> fmap (toLikeB BookmarkDescription) P.takeText p_title = "title:" *> fmap (toLikeB BookmarkDescription) P.takeText
p_description = "description:" *> fmap (toLikeB BookmarkExtended) P.takeText p_description = "description:" *> fmap (toLikeB BookmarkExtended) P.takeText
p_tags = "tags:" *> fmap (\term' -> exists $ from (\t -> where_ $ p_tags = "tags:" *> fmap (\term' -> E.exists $ from (\t -> where_ $
(t ^. BookmarkTagBookmarkId E.==. b ^. BookmarkId) &&. (t ^. BookmarkTagBookmarkId E.==. b ^. BookmarkId) &&.
(t ^. BookmarkTagTag `E.like` wild term'))) P.takeText (t ^. BookmarkTagTag `E.like` wild term'))) P.takeText
p_after = "after:" *> fmap ((b ^. BookmarkTime E.>=.) . val) (parseTimeText =<< P.takeText) p_after = "after:" *> fmap ((b ^. BookmarkTime E.>=.) . val) (parseTimeText =<< P.takeText)
@ -568,7 +568,7 @@ tagCountRelated user tags =
from \t -> do from \t -> do
where_ $ where_ $
foldl (\expr tag -> foldl (\expr tag ->
expr &&. (exists $ expr &&. (E.exists $
from \u -> from \u ->
where_ (u ^. BookmarkTagBookmarkId E.==. t ^. BookmarkTagBookmarkId &&. where_ (u ^. BookmarkTagBookmarkId E.==. t ^. BookmarkTagBookmarkId &&.
(u ^. BookmarkTagTag `E.like` val tag)))) (u ^. BookmarkTagTag `E.like` val tag))))

3
stack.yaml
View file

@ -1,4 +1,4 @@
resolver: lts-16.19 resolver: lts-17.15
# allow-newer: true # allow-newer: true
packages: packages:
- '.' - '.'
@ -7,4 +7,5 @@ extra-deps:
# - ekg-json-0.1.0.6 # - ekg-json-0.1.0.6
# - monad-metrics-0.2.1.4 # - monad-metrics-0.2.1.4
# - wai-middleware-metrics-0.2.4 # - wai-middleware-metrics-0.2.4
- classy-prelude-yesod-1.5.0@sha256:8f7e183bdfd6d2ea9674284c4f285294ab086aff60d9be4e5d7d2f3c1a2b05b7,1330
- yesod-newsfeed-1.7.0.0 - yesod-newsfeed-1.7.0.0

15
stack.yaml.lock
View file

@ -4,6 +4,13 @@
# https://docs.haskellstack.org/en/stable/lock_files # https://docs.haskellstack.org/en/stable/lock_files
packages: packages:
- completed:
hackage: classy-prelude-yesod-1.5.0@sha256:8f7e183bdfd6d2ea9674284c4f285294ab086aff60d9be4e5d7d2f3c1a2b05b7,1330
pantry-tree:
size: 330
sha256: ae84d4cc0e1daf985db6cdcf2ac92319531b8e60f547183cc46480d00aafbe20
original:
hackage: classy-prelude-yesod-1.5.0@sha256:8f7e183bdfd6d2ea9674284c4f285294ab086aff60d9be4e5d7d2f3c1a2b05b7,1330
- completed: - completed:
hackage: yesod-newsfeed-1.7.0.0@sha256:ba49f9af47fe96c521ed889bf041c559b4bddb60a81f385449f7557f8f4aaef2,1345 hackage: yesod-newsfeed-1.7.0.0@sha256:ba49f9af47fe96c521ed889bf041c559b4bddb60a81f385449f7557f8f4aaef2,1345
pantry-tree: pantry-tree:
@ -13,7 +20,7 @@ packages:
hackage: yesod-newsfeed-1.7.0.0 hackage: yesod-newsfeed-1.7.0.0
snapshots: snapshots:
- completed: - completed:
size: 532177 size: 567679
url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/16/19.yaml url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/17/15.yaml
sha256: d2b828ecf50386841d0c5700b58d38566992e10d63a062af497ab29ab031faa1 sha256: 72e87841a0ab5b72f6f018e8ee692fd972b7bb32a944990f028e10d6eb528e63
original: lts-16.19 original: lts-17.15