diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,3 @@ +#!/usr/bin/env runhaskell +import Distribution.Simple +main = defaultMain diff --git a/UNLICENSE b/UNLICENSE new file mode 100644 --- /dev/null +++ b/UNLICENSE @@ -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 diff --git a/scrz.cabal b/scrz.cabal new file mode 100644 --- /dev/null +++ b/scrz.cabal @@ -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 diff --git a/src/Scrz/Main.hs b/src/Scrz/Main.hs new file mode 100644 --- /dev/null +++ b/src/Scrz/Main.hs @@ -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