use fast-logger for better logging

3 files changed, 72 insertions, 41 deletions

diff --git a/HTTP/Logger.hs b/HTTP/Logger.hs
new file mode 100644
index 0000000..2758c37
--- /dev/null
+++ b/HTTP/Logger.hs
@@ -0,0 +1,25 @@
+{- Copyright 2016 Joey Hess <id@joeyh.name>
+ -
+ - Licensed under the GNU AGPL version 3 or higher.
+ -}
+
+module HTTP.Logger where
+
+import System.Log.FastLogger
+import Data.String
+
+data Logger = Logger LoggerSet LoggerSet
+
+newLogger :: IO Logger
+newLogger = Logger
+	<$> newStdoutLoggerSet defaultBufSize
+	<*> newStderrLoggerSet defaultBufSize
+
+logStdout :: Logger -> String -> IO ()
+logStdout (Logger l _) = sendLogger l
+
+logStderr :: Logger -> String -> IO ()
+logStderr (Logger _ l) = sendLogger l
+
+sendLogger :: LoggerSet -> String -> IO ()
+sendLogger l s = pushLogStrLn l (fromString s)
diff --git a/HTTP/RateLimit.hs b/HTTP/RateLimit.hs
index d9ec752..e09da6e 100644
--- a/HTTP/RateLimit.hs
+++ b/HTTP/RateLimit.hs
@@ -8,6 +8,7 @@ module HTTP.RateLimit where
 import Types.Cost
 import HTTP
 import HTTP.ProofOfWork
+import HTTP.Logger
 import Tunables
 import CmdLine (ServerConfig(..))
 import Types.Storage
@@ -23,7 +24,6 @@ import Data.BloomFilter.Easy (suggestSizing)
 import Control.Monad
 import Control.Monad.ST
 import Control.Exception.Lifted (bracket)
-import System.IO
 import System.DiskSpace
 import Data.Maybe
 import Data.Word
@@ -69,8 +69,8 @@ minFillInterval = 2 * 60 * 1000000 -- 1 token every other minute
 burstSize :: Word64
 burstSize = 4 -- 256 kb immediate storage
 
-newRateLimiter :: ServerConfig -> Maybe LocalStorageDirectory -> IO RateLimiter
-newRateLimiter cfg storedir = do
+newRateLimiter :: ServerConfig -> Maybe LocalStorageDirectory -> Logger -> IO RateLimiter
+newRateLimiter cfg storedir logger = do
 	rl <- RateLimiter 
 		<$> (newTMVarIO =<< mkbuckets (sdiv maxProofOfWork 2) [])
 		<*> newTMVarIO []
@@ -82,7 +82,7 @@ newRateLimiter cfg storedir = do
 		<*> newTokenBucket
 		<*> newTMVarIO []
 		<*> newTMVarIO 0
-	_ <- forkIO (adjusterThread cfg storedir rl)
+	_ <- forkIO (adjusterThread cfg storedir rl logger)
 	return rl
   where
 	-- The last bucket takes half of maxProofOfWork to access, and
@@ -127,23 +127,23 @@ bloomMaxSize = 1000000
 
 -- A request is tried in each bucket in turn which its proof of work allows
 -- access to, until one is found that accepts it.
-rateLimit :: POWIdent p => RateLimiter -> Maybe ProofOfWork -> p -> Handler a -> Handler (POWGuarded a)
-rateLimit ratelimiter mpow p a = do
+rateLimit :: POWIdent p => RateLimiter -> Logger -> Maybe ProofOfWork -> p -> Handler a -> Handler (POWGuarded a)
+rateLimit ratelimiter logger mpow p a = do
 	validsalt <- liftIO $ checkValidSalt ratelimiter mpow
 	bs <- getBuckets ratelimiter
 	if validsalt
 		then go bs
-		else assignWork ratelimiter bs
+		else assignWork ratelimiter logger bs
   where
