Support using echo/not logging to stdout

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

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" ""

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)

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
 

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