diff --git a/README.md b/README.md index 069b02b..88f57a2 100644 --- a/README.md +++ b/README.md @@ -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 diff --git a/config/settings.yml b/config/settings.yml index 40cac81..59eb219 100644 --- a/config/settings.yml +++ b/config/settings.yml @@ -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" diff --git a/docker-compose.yml b/docker-compose.yml index 0d326b9..8c99f2e 100644 --- a/docker-compose.yml +++ b/docker-compose.yml @@ -7,7 +7,7 @@ services: dockerfile: ../Dockerfile ports: - "3000:3000" - - "8000:8000" + # - "8000:8000" volumes: - '$APPDATA:/app/data' environment: diff --git a/espial.cabal b/espial.cabal index 8ca4f7a..b460eb0 100644 --- a/espial.cabal +++ b/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 diff --git a/package.yaml b/package.yaml index 028a89a..bc7993b 100644 --- a/package.yaml +++ b/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 diff --git a/src/Application.hs b/src/Application.hs index 2ed629b..43a735a 100644 --- a/src/Application.hs +++ b/src/Application.hs @@ -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) diff --git a/src/Foundation.hs b/src/Foundation.hs index a5a2a59..0d2d56c 100644 --- a/src/Foundation.hs +++ b/src/Foundation.hs @@ -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 diff --git a/src/Handler/Archive.hs b/src/Handler/Archive.hs index 955ff49..6fd0b0e 100644 --- a/src/Handler/Archive.hs +++ b/src/Handler/Archive.hs @@ -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 diff --git a/src/Handler/Notes.hs b/src/Handler/Notes.hs index 2b4fa00..a34076a 100644 --- a/src/Handler/Notes.hs +++ b/src/Handler/Notes.hs @@ -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 diff --git a/src/Handler/User.hs b/src/Handler/User.hs index 5966616..09c4013 100644 --- a/src/Handler/User.hs +++ b/src/Handler/User.hs @@ -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 diff --git a/src/Model.hs b/src/Model.hs index db096a0..929cd2a 100644 --- a/src/Model.hs +++ b/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" diff --git a/src/Settings.hs b/src/Settings.hs index 7d794a7..5cd4c52 100644 --- a/src/Settings.hs +++ b/src/Settings.hs @@ -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 {..} diff --git a/stack.yaml b/stack.yaml index 11f4019..15ed6c8 100644 --- a/stack.yaml +++ b/stack.yaml @@ -1,4 +1,4 @@ -resolver: lts-14.27 +resolver: nightly-2020-03-29 # allow-newer: true packages: - '.' diff --git a/stack.yaml.lock b/stack.yaml.lock index 60ba1c0..a93266f 100644 --- a/stack.yaml.lock +++ b/stack.yaml.lock @@ -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