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:
parent
2d142b4368
commit
8ff9938d97
5 changed files with 12 additions and 36 deletions
|
@ -47,6 +47,8 @@ import Yesod
|
|||
import Network.Socket (SockAddr, HostName)
|
||||
import Data.Text (pack, unpack)
|
||||
import qualified Network.Wai.Handler.WarpTLS as TLS
|
||||
import Network.Wai.Middleware.RequestLogger
|
||||
import System.Log.Logger
|
||||
|
||||
mkYesodDispatch "WebApp" $(parseRoutesFile "Assistant/WebApp/routes")
|
||||
|
||||
|
@ -83,7 +85,7 @@ webAppThread assistantdata urlrenderer noannex cannotrun postfirstrun listenhost
|
|||
setUrlRenderer urlrenderer $ yesodRender webapp (pack "")
|
||||
app <- toWaiAppPlain webapp
|
||||
app' <- ifM debugEnabled
|
||||
( return $ httpDebugLogger app
|
||||
( return $ logStdout app
|
||||
, return app
|
||||
)
|
||||
runWebApp tlssettings listenhost' app' $ \addr -> if noannex
|
||||
|
@ -135,3 +137,9 @@ getTlsSettings = do
|
|||
#else
|
||||
return Nothing
|
||||
#endif
|
||||
|
||||
{- Checks if debugging is actually enabled. -}
|
||||
debugEnabled :: IO Bool
|
||||
debugEnabled = do
|
||||
l <- getRootLogger
|
||||
return $ getLevel l <= Just DEBUG
|
||||
|
|
|
@ -18,16 +18,12 @@ import qualified Yesod
|
|||
import qualified Network.Wai as Wai
|
||||
import Network.Wai.Handler.Warp
|
||||
import Network.Wai.Handler.WarpTLS
|
||||
import Network.Wai.Logger
|
||||
import Control.Monad.IO.Class
|
||||
import Network.HTTP.Types
|
||||
import System.Log.Logger
|
||||
import qualified Data.CaseInsensitive as CI
|
||||
import Network.Socket
|
||||
import "crypto-api" Crypto.Random
|
||||
import qualified Web.ClientSession as CS
|
||||
import qualified Data.ByteString.Lazy as L
|
||||
import qualified Data.ByteString.Lazy.UTF8 as L8
|
||||
import qualified Data.ByteString as B
|
||||
import qualified Data.Text as T
|
||||
import qualified Data.Text.Encoding as TE
|
||||
|
@ -158,35 +154,6 @@ getSocket h = do
|
|||
listen sock maxListenQueue
|
||||
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 k req = fromMaybe "" . lookup k $ Wai.requestHeaders req
|
||||
|
||||
|
|
1
debian/changelog
vendored
1
debian/changelog
vendored
|
@ -6,6 +6,7 @@ git-annex (5.20140607) UNRELEASED; urgency=medium
|
|||
* Avoid bad commits after interrupted direct mode sync (or merge).
|
||||
* Windows: Fix opening webapp when repository is in a directory with
|
||||
spaces in the path.
|
||||
* Fix build with wai 0.3.0.
|
||||
|
||||
-- Joey Hess <joeyh@debian.org> Mon, 09 Jun 2014 14:44:09 -0400
|
||||
|
||||
|
|
2
debian/control
vendored
2
debian/control
vendored
|
@ -40,7 +40,7 @@ Build-Depends:
|
|||
libghc-warp-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-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-byteable-dev,
|
||||
libghc-dns-dev,
|
||||
|
|
|
@ -189,7 +189,7 @@ Executable git-annex
|
|||
if flag(Webapp)
|
||||
Build-Depends:
|
||||
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,
|
||||
template-haskell, data-default, aeson, network-conduit,
|
||||
shakespeare
|
||||
|
|
Loading…
Reference in a new issue