keter 0.1 → 0.1.0.1

raw patch · 4 files changed

+48/−9 lines, 4 filesdep ~yamlPVP: minor bump suggested

API additions: PVP suggests at least a minor version bump

Dependency ranges changed: yaml

API changes (from Hackage documentation)

Files

• Keter/Logger.hs +2/−0
• Keter/Main.hs +27/−5
• Keter/Nginx.hs +17/−2
• keter.cabal +2/−2

@@ -51,6 +51,8 @@                 LogFile.close lfout                 LogFile.close lferr             Attach (Handles min mout merr) -> do+                LogFile.addChunk lfout "\n\nAttaching new process\n\n"+                LogFile.addChunk lferr "\n\nAttaching new process\n\n"                 hmClose min                 let go mhandle lf =                         case mhandle of

@@ -1,6 +1,7 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE RecordWildCards #-} module Keter.Main     ( keter     ) where@@ -16,19 +17,40 @@ import qualified Control.Concurrent.MVar as M import qualified Data.Map as Map import qualified System.INotify as I-import Control.Monad (forever)+import Control.Monad (forever, mzero) import qualified Filesystem.Path.CurrentOS as F+import qualified Filesystem 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 import Data.Maybe (fromMaybe)+import Data.Yaml (decodeFile, FromJSON (parseJSON), Value (Object), (.:), (.:?), (.!=))+import Control.Applicative ((<$>), (<*>)) -keter :: P.FilePath -- ^ root directory, with incoming, temp, and etc folders+data Config = Config+    { configDir :: F.FilePath+    , configNginx :: Nginx.Settings+    }++instance FromJSON Config where+    parseJSON (Object o) = Config+        <$> (F.fromText <$> o .: "root")+        <*> o .:? "nginx" .!= def+    parseJSON _ = mzero++keter :: P.FilePath -- ^ root directory or config file       -> P.IO ()-keter dir' = do-    nginx <- runThrow $ Nginx.start def+keter input' = do+    exists <- F.isFile input+    Config{..} <-+        if exists+            then decodeFile input' >>= maybe (P.error "Invalid config file") return+            else return $ Config input def+    let dir = F.directory input F.</> configDir++    nginx <- runThrow $ Nginx.start configNginx     tf <- runThrow $ TempFolder.setup $ dir </> "temp"     postgres <- runThrow $ Postgres.load def $ dir </> "etc" </> "postgres.yaml"     mainlog <- runThrow $ LogFile.start $ dir </> "log" </> "keter"@@ -110,4 +132,4 @@     getAppname = either id id . toText . basename     getAppname' = getAppname . F.decodeString     runThrow f = runKIO P.print f >>= either throwIO return-    dir = F.decodeString dir'+    input = F.decodeString input'

@@ -29,7 +29,7 @@ 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, mzero)
 import qualified Data.ByteString.Lazy as L
 import Blaze.ByteString.Builder (copyByteString, toLazyByteString)
 import Blaze.ByteString.Builder.Char.Utf8 (fromString, fromShow)
@@ -38,6 +38,8 @@ import qualified Network
 import qualified Data.ByteString as S
 import System.Exit (ExitCode (ExitSuccess))
+import Data.Yaml (FromJSON (parseJSON), Value (Object), (.:?), (.!=))
+import Control.Applicative ((<$>), (<*>))
 
 -- | A port for an individual app to listen on.
 type Port = Int
@@ -80,6 +82,19 @@         , portRange = [4000..4999]
         }
 
+instance FromJSON Settings where
+    parseJSON (Object o) = Settings
+        <$> (fmap fromText <$> o .:? "config") .!= configFile def
+        <*> (runRawSystem (reloadAction def) <$> (o .:? "reload"))
+        <*> (runRawSystem (startAction def) <$> (o .:? "start"))
+        <*> return (portRange def)
+      where
+        runRawSystem :: KIO (Either SomeException ()) -> Maybe [Text] -> KIO (Either SomeException ())
+        runRawSystem _ (Just (command:args)) = rawSystem' (fromText command) args
+        runRawSystem _ (Just []) = fail "Command with empty list"
+        runRawSystem k Nothing = k
+    parseJSON _ = mzero
+
 rawSystem' :: FilePath -> [String] -> KIO (Either SomeException ())
 rawSystem' fp args = do
     eec <- liftIO $ rawSystem (toString fp) (map toString args)
@@ -173,7 +188,7 @@         copyByteString "}\n"
     mkConfigEntry (AppEntry port) =
         copyByteString "    location / {\n        proxy_pass http://127.0.0.1:" ++
-        fromShow port ++ copyByteString ";\n    }\n"
+        fromShow port ++ copyByteString ";\n        proxy_set_header X-Real-IP $remote_addr;\n    }\n"
     mkConfigEntry (StaticEntry fp) =
         copyByteString "    root " ++ fromString (toString fp) ++ copyByteString ";\n    expires max;\n"
 

@@ -1,5 +1,5 @@ Name:                keter-Version:             0.1+Version:             0.1.0.1 Synopsis:            Web application deployment manager, focusing on Haskell web frameworks Description:         Handles deployment of web apps, using Nginx as a reverse proxy to achieve zero downtime deployments. For more information, please see the README on Github: <https://github.com/snoyberg/keter#readme> Homepage:            http://www.yesodweb.com/@@ -28,7 +28,7 @@                      , time                      , template-haskell                      , blaze-builder             >= 0.3           && < 0.4-                     , yaml                      >= 0.7           && < 0.8+                     , yaml                      >= 0.7           && < 0.9                      , unix-compat               >= 0.3           && < 0.4                      , hinotify                  >= 0.3           && < 0.4                      , system-filepath           >= 0.4           && < 0.5