├── README.md ├── Setup.hs ├── .gitignore ├── test.sh ├── TODO.md ├── src ├── tests.txt ├── Utils.hs ├── appdeployer.hs ├── NginxUpdater.hs ├── appcontroller.hs └── Deploy │ └── Controller.hs ├── LICENSE ├── appdeploy.cabal └── .env /README.md: -------------------------------------------------------------------------------- 1 | AppDeploy 2 | ========= 3 | -------------------------------------------------------------------------------- /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | AppDeploy 2 | *.hi 3 | *.o 4 | dist/ 5 | minicontroller.hs 6 | -------------------------------------------------------------------------------- /test.sh: -------------------------------------------------------------------------------- 1 | echo "launch" 2 | echo "memcached" 3 | echo "PORT=11211" 4 | echo "" 5 | 6 | size=`wc -c $1 | cut -d " " -f 2` 7 | 8 | echo $size 9 | cat $1 10 | 11 | -------------------------------------------------------------------------------- /TODO.md: -------------------------------------------------------------------------------- 1 | # TODO 2 | 3 | ## Controller 4 | 5 | 1. Change deployer port number to be inputted by user 6 | 2. Test what happens when a deployer dies & make sure apps are re-deployed properly 7 | 8 | ## Nginx 9 | 10 | 1. Load balancing (http://wiki.nginx.org/LoadBalanceExample) 11 | 12 | ## Misc. 13 | 14 | 1. Heroku style client-side app deployment (buildpacks, command-line client, compile server, shared file-system with appcontroller, etc....) 15 | 16 | -------------------------------------------------------------------------------- /src/tests.txt: -------------------------------------------------------------------------------- 1 | 2 | Adding a deployer: yes 3 | Running an app: yes 4 | Running multiple apps: yes 5 | Running multiple apps w/ different tar files: 6 | Killing an app: yes 7 | Killing an app when multiple are running: yes 8 | App restarts when it dies: yes 9 | 10 | Update hashtable when app is added: yes 11 | Update hashtable when app is killed: yes 12 | *Update hashtable when app dies: 13 | Update nginx file when app is added: yes 14 | Update nginx file when app is killed: yes 15 | *Update nginx file when app dies: 16 | 17 | Running hails app: yes 18 | Running multiple hails apps: yes 19 | Running multiple hails apps on same port: doesn't break 20 | 21 | -------------------------------------------------------------------------------- /src/Utils.hs: -------------------------------------------------------------------------------- 1 | 2 | module Utils where 3 | 4 | import Control.Concurrent 5 | import Data.Char 6 | --import Data.String.Utils 7 | import System.IO 8 | 9 | foreverOrEOF2 :: Handle -> IO () -> IO () 10 | foreverOrEOF2 h act = do 11 | eof <- hIsEOF h 12 | if eof then 13 | return () 14 | else do 15 | act 16 | foreverOrEOF2 h act 17 | 18 | atomic :: MVar b -> IO a -> IO a 19 | atomic mtx act = withMVar mtx $ \_ -> act 20 | 21 | trim :: [Char] -> [Char] 22 | trim = triml . trimr 23 | 24 | triml :: [Char] -> [Char] 25 | triml [] = [] 26 | triml arr@(x:xs) = 27 | if (isSpace x) 28 | then triml xs 29 | else arr 30 | 31 | trimrhelper :: [Char] -> [Char] -> [Char] -> [Char] 32 | trimrhelper "" accm _ = reverse accm 33 | trimrhelper str accm total = 34 | let next = ((head str):total) 35 | in if isSpace $ head str then 36 | trimrhelper (tail str) accm next 37 | else trimrhelper (tail str) next next 38 | 39 | trimr :: [Char] -> [Char] 40 | trimr [] = [] 41 | trimr x = trimrhelper x "" "" 42 | 43 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2013, Amy Shen, Amit Levy 2 | 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions are met: 7 | 8 | * Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | 11 | * Redistributions in binary form must reproduce the above 12 | copyright notice, this list of conditions and the following 13 | disclaimer in the documentation and/or other materials provided 14 | with the distribution. 15 | 16 | * Neither the name of Amy Shen, Amit Levy nor the names of other 17 | contributors may be used to endorse or promote products derived 18 | from this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 31 | -------------------------------------------------------------------------------- /appdeploy.cabal: -------------------------------------------------------------------------------- 1 | -- Initial appdeploy.cabal generated by cabal init. For further 2 | -- documentation, see http://haskell.org/cabal/users-guide/ 3 | 4 | name: appdeploy 5 | version: 0.1.0.0 6 | -- synopsis: 7 | -- description: 8 | license: BSD3 9 | license-file: LICENSE 10 | author: Amy Shen, Amit Levy 11 | maintainer: amit@amitlevy.com 12 | -- copyright: 13 | category: System 14 | build-type: Simple 15 | extra-source-files: README.md 16 | cabal-version: >=1.10 17 | 18 | library 19 | hs-source-dirs: src 20 | build-depends: 21 | base < 6.0 22 | , bytestring 23 | , directory 24 | , hashtables 25 | , monad-peel 26 | , MissingH 27 | , mtl 28 | , network 29 | , regex-compat 30 | , process 31 | , transformers 32 | exposed-modules: 33 | Deploy.Controller 34 | default-language: Haskell2010 35 | 36 | executable appdeployer 37 | main-is: appdeployer.hs 38 | GHC-options: -threaded -Wall 39 | -- other-modules: 40 | build-depends: 41 | base < 6.0 42 | , directory 43 | , filepath 44 | , hashtables 45 | , MissingH 46 | , network 47 | , process 48 | , split 49 | , bytestring 50 | , tar 51 | , temporary 52 | , time 53 | hs-source-dirs: src 54 | default-language: Haskell2010 55 | 56 | executable appcontroller 57 | main-is: appcontroller.hs 58 | GHC-options: -threaded -Wall 59 | -- other-modules: 60 | build-depends: 61 | base < 6.0 62 | , bytestring 63 | , directory 64 | , hashtables 65 | , MissingH 66 | , network 67 | , monad-peel 68 | , mtl 69 | , temporary 70 | , transformers 71 | , process 72 | , regex-compat 73 | , split 74 | hs-source-dirs: src 75 | default-language: Haskell2010 76 | -------------------------------------------------------------------------------- /.env: -------------------------------------------------------------------------------- 1 | XDG_SEAT_PATH=/org/freedesktop/DisplayManager/Seat0 2 | XDG_CONFIG_DIRS=/etc/xdg/xdg-ubuntu:/etc/xdg 3 | LANG=en_US.UTF-8 4 | PWD=/home/ryan/hails/AppDeploy 5 | DISPLAY=:0 6 | LOGNAME=ryan 7 | COMPIZ_CONFIG_PROFILE=ubuntu 8 | MANDATORY_PATH=/usr/share/gconf/ubuntu.mandatory.path 9 | GNOME_KEYRING_PID=1833 10 | XAUTHORITY=/home/ryan/.Xauthority 11 | COLORTERM=gnome-terminal 12 | DESKTOP_SESSION=ubuntu 13 | DEFAULTS_PATH=/usr/share/gconf/ubuntu.default.path 14 | GDMSESSION=ubuntu 15 | GNOME_KEYRING_CONTROL=/run/user/ryan/keyring-zDy28e 16 | TEXTDOMAINDIR=/usr/share/locale/ 17 | GNOME_DESKTOP_SESSION_ID=this-is-deprecated 18 | TEXTDOMAIN=im-config 19 | COMPIZ_BIN_PATH=/usr/bin/ 20 | DBUS_SESSION_BUS_ADDRESS=unix:abstract=/tmp/dbus-4vlYBFQgIa,guid=ec27263665ee0411fa2915b1521d1468 21 | UBUNTU_MENUPROXY=libappmenu.so 22 | XDG_DATA_DIRS=/usr/share/ubuntu:/usr/share/gnome:/usr/local/share/:/usr/share/ 23 | XDG_SESSION_COOKIE=360bfd26a6466112419be11151ededaa-1377637480.926176-494139605 24 | SHELL=/bin/zsh 25 | WINDOWID=35651589 26 | SSH_AGENT_PID=1889 27 | GTK_MODULES=overlay-scrollbar 28 | SESSION_MANAGER=local/ryan-Dell-System-XPS-L502X:@/tmp/.ICE-unix/1844,unix/ryan-Dell-System-XPS-L502X:/tmp/.ICE-unix/1844 29 | SSH_AUTH_SOCK=/run/user/ryan/keyring-zDy28e/ssh 30 | PATH=/usr/lib/lightdm/lightdm:/usr/local/sbin:/usr/local/bin:/usr/sbin:/usr/bin:/sbin:/bin:/usr/games:/usr/local/games:/usr/lib/lightdm/lightdm:/usr/local/sbin:/usr/local/bin:/usr/sbin:/usr/bin:/sbin:/bin:/usr/games:/usr/local/games:/home/ryan/.cabal/bin 31 | XDG_CURRENT_DESKTOP=Unity 32 | TERM=xterm 33 | HOME=/home/ryan 34 | USER=ryan 35 | XDG_RUNTIME_DIR=/run/user/ryan 36 | XDG_SESSION_PATH=/org/freedesktop/DisplayManager/Session0 37 | GPG_AGENT_INFO=/run/user/ryan/keyring-zDy28e/gpg:0:1 38 | SHLVL=1 39 | OLDPWD=/home/ryan 40 | GREP_OPTIONS=--color=auto 41 | GREP_COLOR=1;32 42 | PAGER=less 43 | LESS=-R 44 | LC_CTYPE=en_US.UTF-8 45 | LSCOLORS=Gxfxcxdxbxegedabagacad 46 | WORKON_HOME=/home/ryan/.virtualenvs 47 | VIRTUALENVWRAPPER_PROJECT_FILENAME=.project 48 | VIRTUALENVWRAPPER_HOOK_DIR=/home/ryan/.virtualenvs 49 | PIP_VIRTUALENV_BASE=/home/ryan/.virtualenvs 50 | _=/usr/bin/env 51 | -------------------------------------------------------------------------------- /src/appdeployer.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import Control.Exception 4 | import Control.Monad 5 | import System.FilePath 6 | import System.Directory 7 | import System.Process 8 | import Control.Concurrent 9 | import Data.List.Split 10 | import qualified Data.HashTable.IO as H 11 | import qualified Data.ByteString.Lazy as L 12 | import Data.Time.Clock 13 | import qualified Codec.Archive.Tar as Tar 14 | import Network 15 | import System.Environment 16 | import System.IO 17 | import System.IO.Unsafe 18 | import Utils 19 | 20 | -- hashtable of app identifiers and process handles 21 | ht :: (H.BasicHashTable Int ProcessHandle) 22 | {-# NOINLINE ht #-} 23 | ht = unsafePerformIO $ H.new 24 | 25 | tmpDir :: FilePath 26 | tmpDir = "tmp" 27 | 28 | main :: IO () 29 | main = do 30 | portstr <- head `fmap` getArgs 31 | let port = PortNumber $ toEnum $ read portstr 32 | bracket (listenOn port) sClose $ \s -> do 33 | exists <- doesDirectoryExist tmpDir 34 | when exists $ removeDirectoryRecursive tmpDir 35 | createDirectory tmpDir 36 | 37 | htMutex <- newMVar 0 38 | forever $ do 39 | (h, _, _) <- accept s 40 | forkIO $ handleConnection h htMutex 41 | `finally` hClose h 42 | 43 | handleConnection :: Handle -> MVar Int -> IO () 44 | handleConnection h htMutex = foreverOrEOF2 h $ do 45 | cmd <- trim `fmap` hGetLine h 46 | case cmd of 47 | "statuses" -> do -- prints list of processes 48 | statusList <- atomic htMutex $ H.toList ht 49 | hPutStrLn h (show $ map fst statusList) 50 | "launch" -> do -- prints pid 51 | putStrLn "launch called!" 52 | -- format: 53 | -- shell cmd 54 | -- identifier (as an int) 55 | -- var1=val1 56 | -- var2=val2 57 | -- ... 58 | -- 59 | -- num bytes 60 | -- tar data 61 | shellcmd <- trim `fmap` hGetLine h 62 | putStrLn $ "SHELL: " ++ (show shellcmd) 63 | identifier <- (read . trim) `fmap` hGetLine h 64 | putStrLn $ "ID: " ++ (show (identifier :: Int)) 65 | envs <- readenvs h 66 | nbytes <- read `fmap` hGetLine h 67 | tarfile <- L.hGet h nbytes 68 | let entries = Tar.read tarfile 69 | Tar.unpack tmpDir entries 70 | void $ forkIO $ startApp htMutex shellcmd envs tmpDir identifier 0 71 | "kill" -> atomic htMutex $ do -- OK or NOT FOUND 72 | -- format: 73 | -- app identifier 74 | key <- (read . trim) `fmap` hGetLine h 75 | mPHandle <- H.lookup ht key 76 | case mPHandle of 77 | Nothing -> hPutStrLn h "NOT FOUND" 78 | Just pHandle -> do 79 | terminateProcess pHandle 80 | H.delete ht key 81 | hPutStrLn h "OK" 82 | _ -> do 83 | hPutStrLn h $ "INVALID COMMAND (" ++ cmd ++ ")" 84 | 85 | startApp :: MVar Int 86 | -> String -- Command 87 | -> [(String, String)] -- Environment 88 | -> FilePath -- cwd 89 | -> Int -- Identifier 90 | -> Int -- Retries 91 | -> IO () 92 | startApp htMutex command envs cwdpath identifier retries = when (retries < 5) $ do 93 | output <- openFile (cwdpath "log.out") AppendMode 94 | err <- openFile (cwdpath "log.err") AppendMode 95 | input <- openFile "/dev/null" ReadMode 96 | let createProc = (shell command) { env = Just envs 97 | , cwd = Just cwdpath 98 | , std_in = UseHandle input 99 | , std_out = UseHandle output 100 | , std_err = UseHandle err } 101 | pHandle <- atomic htMutex $ do 102 | (_, _, _, pHandle) <- createProcess createProc 103 | hClose output 104 | hClose err 105 | hClose input 106 | H.insert ht identifier pHandle 107 | return pHandle 108 | startTime <- getCurrentTime 109 | _ <- waitForProcess pHandle 110 | endTime <- getCurrentTime 111 | mPHandle <- withMVar htMutex $ \_ -> H.lookup ht identifier 112 | case mPHandle of 113 | Nothing -> removeDirectoryRecursive cwdpath 114 | Just _ -> do 115 | atomic htMutex $ H.delete ht identifier 116 | removeFromController command identifier 117 | let nextRetries = if (diffUTCTime endTime startTime < 30) then 118 | retries + 1 119 | else 0 120 | startApp htMutex command envs cwdpath identifier nextRetries 121 | 122 | 123 | -- Utils 124 | 125 | removeFromController :: Show a => String -> a -> IO () 126 | removeFromController appname identifier = do 127 | let hostname = "localhost" -- hostname of the app controller 128 | port = PortNumber 1234 -- port of the app controller 129 | h <- connectTo hostname port -- handle for the app controller 130 | hPutStrLn h "remove" 131 | hPutStrLn h appname 132 | hPutStrLn h $ show identifier 133 | 134 | readenvs :: Handle -> IO [(String,String)] 135 | readenvs h = go h [] 136 | where go hand list = do 137 | line <- trim `fmap` hGetLine hand 138 | putStrLn line 139 | if line == "" then 140 | return $ reverse list 141 | else go hand $ (parseEnv line):list 142 | 143 | parseEnv :: String -> (String, String) 144 | parseEnv envString = 145 | let (key:value:[]) = splitOn "=" envString 146 | in (key, value) 147 | 148 | -------------------------------------------------------------------------------- /src/NginxUpdater.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TypeSynonymInstances, FlexibleInstances, MultiParamTypeClasses #-} 2 | 3 | module NginxUpdater where 4 | 5 | import Data.Maybe 6 | import Debug.Trace 7 | import Data.List 8 | import System.Directory 9 | import System.IO 10 | import System.Process 11 | import Text.Regex 12 | 13 | type AppName = String 14 | 15 | data DeployInfo = DeployInfo { 16 | identifier :: Int, 17 | hostname :: String, 18 | portnum :: Int 19 | } deriving Show 20 | 21 | class Monad m => Table d m where 22 | addEntry :: d -> AppName -> DeployInfo -> m () 23 | removeEntry :: d -> AppName -> DeployInfo -> m () 24 | lookup :: d -> AppName -> m (Maybe DeployInfo) 25 | 26 | 27 | instance Table FilePath IO where 28 | 29 | addEntry filepath appname deployinfo = do 30 | trace "===nginx: addEntry===" $ return () 31 | oldh <- openFile filepath ReadWriteMode -- handle to current config file 32 | trace "addEntry: opened current file" $ return () 33 | let tmppath = filepath ++ ".new" -- temporary; will be copied back to filepath at the end 34 | newh <- openFile tmppath ReadWriteMode -- handle to modified config file 35 | trace "addEntry: opened tmp file" $ return () 36 | let starttag = "# START: " ++ appname ++ (show $ identifier deployinfo) 37 | endtag = "# END: " ++ appname ++ (show $ identifier deployinfo) 38 | let code = starttag ++ "\n" ++ -- new code to add to the config file 39 | " server { \n\ 40 | \ listen 8080; \n\ 41 | \ server_name " ++ appname ++ ".lvh.me; \n " ++ 42 | " location / { \n\ 43 | \ proxy_pass http://localhost:1234; \n\ 44 | \ } \n\ 45 | \ } \n" 46 | ++ endtag 47 | insertAt "http {" code oldh newh 48 | hClose newh 49 | hClose oldh 50 | renameFile filepath (filepath ++ ".backup") 51 | renameFile tmppath filepath 52 | restartNginx 53 | where insertAt tag newtext oldh newh = do 54 | eof <- hIsEOF oldh 55 | if eof then do 56 | hPutStrLn newh "http {" 57 | hPutStrLn newh newtext 58 | hPutStrLn newh "}" 59 | return () 60 | else do 61 | line <- hGetLine oldh 62 | hPutStrLn newh line 63 | if (isInfixOf tag line) then do -- if the http tag is part of the line 64 | hPutStrLn newh newtext 65 | copyRemainder oldh newh -- copy the rest of the old file into the new file 66 | else insertAt tag newtext oldh newh 67 | copyRemainder oldh newh = do -- copy the remainder of oldh's file into newh's file 68 | eof <- hIsEOF oldh 69 | if eof then return () else do 70 | line <- hGetLine oldh 71 | hPutStrLn newh line 72 | copyRemainder oldh newh 73 | 74 | removeEntry filepath appname deployinfo = do 75 | let starttag = "# START: " ++ appname ++ (show $ identifier deployinfo) 76 | endtag = "# END: " ++ appname ++ (show $ identifier deployinfo) 77 | let backuppath = filepath ++ ".backup" 78 | renameFile filepath backuppath 79 | oldh <- openFile backuppath ReadWriteMode 80 | newh <- openFile filepath ReadWriteMode 81 | processFile oldh newh starttag endtag True 82 | hClose oldh 83 | hClose newh 84 | restartNginx 85 | where processFile oldh newh starttag endtag copymode = do 86 | eof <- hIsEOF oldh 87 | if eof then return () else do 88 | line <- hGetLine oldh 89 | --trace ("line: " ++ line) $ return () 90 | --trace ("copymode: " ++ show copymode) $ return () 91 | if (isInfixOf starttag line || isInfixOf endtag line) then 92 | processFile oldh newh starttag endtag $ not copymode 93 | else do 94 | if copymode then hPutStrLn newh line 95 | else return () 96 | processFile oldh newh starttag endtag copymode 97 | 98 | lookup filepath appname = do 99 | -- todo: decide whether to add the app identifier as a parameter (there could be multiple instances of an app running) 100 | handle <- openFile filepath ReadWriteMode 101 | lookuphelper appname handle 102 | where lookuphelper app h = do 103 | -- this looks for the start tag. if found, it calls getDeployInfo to get the deploy info; if not, return Nothing because the app is not running. 104 | eof <- hIsEOF h 105 | if eof then return Nothing 106 | else do 107 | line <- hGetLine h 108 | let starttag = "# START: " ++ appname 109 | if (isInfixOf starttag line) then do 110 | let matches = matchRegex (mkRegex (appname ++ "([0-9]+)")) line 111 | appidentifier = read $ head $ fromJust matches 112 | getDeployInfo h appidentifier Nothing -- found start tag; now get deploy info 113 | else lookuphelper app h 114 | getDeployInfo h identifier mhostname = do 115 | -- parse an app's config info to get its deploy info 116 | line <- hGetLine h 117 | case mhostname of 118 | Just hostname -> -- found the hostname; now find the port number 119 | if (isInfixOf "proxy_pass" line) then 120 | let matches = fromJust $ matchRegex (mkRegex "http://[a-zA-Z0-9]+:([0-9]+);") line 121 | -- matches = ["1234"] or whatever the portnum is 122 | in return $ Just $ DeployInfo identifier hostname $ read $ head matches 123 | else getDeployInfo h identifier mhostname 124 | Nothing -> -- hostname is still unknown; find the hostname 125 | if (isInfixOf "server_name" line) then 126 | let pattern = mkRegex "server_name[[:space:]]+([a-z[:punct:]]+);" 127 | hostname = head $ fromJust $ matchRegex pattern line 128 | in getDeployInfo h identifier $ Just hostname 129 | else getDeployInfo h identifier Nothing 130 | 131 | restartNginx :: IO () 132 | restartNginx = do 133 | let createProc = shell "nginx -s reload" 134 | (_, _, _, _) <- createProcess createProc -- the last underscore is a handle 135 | return () 136 | 137 | -------------------------------------------------------------------------------- /src/appcontroller.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import Control.Concurrent 4 | import Control.Exception 5 | import Control.Monad 6 | import Control.Monad.IO.Class 7 | import Control.Monad.Trans.State 8 | import qualified Data.HashTable.IO as H 9 | import qualified Data.ByteString as S 10 | import qualified Data.ByteString.Char8 as S8 11 | import Data.String.Utils 12 | import Network 13 | import System.IO 14 | import Deploy.Controller 15 | import Utils 16 | 17 | 18 | main :: IO () 19 | main = bracket (listenOn $ PortNumber 1234) sClose $ \s -> forever $ do 20 | jobMutex <- newMVar 0 -- for job backup file 21 | deployerMutex <- newMVar () -- for deployer backup file 22 | nginxMutex <- newMVar () -- for nginx config file 23 | (h, _, _) <- accept s 24 | jobs <- fillJobsFromFile jobFile jobMutex 25 | deployers <- fillDeployerFromFile deployerFile deployerMutex 26 | let cstate = ControllerState jobs deployers 27 | forkIO $ flip evalStateT cstate $ forever $ do -- thread to monitor deployers 28 | deployerht <- gets ctrlDeployers 29 | jobht <- gets ctrlJobs 30 | liftIO $ atomic deployerMutex $ flip H.mapM_ deployerht $ \pair -> do -- pair = (did, mdep) 31 | alive <- checkDeployer deployerht jobht jobMutex nginxMutex pair 32 | if alive then return () -- deployer is fine 33 | else evalStateT (removeDeployer (fst pair) deployerMutex jobMutex nginxMutex) cstate 34 | return () 35 | forkIO $ do 36 | _ <- execStateT (handleConnection h jobMutex deployerMutex nginxMutex) cstate 37 | hClose h 38 | return () 39 | 40 | handleConnection :: Handle -> MVar Int -> MVar () -> MVar () -> Controller () 41 | handleConnection chandle jobMutex deployerMutex nginxMutex = foreverOrEOF chandle $ do 42 | cmd <- liftIO $ trim `fmap` hGetLine chandle 43 | case cmd of 44 | "statuses" -> do -- show statuses of all app deployers in the hashtable 45 | deployerht <- gets ctrlDeployers -- ht of dId's and deployers 46 | liftIO $ do 47 | deployerList <- H.toList deployerht 48 | mdeployers <- mapM (readMVar . snd) deployerList -- list of mvar deployers 49 | hPutStrLn chandle $ show $ map deployerId mdeployers 50 | "deployer" -> do -- show statuses of all apps of a deployer 51 | -- format: 52 | -- hostname 53 | -- port num 54 | hostname <- liftIO $ trim `fmap` hGetLine chandle 55 | deployerPort <- liftIO $ (read . trim) `fmap` hGetLine chandle 56 | estats <- deployerStats (hostname, deployerPort) 57 | liftIO $ case estats of 58 | Left msg -> hPutStrLn chandle msg 59 | Right msg -> hPutStrLn chandle $ S8.unpack msg 60 | "run" -> do -- run an app 61 | -- format: 62 | -- app name 63 | -- shell command to be run 64 | -- var1=val1 65 | -- var2=val2 66 | -- ... 67 | -- 68 | -- size of tar file 69 | -- tar file path 70 | appname <- liftIO $ (S8.pack . trim) `fmap` hGetLine chandle 71 | cmd <- liftIO $ (S8.pack . trim) `fmap` hGetLine chandle 72 | envs <- liftIO $ readEnvs chandle 73 | filesize <- liftIO $ (read . trim) `fmap` hGetLine chandle 74 | filename <- liftIO $ trim `fmap` hGetLine chandle 75 | tarBS <- liftIO $ S.readFile filename -- convert to bytestring 76 | appId <- liftIO $ modifyMVar jobMutex (\a -> return (a + 1, a)) 77 | let tarwriter dput = dput tarBS 78 | let job = Job appId appname cmd envs filesize filename tarwriter 79 | msg <- deployJob job jobMutex nginxMutex 80 | liftIO $ hPutStrLn chandle msg 81 | "add" -> do -- add a new deployer 82 | -- format: 83 | -- hostname 84 | -- deployer's port number 85 | --liftIO $ do 86 | hostname <- liftIO $ trim `fmap` hGetLine chandle 87 | dPort <- liftIO $ trim `fmap` hGetLine chandle 88 | dhandle <- liftIO $ connectTo hostname $ toPortId dPort -- handle for the app deployer 89 | deployer <- liftIO $ deployerFromHandle (hostname, read dPort) dhandle 90 | addDeployer deployer deployerMutex 91 | "kill" -> do -- kill an app 92 | -- format: 93 | -- app name 94 | -- appId 95 | appname <- liftIO $ trim `fmap` hGetLine chandle 96 | appId <- liftIO $ (read . trim) `fmap` hGetLine chandle 97 | eresponse <- killJob appId appname jobMutex nginxMutex 98 | liftIO $ case eresponse of 99 | Right () -> do -- success 100 | hPutStrLn chandle "Done" 101 | Left error -> hPutStrLn chandle error 102 | "remove" -> do 103 | -- remove an app from the ht (deployer will invoke this function when an app dies without the kill command) 104 | -- format: 105 | -- app name 106 | -- appId 107 | appname <- liftIO $ trim `fmap` hGetLine chandle 108 | appId <- liftIO $ (read . trim) `fmap` hGetLine chandle 109 | removeJob appId appname jobMutex nginxMutex 110 | _ -> do 111 | liftIO $ hPutStrLn chandle $ "INVALID COMMAND: " ++ cmd 112 | 113 | 114 | -- Utils 115 | 116 | foreverOrEOF :: Handle -> Controller () -> Controller () 117 | foreverOrEOF h act = do 118 | eof <- liftIO $ hIsEOF h 119 | if eof then 120 | return () 121 | else do 122 | act 123 | foreverOrEOF h act 124 | 125 | -- return a hashtable with deployerId's and deployers from the backup file 126 | fillDeployerFromFile :: FilePath -> MVar () -> IO DeployerHt 127 | fillDeployerFromFile filepath mutex = do 128 | h <- atomic mutex $ openFile filepath ReadWriteMode 129 | ht <- H.new 130 | foreverOrEOF2 h $ do 131 | idStr <- trim `fmap` hGetLine h 132 | let [hostname, dport] = split "," idStr 133 | did = (hostname, read dport) 134 | dhandle <- connectTo hostname $ toPortId dport 135 | deployer <- deployerFromHandle did dhandle 136 | mdeployer <- newMVar deployer 137 | atomic mutex $ H.insert ht did mdeployer -- hostname = deployer id 138 | hClose h 139 | return ht 140 | 141 | -- return a hashtable with jobId's and deployers from the backup file 142 | fillJobsFromFile :: FilePath -> MVar Int -> IO JobHt 143 | fillJobsFromFile filepath mutex = do 144 | h <- atomic mutex $ openFile filepath ReadWriteMode 145 | ht <- H.new 146 | foreverOrEOF2 h $ do 147 | entry <- atomic mutex $ trim `fmap` hGetLine h 148 | let [jid, appname, cmd, tarsize, tarfile, hostname, deployerPort] = split "," entry 149 | envs <- readEnvs h 150 | tarBS <- S.readFile tarfile -- convert to bytestring 151 | let tarwriter dput = dput tarBS 152 | let job = Job (read jid) (S8.pack appname) (S8.pack cmd) envs (read tarsize) tarfile tarwriter 153 | dhandle <- connectTo hostname $ toPortId deployerPort 154 | deployer <- deployerFromHandle (hostname, read deployerPort) dhandle 155 | mdeployer <- newMVar deployer 156 | H.insert ht job mdeployer -- hostname = deployer id 157 | eof <- hIsEOF h 158 | if eof then do 159 | takeMVar mutex 160 | putMVar mutex (read jid + 1) 161 | else return () 162 | hClose h 163 | return ht 164 | 165 | -- Checks to see if a deployer is alive 166 | checkDeployer :: DeployerHt -> JobHt -> MVar Int -> MVar () -> (DeployerId, MVar Deployer) -> IO Bool 167 | checkDeployer deployerht jobht jobMutex nginxMutex (did, mdeployer) = do 168 | result <- try $ connectTo (fst did) (PortNumber $ toEnum $ snd did) 169 | case (result :: Either IOException Handle) of 170 | Left _ -> do 171 | return False 172 | Right handle -> return True 173 | 174 | readEnvs :: Handle -> IO String 175 | readEnvs handle = do 176 | str <- readEnvHelper handle "" 177 | return str 178 | where readEnvHelper h envs = do 179 | line <- trim `fmap` hGetLine h 180 | case line of 181 | "" -> return envs 182 | env -> readEnvHelper h (envs ++ env ++ "\n") 183 | 184 | toPortId str = PortNumber $ toEnum $ read str 185 | -------------------------------------------------------------------------------- /src/Deploy/Controller.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings, ScopedTypeVariables #-} 2 | module Deploy.Controller where 3 | 4 | import Control.Applicative 5 | import Control.Concurrent.MVar 6 | import Control.Monad 7 | import Control.Monad.IO.Class 8 | import Control.Monad.ST.Safe 9 | import Control.Exception.Peel 10 | import qualified Data.ByteString as S 11 | import qualified Data.ByteString.Char8 as S8 12 | import Data.Hashable 13 | import qualified Data.HashTable.IO as H 14 | import qualified Data.HashTable.ST.Basic as HST 15 | import Data.Maybe 16 | import Data.Monoid 17 | import Control.Monad.Trans.State 18 | import System.IO 19 | import NginxUpdater 20 | import Utils 21 | 22 | type JobId = Int 23 | 24 | type DeployerId = (String, Int) 25 | 26 | nginxfile :: String 27 | nginxfile = "nginx.conf" 28 | 29 | jobFile :: FilePath -- backup of the ctrlJobs hashtable, with key/value pairs separated by commas 30 | jobFile = "jobinfo.txt" 31 | 32 | deployerFile :: FilePath -- list of all the deployer id's 33 | deployerFile = "deployerinfo.txt" 34 | 35 | data Deployer = Deployer { deployerId :: DeployerId -- aka hostname 36 | , deployerPut :: S.ByteString -> IO () 37 | , deployerGet :: Int -> IO S.ByteString 38 | , deployerGetLine :: IO S.ByteString 39 | , deployerClose :: IO () } 40 | 41 | deployerFromHandle :: DeployerId -> Handle -> IO Deployer 42 | deployerFromHandle did handle = return $ 43 | Deployer { deployerId = did 44 | , deployerPut = S.hPut handle 45 | , deployerGet = S.hGet handle 46 | , deployerGetLine = S.hGetLine handle 47 | , deployerClose = hClose handle } 48 | 49 | type DeployerStatus = Int 50 | 51 | data Job = Job { jobId :: JobId 52 | , jobName :: S.ByteString -- the name of the app 53 | , jobCommand :: S.ByteString -- the shell command to be run 54 | , jobEnvs :: String -- environment vars, separated by newlines 55 | , jobTarballSize :: Integer 56 | , jobTarballName :: String 57 | , jobTarballWriter :: (S.ByteString -> IO ()) -> IO () -- takes in deployerPut function and writes tarball to deployer 58 | } 59 | 60 | instance Hashable Job where 61 | hashWithSalt s job = hashWithSalt s $ jobId job 62 | 63 | instance Eq Job where 64 | a == b = (jobId a) == (jobId b) 65 | 66 | 67 | type JobHt = H.BasicHashTable Job (MVar Deployer) -- job id's and their deployers 68 | type DeployerHt = H.BasicHashTable DeployerId (MVar Deployer) -- deployer ids and deployers 69 | 70 | data ControllerState = ControllerState 71 | { ctrlJobs :: JobHt 72 | , ctrlDeployers :: DeployerHt } 73 | 74 | type Controller = StateT ControllerState IO -- stores a ControllerState along with every action 75 | 76 | removeDeployer :: DeployerId -> MVar () -> MVar Int -> MVar () -> Controller () 77 | removeDeployer did depMutex jobMutex nginxMutex = do 78 | deployers <- gets ctrlDeployers 79 | jobht <- gets ctrlJobs 80 | md <- liftIO $ stToIO $ do 81 | md <- HST.lookup deployers did -- the mvar deployer 82 | when (isJust md) $ HST.delete deployers did -- deployer exists, so delete it from ht 83 | return md 84 | when (isJust md) $ do 85 | joblist <- liftIO $ H.toList jobht 86 | flip mapM joblist $ \(job, mdep) -> -- re-deploy jobs 87 | if mdep == (fromJust md) then deployJob job jobMutex nginxMutex 88 | else return "" 89 | liftIO $ do 90 | updateDeployerFile deployers deployerFile depMutex -- update the file backup 91 | withMVar (fromJust md) deployerClose -- close the handle 92 | return () 93 | 94 | addDeployer :: Deployer -> MVar () -> Controller () 95 | addDeployer deployer mutex = do 96 | deployers <- gets ctrlDeployers 97 | liftIO $ do 98 | mdeployer <- newMVar deployer 99 | H.insert deployers (deployerId deployer) mdeployer 100 | updateDeployerFile deployers deployerFile mutex 101 | --addDeployerToFile deployerFile (deployerId deployer) mutex 102 | 103 | chooseDeployer :: Job -> Controller (MVar Deployer) 104 | chooseDeployer job = do 105 | deployers <- liftIO . H.toList =<< gets ctrlDeployers 106 | let mdeployer = snd $ deployers !! (jobId job `mod` (length deployers)) 107 | --let mdeployer = snd $ deployers !! (jobId job `mod` (length deployers)) 108 | isEmpty <- liftIO $ isEmptyMVar mdeployer 109 | return . snd $ deployers !! (jobId job `mod` (length deployers)) 110 | 111 | withDeployer :: Maybe (Controller a) -> MVar Deployer -> (Deployer -> Controller a) -> Controller a 112 | withDeployer mretry mdeployer func = do 113 | bracket (liftIO $ takeMVar mdeployer) (liftIO . putMVar mdeployer) $ \deployer -> do 114 | -- get the mdeployer out of its mvar, do the stuff below, and then put it back 115 | func deployer `catch` -- what happens if the deployer is down or whatever 116 | (\(e :: IOException) -> do 117 | deployers <- gets ctrlDeployers 118 | liftIO $ H.delete deployers $ deployerId deployer 119 | case mretry of 120 | Nothing -> liftIO $ throwIO e 121 | Just retry -> retry) 122 | 123 | crlf :: S.ByteString 124 | crlf = "\r\n" 125 | 126 | deployJob :: Job -> MVar Int -> MVar () -> Controller String 127 | deployJob job jobMutex nginxMutex = do 128 | md <- chooseDeployer job 129 | withDeployer (Just $ deployJob job jobMutex nginxMutex) md $ \deployer -> do -- to retry, just run deployJob again 130 | liftIO $ do 131 | deployerPut deployer $ 132 | "launch" <> crlf 133 | <> jobCommand job <> crlf 134 | <> (S8.pack $ show $ jobId job) <> crlf 135 | <> (S8.pack $ jobEnvs job) 136 | <> crlf 137 | <> (S8.pack . show $ jobTarballSize job) <> crlf 138 | jobTarballWriter job $ deployerPut deployer 139 | let jobname = S8.unpack $ jobName job 140 | atomic nginxMutex $ 141 | let (dhost, dport) = deployerId deployer in 142 | addEntry nginxfile jobname $ DeployInfo (jobId job) dhost dport 143 | jobs <- gets ctrlJobs 144 | liftIO $ do 145 | H.insert jobs job md 146 | addJobToFile jobFile job deployer jobMutex 147 | return ("Launched new job with ID: " ++ (show $ jobId job)) 148 | 149 | killJob :: JobId -> String -> MVar Int -> MVar () -> Controller (Either String ()) 150 | killJob jid jobname jobMutex nginxMutex = do 151 | jobs <- gets ctrlJobs -- job id's + deployers 152 | md <- liftIO $ lookupById jobs jid 153 | case md of 154 | Nothing -> return . Left $ "No job found with id " ++ (show jid) 155 | Just dmv -> do 156 | liftIO $ do 157 | atomic jobMutex $ deleteById jobs jid jobMutex 158 | updateJobFile jobs jobFile jobMutex 159 | withDeployer Nothing dmv $ \deployer -> liftIO $ do -- dmv = deployer mvar 160 | atomic nginxMutex $ 161 | let (dhost, dport) = deployerId deployer in 162 | removeEntry nginxfile jobname $ DeployInfo jid dhost dport 163 | deployerPut deployer $ "kill" <> crlf <> (S8.pack $ show jid) <> crlf 164 | ln <- deployerGetLine deployer 165 | if ln == "NOT FOUND" then 166 | return . Left $ "Job " ++ (show jid) ++ " not found on deployer" 167 | else return $ Right () 168 | 169 | deployerStats :: DeployerId -> Controller (Either String S.ByteString) 170 | deployerStats did = do 171 | deployers <- gets ctrlDeployers 172 | mdvar <- liftIO $ H.lookup deployers did 173 | case mdvar of 174 | Nothing -> return $ Left $ "No deployer with id " ++ (show did) 175 | Just dvar -> do 176 | liftIO $ withMVar dvar $ \deployer -> do 177 | deployerPut deployer $ "statuses" <> crlf 178 | Right <$> deployerGetLine deployer 179 | 180 | removeJob :: JobId -> String -> MVar Int -> MVar () -> Controller () 181 | removeJob jobId jobName jobMutex nginxMutex = do 182 | jobs <- gets ctrlJobs -- job id's + deployers 183 | md <- liftIO $ lookupById jobs jobId -- deployer 184 | case md of 185 | Nothing -> return () 186 | Just dmv -> withDeployer Nothing dmv $ \deployer -> liftIO $ do -- dmv = deployer mvar 187 | atomic jobMutex $ deleteById jobs jobId jobMutex 188 | atomic nginxMutex $ 189 | let (dhost, dport) = deployerId deployer in 190 | removeEntry nginxfile jobName $ DeployInfo jobId dhost dport 191 | updateJobFile jobs jobFile jobMutex 192 | 193 | -- replace the existing file with the contents of the hashtable 194 | updateDeployerFile :: DeployerHt -> FilePath -> MVar () -> IO () 195 | updateDeployerFile ht filepath mutex = do 196 | h <- atomic mutex $ openFile filepath WriteMode -- overwrite anything that's currently in the file 197 | list <- H.toList ht 198 | _ <- mapM (\(did, mvar) -> atomic mutex $ hPutStrLn h (fst did ++ "," ++ (show $ snd did))) list 199 | hClose h 200 | 201 | --type DeployerHt = H.BasicHashTable DeployerId (MVar Deployer) -- deployer ids and deployers 202 | 203 | -- back up the jobId and its deployer's id to a file 204 | addJobToFile :: FilePath -> Job -> Deployer -> MVar Int -> IO () 205 | addJobToFile filepath job deployer mutex = do 206 | h <- atomic mutex $ openFile filepath AppendMode 207 | atomic mutex $ hPutStrLn h (stringify job deployer) 208 | hClose h 209 | 210 | updateJobFile :: JobHt -> FilePath -> MVar Int -> IO () 211 | updateJobFile ht filepath mutex = do 212 | h <- atomic mutex $ openFile filepath WriteMode -- overwrite anything that's currently in the file 213 | list <- H.toList ht 214 | _ <- mapM (addToFile h) list 215 | hClose h 216 | where addToFile h (job, mdeployer) = do 217 | deployer <- readMVar mdeployer 218 | hPutStrLn h (stringify job deployer) 219 | 220 | stringify job deployer = 221 | (show $ jobId job) ++ "," ++ (S8.unpack $ jobName job) ++ "," ++ 222 | (S8.unpack $ jobCommand job) ++ "," ++ (show $ jobTarballSize job) ++ "," ++ 223 | jobTarballName job ++ "," ++ (fst $ deployerId deployer) ++ "," ++ 224 | (show $ snd $ deployerId deployer) ++ "\n" ++ jobEnvs job 225 | -- env vars are separated by newlines 226 | 227 | lookupById :: JobHt -> JobId -> IO (Maybe (MVar Deployer)) 228 | lookupById ht jid = do 229 | list <- H.toList ht 230 | let matches = filter (\(job, md) -> jobId job == jid) list 231 | case matches of 232 | [] -> return Nothing 233 | justmd -> return $ Just $ snd $ head matches 234 | 235 | deleteById :: JobHt -> JobId -> MVar Int -> IO () 236 | deleteById ht jid mutex = do 237 | list <- H.toList ht 238 | let matches = filter (\(job, md) -> jobId job == jid) list 239 | flip mapM_ matches $ \(job, md) -> H.delete ht job 240 | return () 241 | 242 | --------------------------------------------------------------------------------