scrz (empty) → 0.0.0.1
raw patch · 4 files changed
+235/−0 lines, 4 filesdep +MonadRandomdep +aesondep +basesetup-changed
Dependencies added: MonadRandom, aeson, base, base16-bytestring, bytestring, conduit, containers, cryptohash, directory, filepath, friendly-time, hashable, http-conduit, http-types, mtl, network, old-locale, process, random, stm, template-haskell, text, time, unix
Files
- Setup.hs +3/−0
- UNLICENSE +24/−0
- scrz.cabal +76/−0
- src/Scrz/Main.hs +132/−0
+ Setup.hs view
@@ -0,0 +1,3 @@+#!/usr/bin/env runhaskell+import Distribution.Simple+main = defaultMain
+ UNLICENSE view
@@ -0,0 +1,24 @@+This is free and unencumbered software released into the public domain.++Anyone is free to copy, modify, publish, use, compile, sell, or+distribute this software, either in source code form or as a compiled+binary, for any purpose, commercial or non-commercial, and by any+means.++In jurisdictions that recognize copyright laws, the author or authors+of this software dedicate any and all copyright interest in the+software to the public domain. We make this dedication for the benefit+of the public at large and to the detriment of our heirs and+successors. We intend this dedication to be an overt act of+relinquishment in perpetuity of all present and future rights to this+software under copyright law.++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 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.++For more information, please refer to <http://unlicense.org/>
+ scrz.cabal view
@@ -0,0 +1,76 @@+Name: scrz+Version: 0.0.0.1++License: OtherLicense+License-file: UNLICENSE++Author: Tomas Carnecky++Synopsis: Process management and supervision daemon++Description: @scrz@ is a daemon that runs and monitors other processes.+ It is similar to djb's `daemontools`, the Ruby project `god`+ or Haskell's `Angel`.++ It's goals are to keep a set of services running, and to+ facilitate the easy configuration and restart of those+ services.++Maintainer: tomas.carnecky@gmail.com++Homepage: http://github.com/wereHamster/scrz++Stability: Stable+Category: System+Build-type: Simple++Cabal-version: >= 1.6+++Source-Repository head+ Type: git+ Location: https://github.com/wereHamster/scrz.git+++Executable scrz++ Build-depends: MonadRandom >= 0+ Build-depends: aeson >= 0+ Build-depends: base >= 4 && < 5+ Build-depends: base16-bytestring >= 0+ Build-depends: bytestring >= 0+ Build-depends: conduit >= 0+ Build-depends: containers >= 0+ Build-depends: cryptohash >= 0+ Build-depends: directory >= 0+ Build-depends: filepath >= 0+ Build-depends: friendly-time >= 0+ Build-depends: hashable >= 0+ Build-depends: http-conduit >= 0+ Build-depends: http-types >= 0+ Build-depends: mtl >= 0+ Build-depends: network >= 0+ Build-depends: old-locale >= 0+ Build-depends: process >= 0+ Build-depends: random >= 0+ Build-depends: stm >= 0+ Build-depends: template-haskell >= 0+ Build-depends: text >= 0+ Build-depends: time >= 0+ Build-depends: unix >= 0++ Hs-Source-Dirs: src++ Main-is: Scrz/Main.hs++ Extensions: BangPatterns+ Extensions: DeriveGeneric+ Extensions: DoAndIfThenElse+ Extensions: ForeignFunctionInterface+ Extensions: OverloadedStrings+ Extensions: RecordWildCards+ Extensions: RecursiveDo+ Extensions: ScopedTypeVariables+ Extensions: ViewPatterns++ Ghc-Options: -threaded -Wall
+ src/Scrz/Main.hs view
@@ -0,0 +1,132 @@+module Main where++import Control.Monad+import System.Environment+import System.Directory+import System.Posix.Process+import System.Posix.IO+import System.Posix.Terminal (openPseudoTerminal, getSlaveTerminalName)++import Control.Exception+import Control.Concurrent++import Scrz.Protocol+import Scrz.Commands+import Scrz.Image+import Scrz.Log+import Scrz.Proxy+import Scrz.Socket+import Scrz.Terminal+import Scrz.Types+import Scrz.Utils+import Scrz.Supervisor++++run :: [ String ] -> IO ()++run [ "supervisor" ] = startSupervisor Nothing+run [ "supervisor", url ] = startSupervisor (Just url)++run [ "ipvs", addr, url ] = ipvsProxy addr url++run [ "inspect", id' ] = inspectContainer id'+run [ "ps" ] = listContainers+run [ "list-containers" ] = listContainers+run [ "stop-container", id' ] = stopContainer id'+run [ "destroy-container", id' ] = destroyContainer id'+run [ "start", id' ] = startContainer id'+run [ "stop", id' ] = stopContainer id'+run [ "restart", id' ] = stopContainer id' >> startContainer id'+run [ "quit" ] = quitSupervisor+run [ "snapshot", container, image ] = snapshotContainer container image+run [ "pack-image", id' ] = packImage id'+run [ "list-images" ] = listImages+run [ "destroy-image", id' ] = destroyImage id'+run [ "download-image", url, checksum, size ] = downloadImage url checksum (read size)+++run [ "console", id' ] = do+ executeFile "lxc-console" True [ "-n", id' ] Nothing+++run [ "clone-image", localImageId, newImageId ] = do+ let srcImage = Image localImageId Nothing+ let dstImage = Image newImageId Nothing++ createDirectoryIfMissing True (imageBasePath dstImage)+ cloneImage srcImage (imageVolumePath dstImage)+++run ("run":args) = do+ (ptm, pts) <- openPseudoTerminal+ attrs <- setRawModeFd stdInput++ response <- finally (sendRunCommand ptm) (freeResources ptm pts attrs) `catch` \(_ :: SomeException) -> return ErrorResponse++ logger $ show response+ handleResponse response `onException` do+ logger $ "Got exception"+++ where+ ra = parseRunArguments (RunArgs "" [] [] Nothing) args+ pump src dst = fdRead src 999 >>= \(x, _) -> fdWrite dst x++ freeResources ptm pts attrs = do+ resetModeFd stdInput attrs+ closeFd ptm+ closeFd pts++ sendRunCommand ptm = do+ void $ forkFinally (forever $ pump ptm stdOutput) (const $ return ())+ void $ forkFinally (forever $ pump stdInput ptm) (const $ return ())++ slaveName <- getSlaveTerminalName ptm+ response <- sendCommand $ Run (runArgsImage ra) (runArgsCommand ra) slaveName (runArgsMounts ra)++ case response of+ CreateContainerResponse id' -> void $ sendCommand $ Wait id'+ _ -> return ()++ return response++ handleResponse response = do+ case response of+ CreateContainerResponse id' -> do+ imageId' <- maybe newId return (runArgsSaveAs ra)+ logger $ "Saving image under id " ++ imageId'+ void $ sendCommand $ Snapshot id' imageId'+ void $ sendCommand $ DestroyContainer id'++ _ -> do+ logger $ "Received unexpected response: " ++ show response+++run args = do+ logger $ "Unknown arguments: " ++ (show args)+++data RunArgs = RunArgs+ { runArgsImage :: String+ , runArgsCommand :: [String]+ , runArgsMounts :: [(String,String)]+ , runArgsSaveAs :: Maybe String+ } deriving (Show)++parseRunArguments :: RunArgs -> [String] -> RunArgs+parseRunArguments ra ("--save-as" : id' : args) =+ let pra = ra { runArgsSaveAs = Just id' }+ in parseRunArguments pra args++parseRunArguments ra ("--mount" : bv : mp : args) =+ let pra = ra { runArgsMounts = (bv,mp) : runArgsMounts ra }+ in parseRunArguments pra args++parseRunArguments ra (image : command) =+ ra { runArgsImage = image, runArgsCommand = command }++parseRunArguments ra [] = ra++main :: IO ()+main = getArgs >>= run