-	go [] = allBucketsEmpty ratelimiter a
+	go [] = allBucketsEmpty ratelimiter logger a
 	go (b:bs) = case mkProofOfWorkRequirement (proofOfWorkRequired b) of
 		Nothing -> checkbucket b bs
 		Just mkreq -> case mpow of
-			Nothing -> assignWork ratelimiter (b:bs)
+			Nothing -> assignWork ratelimiter logger (b:bs)
 			Just pow@(ProofOfWork _ salt) -> 
 				if isValidProofOfWork pow (mkreq salt) p
 					then checkbucket b bs
-					else assignWork ratelimiter (b:bs)
+					else assignWork ratelimiter logger (b:bs)
 	checkbucket b bs = do
 		allowed <- liftIO $ tokenBucketTryAlloc (tokenBucket b) 
 			burstSize (fillInterval b) 1
@@ -167,8 +167,8 @@ checkValidSalt rl (Just (ProofOfWork _ salt)) = do
   where
 	iselem f = withBloomFilter rl f (BloomFilter.elem salt)
 
-assignWork :: RateLimiter -> [Bucket] -> Handler (POWGuarded a)
-assignWork ratelimiter bs = case mapMaybe (mkProofOfWorkRequirement . proofOfWorkRequired) bs of
+assignWork :: RateLimiter -> Logger -> [Bucket] -> Handler (POWGuarded a)
+assignWork ratelimiter logger bs = case mapMaybe (mkProofOfWorkRequirement . proofOfWorkRequired) bs of
 	[] -> throwError err404
 	(mkreq:_) -> liftIO $ do
 		-- This prevents an attacker flooding requests that 
