LogFile

.gitignore

@@ -10,3 +10,4 @@ temp/
 *.keter
 test/app
 incoming/foo/hello
+log/

Keter/LogFile.hs

@@ -0,0 +1,75 @@
+{-# LANGUAGE NoImplicitPrelude #-}
+{-# LANGUAGE OverloadedStrings #-}
+module Keter.LogFile
+    ( LogFile
+    , start
+    , addChunk
+    , close
+    ) where
+
+import Keter.Prelude
+import qualified Data.ByteString as S
+import Data.Time (getCurrentTime)
+import qualified System.IO as SIO
+import qualified Filesystem as F
+import qualified Data.Text as T
+
+data Command = AddChunk S.ByteString
+             | Close
+
+newtype LogFile = LogFile (Command -> KIO ())
+
+addChunk :: LogFile -> S.ByteString -> KIO ()
+addChunk (LogFile f) bs = f $ AddChunk bs
+
+close :: LogFile -> KIO ()
+close (LogFile f) = f Close
+
+start :: FilePath -- ^ folder to contain logs
+      -> KIO (Either SomeException LogFile)
+start dir = do
+    res <- liftIO $ do
+        createTree dir
+        moveCurrent Nothing
+    case res of
+        Left e -> return $ Left e
+        Right handle -> do
+            chan <- newChan
+            forkKIO $ loop chan handle 0
+            return $ Right $ LogFile $ writeChan chan
+  where
+    current = dir </> "current.log"
+    moveCurrent mhandle = do
+        maybe (return ()) SIO.hClose mhandle
+        x <- isFile current
+        when x $ do
+            now <- getCurrentTime
+            rename current $ dir </> suffix now
+        F.openFile current F.WriteMode
+    suffix now = fromText (T.replace " " "_" $ T.takeWhile (/= '.') $ show now) <.> "log"
+    loop chan handle total = do
+        c <- readChan chan
+        case c of
+            AddChunk bs -> do
+                let total' = total + S.length bs
+                res <- liftIO $ S.hPut handle bs >> SIO.hFlush handle
+                either (log . ExceptionThrown) return res
+                if total' > maxTotal
+                    then do
+                        res2 <- liftIO $ moveCurrent $ Just handle
+                        case res2 of
+                            Left e -> do
+                                log $ ExceptionThrown e
+                                deadLoop chan
+                            Right handle' -> loop chan handle' 0
+                    else loop chan handle total'
+            Close ->
+                liftIO (SIO.hClose handle) >>=
+                    either (log . ExceptionThrown) return
+    deadLoop chan = do
+        c <- readChan chan
+        case c of
+            AddChunk _ -> deadLoop chan
+            Close -> return ()
+
+    maxTotal = 5 * 1024 * 1024 -- 5 MB

Keter/Main.hs

@@ -9,6 +9,7 @@ import qualified Keter.Nginx as Nginx
 import qualified Keter.TempFolder as TempFolder
 import qualified Keter.App as App
 import qualified Keter.Postgres as Postgres
+import qualified Keter.LogFile as LogFile
 
 import qualified Control.Concurrent.MVar as M
 import qualified Data.Map as Map
@@ -17,6 +18,9 @@ import Control.Monad (forever)
 import qualified Filesystem.Path.CurrentOS as F
 import Control.Exception (throwIO)
 import qualified Prelude as P
+import Data.Text.Encoding (encodeUtf8)
+import Data.Time (getCurrentTime)
+import qualified Data.Text as T
 
 keter :: P.FilePath -- ^ root directory, with incoming, temp, and etc folders
       -> P.IO ()
@@ -24,6 +28,18 @@ keter dir' = do
     nginx <- runThrow $ Nginx.start def
     tf <- runThrow $ TempFolder.setup $ dir </> "temp"
     postgres <- runThrow $ Postgres.load def $ dir </> "etc" </> "postgres.yaml"
+    mainlog <- runThrow $ LogFile.start $ dir </> "log" </> "keter"
+
+    let runKIO' = runKIO $ \ml -> do
+            now <- getCurrentTime
+            let bs = encodeUtf8 $ T.concat
+                    [ show now
+                    , ": "
+                    , show ml
+                    , "\n"
+                    ]
+            runKIOPrint $ LogFile.addChunk mainlog bs
+        runKIOPrint = runKIO P.print
 
     mappMap <- M.newMVar Map.empty
     let removeApp appname = Keter.Prelude.modifyMVar_ mappMap $ return . Map.delete appname
@@ -59,18 +75,18 @@ keter dir' = do
 
     let events = [I.MoveIn, I.MoveOut, I.Delete, I.CloseWrite]
     i <- I.initINotify
-    _ <- I.addWatch i events (toString incoming) $ \e ->
+    _ <- I.addWatch i events (toString incoming) $ \e -> do
+        runKIO' $ log $ ReceivedInotifyEvent $ show e
         case e of
             I.Deleted _ fp -> when (isKeter' fp) $ terminateApp $ getAppname' fp
             I.MovedOut _ fp _ -> when (isKeter' fp) $ terminateApp $ getAppname' fp
             I.Closed _ (Just fp) _ -> when (isKeter' fp) $ runKIO' $ addApp $ incoming </> F.decodeString fp
             I.MovedIn _ fp _ -> when (isKeter' fp) $ runKIO' $ addApp $ incoming </> F.decodeString fp
-            _ -> P.print e -- FIXME
+            _ -> return ()
 
     runKIO' $ forever $ threadDelay $ 60 * 1000 * 1000
   where
     getAppname = either id id . toText . basename
     getAppname' = getAppname . F.decodeString
-    runThrow f = runKIO' f >>= either throwIO return
-    runKIO' = runKIO P.print
+    runThrow f = runKIO P.print f >>= either throwIO return
     dir = F.decodeString dir'

Keter/Prelude.hs

@@ -50,6 +50,9 @@ module Keter.Prelude
     , P.mapM_
     , P.fmap
     , P.not
+    , P.maybe
+    , (P.>)
+    , (P.+)
       -- * Filepath
     , (F.</>)
     , (F.<.>)
@@ -64,6 +67,7 @@ module Keter.Prelude
     , F.toText
     , F.hasExtension
     , F.listDirectory
+    , F.decodeString
       -- * MVar
     , M.MVar
     , newMVar
@@ -147,6 +151,7 @@ data LogMessage
     | FinishedReloading T.Text
     | TerminatingOldProcess T.Text
     | RemovingOldFolder F.FilePath
+    | ReceivedInotifyEvent T.Text
   deriving P.Show
 
 class ToString a where

keter.cabal

@@ -25,6 +25,7 @@ Library
                      , zlib
                      , tar
                      , network
+                     , time
                      , blaze-builder             >= 0.3           && < 0.4
                      , yaml                      >= 0.7           && < 0.8
                      , unix-compat               >= 0.3           && < 0.4
@@ -38,6 +39,7 @@ Library
                        Keter.App
                        Keter.Main
                        Keter.Prelude
+                       Keter.LogFile
   ghc-options:         -Wall -Werror
 
 Executable keter

test/logfile.hs

@@ -0,0 +1,9 @@
+{-# LANGUAGE OverloadedStrings #-}
+import Keter.LogFile
+import Keter.Prelude
+
+main = runKIO print $ do
+    Right lf <- start "log/test"
+    addChunk lf "foo\n"
+    addChunk lf "bar\n"
+    addChunk lf "baz\n"