keter (empty) → 0.1
raw patch · 13 files changed
+1350/−0 lines, 13 filesdep +basedep +blaze-builderdep +bytestringsetup-changed
Dependencies added: base, blaze-builder, bytestring, containers, data-default, directory, filepath, hinotify, keter, network, process, random, system-fileio, system-filepath, tar, template-haskell, text, time, transformers, unix-compat, yaml, zlib
Files
- Keter/App.hs +207/−0
- Keter/LogFile.hs +79/−0
- Keter/Logger.hs +99/−0
- Keter/Main.hs +113/−0
- Keter/Nginx.hs +209/−0
- Keter/Postgres.hs +144/−0
- Keter/Prelude.hs +309/−0
- Keter/Process.hs +67/−0
- Keter/TempFolder.hs +33/−0
- LICENSE +20/−0
- Setup.hs +2/−0
- keter.cabal +55/−0
- main/keter.hs +13/−0
+ Keter/App.hs view
@@ -0,0 +1,207 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE TemplateHaskell #-}+module Keter.App+ ( App+ , start+ , reload+ , Keter.App.terminate+ ) where++import Keter.Prelude+import Keter.TempFolder+import Keter.Postgres+import Keter.Process+import Keter.Logger (Logger, detach)+import Keter.Nginx hiding (start)+import qualified Codec.Archive.Tar as Tar+import Codec.Compression.GZip (decompress)+import qualified Filesystem.Path.CurrentOS as F+import Data.Yaml+import Control.Applicative ((<$>), (<*>))+import System.PosixCompat.Files+import qualified Network+import Data.Maybe (fromMaybe)+import Control.Exception (onException)+import System.IO (hClose)++data Config = Config+ { configExec :: F.FilePath+ , configArgs :: [Text]+ , configHost :: String+ , configPostgres :: Bool+ }++instance FromJSON Config where+ parseJSON (Object o) = Config+ <$> (F.fromText <$> o .: "exec")+ <*> o .:? "args" .!= []+ <*> o .: "host"+ <*> o .:? "postgres" .!= False+ parseJSON _ = fail "Wanted an object"++data Command = Reload | Terminate+newtype App = App (Command -> KIO ())++unpackBundle :: TempFolder+ -> F.FilePath+ -> Appname+ -> KIO (Either SomeException (FilePath, Config))+unpackBundle tf bundle appname = do+ elbs <- readFileLBS bundle+ case elbs of+ Left e -> return $ Left e+ Right lbs -> do+ edir <- getFolder tf appname+ case edir of+ Left e -> return $ Left e+ Right dir -> do+ log $ UnpackingBundle bundle dir+ let rest = do+ Tar.unpack (F.encodeString dir) $ Tar.read $ decompress lbs+ let configFP = dir F.</> "config" F.</> "keter.yaml"+ Just config <- decodeFile $ F.encodeString configFP+ return (dir, config)+ liftIO $ rest `onException` removeTree dir++start :: TempFolder+ -> Nginx+ -> Postgres+ -> Logger+ -> Appname+ -> F.FilePath -- ^ app bundle+ -> KIO () -- ^ action to perform to remove this App from list of actives+ -> KIO (App, KIO ())+start tf nginx postgres logger appname bundle removeFromList = do+ chan <- newChan+ return (App $ writeChan chan, rest chan)+ where+ runApp port dir config = do+ res1 <- liftIO $ setFileMode (toString $ dir </> "config" </> configExec config) ownerExecuteMode+ case res1 of+ Left e -> $logEx e+ Right () -> return ()+ otherEnv <- do+ mdbi <-+ if configPostgres config+ then do+ edbi <- getInfo postgres appname+ case edbi of+ Left e -> do+ $logEx e+ return Nothing+ Right dbi -> return $ Just dbi+ else return Nothing+ return $ case mdbi of+ Just dbi ->+ [ ("PGHOST", "localhost")+ , ("PGPORT", "5432")+ , ("PGUSER", dbiUser dbi)+ , ("PGPASS", dbiPass dbi)+ , ("PGDATABASE", dbiName dbi)+ ]+ Nothing -> []+ let env = ("PORT", show port)+ : ("APPROOT", "http://" ++ configHost config)+ : otherEnv+ run+ ("config" </> configExec config)+ dir+ (configArgs config)+ env+ logger++ rest chan = forkKIO $ do+ mres <- unpackBundle tf bundle appname+ case mres of+ Left e -> do+ $logEx e+ removeFromList+ Right (dir, config) -> do+ eport <- getPort nginx+ case eport of+ Left e -> do+ $logEx e+ removeFromList+ Right port -> do+ process <- runApp port dir config+ b <- testApp port+ if b+ then do+ addEntry nginx (configHost config) $ AppEntry port+ loop chan dir process port config+ else do+ removeFromList+ releasePort nginx port+ Keter.Process.terminate process++ loop chan dirOld processOld portOld configOld = do+ command <- readChan chan+ case command of+ Terminate -> do+ removeFromList+ removeEntry nginx $ configHost configOld+ log $ TerminatingApp appname+ terminateOld+ detach logger+ Reload -> do+ mres <- unpackBundle tf bundle appname+ case mres of+ Left e -> do+ log $ InvalidBundle bundle e+ loop chan dirOld processOld portOld configOld+ Right (dir, config) -> do+ eport <- getPort nginx+ case eport of+ Left e -> $logEx e+ Right port -> do+ process <- runApp port dir config+ b <- testApp port+ if b+ then do+ addEntry nginx (configHost config) $ AppEntry port+ when (configHost config /= configHost configOld) $+ removeEntry nginx $ configHost configOld+ log $ FinishedReloading appname+ terminateOld+ loop chan dir process port config+ else do+ releasePort nginx port+ Keter.Process.terminate process+ log $ ProcessDidNotStart bundle+ loop chan dirOld processOld portOld configOld+ where+ terminateOld = forkKIO $ do+ threadDelay $ 20 * 1000 * 1000+ log $ TerminatingOldProcess appname+ Keter.Process.terminate processOld+ threadDelay $ 60 * 1000 * 1000+ log $ RemovingOldFolder dirOld+ res <- liftIO $ removeTree dirOld+ case res of+ Left e -> $logEx e+ Right () -> return ()++testApp :: Port -> KIO Bool+testApp port = do+ res <- timeout (90 * 1000 * 1000) testApp'+ return $ fromMaybe False res+ where+ testApp' = do+ threadDelay $ 2 * 1000 * 1000+ eres <- liftIO $ Network.connectTo "127.0.0.1" $ Network.PortNumber $ fromIntegral port+ case eres of+ Left _ -> testApp'+ Right handle -> do+ res <- liftIO $ hClose handle+ case res of+ Left e -> $logEx e+ Right () -> return ()+ return True++reload :: App -> KIO ()+reload (App f) = f Reload++terminate :: App -> KIO ()+terminate (App f) = f Terminate
+ Keter/LogFile.hs view
@@ -0,0 +1,79 @@+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TemplateHaskell #-}+module Keter.LogFile+ ( LogFile+ , start+ , addChunk+ , close+ ) where++import Keter.Prelude hiding (getCurrentTime)+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.concatMap fix $ T.takeWhile (/= '.') $ show now) <.> "log"+ fix ' ' = "_"+ fix c | '0' <= c && c <= '9' = T.singleton c+ fix _ = T.empty+ 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 $logEx return res+ if total' > maxTotal+ then do+ res2 <- liftIO $ moveCurrent $ Just handle+ case res2 of+ Left e -> do+ $logEx e+ deadLoop chan+ Right handle' -> loop chan handle' 0+ else loop chan handle total'+ Close ->+ liftIO (SIO.hClose handle) >>=+ either $logEx return+ deadLoop chan = do+ c <- readChan chan+ case c of+ AddChunk _ -> deadLoop chan+ Close -> return ()++ maxTotal = 5 * 1024 * 1024 -- 5 MB
+ Keter/Logger.hs view
@@ -0,0 +1,99 @@+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TemplateHaskell #-}+module Keter.Logger+ ( Logger+ , start+ , attach+ , detach+ , Handles (..)+ , dummy+ ) where++import Keter.Prelude+import System.IO (Handle, hClose)+import qualified Prelude as P+import qualified Keter.LogFile as LogFile+import Control.Concurrent (killThread)+import qualified Data.ByteString as S+import Control.Exception (fromException, AsyncException (ThreadKilled))++data Handles = Handles+ { stdIn :: Maybe Handle+ , stdOut :: Maybe Handle+ , stdErr :: Maybe Handle+ }++newtype Logger = Logger (Command -> KIO ())++data Command = Attach Handles | Detach++start :: LogFile.LogFile -- ^ stdout+ -> LogFile.LogFile -- ^ stderr+ -> KIO Logger+start lfout lferr = do+ chan <- newChan+ forkKIO $ loop chan Nothing Nothing+ return $ Logger $ writeChan chan+ where+ killOld tid = do+ res <- liftIO $ killThread tid+ case res of+ Left e -> $logEx e+ Right () -> return ()++ loop chan moldout molderr = do+ c <- readChan chan+ maybe (return ()) killOld moldout+ maybe (return ()) killOld molderr+ case c of+ Detach -> do+ LogFile.close lfout+ LogFile.close lferr+ Attach (Handles min mout merr) -> do+ hmClose min+ let go mhandle lf =+ case mhandle of+ Nothing -> return Nothing+ Just handle -> do+ etid <- forkKIO' $ listener handle lf+ case etid of+ Left e -> do+ $logEx e+ hmClose mhandle+ return Nothing+ Right tid -> return $ Just tid+ newout <- go mout lfout+ newerr <- go merr lferr+ loop chan newout newerr++hmClose :: Maybe Handle -> KIO ()+hmClose Nothing = return ()+hmClose (Just h) = liftIO (hClose h) >>= either $logEx return++listener :: Handle -> LogFile.LogFile -> KIO ()+listener out lf =+ loop+ where+ loop = do+ ebs <- liftIO $ S.hGetSome out 4096+ case ebs of+ Left e -> do+ case fromException e of+ Just ThreadKilled -> return ()+ _ -> $logEx e+ hmClose $ Just out+ Right bs+ | S.null bs -> hmClose (Just out)+ | otherwise -> do+ LogFile.addChunk lf bs+ listener out lf++attach :: Logger -> Handles -> KIO ()+attach (Logger f) h = f (Attach h)++detach :: Logger -> KIO ()+detach (Logger f) = f Detach++dummy :: Logger+dummy = P.error "Logger.dummy"
+ Keter/Main.hs view
@@ -0,0 +1,113 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE TemplateHaskell #-}+module Keter.Main+ ( keter+ ) where++import Keter.Prelude hiding (getCurrentTime)+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 Keter.Logger as Logger++import qualified Control.Concurrent.MVar as M+import qualified Data.Map as Map+import qualified System.INotify as I+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+import Data.Maybe (fromMaybe)++keter :: P.FilePath -- ^ root directory, with incoming, temp, and etc folders+ -> P.IO ()+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+ [ T.take 22 $ 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+ addApp bundle = do+ let appname = getAppname bundle+ rest <- modifyMVar mappMap $ \appMap ->+ case Map.lookup appname appMap of+ Just app -> do+ App.reload app+ return (appMap, return ())+ Nothing -> do+ mlogger <- do+ let dirout = dir </> "log" </> fromText ("app-" ++ appname)+ direrr = dirout </> "err"+ elfout <- LogFile.start dirout+ case elfout of+ Left e -> do+ $logEx e+ return Nothing+ Right lfout -> do+ elferr <- LogFile.start direrr+ case elferr of+ Left e -> do+ $logEx e+ LogFile.close lfout+ return Nothing+ Right lferr -> fmap Just $ Logger.start lfout lferr+ let logger = fromMaybe Logger.dummy mlogger+ (app, rest) <- App.start+ tf+ nginx+ postgres+ logger+ 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 -> runKIO' $ App.terminate app++ let incoming = dir </> "incoming"+ isKeter fp = hasExtension fp "keter"+ isKeter' = isKeter . F.decodeString+ createTree incoming+ bundles <- fmap (filter isKeter) $ listDirectory incoming+ runKIO' $ mapM_ addApp bundles++ let events = [I.MoveIn, I.MoveOut, I.Delete, I.CloseWrite]+ i <- I.initINotify+ _ <- I.addWatch i events (toString incoming) $ \e -> do+ 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+ _ -> runKIO' $ log $ ReceivedInotifyEvent $ show e++ runKIO' $ forever $ threadDelay $ 60 * 1000 * 1000+ where+ getAppname = either id id . toText . basename+ getAppname' = getAppname . F.decodeString+ runThrow f = runKIO P.print f >>= either throwIO return+ dir = F.decodeString dir'
+ Keter/Nginx.hs view
@@ -0,0 +1,209 @@+{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE TemplateHaskell #-} +module Keter.Nginx + ( -- * Types + Port + , Host + , Entry (..) + , Nginx + -- ** Settings + , Settings + , configFile + , reloadAction + , startAction + , portRange + -- * Actions + , getPort + , releasePort + , addEntry + , removeEntry + -- * Initialize + , start + ) where + +import Keter.Prelude +import System.Cmd (rawSystem) +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 qualified Data.ByteString.Lazy as L +import Blaze.ByteString.Builder (copyByteString, toLazyByteString) +import Blaze.ByteString.Builder.Char.Utf8 (fromString, fromShow) +import Data.Monoid (Monoid, mconcat) +import Data.ByteString.Char8 () +import qualified Network +import qualified Data.ByteString as S +import System.Exit (ExitCode (ExitSuccess)) + +-- | A port for an individual app to listen on. +type Port = Int + +-- | A virtual host we want to serve content from. +type Host = String + +data Command = GetPort (Either SomeException Port -> KIO ()) + | ReleasePort Port + | AddEntry Host Entry + | RemoveEntry Host + +-- | An individual virtual host may either be a reverse proxy to an app +-- (@AppEntry@), or may serve static files (@StaticEntry@). +data Entry = AppEntry Port + | StaticEntry FilePath + +-- | An abstract type which can accept commands and sends them to a background +-- nginx thread. +newtype Nginx = Nginx (Command -> KIO ()) + +-- | Controls execution of the nginx thread. Follows the settings type pattern. +-- See: <http://www.yesodweb.com/book/settings-types>. +data Settings = Settings + { configFile :: FilePath + -- ^ Location of config file. Default: \/etc\/nginx\/sites-enabled\/keter + , reloadAction :: KIO (Either SomeException ()) + -- ^ How to tell Nginx to reload config file. Default: \/etc\/init.d\/nginx reload + , startAction :: KIO (Either SomeException ()) + -- ^ How to tell Nginx to start running. Default: \/etc\/init.d\/nginx start + , portRange :: [Port] + -- ^ Which ports to assign to apps. Default: 4000-4999 + } + +instance Default Settings where + def = Settings + { configFile = "/etc/nginx/sites-enabled/keter" + , reloadAction = rawSystem' "/etc/init.d/nginx" ["reload"] + , startAction = rawSystem' "/etc/init.d/nginx" ["start"] + , portRange = [4000..4999] + } + +rawSystem' :: FilePath -> [String] -> KIO (Either SomeException ()) +rawSystem' fp args = do + eec <- liftIO $ rawSystem (toString fp) (map toString args) + case eec of + Left e -> return $ Left e + Right ec + | ec == ExitSuccess -> return $ Right () + | otherwise -> return $ Left $ toException $ ExitCodeFailure fp ec + +-- | Start running a separate thread which will accept commands and modify +-- Nginx's behavior accordingly. +start :: Settings -> KIO (Either SomeException Nginx) +start Settings{..} = do + -- Start off by ensuring we can read and write the config file and reload + eres <- liftIO $ do + exists <- isFile configFile + config0 <- + if exists + then S.readFile $ toString configFile + else return "" + let tmp = configFile <.> "tmp" + S.writeFile (toString tmp) config0 + rename tmp configFile + case eres of + Left e -> return $ Left e + Right () -> do + eres2 <- reloadAction + case eres2 of + Left e -> return $ Left e + Right () -> go + + where + go :: KIO (Either SomeException Nginx) + go = do + chan <- newChan + forkKIO $ flip S.evalStateT (NState portRange [] Map.empty) $ forever $ do + command <- lift $ readChan chan + case command of + GetPort f -> do + ns0 <- S.get + let loop :: NState -> KIO (Either SomeException Port, NState) + loop ns = + case nsAvail ns of + p:ps -> do + res <- liftIO $ Network.listenOn $ Network.PortNumber $ fromIntegral p + case res of + Left (_ :: SomeException) -> do + log $ RemovingPort p + loop ns { nsAvail = ps } + Right socket -> do + res' <- liftIO $ Network.sClose socket + case res' of + Left e -> do + $logEx e + log $ RemovingPort p + loop ns { nsAvail = ps } + Right () -> return (Right p, ns { nsAvail = ps }) + [] -> + case reverse $ nsRecycled ns of + [] -> return (Left $ toException NoPortsAvailable, ns) + ps -> loop ns { nsAvail = ps, nsRecycled = [] } + (eport, ns) <- lift $ loop ns0 + S.put ns + lift $ f eport + ReleasePort p -> + S.modify $ \ns -> ns { nsRecycled = p : nsRecycled ns } + AddEntry h e -> change $ Map.insert h e + RemoveEntry h -> change $ Map.delete h + return $ Right $ Nginx $ writeChan chan + + change f = do + ns <- S.get + let entries = f $ nsEntries ns + S.put $ ns { nsEntries = entries } + let tmp = configFile <.> "tmp" + lift $ do + res1 <- liftIO $ do + L.writeFile (toString tmp) $ mkConfig entries + rename tmp configFile + res2 <- case res1 of + Left e -> return $ Left e + Right () -> reloadAction + case res2 of + Left e -> $logEx e + Right () -> return () + mkConfig = toLazyByteString . mconcat . map mkConfig' . Map.toList + mkConfig' (host, entry) = + copyByteString "server {\n listen 80;\n server_name " ++ + fromText host ++ copyByteString ";\n" ++ + mkConfigEntry entry ++ + copyByteString "}\n" + mkConfigEntry (AppEntry port) = + copyByteString " location / {\n proxy_pass http://127.0.0.1:" ++ + fromShow port ++ copyByteString ";\n }\n" + mkConfigEntry (StaticEntry fp) = + copyByteString " root " ++ fromString (toString fp) ++ copyByteString ";\n expires max;\n" + +data NState = NState + { nsAvail :: [Port] + , nsRecycled :: [Port] + , nsEntries :: Map.Map Host Entry + } + +-- | Gets an unassigned port number. +getPort :: Nginx -> KIO (Either SomeException Port) +getPort (Nginx f) = do + x <- newEmptyMVar + f $ GetPort $ \p -> putMVar x p + takeMVar x + +-- | Inform the nginx thread that the given port number is no longer being +-- used, and may be reused by a new process. Note that recycling puts the new +-- ports at the end of the queue (FIFO), so that if an application holds onto +-- the port longer than expected, there should be no issues. +releasePort :: Nginx -> Port -> KIO () +releasePort (Nginx f) p = f $ ReleasePort p + +-- | Add a new entry to the configuration for the given hostname and reload +-- nginx. Will overwrite any existing configuration for the given host. The +-- second point is important: it is how we achieve zero downtime transitions +-- between an old and new version of an app. +addEntry :: Nginx -> Host -> Entry -> KIO () +addEntry (Nginx f) h e = f $ AddEntry h e + +-- | Remove an entry from the configuration and reload nginx. +removeEntry :: Nginx -> Host -> KIO () +removeEntry (Nginx f) h = f $ RemoveEntry h
+ Keter/Postgres.hs view
@@ -0,0 +1,144 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE NoImplicitPrelude #-}+module Keter.Postgres+ ( -- * Types+ Appname+ , DBInfo (..)+ , Postgres+ -- ** Settings+ , Settings+ , setupDBInfo+ -- * Functions+ , load+ , getInfo+ ) where++import Keter.Prelude+import qualified Prelude as P+import qualified Data.Text as T+import Data.Yaml+import qualified Data.Map as Map+import Control.Monad (forever, mzero, replicateM)+import qualified Control.Monad.Trans.State as S+import Control.Monad.Trans.Class (lift)+import Control.Applicative ((<$>), (<*>))+import qualified System.Random as R+import Data.Text.Lazy.Builder (toLazyText)+import qualified Data.Text.Lazy as TL+import System.Process (readProcess)++data Settings = Settings+ { setupDBInfo :: DBInfo -> P.IO ()+ -- ^ How to create the given user/database. Default: uses the @psql@+ -- command line tool and @sudo -u postgres@.+ }++instance Default Settings where+ def = Settings+ { setupDBInfo = \DBInfo{..} -> do+ let sql = toLazyText $+ "CREATE USER " ++ fromText dbiUser +++ " PASSWORD '" ++ fromText dbiPass +++ "';\nCREATE DATABASE " ++ fromText dbiName +++ " OWNER " ++ fromText dbiUser +++ ";"+ _ <- readProcess "sudo" ["-u", "postgres", "psql"] $ TL.unpack sql+ return ()+ }++-- | Name of the application. Should just be the basename of the application+-- file.+type Appname = Text++-- | Information on an individual PostgreSQL database.+data DBInfo = DBInfo+ { dbiName :: Text+ , dbiUser :: Text+ , dbiPass :: Text+ }+ deriving Show++randomDBI :: R.StdGen -> (DBInfo, R.StdGen)+randomDBI =+ S.runState (DBInfo <$> rt <*> rt <*> rt)+ where+ rt = T.pack <$> replicateM 10 (S.state $ R.randomR ('a', 'z'))++instance ToJSON DBInfo where+ toJSON (DBInfo n u p) = object+ [ "name" .= n+ , "user" .= u+ , "pass" .= p+ ]++instance FromJSON DBInfo where+ parseJSON (Object o) = DBInfo+ <$> o .: "name"+ <*> o .: "user"+ <*> o .: "pass"+ parseJSON _ = mzero++-- | Abstract type allowing access to config information via 'getInfo'+newtype Postgres = Postgres+ { getInfo :: Appname -> KIO (Either SomeException DBInfo)+ -- ^ Get information on an individual app\'s database information. If no+ -- information exists, it will create a random database, add it to the+ -- config file, and return it.+ }++data Command = GetConfig Appname (Either SomeException DBInfo -> KIO ())++-- | Load a set of existing connections from a config file. If the file does+-- not exist, it will be created. Any newly created databases will+-- automatically be saved to this file.+load :: Settings -> FilePath -> KIO (Either SomeException Postgres)+load Settings{..} fp = do+ mdb <- liftIO $ do+ createTree $ directory fp+ e <- isFile fp+ if e+ then decodeFile $ toString fp+ else return $ Just Map.empty+ case mdb of+ Left e -> return $ Left e+ Right Nothing -> return $ Left $ toException $ CannotParsePostgres fp+ Right (Just db0) -> go (db0 :: Map.Map Appname DBInfo)+ where+ go db0 = do+ chan <- newChan+ g0 <- newStdGen+ forkKIO $ flip S.evalStateT (db0, g0) $ forever $ loop chan+ return $ Right $ Postgres $ \appname -> do+ x <- newEmptyMVar+ writeChan chan $ GetConfig appname $ putMVar x+ takeMVar x++ tmpfp = fp <.> "tmp"++ loop chan = do+ GetConfig appname f <- lift $ readChan chan+ (db, g) <- S.get+ dbi <-+ case Map.lookup appname db of+ Just dbi -> return $ Right dbi+ Nothing -> do+ let (dbi', g') = randomDBI g+ let dbi = dbi'+ { dbiName = appname ++ dbiName dbi'+ , dbiUser = appname ++ dbiUser dbi'+ }+ ex <- lift $ liftIO $ setupDBInfo dbi+ case ex of+ Left e -> return $ Left e+ Right () -> do+ let db' = Map.insert appname dbi db+ ey <- lift $ liftIO $ do+ encodeFile (toString tmpfp) db'+ rename tmpfp fp+ case ey of+ Left e -> return $ Left e+ Right () -> do+ S.put (db', g')+ return $ Right dbi+ lift $ f dbi
+ Keter/Prelude.hs view
@@ -0,0 +1,309 @@+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE FlexibleInstances #-}+module Keter.Prelude+ ( T.Text+ , String+ , P.Monad (..)+ , P.Maybe (..)+ , P.Bool (..)+ , (P.$)+ , (P..)+ , LogMessage (..)+ , log+ , logEx+ , KIO+ , toString+ , P.map+ , (A.***)+ , readFileLBS+ , P.Either (..)+ , P.either+ , E.SomeException+ , runKIO+ , void+ , liftIO+ , forkKIO+ , forkKIO'+ , (++)+ , P.minBound+ , P.succ+ , show+ , Control.Monad.when+ , fromText+ , P.flip+ , P.Show+ , KeterException (..)+ , E.toException+ , newStdGen+ , Default (..)+ , P.Int+ , (P.&&)+ , (P.==)+ , (P./=)+ , (P.*)+ , P.fromIntegral+ , P.reverse+ , P.otherwise+ , timeout+ , threadDelay+ , P.id+ , P.filter+ , P.mapM_+ , P.fmap+ , P.not+ , P.maybe+ , (P.>)+ , (P.<)+ , (P.<=)+ , (P.+)+ , (P.-)+ , getCurrentTime+ -- * Filepath+ , (F.</>)+ , (F.<.>)+ , F.FilePath+ , F.isDirectory+ , F.isFile+ , F.removeTree+ , F.createTree+ , F.directory+ , F.rename+ , F.basename+ , F.toText+ , F.hasExtension+ , F.listDirectory+ , F.decodeString+ -- * MVar+ , M.MVar+ , newMVar+ , newEmptyMVar+ , modifyMVar+ , modifyMVar_+ , swapMVar+ , takeMVar+ , putMVar+ -- * IORef+ , I.IORef+ , newIORef+ , atomicModifyIORef+ -- * Chan+ , C.Chan+ , newChan+ , readChan+ , writeChan+ ) where++import qualified Filesystem.Path.CurrentOS as F+import qualified Filesystem as F+import qualified Data.Text as T+import qualified Prelude as P+import qualified Control.Arrow as A+import qualified Data.ByteString.Lazy as L+import Prelude (($), (.))+import qualified Control.Exception as E+import qualified Control.Monad+import qualified Control.Applicative+import qualified Control.Concurrent.MVar as M+import Control.Concurrent (forkIO, ThreadId)+import qualified Control.Concurrent+import qualified Data.IORef as I+import Data.Monoid (Monoid, mappend)+import qualified Data.Text.Lazy.Builder as B+import Data.Typeable (Typeable)+import qualified Control.Concurrent.Chan as C+import qualified System.Random as R+import Data.Default (Default (..))+import System.Exit (ExitCode)+import qualified Blaze.ByteString.Builder as Blaze+import qualified Blaze.ByteString.Builder.Char.Utf8+import qualified System.Timeout+import qualified Language.Haskell.TH.Syntax as TH+import qualified Data.Time++type String = T.Text++newtype KIO a = KIO { unKIO :: (LogMessage -> P.IO ()) -> P.IO a }++instance P.Monad KIO where+ return = KIO . P.const . P.return+ KIO x >>= y = KIO $ \f -> do+ x' <- x f+ let KIO mz = y x'+ mz f++instance P.Functor KIO where+ fmap = Control.Monad.liftM+instance Control.Applicative.Applicative KIO where+ (<*>) = Control.Monad.ap+ pure = P.return++log :: LogMessage -> KIO ()+log msg = do+ f <- getLogger+ void $ liftIO $ f msg+ where+ getLogger = KIO P.return++void :: P.Monad m => m a -> m ()+void f = f P.>> P.return ()++data LogMessage+ = ProcessCreated F.FilePath+ | InvalidBundle F.FilePath E.SomeException+ | ProcessDidNotStart F.FilePath+ | ExceptionThrown T.Text E.SomeException+ | RemovingPort P.Int+ | UnpackingBundle F.FilePath F.FilePath+ | TerminatingApp T.Text+ | FinishedReloading T.Text+ | TerminatingOldProcess T.Text+ | RemovingOldFolder F.FilePath+ | ReceivedInotifyEvent T.Text+ | ProcessWaiting F.FilePath++instance P.Show LogMessage where+ show (ProcessCreated f) = "Created process: " ++ F.encodeString f+ show (InvalidBundle f e) = P.concat+ [ "Unable to parse bundle file '"+ , F.encodeString f+ , "': "+ , P.show e+ ]+ show (ProcessDidNotStart fp) = P.concat+ [ "Could not start process within timeout period: "+ , F.encodeString fp+ ]+ show (ExceptionThrown t e) = P.concat+ [ T.unpack t+ , ": "+ , P.show e+ ]+ show (RemovingPort p) = "Port in use, removing from port pool: " ++ P.show p+ show (UnpackingBundle b dir) = P.concat+ [ "Unpacking bundle '"+ , F.encodeString b+ , "' into folder: "+ , F.encodeString dir+ ]+ show (TerminatingApp t) = "Shutting down app: " ++ T.unpack t+ show (FinishedReloading t) = "App finished reloading: " ++ T.unpack t+ show (TerminatingOldProcess t) = "Sending old process TERM signal: " ++ T.unpack t+ show (RemovingOldFolder fp) = "Removing unneeded folder: " ++ F.encodeString fp+ show (ReceivedInotifyEvent t) = "Received unknown INotify event: " ++ T.unpack t+ show (ProcessWaiting f) = "Process restarting too quickly, waiting before trying again: " ++ F.encodeString f++logEx :: TH.Q TH.Exp+logEx = do+ let showLoc TH.Loc { TH.loc_module = m, TH.loc_start = (l, c) } = P.concat+ [ m+ , ":"+ , P.show l+ , ":"+ , P.show c+ ]+ loc <- P.fmap showLoc TH.qLocation+ [|log P.. ExceptionThrown (T.pack $(TH.lift loc))|]++class ToString a where+ toString :: a -> P.String++instance ToString P.String where+ toString = P.id+instance ToString T.Text where+ toString = T.unpack+instance ToString F.FilePath where+ toString = F.encodeString++readFileLBS :: F.FilePath -> KIO (P.Either E.SomeException L.ByteString)+readFileLBS = liftIO . L.readFile P.. toString++liftIO :: P.IO a -> KIO (P.Either E.SomeException a)+liftIO = KIO . P.const . E.try++liftIO_ :: P.IO a -> KIO a+liftIO_ = KIO . P.const++runKIO :: (LogMessage -> P.IO ()) -> KIO a -> P.IO a+runKIO f (KIO g) = g f++newMVar :: a -> KIO (M.MVar a)+newMVar = liftIO_ . M.newMVar++newEmptyMVar :: KIO (M.MVar a)+newEmptyMVar = liftIO_ M.newEmptyMVar++modifyMVar :: M.MVar a -> (a -> KIO (a, b)) -> KIO b+modifyMVar m f = KIO $ \x -> M.modifyMVar m (\a -> unKIO (f a) x)++modifyMVar_ :: M.MVar a -> (a -> KIO a) -> KIO ()+modifyMVar_ m f = KIO $ \x -> M.modifyMVar_ m (\a -> unKIO (f a) x)++swapMVar :: M.MVar a -> a -> KIO a+swapMVar m = liftIO_ . M.swapMVar m++takeMVar :: M.MVar a -> KIO a+takeMVar = liftIO_ . M.takeMVar++putMVar :: M.MVar a -> a -> KIO ()+putMVar m = liftIO_ . M.putMVar m++forkKIO :: KIO () -> KIO ()+forkKIO = void . forkKIO'++forkKIO' :: KIO () -> KIO (P.Either E.SomeException ThreadId)+forkKIO' f = do+ x <- KIO P.return+ liftIO $ forkIO $ unKIO f x++newIORef :: a -> KIO (I.IORef a)+newIORef = liftIO_ . I.newIORef++atomicModifyIORef :: I.IORef a -> (a -> (a, b)) -> KIO b+atomicModifyIORef x = liftIO_ . I.atomicModifyIORef x++(++) :: Monoid m => m -> m -> m+(++) = mappend++show :: P.Show a => a -> T.Text+show = T.pack . P.show++class FromText a where+ fromText :: T.Text -> a+instance FromText T.Text where+ fromText = P.id+instance FromText F.FilePath where+ fromText = F.fromText+instance FromText B.Builder where+ fromText = B.fromText+instance FromText Blaze.Builder where+ fromText = Blaze.ByteString.Builder.Char.Utf8.fromText++data KeterException = CannotParsePostgres F.FilePath+ | ExitCodeFailure F.FilePath ExitCode+ | NoPortsAvailable+ deriving (P.Show, Typeable)+instance E.Exception KeterException++newChan :: KIO (C.Chan a)+newChan = liftIO_ C.newChan++newStdGen :: KIO R.StdGen+newStdGen = liftIO_ R.newStdGen++readChan :: C.Chan a -> KIO a+readChan = liftIO_ . C.readChan++writeChan :: C.Chan a -> a -> KIO ()+writeChan c = liftIO_ . C.writeChan c++timeout :: P.Int -> KIO a -> KIO (P.Maybe a)+timeout seconds (KIO f) = KIO $ \x -> System.Timeout.timeout seconds $ f x++threadDelay :: P.Int -> KIO ()+threadDelay = liftIO_ . Control.Concurrent.threadDelay++getCurrentTime :: KIO Data.Time.UTCTime+getCurrentTime = liftIO_ Data.Time.getCurrentTime
+ Keter/Process.hs view
@@ -0,0 +1,67 @@+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE TemplateHaskell #-}+module Keter.Process+ ( run+ , terminate+ , Process+ ) where++import Keter.Prelude+import Keter.Logger+import qualified System.Process as SP+import Data.Time (diffUTCTime)++data Status = NeedsRestart | NoRestart | Running SP.ProcessHandle++-- | Run the given command, restarting if the process dies.+run :: FilePath -- ^ executable+ -> FilePath -- ^ working directory+ -> [String] -- ^ command line parameter+ -> [(String, String)] -- ^ environment+ -> Logger+ -> KIO Process+run exec dir args env logger = do+ mstatus <- newMVar NeedsRestart+ let loop mlast = do+ next <- modifyMVar mstatus $ \status ->+ case status of+ NoRestart -> return (NoRestart, return ())+ _ -> do+ now <- getCurrentTime+ case mlast of+ Just last | diffUTCTime now last < 5 -> do+ log $ ProcessWaiting exec+ threadDelay $ 5 * 1000 * 1000+ _ -> return ()+ res <- liftIO $ SP.createProcess cp+ case res of+ Left e -> do+ $logEx e+ return (NeedsRestart, return ())+ Right (hin, hout, herr, ph) -> do+ attach logger $ Handles hin hout herr+ log $ ProcessCreated exec+ return (Running ph, liftIO (SP.waitForProcess ph) >> loop (Just now))+ next+ forkKIO $ loop Nothing+ return $ Process mstatus+ where+ cp = (SP.proc (toString exec) $ map toString args)+ { SP.cwd = Just $ toString dir+ , SP.env = Just $ map (toString *** toString) env+ , SP.std_in = SP.CreatePipe+ , SP.std_out = SP.CreatePipe+ , SP.std_err = SP.CreatePipe+ , SP.close_fds = True+ }++-- | Abstract type containing information on a process which will be restarted.+newtype Process = Process (MVar Status)++-- | Terminate the process and prevent it from being restarted.+terminate :: Process -> KIO ()+terminate (Process mstatus) = do+ status <- swapMVar mstatus NoRestart+ case status of+ Running ph -> void $ liftIO $ SP.terminateProcess ph+ _ -> return ()
+ Keter/TempFolder.hs view
@@ -0,0 +1,33 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE OverloadedStrings #-}+module Keter.TempFolder+ ( TempFolder+ , setup+ , getFolder+ ) where++import Keter.Prelude+import Data.Word (Word)+import Keter.Postgres (Appname)+import qualified Data.IORef as I++data TempFolder = TempFolder+ { tfRoot :: FilePath+ , tfCounter :: IORef Word+ }++setup :: FilePath -> KIO (Either SomeException TempFolder)+setup fp = liftIO $ do+ e <- isDirectory fp+ when e $ removeTree fp+ createTree fp+ c <- I.newIORef minBound+ return $ TempFolder fp c++getFolder :: TempFolder -> Appname -> KIO (Either SomeException FilePath)+getFolder TempFolder {..} appname = do+ !i <- atomicModifyIORef tfCounter $ \i -> (succ i, i)+ let fp = tfRoot </> fromText (appname ++ "-" ++ show i)+ liftIO (createTree fp >> return fp)
+ LICENSE view
@@ -0,0 +1,20 @@+Copyright (c) 2012 Michael Snoyman, http://www.yesodweb.com/++Permission is hereby granted, free of charge, to any person obtaining+a copy of this software and associated documentation files (the+"Software"), to deal in the Software without restriction, including+without limitation the rights to use, copy, modify, merge, publish,+distribute, sublicense, and/or sell copies of the Software, and to+permit persons to whom the Software is furnished to do so, subject to+the following conditions:++The above copyright notice and this permission notice shall be+included in all copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,+EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF+MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND+NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE+LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION+OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION+WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ keter.cabal view
@@ -0,0 +1,55 @@+Name: keter+Version: 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/+License: MIT+License-file: LICENSE+Author: Michael Snoyman+Maintainer: michael@snoyman.com+Category: Web, Yesod+Build-type: Simple+Cabal-version: >=1.8++Library+ Build-depends: base >= 4 && < 5+ , directory+ , bytestring+ , text+ , containers+ , transformers+ , process+ , random+ , data-default+ , filepath+ , zlib+ , tar+ , network+ , time+ , template-haskell+ , blaze-builder >= 0.3 && < 0.4+ , yaml >= 0.7 && < 0.8+ , unix-compat >= 0.3 && < 0.4+ , hinotify >= 0.3 && < 0.4+ , system-filepath >= 0.4 && < 0.5+ , system-fileio >= 0.3 && < 0.4+ Exposed-Modules: Keter.Nginx+ Keter.Process+ Keter.Postgres+ Keter.TempFolder+ Keter.App+ Keter.Main+ Keter.Prelude+ Keter.LogFile+ Keter.Logger+ ghc-options: -Wall++Executable keter+ Main-is: keter.hs+ hs-source-dirs: main+ Build-depends: base, keter+ ghc-options: -threaded -Wall++source-repository head+ type: git+ location: https://github.com/snoyberg/keter
+ main/keter.hs view
@@ -0,0 +1,13 @@+{-# LANGUAGE NoImplicitPrelude #-}+import Prelude (error, (++), ($), IO)+import System.Environment (getArgs, getProgName)+import Keter.Main (keter)++main :: IO ()+main = do+ args <- getArgs+ case args of+ [dir] -> keter dir+ _ -> do+ pn <- getProgName+ error $ "Usage: " ++ pn ++ " <root folder>"