From faf401e1a51bf30a1320699b22662704249d1869 Mon Sep 17 00:00:00 2001 From: Chris Done Date: Sun, 1 Jun 2014 11:58:34 +0200 Subject: [PATCH] Support using echo/not logging to stdout --- Application.hs | 110 ++++++++++++++++++++++++------------------ Echo.hs | 46 ++++++++++++++++++ app/main.hs | 11 +++-- devel.hs | 2 +- stackage-server.cabal | 4 +- 5 files changed, 119 insertions(+), 54 deletions(-) create mode 100644 Echo.hs diff --git a/Application.hs b/Application.hs index a4fc4e2..c73e8f8 100644 --- a/Application.hs +++ b/Application.hs @@ -5,49 +5,53 @@ module Application , makeFoundation ) where -import Import hiding (catch) -import Settings -import Yesod.Default.Config -import Yesod.Default.Main -import Yesod.Default.Handlers -import Network.Wai.Middleware.RequestLogger +import qualified Aws +import Control.Concurrent (forkIO, threadDelay) +import Control.Monad.Logger (runLoggingT, LoggingT) +import Control.Monad.Reader (MonadReader (..)) +import Control.Monad.Reader (runReaderT, ReaderT) +import Control.Monad.Trans.Control +import Data.BlobStore (fileStore, storeWrite, cachedS3Store) +import Data.Conduit.Lazy (MonadActive, monadActive) +import Data.Hackage +import Data.Hackage.Views + +import Data.Time (diffUTCTime) +import qualified Database.Persist +import Filesystem (getModified, removeTree) +import Import hiding (catch) +import Language.Haskell.TH.Syntax (Loc(..)) +import Network.Wai.Logger (clockDateCacher) +import Network.Wai.Middleware.RequestLogger ( mkRequestLogger, outputFormat, OutputFormat (..), IPAddrSource (..), destination ) import qualified Network.Wai.Middleware.RequestLogger as RequestLogger -import qualified Database.Persist -import Control.Monad.Logger (runLoggingT, LoggingT) -import Control.Monad.Reader (runReaderT, ReaderT) -import Control.Monad.Trans.Control -import Control.Concurrent (forkIO, threadDelay) -import System.Log.FastLogger (newStdoutLoggerSet, defaultBufSize, flushLogStr) -import Network.Wai.Logger (clockDateCacher) -import Yesod.Core.Types (loggerSet, Logger (Logger)) +import Settings +import System.Log.FastLogger (newStdoutLoggerSet, newFileLoggerSet, defaultBufSize, flushLogStr, fromLogStr) import qualified System.Random.MWC as MWC -import Data.BlobStore (fileStore, storeWrite, cachedS3Store) -import Data.Hackage -import Data.Hackage.Views -import Data.Conduit.Lazy (MonadActive, monadActive) -import Control.Monad.Reader (MonadReader (..)) -import Filesystem (getModified, removeTree) -import Data.Time (diffUTCTime) -import qualified Aws +import Yesod.Core.Types (loggerSet, Logger (Logger)) +import Yesod.Default.Config +import Yesod.Default.Handlers +import Yesod.Default.Main + +import qualified Echo -- Import all relevant handler modules here. -- Don't forget to add new modules to your cabal file! -import Handler.Home -import Handler.Profile -import Handler.Email -import Handler.ResetToken -import Handler.UploadStackage -import Handler.StackageHome -import Handler.StackageIndex -import Handler.StackageSdist -import Handler.HackageViewIndex -import Handler.HackageViewSdist -import Handler.Aliases -import Handler.Alias -import Handler.Progress -import Handler.System +import Handler.Home +import Handler.Profile +import Handler.Email +import Handler.ResetToken +import Handler.UploadStackage +import Handler.StackageHome +import Handler.StackageIndex +import Handler.StackageSdist +import Handler.HackageViewIndex +import Handler.HackageViewSdist +import Handler.Aliases +import Handler.Alias +import Handler.Progress +import Handler.System -- This line actually creates our YesodDispatch instance. It is the second half -- of the call to mkYesodData which occurs in Foundation.hs. Please see the @@ -58,10 +62,21 @@ mkYesodDispatch "App" resourcesApp -- performs initialization and creates a WAI application. This is also the -- place to put your migrate statements to have automatic database -- migrations handled by Yesod. -makeApplication :: AppConfig DefaultEnv Extra -> IO (Application, LogFunc) -makeApplication conf = do - foundation <- makeFoundation conf - +makeApplication :: Bool -- ^ Use Echo. + -> AppConfig DefaultEnv Extra -> IO (Application, LogFunc) +makeApplication echo@True conf = do + foundation <- makeFoundation echo conf + app <- toWaiAppPlain foundation + logWare <- mkRequestLogger def + { destination = RequestLogger.Callback (const (return ())) + } + Echo.clear + return (logWare (defaultMiddlewaresNoLogging app),logFunc) + where logFunc (Loc filename _pkg _mod (line,_) _) source level str = + Echo.write (filename,line) (show source ++ ": " ++ show level ++ ": " ++ toStr str) + toStr = unpack . decodeUtf8 . fromLogStr +makeApplication echo@False conf = do + foundation <- makeFoundation echo conf -- Initialize the logging middleware logWare <- mkRequestLogger def { outputFormat = @@ -70,7 +85,6 @@ makeApplication conf = do else Apache FromSocket , destination = RequestLogger.Logger $ loggerSet $ appLogger foundation } - -- Create the WAI application and apply middlewares app <- toWaiAppPlain foundation let logFunc = messageLoggerSource foundation (appLogger foundation) @@ -79,8 +93,8 @@ makeApplication conf = do -- | Loads up any necessary settings, creates your foundation datatype, and -- performs some initialization. -makeFoundation :: AppConfig DefaultEnv Extra -> IO App -makeFoundation conf = do +makeFoundation :: Bool -> AppConfig DefaultEnv Extra -> IO App +makeFoundation useEcho conf = do manager <- newManager s <- staticSite dbconf <- withYamlEnvironment "config/postgresql.yml" (appEnv conf) @@ -88,7 +102,9 @@ makeFoundation conf = do Database.Persist.applyEnv p <- Database.Persist.createPoolConfig (dbconf :: Settings.PersistConf) - loggerSet' <- newStdoutLoggerSet defaultBufSize + loggerSet' <- if useEcho + then newFileLoggerSet defaultBufSize "/dev/null" + else newStdoutLoggerSet defaultBufSize (getter, updater) <- clockDateCacher -- If the Yesod logger (as opposed to the request logger middleware) is @@ -197,9 +213,9 @@ instance MonadReader env m => MonadReader env (SqlPersistT m) where restoreT (return stT) -- for yesod devel -getApplicationDev :: IO (Int, Application) -getApplicationDev = - defaultDevelApp loader (fmap fst . makeApplication) +getApplicationDev :: Bool -> IO (Int, Application) +getApplicationDev useEcho = + defaultDevelApp loader (fmap fst . makeApplication useEcho) where loader = Yesod.Default.Config.loadConfig (configSettings Development) { csParseExtra = parseExtra diff --git a/Echo.hs b/Echo.hs new file mode 100644 index 0000000..b12a3a0 --- /dev/null +++ b/Echo.hs @@ -0,0 +1,46 @@ +-- | A quick and dirty way to echo a printf-style debugging message to +-- a file from anywhere. +-- +-- To use from Emacs, run `tail -f /tmp/echo` with M-x grep. You can +-- rename the buffer to *echo* or something. The grep-mode buffer has +-- handy up/down keybindings that will open the file location for you +-- and it supports results coming in live. So it's a perfect way to +-- browse printf-style debugging logs. + +module Echo where + +import Control.Concurrent.MVar +import Control.Monad.Trans (MonadIO(..)) +import System.Locale +import Data.Time +import Language.Haskell.TH +import Language.Haskell.TH.Lift +import Prelude +import System.IO.Unsafe + +-- | God forgive me for my sins. +echoV :: MVar () +echoV = unsafePerformIO (newMVar ()) +{-# NOINLINE echoV #-} + +-- | Echo something. +echo :: Q Exp +echo = [|write $(location >>= liftLoc) |] + +-- | Grab the filename and line/col. +liftLoc :: Loc -> Q Exp +liftLoc (Loc filename _pkg _mod (line, _) _) = + [|($(lift filename) + ,$(lift line))|] + +-- | Thread-safely (probably) write to the log. +write :: (MonadIO m) => (FilePath,Int) -> String -> m () +write (file,line) it = + liftIO (withMVar echoV (const (loggit))) + where loggit = + do now <- getCurrentTime + appendFile "/tmp/echo" (loc ++ ": " ++ fmt now ++ " " ++ it ++ "\n") + loc = file ++ ":" ++ show line + fmt = formatTime defaultTimeLocale "%T%Q" + +clear = writeFile "/tmp/echo" "" diff --git a/app/main.hs b/app/main.hs index 7c6327f..35cc468 100644 --- a/app/main.hs +++ b/app/main.hs @@ -1,8 +1,9 @@ -import Prelude (IO) +import Application (makeApplication) +import Prelude (IO) +import Prelude (Bool(..)) +import Settings (parseExtra) import Yesod.Default.Config (fromArgs) -import Yesod.Default.Main (defaultMainLog) -import Settings (parseExtra) -import Application (makeApplication) +import Yesod.Default.Main (defaultMainLog) main :: IO () -main = defaultMainLog (fromArgs parseExtra) makeApplication +main = defaultMainLog (fromArgs parseExtra) (makeApplication False) diff --git a/devel.hs b/devel.hs index a219de0..9caae55 100644 --- a/devel.hs +++ b/devel.hs @@ -10,7 +10,7 @@ import Control.Concurrent (threadDelay) main :: IO () main = do putStrLn "Starting devel application" - (port, app) <- getApplicationDev + (port, app) <- getApplicationDev False forkIO $ runSettings (setPort port defaultSettings) app loop diff --git a/stackage-server.cabal b/stackage-server.cabal index ff649f6..fafe7a6 100644 --- a/stackage-server.cabal +++ b/stackage-server.cabal @@ -67,7 +67,9 @@ library StandaloneDeriving UndecidableInstances - build-depends: base >= 4 && < 5 + build-depends: old-locale >= 1.0.0.5, + th-lift >= 0.6.1, + base >= 4 && < 5 , yesod >= 1.2.5 && < 1.3 , yesod-core >= 1.2.12 && < 1.3 , yesod-auth >= 1.3 && < 1.4