Browse Source

Support using echo/not logging to stdout

tags/dead/2015-03-18-new-upload
Chris Done 8 years ago
parent
commit
faf401e1a5
  1. 110
      Application.hs
  2. 46
      Echo.hs
  3. 11
      app/main.hs
  4. 2
      devel.hs
  5. 4
      stackage-server.cabal

110
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

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

11
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)

2
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

4
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

Loading…
Cancel
Save