File watching: it all works

Keter/App.hs

@@ -15,7 +15,6 @@ import qualified Codec.Archive.Tar as Tar
 import qualified Data.ByteString.Lazy as L
 import Codec.Compression.GZip (decompress)
 import qualified System.FilePath as F
-import Data.Text (pack)
 import Data.Yaml
 import Control.Applicative ((<$>), (<*>))
 import System.PosixCompat.Files
@@ -71,14 +70,14 @@ unpackBundle tf bundle appname = tryM $ do
 
 start :: TempFolder
       -> Nginx
+      -> Appname
       -> FilePath -- ^ app bundle
       -> IO () -- ^ action to perform to remove this App from list of actives
       -> IO (App, IO ())
-start tf nginx bundle removeFromList = do
+start tf nginx appname bundle removeFromList = do
     chan <- C.newChan
     return (App $ C.writeChan chan, rest chan)
   where
-    appname = pack $ F.takeBaseName bundle
     void f = f >> return ()
 
     runApp port dir config = do
@@ -113,6 +112,7 @@ start tf nginx bundle removeFromList = do
             Terminate -> do
                 removeFromList
                 removeEntry nginx $ configHost configOld
+                putStrLn $ "Received terminate signal for app: " ++ show appname
                 terminateOld
             Reload -> do
                 mres <- unpackBundle tf bundle appname
@@ -129,6 +129,7 @@ start tf nginx bundle removeFromList = do
                                 addEntry nginx (configHost config) $ AppEntry port
                                 when (configHost config /= configHost configOld) $
                                     removeEntry nginx $ configHost configOld
+                                putStrLn $ "Finished reloading: " ++ show appname
                                 terminateOld
                                 loop chan dir process port config
                             else do

Keter/Main.hs

@@ -0,0 +1,66 @@
+module Keter.Main
+    ( keter
+    ) where
+
+import qualified Keter.Nginx as Nginx
+import qualified Keter.TempFolder as TempFolder
+import qualified Keter.App as App
+
+import Data.Default (def)
+import System.FilePath ((</>), takeBaseName)
+import qualified Control.Concurrent.MVar as M
+import qualified Data.Map as Map
+import Data.Text (pack)
+import System.Directory (getDirectoryContents)
+import Control.Concurrent (threadDelay)
+import qualified System.INotify as I
+import Control.Monad (forever, when)
+import Data.List (isSuffixOf)
+
+keter :: FilePath -- ^ root directory, with incoming, temp, and etc folders
+      -> IO ()
+keter dir = do
+    nginx <- Nginx.start def
+    tf <- TempFolder.setup $ dir </> "temp"
+
+    mappMap <- M.newMVar Map.empty
+    let removeApp appname = M.modifyMVar_ mappMap $ return . Map.delete appname
+        addApp bundle = do
+            let appname = getAppname bundle
+            rest <- M.modifyMVar mappMap $ \appMap ->
+                case Map.lookup appname appMap of
+                    Just app -> do
+                        App.reload app
+                        return (appMap, return ())
+                    Nothing -> do
+                        (app, rest) <- App.start tf nginx appname bundle $ removeApp appname
+                        let appMap' = Map.insert appname app appMap
+                        return (appMap', rest)
+            rest
+        terminateApp appname = do
+            appMap <- M.readMVar mappMap
+            case Map.lookup appname appMap of
+                Nothing -> return ()
+                Just app -> App.terminate app
+
+    let incoming = dir </> "incoming"
+    let hidden ('.':_) = True
+        hidden _ = False
+        isKeter = isSuffixOf ".keter"
+    bundles <- fmap (map (incoming </>) . filter isKeter . filter (not . hidden))
+             $ getDirectoryContents incoming
+    mapM_ addApp bundles
+
+    let events = [I.MoveIn, I.MoveOut, I.Delete, I.CloseWrite]
+    i <- I.initINotify
+    _ <- I.addWatch i events incoming $ \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) $ addApp $ incoming </> fp
+            I.MovedIn _ fp _ -> when (isKeter fp) $ addApp $ incoming </> fp
+            _ -> print e
+
+    forever $ threadDelay $ 60 * 1000 * 1000
+  where
+    getAppname = pack . takeBaseName

