diff --git a/Keter/App.hs b/Keter/App.hs new file mode 100644 --- /dev/null +++ b/Keter/App.hs @@ -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 diff --git a/Keter/LogFile.hs b/Keter/LogFile.hs new file mode 100644 --- /dev/null +++ b/Keter/LogFile.hs @@ -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 diff --git a/Keter/Logger.hs b/Keter/Logger.hs new file mode 100644 --- /dev/null +++ b/Keter/Logger.hs @@ -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" diff --git a/Keter/Main.hs b/Keter/Main.hs new file mode 100644 --- /dev/null +++ b/Keter/Main.hs @@ -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' diff --git a/Keter/Nginx.hs b/Keter/Nginx.hs new file mode 100644 --- /dev/null +++ b/Keter/Nginx.hs @@ -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: . +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 diff --git a/Keter/Postgres.hs b/Keter/Postgres.hs new file mode 100644 --- /dev/null +++ b/Keter/Postgres.hs @@ -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 diff --git a/Keter/Prelude.hs b/Keter/Prelude.hs new file mode 100644 --- /dev/null +++ b/Keter/Prelude.hs @@ -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 diff --git a/Keter/Process.hs b/Keter/Process.hs new file mode 100644 --- /dev/null +++ b/Keter/Process.hs @@ -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 () diff --git a/Keter/TempFolder.hs b/Keter/TempFolder.hs new file mode 100644 --- /dev/null +++ b/Keter/TempFolder.hs @@ -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) diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/keter.cabal b/keter.cabal new file mode 100644 --- /dev/null +++ b/keter.cabal @@ -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: +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 diff --git a/main/keter.hs b/main/keter.hs new file mode 100644 --- /dev/null +++ b/main/keter.hs @@ -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 ++ " "