Merge pull request #11 from jonschoning/ghc-8.8.3
update to nightly-2020-03-29 (ghc-8.8.3)
This commit is contained in:
Jon Schoning
GitHub
commit
b136e59265
|
|
@ -59,8 +59,6 @@ see `config/settings.yml` for changing default run-time parameters / environment
|
|||
|
||||
default app http port: `3000`
|
||||
|
||||
default ekg http port: `8000`
|
||||
|
||||
ssl: use reverse proxy
|
||||
|
||||
## Development
|
||||
|
|
|
|||
|
|
@ -37,7 +37,7 @@ database:
|
|||
copyright: Insert copyright statement here
|
||||
#analytics: UA-YOURCODE
|
||||
|
||||
ekg-host: "_env:EKG_HOST:0.0.0.0"
|
||||
ekg-port: "_env:EKG_PORT:8000"
|
||||
# ekg-host: "_env:EKG_HOST:0.0.0.0"
|
||||
# ekg-port: "_env:EKG_PORT:8000"
|
||||
|
||||
source-code-uri: "https://github.com/jonschoning/espial"
|
||||
|
|
|
|||
|
|
@ -7,7 +7,7 @@ services:
|
|||
dockerfile: ../Dockerfile
|
||||
ports:
|
||||
- "3000:3000"
|
||||
- "8000:8000"
|
||||
# - "8000:8000"
|
||||
volumes:
|
||||
- '$APPDATA:/app/data'
|
||||
environment:
|
||||
|
|
|
|||
42
espial.cabal
42
espial.cabal
|
|
@ -4,7 +4,7 @@ cabal-version: 1.12
|
|||
--
|
||||
-- see: https://github.com/sol/hpack
|
||||
--
|
||||
-- hash: 853ba5e7d0435fcec73b493932da0f2748f4674bbfc62ebbd54df707166f999b
|
||||
-- hash: b6f4cdc1abf4e7a6b5bbc1382963c22cc62bbbe8c4ae5e5394cf6fe5fc1ff9cb
|
||||
|
||||
name: espial
|
||||
version: 0.0.8
|
||||
|
|
@ -123,7 +123,7 @@ library
|
|||
Paths_espial
|
||||
hs-source-dirs:
|
||||
src
|
||||
default-extensions: BangPatterns CPP ConstraintKinds DataKinds DeriveDataTypeable DeriveGeneric EmptyDataDecls FlexibleContexts FlexibleInstances GADTs GeneralizedNewtypeDeriving InstanceSigs KindSignatures LambdaCase MultiParamTypeClasses MultiWayIf NoImplicitPrelude OverloadedStrings PolyKinds PolymorphicComponents QuasiQuotes Rank2Types RankNTypes RecordWildCards ScopedTypeVariables StandaloneDeriving TemplateHaskell TupleSections TypeApplications TypeFamilies TypeOperators TypeSynonymInstances ViewPatterns
|
||||
default-extensions: BangPatterns 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
|
||||
build-depends:
|
||||
aeson >=1.4
|
||||
, attoparsec
|
||||
|
|
@ -139,11 +139,9 @@ library
|
|||
, containers
|
||||
, data-default
|
||||
, directory >=1.1 && <1.4
|
||||
, ekg
|
||||
, ekg-core
|
||||
, entropy
|
||||
, esqueleto
|
||||
, fast-logger >=2.2 && <2.5
|
||||
, fast-logger >=2.2 && <4
|
||||
, file-embed
|
||||
, foreign-store
|
||||
, hjsmin >=0.1 && <0.3
|
||||
|
|
@ -157,10 +155,9 @@ library
|
|||
, iso8601-time >=0.1.3
|
||||
, microlens
|
||||
, monad-logger >=0.3 && <0.4
|
||||
, monad-metrics
|
||||
, mtl
|
||||
, parser-combinators
|
||||
, persistent >=2.8 && <2.10
|
||||
, persistent >=2.8 && <2.11
|
||||
, persistent-sqlite >=2.6.2
|
||||
, persistent-template >=2.5 && <2.9
|
||||
, pretty-show
|
||||
|
|
@ -175,7 +172,6 @@ library
|
|||
, wai
|
||||
, wai-extra >=3.0 && <3.1
|
||||
, wai-logger >=2.2 && <2.4
|
||||
, wai-middleware-metrics
|
||||
, warp >=3.0 && <3.4
|
||||
, yaml >=0.8 && <0.12
|
||||
, yesod >=1.6 && <1.7
|
||||
|
|
@ -198,7 +194,7 @@ executable espial
|
|||
Paths_espial
|
||||
hs-source-dirs:
|
||||
app
|
||||
default-extensions: BangPatterns CPP ConstraintKinds DataKinds DeriveDataTypeable DeriveGeneric EmptyDataDecls FlexibleContexts FlexibleInstances GADTs GeneralizedNewtypeDeriving InstanceSigs KindSignatures LambdaCase MultiParamTypeClasses MultiWayIf NoImplicitPrelude OverloadedStrings PolyKinds PolymorphicComponents QuasiQuotes Rank2Types RankNTypes RecordWildCards ScopedTypeVariables StandaloneDeriving TemplateHaskell TupleSections TypeApplications TypeFamilies TypeOperators TypeSynonymInstances ViewPatterns
|
||||
default-extensions: BangPatterns 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
|
||||
ghc-options: -threaded -rtsopts -with-rtsopts=-N
|
||||
build-depends:
|
||||
aeson >=1.4
|
||||
|
|
@ -215,12 +211,10 @@ executable espial
|
|||
, containers
|
||||
, data-default
|
||||
, directory >=1.1 && <1.4
|
||||
, ekg
|
||||
, ekg-core
|
||||
, entropy
|
||||
, espial
|
||||
, esqueleto
|
||||
, fast-logger >=2.2 && <2.5
|
||||
, fast-logger >=2.2 && <4
|
||||
, file-embed
|
||||
, foreign-store
|
||||
, hjsmin >=0.1 && <0.3
|
||||
|
|
@ -234,10 +228,9 @@ executable espial
|
|||
, iso8601-time >=0.1.3
|
||||
, microlens
|
||||
, monad-logger >=0.3 && <0.4
|
||||
, monad-metrics
|
||||
, mtl
|
||||
, parser-combinators
|
||||
, persistent >=2.8 && <2.10
|
||||
, persistent >=2.8 && <2.11
|
||||
, persistent-sqlite >=2.6.2
|
||||
, persistent-template >=2.5 && <2.9
|
||||
, pretty-show
|
||||
|
|
@ -252,7 +245,6 @@ executable espial
|
|||
, wai
|
||||
, wai-extra >=3.0 && <3.1
|
||||
, wai-logger >=2.2 && <2.4
|
||||
, wai-middleware-metrics
|
||||
, warp >=3.0 && <3.4
|
||||
, yaml >=0.8 && <0.12
|
||||
, yesod >=1.6 && <1.7
|
||||
|
|
@ -271,7 +263,7 @@ executable migration
|
|||
Paths_espial
|
||||
hs-source-dirs:
|
||||
app/migration
|
||||
default-extensions: BangPatterns CPP ConstraintKinds DataKinds DeriveDataTypeable DeriveGeneric EmptyDataDecls FlexibleContexts FlexibleInstances GADTs GeneralizedNewtypeDeriving InstanceSigs KindSignatures LambdaCase MultiParamTypeClasses MultiWayIf NoImplicitPrelude OverloadedStrings PolyKinds PolymorphicComponents QuasiQuotes Rank2Types RankNTypes RecordWildCards ScopedTypeVariables StandaloneDeriving TemplateHaskell TupleSections TypeApplications TypeFamilies TypeOperators TypeSynonymInstances ViewPatterns
|
||||
default-extensions: BangPatterns 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
|
||||
ghc-options: -threaded -rtsopts -with-rtsopts=-N
|
||||
build-depends:
|
||||
aeson >=1.4
|
||||
|
|
@ -288,12 +280,10 @@ executable migration
|
|||
, containers
|
||||
, data-default
|
||||
, directory >=1.1 && <1.4
|
||||
, ekg
|
||||
, ekg-core
|
||||
, entropy
|
||||
, espial
|
||||
, esqueleto
|
||||
, fast-logger >=2.2 && <2.5
|
||||
, fast-logger >=2.2 && <4
|
||||
, file-embed
|
||||
, foreign-store
|
||||
, hjsmin >=0.1 && <0.3
|
||||
|
|
@ -307,11 +297,10 @@ executable migration
|
|||
, iso8601-time >=0.1.3
|
||||
, microlens
|
||||
, monad-logger >=0.3 && <0.4
|
||||
, monad-metrics
|
||||
, mtl
|
||||
, optparse-generic >=1.2.3
|
||||
, parser-combinators
|
||||
, persistent >=2.8 && <2.10
|
||||
, persistent >=2.8 && <2.11
|
||||
, persistent-sqlite >=2.6.2
|
||||
, persistent-template >=2.5 && <2.9
|
||||
, pretty-show
|
||||
|
|
@ -326,7 +315,6 @@ executable migration
|
|||
, wai
|
||||
, wai-extra >=3.0 && <3.1
|
||||
, wai-logger >=2.2 && <2.4
|
||||
, wai-middleware-metrics
|
||||
, warp >=3.0 && <3.4
|
||||
, yaml >=0.8 && <0.12
|
||||
, yesod >=1.6 && <1.7
|
||||
|
|
@ -349,7 +337,7 @@ test-suite test
|
|||
Paths_espial
|
||||
hs-source-dirs:
|
||||
test
|
||||
default-extensions: BangPatterns CPP ConstraintKinds DataKinds DeriveDataTypeable DeriveGeneric EmptyDataDecls FlexibleContexts FlexibleInstances GADTs GeneralizedNewtypeDeriving InstanceSigs KindSignatures LambdaCase MultiParamTypeClasses MultiWayIf NoImplicitPrelude OverloadedStrings PolyKinds PolymorphicComponents QuasiQuotes Rank2Types RankNTypes RecordWildCards ScopedTypeVariables StandaloneDeriving TemplateHaskell TupleSections TypeApplications TypeFamilies TypeOperators TypeSynonymInstances ViewPatterns
|
||||
default-extensions: BangPatterns 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
|
||||
ghc-options: -Wall
|
||||
build-depends:
|
||||
aeson >=1.4
|
||||
|
|
@ -366,12 +354,10 @@ test-suite test
|
|||
, containers
|
||||
, data-default
|
||||
, directory >=1.1 && <1.4
|
||||
, ekg
|
||||
, ekg-core
|
||||
, entropy
|
||||
, espial
|
||||
, esqueleto
|
||||
, fast-logger >=2.2 && <2.5
|
||||
, fast-logger >=2.2 && <4
|
||||
, file-embed
|
||||
, foreign-store
|
||||
, hjsmin >=0.1 && <0.3
|
||||
|
|
@ -386,10 +372,9 @@ test-suite test
|
|||
, iso8601-time >=0.1.3
|
||||
, microlens
|
||||
, monad-logger >=0.3 && <0.4
|
||||
, monad-metrics
|
||||
, mtl
|
||||
, parser-combinators
|
||||
, persistent >=2.8 && <2.10
|
||||
, persistent >=2.8 && <2.11
|
||||
, persistent-sqlite >=2.6.2
|
||||
, persistent-template >=2.5 && <2.9
|
||||
, pretty-show
|
||||
|
|
@ -404,7 +389,6 @@ test-suite test
|
|||
, wai
|
||||
, wai-extra >=3.0 && <3.1
|
||||
, wai-logger >=2.2 && <2.4
|
||||
, wai-middleware-metrics
|
||||
, warp >=3.0 && <3.4
|
||||
, yaml >=0.8 && <0.12
|
||||
, yesod >=1.6 && <1.7
|
||||
|
|
|
|||
14
package.yaml
14
package.yaml
|
|
@ -47,6 +47,7 @@ default-extensions:
|
|||
- DataKinds
|
||||
- DeriveDataTypeable
|
||||
- DeriveGeneric
|
||||
- DerivingStrategies
|
||||
- EmptyDataDecls
|
||||
- FlexibleContexts
|
||||
- FlexibleInstances
|
||||
|
|
@ -73,6 +74,7 @@ default-extensions:
|
|||
- TypeFamilies
|
||||
- TypeOperators
|
||||
- TypeSynonymInstances
|
||||
- UndecidableInstances
|
||||
- ViewPatterns
|
||||
|
||||
dependencies:
|
||||
|
|
@ -92,7 +94,7 @@ dependencies:
|
|||
- classy-prelude-yesod >=1.4 && <1.6
|
||||
- bytestring >=0.9 && <0.11
|
||||
- text >=0.11 && <2.0
|
||||
- persistent >=2.8 && <2.10
|
||||
- persistent >=2.8 && <2.11
|
||||
# - persistent-postgresql >=2.8 && <2.9
|
||||
- blaze-html >= 0.9 && < 1.0
|
||||
- persistent-template >=2.5 && <2.9
|
||||
|
|
@ -110,7 +112,7 @@ dependencies:
|
|||
# - aeson >=0.6 && <1.4
|
||||
- conduit >=1.0 && <2.0
|
||||
- monad-logger >=0.3 && <0.4
|
||||
- fast-logger >=2.2 && <2.5
|
||||
- fast-logger >=2.2 && <4
|
||||
- wai-logger >=2.2 && <2.4
|
||||
- file-embed
|
||||
- safe
|
||||
|
|
@ -126,8 +128,8 @@ dependencies:
|
|||
- attoparsec
|
||||
- bcrypt >= 0.0.8
|
||||
- entropy
|
||||
- ekg
|
||||
- ekg-core
|
||||
# - ekg
|
||||
# - ekg-core
|
||||
- esqueleto
|
||||
- hscolour
|
||||
- http-api-data >= 0.3.4
|
||||
|
|
@ -135,12 +137,12 @@ dependencies:
|
|||
- http-types
|
||||
- iso8601-time >=0.1.3
|
||||
- microlens
|
||||
- monad-metrics
|
||||
# - monad-metrics
|
||||
- mtl
|
||||
- persistent-sqlite >=2.6.2
|
||||
- pretty-show
|
||||
- transformers >= 0.2.2
|
||||
- wai-middleware-metrics
|
||||
# - wai-middleware-metrics
|
||||
- parser-combinators
|
||||
- html-entities
|
||||
|
||||
|
|
|
|||
|
|
@ -18,7 +18,7 @@ import Control.Monad.Logger (liftLoc, runLoggingT)
|
|||
import Database.Persist.Sqlite (createSqlitePool, runSqlPool, sqlDatabase, sqlPoolSize)
|
||||
import Import
|
||||
import Language.Haskell.TH.Syntax (qLocation)
|
||||
import Lens.Micro
|
||||
-- import Lens.Micro
|
||||
import Network.HTTP.Client.TLS
|
||||
import Network.Wai (Middleware)
|
||||
import Network.Wai.Handler.Warp (Settings, defaultSettings, defaultShouldDisplayException, runSettings, setHost, setOnException, setPort, getPort)
|
||||
|
|
@ -28,12 +28,11 @@ import Network.Wai.Middleware.Gzip
|
|||
import Network.Wai.Middleware.MethodOverride
|
||||
import Network.Wai.Middleware.RequestLogger (Destination(Logger), IPAddrSource(..), OutputFormat(..), destination, mkRequestLogger, outputFormat)
|
||||
import System.Log.FastLogger (defaultBufSize, newStdoutLoggerSet, toLogStr)
|
||||
import Yesod.Auth (getAuth)
|
||||
|
||||
import qualified Control.Monad.Metrics as MM
|
||||
import qualified Network.Wai.Metrics as WM
|
||||
import qualified System.Metrics as EKG
|
||||
import qualified System.Remote.Monitoring as EKG
|
||||
-- import qualified Control.Monad.Metrics as MM
|
||||
-- import qualified Network.Wai.Metrics as WM
|
||||
-- import qualified System.Metrics as EKG
|
||||
-- import qualified System.Remote.Monitoring as EKG
|
||||
|
||||
-- Import all relevant handler modules here.
|
||||
-- Don't forget to add new modules to your cabal file!
|
||||
|
|
@ -52,9 +51,9 @@ makeFoundation :: AppSettings -> IO App
|
|||
makeFoundation appSettings = do
|
||||
appHttpManager <- getGlobalManager
|
||||
appLogger <- newStdoutLoggerSet defaultBufSize >>= makeYesodLogger
|
||||
store <- EKG.newStore
|
||||
EKG.registerGcMetrics store
|
||||
appMetrics <- MM.initializeWith store
|
||||
-- store <- EKG.newStore
|
||||
-- EKG.registerGcMetrics store
|
||||
-- appMetrics <- MM.initializeWith store
|
||||
appStatic <-
|
||||
(if appMutableStatic appSettings
|
||||
then staticDevel
|
||||
|
|
@ -77,13 +76,13 @@ makeApplication :: App -> IO Application
|
|||
makeApplication foundation = do
|
||||
logWare <- makeLogWare foundation
|
||||
appPlain <- toWaiAppPlain foundation
|
||||
let store = appMetrics foundation ^. MM.metricsStore
|
||||
waiMetrics <- WM.registerWaiMetrics store
|
||||
return (logWare (makeMiddleware waiMetrics appPlain))
|
||||
-- let store = appMetrics foundation ^. MM.metricsStore
|
||||
-- waiMetrics <- WM.registerWaiMetrics store
|
||||
return (logWare (makeMiddleware appPlain))
|
||||
|
||||
makeMiddleware :: WM.WaiMetrics -> Middleware
|
||||
makeMiddleware waiMetrics =
|
||||
WM.metrics waiMetrics .
|
||||
makeMiddleware :: Middleware
|
||||
makeMiddleware =
|
||||
-- WM.metrics waiMetrics .
|
||||
acceptOverride .
|
||||
autohead .
|
||||
gzip def {gzipFiles = GzipPreCompressed GzipIgnore} .
|
||||
|
|
@ -127,7 +126,7 @@ getApplicationDev = do
|
|||
foundation <- makeFoundation settings
|
||||
wsettings <- getDevSettings (warpSettings foundation)
|
||||
app <- makeApplication foundation
|
||||
forkEKG foundation
|
||||
-- forkEKG foundation
|
||||
return (wsettings, app)
|
||||
|
||||
getAppSettings :: IO AppSettings
|
||||
|
|
@ -137,15 +136,15 @@ getAppSettings = loadYamlSettings [configSettingsYml] [] useEnv
|
|||
develMain :: IO ()
|
||||
develMain = develMainHelper getApplicationDev
|
||||
|
||||
forkEKG :: App -> IO ()
|
||||
forkEKG foundation =
|
||||
let settings = appSettings foundation in
|
||||
for_ (appEkgHost settings) $ \ekgHost ->
|
||||
for_ (appEkgPort settings) $ \ekgPort ->
|
||||
EKG.forkServerWith
|
||||
(appMetrics foundation ^. MM.metricsStore)
|
||||
(encodeUtf8 ekgHost)
|
||||
ekgPort
|
||||
-- forkEKG :: App -> IO ()
|
||||
-- forkEKG foundation =
|
||||
-- let settings = appSettings foundation in
|
||||
-- for_ (appEkgHost settings) $ \ekgHost ->
|
||||
-- for_ (appEkgPort settings) $ \ekgPort ->
|
||||
-- EKG.forkServerWith
|
||||
-- (appMetrics foundation ^. MM.metricsStore)
|
||||
-- (encodeUtf8 ekgHost)
|
||||
-- ekgPort
|
||||
|
||||
-- | The @main@ function for an executable running this site.
|
||||
appMain :: IO ()
|
||||
|
|
@ -153,7 +152,7 @@ appMain = do
|
|||
settings <- loadYamlSettingsArgs [configSettingsYmlValue] useEnv
|
||||
foundation <- makeFoundation settings
|
||||
app <- makeApplication foundation
|
||||
forkEKG foundation
|
||||
-- forkEKG foundation
|
||||
runSettings (warpSettings foundation) app
|
||||
|
||||
getApplicationRepl :: IO (Int, App, Application)
|
||||
|
|
|
|||
|
|
@ -15,8 +15,8 @@ import PathPiece()
|
|||
import Yesod.Default.Util (addStaticContentExternal)
|
||||
import Yesod.Core.Types
|
||||
import Yesod.Auth.Message
|
||||
import qualified Network.Wai as NW
|
||||
import qualified Control.Monad.Metrics as MM
|
||||
-- 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
|
||||
|
|
@ -27,7 +27,7 @@ data App = App
|
|||
, appConnPool :: ConnectionPool -- ^ Database connection pool.
|
||||
, appHttpManager :: Manager
|
||||
, appLogger :: Logger
|
||||
, appMetrics :: !MM.Metrics
|
||||
-- , appMetrics :: !MM.Metrics
|
||||
} deriving (Typeable)
|
||||
|
||||
mkYesodData "App" $(parseRoutesFile "config/routes")
|
||||
|
|
@ -58,7 +58,8 @@ instance Yesod App where
|
|||
10080 -- min (7 days)
|
||||
"config/client_session_key.aes"
|
||||
|
||||
yesodMiddleware = metricsMiddleware . defaultYesodMiddleware . defaultCsrfMiddleware
|
||||
-- yesodMiddleware = metricsMiddleware . defaultYesodMiddleware . defaultCsrfMiddleware
|
||||
yesodMiddleware = defaultYesodMiddleware . defaultCsrfMiddleware
|
||||
|
||||
defaultLayout widget = do
|
||||
req <- getRequest
|
||||
|
|
@ -68,7 +69,7 @@ instance Yesod App where
|
|||
musername <- maybeAuthUsername
|
||||
muser <- (fmap.fmap) snd maybeAuthPair
|
||||
mcurrentRoute <- getCurrentRoute
|
||||
void $ mapM (incrementRouteEKG req) mcurrentRoute
|
||||
-- void $ mapM (incrementRouteEKG req) mcurrentRoute
|
||||
let msourceCodeUri = appSourceCodeUri (appSettings master)
|
||||
pc <- widgetToPageContent $ do
|
||||
setTitle "Espial"
|
||||
|
|
@ -139,17 +140,17 @@ popupLayout widget = do
|
|||
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
|
||||
-- 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
|
||||
-- incrementRouteEKG :: YesodRequest -> Route App -> Handler ()
|
||||
-- incrementRouteEKG req = MM.increment . (\r -> "route." <> r <> "." <> method) . pack . constrName
|
||||
-- where method = decodeUtf8 $ NW.requestMethod $ reqWaiRequest req
|
||||
|
||||
-- YesodAuth
|
||||
|
||||
|
|
@ -169,8 +170,8 @@ instance YesodAuth App where
|
|||
|
||||
instance YesodAuthPersist App
|
||||
|
||||
instance MM.MonadMetrics Handler where
|
||||
getMetrics = pure . appMetrics =<< getYesod
|
||||
-- instance MM.MonadMetrics Handler where
|
||||
-- getMetrics = pure . appMetrics =<< getYesod
|
||||
|
||||
-- session keys
|
||||
|
||||
|
|
|
|||
|
|
@ -12,7 +12,7 @@ import qualified Network.HTTP.Client as NH
|
|||
import qualified Network.HTTP.Client.TLS as NH
|
||||
import qualified Network.HTTP.Types.Status as NH
|
||||
import qualified Web.FormUrlEncoded as WH
|
||||
import qualified Control.Monad.Metrics as MM
|
||||
-- import qualified Control.Monad.Metrics as MM
|
||||
import HTMLEntities.Decoder (htmlEncodedText)
|
||||
import Data.Text.Lazy.Builder (toLazyText)
|
||||
|
||||
|
|
@ -31,15 +31,15 @@ archiveBookmarkUrl :: Key Bookmark -> String -> Handler ()
|
|||
archiveBookmarkUrl kbid url =
|
||||
(_fetchArchiveSubmitInfo >>= \case
|
||||
Left e -> do
|
||||
MM.increment "archive.fetchSubmitId_noparse"
|
||||
-- MM.increment "archive.fetchSubmitId_noparse"
|
||||
$(logError) (pack e)
|
||||
Right submitInfo -> do
|
||||
userId <- requireAuthId
|
||||
let req = _buildArchiveSubmitRequest submitInfo url
|
||||
MM.increment "archive.submit"
|
||||
-- MM.increment "archive.submit"
|
||||
res <- liftIO $ NH.httpLbs req =<< NH.getGlobalManager
|
||||
let status = NH.responseStatus res
|
||||
MM.increment ("archive.submit_status_" <> (pack.show) (NH.statusCode status))
|
||||
-- MM.increment ("archive.submit_status_" <> (pack.show) (NH.statusCode status))
|
||||
let updateArchiveUrl = runDB . updateBookmarkArchiveUrl userId kbid . Just
|
||||
headers = NH.responseHeaders res
|
||||
case status of
|
||||
|
|
@ -87,9 +87,9 @@ _buildArchiveSubmitRequest (action, submitId) href =
|
|||
|
||||
_fetchArchiveSubmitInfo :: Handler (Either String (String , String))
|
||||
_fetchArchiveSubmitInfo = do
|
||||
MM.increment "archive.fetchSubmitId"
|
||||
-- MM.increment "archive.fetchSubmitId"
|
||||
res <- liftIO $ NH.httpLbs (buildSimpleRequest "https://archive.li/") =<< NH.getGlobalManager
|
||||
MM.increment ("archive.fetchSubmitId_status_" <> (pack.show) (NH.statusCode (NH.responseStatus res)))
|
||||
-- MM.increment ("archive.fetchSubmitId_status_" <> (pack.show) (NH.statusCode (NH.responseStatus res)))
|
||||
let body = LBS.toStrict (responseBody res)
|
||||
action = _parseSubstring (AP8.string "action=\"") (AP8.notChar '"') body
|
||||
submitId = _parseSubstring (AP8.string "submitid\" value=\"") (AP8.notChar '"') body
|
||||
|
|
@ -107,12 +107,13 @@ _parseSubstring start inner res = do
|
|||
|
||||
fetchPageTitle :: String -> Handler (Either String Text)
|
||||
fetchPageTitle url =
|
||||
do MM.increment "fetchPageTitle"
|
||||
do
|
||||
-- MM.increment "fetchPageTitle"
|
||||
res <- liftIO $ NH.httpLbs (buildSimpleRequest url) =<< NH.getGlobalManager
|
||||
let body = LBS.toStrict (responseBody res)
|
||||
pure (decodeHtmlBs <$> parseTitle body)
|
||||
`catch` (\(e :: SomeException) -> do
|
||||
MM.increment "fetchPageTitle.error"
|
||||
-- MM.increment "fetchPageTitle.error"
|
||||
$(logError) $ (pack . show) e
|
||||
pure (Left (show e)))
|
||||
where
|
||||
|
|
|
|||
|
|
@ -6,7 +6,6 @@ import Handler.Common (lookupPagingParams)
|
|||
import qualified Data.Aeson as A
|
||||
import qualified Data.Text as T
|
||||
import Yesod.RssFeed
|
||||
import Text.Blaze.Html (toHtml)
|
||||
import qualified Text.Blaze.Html5 as H
|
||||
|
||||
getNotesR :: UserNameP -> Handler Html
|
||||
|
|
|
|||
|
|
@ -4,7 +4,6 @@ module Handler.User where
|
|||
import qualified Data.Text as T
|
||||
import Handler.Common
|
||||
import Import
|
||||
import Text.Blaze.Html (toHtml)
|
||||
import qualified Text.Blaze.Html5 as H
|
||||
import Yesod.RssFeed
|
||||
import qualified Database.Esqueleto as E
|
||||
|
|
|
|||
22
src/Model.hs
22
src/Model.hs
|
|
@ -3,7 +3,9 @@
|
|||
module Model where
|
||||
|
||||
import qualified ClassyPrelude.Yesod as CP
|
||||
import Control.Monad.Fail (MonadFail)
|
||||
import qualified Data.Aeson as A
|
||||
import qualified Data.Aeson.Types as A (parseFail)
|
||||
import qualified Data.Attoparsec.Text as P
|
||||
import qualified Control.Monad.Combinators as PC
|
||||
import qualified Data.List.NonEmpty as NE
|
||||
|
|
@ -245,7 +247,7 @@ parseSearchQuery toExpr =
|
|||
quotedTerm = PC.between (P.char '"') (P.char '"') (P.takeWhile1 (/= '"'))
|
||||
simpleTerm = P.takeWhile1 (\c -> not (isSpace c) && c /= ':' && c /= '|')
|
||||
|
||||
parseTimeText :: (TI.ParseTime t, Monad m, Alternative m) => Text -> m t
|
||||
parseTimeText :: (TI.ParseTime t, MonadFail m, Alternative m) => Text -> m t
|
||||
parseTimeText t =
|
||||
asum $
|
||||
flip (parseTimeM True defaultTimeLocale) (unpack t) <$>
|
||||
|
|
@ -426,8 +428,8 @@ instance FromJSON TagCloudMode where
|
|||
Just (String "lowerBound") -> TagCloudModeLowerBound <$> o .: "expanded" <*> o .: "value"
|
||||
Just (String "related") -> TagCloudModeRelated <$> o .: "expanded" <*> (fmap words (o .: "value"))
|
||||
Just (String "none") -> pure TagCloudModeNone
|
||||
_ -> fail "bad parse"
|
||||
parseJSON _ = fail "bad parse"
|
||||
_ -> A.parseFail "bad parse"
|
||||
parseJSON _ = A.parseFail "bad parse"
|
||||
|
||||
instance ToJSON TagCloudMode where
|
||||
toJSON (TagCloudModeTop e i) =
|
||||
|
|
@ -635,9 +637,9 @@ upsertBookmark userId mbid bm tags = do
|
|||
get bid >>= \case
|
||||
Just prev_bm -> do
|
||||
when (userId /= bookmarkUserId prev_bm)
|
||||
(fail "unauthorized")
|
||||
(throwString "unauthorized")
|
||||
replaceBookmark bid prev_bm
|
||||
_ -> fail "not found"
|
||||
_ -> throwString "not found"
|
||||
Nothing -> do
|
||||
getBy (UniqueUserHref (bookmarkUserId bm) (bookmarkHref bm)) >>= \case
|
||||
Just (Entity bid prev_bm) -> replaceBookmark bid prev_bm
|
||||
|
|
@ -672,10 +674,10 @@ upsertNote userId mnid note = do
|
|||
get nid >>= \case
|
||||
Just note' -> do
|
||||
when (userId /= (noteUserId note'))
|
||||
(fail "unauthorized")
|
||||
(throwString "unauthorized")
|
||||
replace nid note
|
||||
pure (Updated, nid)
|
||||
_ -> fail "not found"
|
||||
_ -> throwString "not found"
|
||||
Nothing -> do
|
||||
(Created,) <$> insert note
|
||||
|
||||
|
|
@ -702,7 +704,7 @@ instance FromJSON FileBookmark where
|
|||
(o A..:? "selected") <*>
|
||||
(o A..:? "archive_url") <*>
|
||||
(o .: "tags")
|
||||
parseJSON _ = fail "bad parse"
|
||||
parseJSON _ = A.parseFail "bad parse"
|
||||
|
||||
instance ToJSON FileBookmark where
|
||||
toJSON (FileBookmark {..}) =
|
||||
|
|
@ -743,7 +745,7 @@ instance FromJSON FileNote where
|
|||
o .: "length" <*>
|
||||
(readFileNoteTime =<< o .: "created_at") <*>
|
||||
(readFileNoteTime =<< o .: "updated_at")
|
||||
parseJSON _ = fail "bad parse"
|
||||
parseJSON _ = A.parseFail "bad parse"
|
||||
|
||||
instance ToJSON FileNote where
|
||||
toJSON (FileNote {..}) =
|
||||
|
|
@ -757,7 +759,7 @@ instance ToJSON FileNote where
|
|||
]
|
||||
|
||||
readFileNoteTime
|
||||
:: Monad m
|
||||
:: MonadFail m
|
||||
=> String -> m UTCTime
|
||||
readFileNoteTime = parseTimeM True defaultTimeLocale "%F %T"
|
||||
|
||||
|
|
|
|||
|
|
@ -56,10 +56,11 @@ data AppSettings = AppSettings
|
|||
, appAuthDummyLogin :: Bool
|
||||
-- ^ Indicate if auth dummy login should be enabled.
|
||||
|
||||
, appEkgHost :: Maybe Text
|
||||
-- ^ Host/interface the ekg server should bind to.
|
||||
, appEkgPort :: Maybe Int
|
||||
-- ^ Port to listen on
|
||||
-- , appEkgHost :: Maybe Text
|
||||
-- -- ^ Host/interface the ekg server should bind to.
|
||||
-- , appEkgPort :: Maybe Int
|
||||
-- -- ^ Port to listen on
|
||||
|
||||
, appSourceCodeUri :: Maybe Text
|
||||
-- ^ Uri to app source code
|
||||
}
|
||||
|
|
@ -92,8 +93,8 @@ instance FromJSON AppSettings where
|
|||
|
||||
appAuthDummyLogin <- o .:? "auth-dummy-login" .!= dev
|
||||
|
||||
appEkgHost <- o .:? "ekg-host"
|
||||
appEkgPort <- o .:? "ekg-port"
|
||||
-- appEkgHost <- o .:? "ekg-host"
|
||||
-- appEkgPort <- o .:? "ekg-port"
|
||||
appSourceCodeUri <- o .:? "source-code-uri"
|
||||
|
||||
return AppSettings {..}
|
||||
|
|
|
|||
|
|
@ -1,4 +1,4 @@
|
|||
resolver: lts-14.27
|
||||
resolver: nightly-2020-03-29
|
||||
# allow-newer: true
|
||||
packages:
|
||||
- '.'
|
||||
|
|
|
|||
|
|
@ -41,7 +41,7 @@ packages:
|
|||
hackage: yesod-newsfeed-1.7.0.0
|
||||
snapshots:
|
||||
- completed:
|
||||
size: 524996
|
||||
url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/14/27.yaml
|
||||
sha256: 7ea31a280c56bf36ff591a7397cc384d0dff622e7f9e4225b47d8980f019a0f0
|
||||
original: lts-14.27
|
||||
size: 507788
|
||||
url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/nightly/2020/3/29.yaml
|
||||
sha256: f5cfc0452d1dc9d3058dcf389278d1cfb72ebc91b1a9bd48e8dde399c9479999
|
||||
original: nightly-2020-03-29
|
||||
|
|
|
|||
Loading…
Reference in a new issue