Fix build with wai 0.3.0.

This version of wai changed the type of Middleware, so I cannot seem
to liftIO inside it. So, got rid of a lot of not really needed
complexity to use System.Log.Logger's logging stuff, and just use
the standard wai stdout logger when debug logging is enabled.

Format may change some, and it logs http to stdout instead of stderr
now. Doesn't matter for the webapp since both go to the same log anyway.
This commit is contained in:
Joey Hess 2014-06-11 01:29:00 -04:00
parent 2d142b4368
commit 8ff9938d97
5 changed files with 12 additions and 36 deletions

View file

@ -47,6 +47,8 @@ import Yesod
import Network.Socket (SockAddr, HostName) import Network.Socket (SockAddr, HostName)
import Data.Text (pack, unpack) import Data.Text (pack, unpack)
import qualified Network.Wai.Handler.WarpTLS as TLS import qualified Network.Wai.Handler.WarpTLS as TLS
import Network.Wai.Middleware.RequestLogger
import System.Log.Logger
mkYesodDispatch "WebApp" $(parseRoutesFile "Assistant/WebApp/routes") mkYesodDispatch "WebApp" $(parseRoutesFile "Assistant/WebApp/routes")
@ -83,7 +85,7 @@ webAppThread assistantdata urlrenderer noannex cannotrun postfirstrun listenhost
setUrlRenderer urlrenderer $ yesodRender webapp (pack "") setUrlRenderer urlrenderer $ yesodRender webapp (pack "")
app <- toWaiAppPlain webapp app <- toWaiAppPlain webapp
app' <- ifM debugEnabled app' <- ifM debugEnabled
( return $ httpDebugLogger app ( return $ logStdout app
, return app , return app
) )
runWebApp tlssettings listenhost' app' $ \addr -> if noannex runWebApp tlssettings listenhost' app' $ \addr -> if noannex
@ -135,3 +137,9 @@ getTlsSettings = do
#else #else
return Nothing return Nothing
#endif #endif
{- Checks if debugging is actually enabled. -}
debugEnabled :: IO Bool
debugEnabled = do
l <- getRootLogger
return $ getLevel l <= Just DEBUG

View file

@ -18,16 +18,12 @@ import qualified Yesod
import qualified Network.Wai as Wai import qualified Network.Wai as Wai
import Network.Wai.Handler.Warp import Network.Wai.Handler.Warp
import Network.Wai.Handler.WarpTLS import Network.Wai.Handler.WarpTLS
import Network.Wai.Logger
import Control.Monad.IO.Class
import Network.HTTP.Types import Network.HTTP.Types
import System.Log.Logger
import qualified Data.CaseInsensitive as CI import qualified Data.CaseInsensitive as CI
import Network.Socket import Network.Socket
import "crypto-api" Crypto.Random import "crypto-api" Crypto.Random
import qualified Web.ClientSession as CS import qualified Web.ClientSession as CS
import qualified Data.ByteString.Lazy as L import qualified Data.ByteString.Lazy as L
import qualified Data.ByteString.Lazy.UTF8 as L8
import qualified Data.ByteString as B import qualified Data.ByteString as B
import qualified Data.Text as T import qualified Data.Text as T
import qualified Data.Text.Encoding as TE import qualified Data.Text.Encoding as TE
@ -158,35 +154,6 @@ getSocket h = do
listen sock maxListenQueue listen sock maxListenQueue
return sock return sock
{- Checks if debugging is actually enabled. -}
debugEnabled :: IO Bool
debugEnabled = do
l <- getRootLogger
return $ getLevel l <= Just DEBUG
{- WAI middleware that logs using System.Log.Logger at debug level.
-
- Recommend only inserting this middleware when debugging is actually
- enabled, as it's not optimised at all.
-}
httpDebugLogger :: Wai.Middleware
httpDebugLogger waiApp req = do
logRequest req
waiApp req
logRequest :: MonadIO m => Wai.Request -> m ()
logRequest req = do
liftIO $ debugM "WebApp" $ unwords
[ showSockAddr $ Wai.remoteHost req
, frombs $ Wai.requestMethod req
, frombs $ Wai.rawPathInfo req
--, show $ Wai.httpVersion req
--, frombs $ lookupRequestField "referer" req
, frombs $ lookupRequestField "user-agent" req
]
where
frombs v = L8.toString $ L.fromChunks [v]
lookupRequestField :: CI.CI B.ByteString -> Wai.Request -> B.ByteString lookupRequestField :: CI.CI B.ByteString -> Wai.Request -> B.ByteString
lookupRequestField k req = fromMaybe "" . lookup k $ Wai.requestHeaders req lookupRequestField k req = fromMaybe "" . lookup k $ Wai.requestHeaders req

1
debian/changelog vendored
View file

@ -6,6 +6,7 @@ git-annex (5.20140607) UNRELEASED; urgency=medium
* Avoid bad commits after interrupted direct mode sync (or merge). * Avoid bad commits after interrupted direct mode sync (or merge).
* Windows: Fix opening webapp when repository is in a directory with * Windows: Fix opening webapp when repository is in a directory with
spaces in the path. spaces in the path.
* Fix build with wai 0.3.0.
-- Joey Hess <joeyh@debian.org> Mon, 09 Jun 2014 14:44:09 -0400 -- Joey Hess <joeyh@debian.org> Mon, 09 Jun 2014 14:44:09 -0400

2
debian/control vendored
View file

@ -40,7 +40,7 @@ Build-Depends:
libghc-warp-dev [i386 amd64 kfreebsd-i386 kfreebsd-amd64 powerpc sparc], libghc-warp-dev [i386 amd64 kfreebsd-i386 kfreebsd-amd64 powerpc sparc],
libghc-warp-tls-dev [i386 amd64 kfreebsd-i386 kfreebsd-amd64 powerpc sparc], libghc-warp-tls-dev [i386 amd64 kfreebsd-i386 kfreebsd-amd64 powerpc sparc],
libghc-wai-dev [i386 amd64 kfreebsd-i386 kfreebsd-amd64 powerpc sparc], libghc-wai-dev [i386 amd64 kfreebsd-i386 kfreebsd-amd64 powerpc sparc],
libghc-wai-logger-dev [i386 amd64 kfreebsd-i386 kfreebsd-amd64 powerpc sparc], libghc-wai-extra-dev [i386 amd64 kfreebsd-i386 kfreebsd-amd64 powerpc sparc],
libghc-securemem-dev, libghc-securemem-dev,
libghc-byteable-dev, libghc-byteable-dev,
libghc-dns-dev, libghc-dns-dev,

View file

@ -189,7 +189,7 @@ Executable git-annex
if flag(Webapp) if flag(Webapp)
Build-Depends: Build-Depends:
yesod, yesod-default, yesod-static, yesod-form, yesod-core, yesod, yesod-default, yesod-static, yesod-form, yesod-core,
http-types, transformers, wai, wai-logger, warp, warp-tls, http-types, transformers, wai, wai-extra, warp, warp-tls,
blaze-builder, crypto-api, hamlet, clientsession, blaze-builder, crypto-api, hamlet, clientsession,
template-haskell, data-default, aeson, network-conduit, template-haskell, data-default, aeson, network-conduit,
shakespeare shakespeare