Keter/Nginx.hs

@@ -30,7 +30,7 @@ import Control.Concurrent (forkIO)
 import qualified Control.Monad.Trans.State as S
 import Control.Monad.Trans.Class (lift)
 import qualified Data.Map as Map
-import Control.Monad (forever)
+import Control.Monad (forever, unless)
 import qualified Data.ByteString.Lazy as L
 import Blaze.ByteString.Builder (copyByteString, toLazyByteString)
 import Blaze.ByteString.Builder.Char.Utf8 (fromString, fromShow)
@@ -39,6 +39,8 @@ import Data.ByteString.Char8 ()
 import System.Directory (renameFile)
 import qualified Network
 import Control.Exception (SomeException, try)
+import qualified Data.ByteString as S
+import System.Exit (ExitCode (ExitSuccess))
 
 (<>) :: Monoid m => m -> m -> m
 (<>) = mappend
@@ -79,15 +81,25 @@ data Settings = Settings
 instance Default Settings where
     def = Settings
         { configFile = "/etc/nginx/sites-enabled/keter"
-        , reloadAction = rawSystem "/etc/init.d/nginx" ["reload"] >> return ()
+        , reloadAction = rawSystem' "/etc/init.d/nginx" ["reload"]
-        , startAction = rawSystem "/etc/init.d/nginx" ["start"] >> return ()
+        , startAction = rawSystem' "/etc/init.d/nginx" ["start"]
         , portRange = [4000..4999]
         }
 
+rawSystem' :: FilePath -> [String] -> IO ()
+rawSystem' fp args = do
+    ec <- rawSystem fp args
+    unless (ec == ExitSuccess) $ error $ "Received exit failure when running: " ++ show (fp:args)
+
 -- | Start running a separate thread which will accept commands and modify
 -- Nginx's behavior accordingly.
 start :: Settings -> IO Nginx
 start Settings{..} = do
+    -- Start off by ensuring we can read and write the config file and reload
+    config0 <- S.readFile configFile
+    S.writeFile configFile config0
+    reloadAction
+
     chan <- C.newChan
     _ <- forkIO $ flip S.evalStateT (NState portRange [] Map.empty) $ forever $ do
         command <- lift $ C.readChan chan

incoming/foo/hello.hs

@@ -4,10 +4,15 @@ import qualified Data.ByteString.Lazy.Char8 as L8
 import Network.Wai
 import Network.Wai.Handler.Warp
 import Network.HTTP.Types
+import System.Directory
 
 main :: IO ()
 main = do
+    fp <- canonicalizePath "."
     [msg] <- getArgs
     portS <- getEnv "PORT"
     let port = read portS
-    run port $ const $ return $ responseLBS status200 [("content-type", "text/plain")] $ L8.pack msg
+    run port $ const $ return $ responseLBS status200 [("content-type", "text/plain")] $ L8.pack $ unlines
+        [ "Message: " ++ msg
+        , "Path: " ++ fp
+        ]

keter.cabal

@@ -28,17 +28,20 @@ Library
                      , blaze-builder             >= 0.3           && < 0.4
                      , yaml                      >= 0.7           && < 0.8
                      , unix-compat               >= 0.3           && < 0.4
+                     , hinotify                  >= 0.3           && < 0.4
   Exposed-Modules:     Keter.Nginx
                        Keter.Process
                        Keter.Postgres
                        Keter.TempFolder
                        Keter.App
+                       Keter.Main
   ghc-options:         -Wall -Werror
 
 Executable keter
   Main-is:             ../keter.hs
   hs-source-dirs:      dist
   Build-depends:       base, keter
+  ghc-options:         -threaded -Wall -Werror
 
 source-repository head
   type:     git

keter.hs

@@ -1,4 +1,11 @@
-import Keter.Nginx ()
+import System.Environment (getArgs, getProgName)
+import Keter.Main (keter)
 
 main :: IO ()
-main = putStrLn "Nothing here yet"
+main = do
+    args <- getArgs
+    case args of
+        [dir] -> keter dir
+        _ -> do
+            pn <- getProgName
+            error $ "Usage: " ++ pn ++ " <root folder>"