@@ -198,7 +198,7 @@ assignWork ratelimiter bs = case mapMaybe (mkProofOfWorkRequirement . proofOfWor
   where
 	handlerotation Nothing = return ()
 	handlerotation (Just n) = do
-		hPutStrLn stderr $ "rotating bloom filters after processing " ++ show n ++ " requests"
+		logStderr logger $ "rotating bloom filters after processing " ++ show n ++ " requests"
 		newassigned <- mkBloomFilter
 		newused <- mkBloomFilter
 		atomically $ do
@@ -234,8 +234,9 @@ putBuckets rl bs = liftIO $ atomically $ do
 -- Only 100 requests are allowed to block this way at a time, since the
 -- requests are taking up server memory while blocked, and because we don't
 -- want to stall legitimate clients too long.
-allBucketsEmpty :: RateLimiter -> Handler a -> Handler (POWGuarded a)
-allBucketsEmpty ratelimiter a = bracket (liftIO addq) (liftIO . removeq) go
+allBucketsEmpty :: RateLimiter -> Logger -> Handler a -> Handler (POWGuarded a)
+allBucketsEmpty ratelimiter logger a = 
+	bracket (liftIO addq) (liftIO . removeq) go
   where
 	q = blockedRequestQueue ratelimiter
 
@@ -258,7 +259,7 @@ allBucketsEmpty ratelimiter a = bracket (liftIO addq) (liftIO . removeq) go
 		bs <- getBuckets ratelimiter
 		case reverse bs of
 			(lastb:_) -> do
-				hPutStrLn stderr "** warning: All token buckets are empty. Delaying request.."
+				logStderr logger "** warning: All token buckets are empty. Delaying request.."
 				tokenBucketWait (tokenBucket lastb) burstSize (fillInterval lastb)
 				return True
 			[] -> return False
@@ -271,8 +272,8 @@ allBucketsEmpty ratelimiter a = bracket (liftIO addq) (liftIO . removeq) go
 			else giveup
 	
 	giveup = do
-		liftIO $ hPutStrLn stderr "** warning: All token buckets are empty and request queue is large; possible DOS attack? Rejected request.."
-		assignWork ratelimiter =<< getBuckets ratelimiter
+		liftIO $ logStderr logger "** warning: All token buckets are empty and request queue is large; possible DOS attack? Rejected request.."
+		assignWork ratelimiter logger =<< getBuckets ratelimiter
 
 -- | How much data could be stored, in bytes per second, assuming all
 -- buckets in the rate limiter being constantly drained by requests,
@@ -306,8 +307,8 @@ instance Show Bucket where
 	show b = show (fillInterval b `div` (60 * 1000000)) ++ " Second/Request"
 		++ " (PoW=" ++ show (proofOfWorkRequired b) ++ ")"
 
-increaseDifficulty :: RateLimiter -> IO ()
-increaseDifficulty ratelimiter = do
+increaseDifficulty :: Logger -> RateLimiter -> IO ()
+increaseDifficulty logger ratelimiter = do
 	bs <- getBuckets ratelimiter
 	case bs of
 		[] -> unable
@@ -329,14 +330,14 @@ increaseDifficulty ratelimiter = do
 			putBuckets ratelimiter rest
 			done
   where
-	unable = putStrLn "Unable to increase difficulty any further!"
+	unable = logStderr logger "Unable to increase difficulty any further!"
 	done = do
 		desc <- describeRateLimiter ratelimiter
-		putStrLn $ "increased difficulty -- " ++ desc
+		logStdout logger $ "increased difficulty -- " ++ desc
 
 -- Should undo the effect of increaseDifficulty.
-reduceDifficulty :: RateLimiter -> IO ()
-reduceDifficulty ratelimiter = do
+reduceDifficulty :: Logger -> RateLimiter -> IO ()
+reduceDifficulty logger ratelimiter = do
 	bs <- getBuckets ratelimiter
 	case bs of
 		(b:[]) | fillInterval b > minFillInterval -> do
@@ -363,7 +364,7 @@ reduceDifficulty ratelimiter = do
 	unable = return ()
 	done = do
 		desc <- describeRateLimiter ratelimiter
-		putStrLn $ "reduced difficulty -- " ++ desc
+		logStdout logger $ "reduced difficulty -- " ++ desc
 
 allowRequest :: RateLimiter -> Handler a -> Handler (POWGuarded a)
 allowRequest ratelimiter a = do
@@ -380,15 +381,15 @@ addRequest ratelimiter n = liftIO $ atomically $ do
 -- Thread that wakes up periodically and checks the request rate
 -- against the available disk space. If the disk is filling too quickly,
 -- the difficulty is increased.
-adjusterThread :: ServerConfig -> Maybe LocalStorageDirectory -> RateLimiter -> IO ()
-adjusterThread cfg storedir ratelimiter = forever $ do
+adjusterThread :: ServerConfig -> Maybe LocalStorageDirectory -> RateLimiter -> Logger -> IO ()
+adjusterThread cfg storedir ratelimiter logger = forever $ do
 	delay (1000000 * intervalsecs)
-	checkRequestRate cfg storedir ratelimiter intervalsecs
+	checkRequestRate cfg storedir ratelimiter logger intervalsecs
   where
 	intervalsecs = 60*60
 
-checkRequestRate :: ServerConfig -> Maybe LocalStorageDirectory -> RateLimiter -> Integer -> IO ()
-checkRequestRate cfg storedir ratelimiter intervalsecs = do
+checkRequestRate :: ServerConfig -> Maybe LocalStorageDirectory -> RateLimiter -> Logger -> Integer -> IO ()
+checkRequestRate cfg storedir ratelimiter logger intervalsecs = do
 	let storesize = maximum knownObjectSizes
 	n <- liftIO $ atomically $ swapTMVar (requestCounter ratelimiter) 0
 	let maxstoredinterval = n * fromIntegral storesize
@@ -398,7 +399,7 @@ checkRequestRate cfg storedir ratelimiter intervalsecs = do
 	let estimate = if maxstoredthismonth <= 0 
 		then 10000
 		else freespace `div` maxstoredthismonth `div` 2
-	putStrLn $ unlines
+	logStdout logger $ unlines
 		[ "rate limit check"
 		, "  free disk space:" ++ showBytes freespace
 		, "  number of requests since last check: " ++ show n
@@ -406,7 +407,7 @@ checkRequestRate cfg storedir ratelimiter intervalsecs = do
 		, "  estimate min " ++ show estimate ++ " months to fill half of disk"
 		]
 	if estimate > target * 2
-		then reduceDifficulty ratelimiter
+		then reduceDifficulty logger ratelimiter
 		else if estimate < target
-			then increaseDifficulty ratelimiter
+			then increaseDifficulty logger ratelimiter
 			else return ()
diff --git a/HTTP/Server.hs b/HTTP/Server.hs
index aab3dab..e2165eb 100644
--- a/HTTP/Server.hs
+++ b/HTTP/Server.hs
@@ -10,6 +10,7 @@ module HTTP.Server (runServer) where
 import HTTP
 import HTTP.ProofOfWork
 import HTTP.RateLimit
+import HTTP.Logger
 import Types
 import Types.Storage
 import Tunables
@@ -30,13 +31,17 @@ data ServerState = ServerState
 	{ obscurerRequest :: TMVar ()
 	, storageDirectory :: Maybe LocalStorageDirectory
 	, rateLimiter :: RateLimiter
+	, logger :: Logger
 	}
 
 newServerState :: Maybe LocalStorageDirectory -> ServerConfig -> IO ServerState
-newServerState d cfg = ServerState
-	<$> newEmptyTMVarIO
-	<*> pure d
-	<*> newRateLimiter cfg d
+newServerState d cfg = do
+	l <- newLogger
+	ServerState
+		<$> newEmptyTMVarIO
+		<*> pure d
+		<*> newRateLimiter cfg d l
+		<*> pure l
 
 runServer :: Maybe LocalStorageDirectory -> ServerConfig -> IO ()
 runServer d cfg = do
@@ -66,7 +71,7 @@ motd :: Handler Motd
 motd = return $ Motd "Hello World!"
 
 getObject :: ServerState -> StorableObjectIdent -> Maybe ProofOfWork -> Handler (POWGuarded StorableObject)
-getObject st i pow = rateLimit (rateLimiter st) pow i $ do
+getObject st i pow = rateLimit (rateLimiter st) (logger st) pow i $ do
 	r <- liftIO $ retrieveShare (serverStorage st) dummyShareNum i
 	liftIO $ requestObscure st
 	case r of
@@ -74,7 +79,7 @@ getObject st i pow = rateLimit (rateLimiter st) pow i $ do
 		RetrieveFailure _ -> throwError err404
 
 putObject :: ServerState -> StorableObjectIdent -> Maybe ProofOfWork -> StorableObject -> Handler (POWGuarded StoreResult)
-putObject st i pow o = rateLimit (rateLimiter st) pow i $ do
+putObject st i pow o = rateLimit (rateLimiter st) (logger st) pow i $ do
 	if validObjectsize o
 		then do
 			r <- liftIO $ storeShare (serverStorage st) i (Share dummyShareNum o)
@@ -88,7 +93,7 @@ validObjectsize o = any (sz ==) knownObjectSizes
 	sz = B.length (fromStorableObject o)
 
 countObjects :: ServerState -> Maybe ProofOfWork -> Handler (POWGuarded CountResult)
-countObjects st pow = rateLimit (rateLimiter st) pow NoPOWIdent $
+countObjects st pow = rateLimit (rateLimiter st) (logger st) pow NoPOWIdent $
 	liftIO $ countShares $ serverStorage st
 
 -- | 1 is a dummy value; the server does not know the actual share numbers.
@@ -101,7 +106,7 @@ dummyShareNum = 1
 obscurerThread :: ServerState -> IO ()
 obscurerThread st = do
 	_ <- obscureShares (serverStorage st)
-	putStrLn "obscured shares"
+	logStdout (logger st) "obscured shares"
 	delay (1000000*60*30)
 	_ <- atomically $ takeTMVar (obscurerRequest st)
 	obscurerThread st