diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,20 @@ +Copyright (c) 2014 Tomas Carnecky + +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/appc.cabal b/appc.cabal new file mode 100644 --- /dev/null +++ b/appc.cabal @@ -0,0 +1,66 @@ +name: appc +version: 0.0.2 +license: MIT +license-file: LICENSE +author: Tomas Carnecky +maintainer: tomas.carnecky@gmail.com +category: Data +build-type: Simple +cabal-version: >=1.10 + +synopsis: app container types and tools +description: + See https://github.com/appc/spec + +library + default-language: Haskell2010 + hs-source-dirs: src + + exposed-modules: + Data.AppContainer.Types + + build-depends: + base >=4.6 && <4.8, + aeson, + containers, + semver, + uuid, + text + + +executable appc + default-language: Haskell2010 + hs-source-dirs: src + + main-is: Main.hs + + build-depends: + base >=4.6 && <4.8, + aeson, + bytestring, + containers, + optparse-applicative, + semver, + uuid, + text + + ghc-options: -Wall + + +test-suite spec + default-language: Haskell2010 + hs-source-dirs: test + + main-is: Test.hs + type: exitcode-stdio-1.0 + + build-depends: + base >=4.6 && <4.8, + hspec, + smallcheck, + hspec-smallcheck, + appc, + text, + semver, + uuid, + aeson diff --git a/src/Data/AppContainer/Types.hs b/src/Data/AppContainer/Types.hs new file mode 100644 --- /dev/null +++ b/src/Data/AppContainer/Types.hs @@ -0,0 +1,210 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE RecordWildCards #-} + +module Data.AppContainer.Types + ( ImageManifest(..) + , ContainerRuntimeManifest(..) + , Image(..) + , App(..) + , Label(..) + ) where + + +import Control.Applicative +import Control.Monad + +import Data.Text (Text) +import qualified Data.Text as T + +import Data.Map (Map) +import qualified Data.Map as M + +import Data.SemVer +import Data.UUID + +import Data.Aeson +import Data.Aeson.Types +import Data.AppContainer.TH + + + +------------------------------------------------------------------------------ +-- ImageManifest + +data ImageManifest = ImageManifest + { imName :: !Text + , imVersion :: !Version + , imLabels :: ![Label] + , imApp :: !(Maybe App) + , imDependencies :: ![Dependency] + + -- , crmAnnotations + } deriving (Show, Eq) + +imageManifestKind :: Text +imageManifestKind = "ImageManifest" + + + +instance FromJSON ImageManifest where + parseJSON (Object o) = do + acKind <- o .: "acKind" + guard $ acKind == imageManifestKind + + ImageManifest + <$> o .: "name" + <*> (o .: "acVersion" >>= parseVersion) + <*> o .:? "labels" .!= [] + <*> o .:? "app" + <*> o .:? "dependencies" .!= [] + + parseJSON _ = fail "ImageManifest" + +instance ToJSON ImageManifest where + toJSON ImageManifest{..} = object + [ "acKind" .= imageManifestKind + , "acVersion" .= toText imVersion + , "name" .= imName + , "labels" .= imLabels + , "dependencies" .= imDependencies + ] + + + +------------------------------------------------------------------------------ +-- ContainerRuntimeManifest + +data ContainerRuntimeManifest = ContainerRuntimeManifest + { crmUUID :: !UUID + , crmVersion :: !Version + , crmImages :: ![Image] + , crmVolumes :: ![Volume] + + -- , crmIsolators + -- , crmAnnotations + } deriving (Show, Eq) + +containerRuntimeManifestKind :: Text +containerRuntimeManifestKind = "ContainerRuntimeManifest" + + +instance FromJSON ContainerRuntimeManifest where + parseJSON (Object o) = do + acKind <- o .: "acKind" + guard $ acKind == containerRuntimeManifestKind + + ContainerRuntimeManifest + <$> o .: "uuid" + <*> (o .: "acVersion" >>= parseVersion) + <*> o .: "apps" + <*> o .:? "volumes" .!= [] + + parseJSON _ = fail "ContainerRuntimeManifest" + +instance ToJSON ContainerRuntimeManifest where + toJSON ContainerRuntimeManifest{..} = object + [ "acKind" .= containerRuntimeManifestKind + , "acVersion" .= toText crmVersion + , "uuid" .= crmUUID + , "apps" .= crmImages + , "volumes" .= crmVolumes + ] + +data Label = Label + { labelName :: !Text + , labelVal :: !Text + } deriving (Show, Eq) + +data Image = Image + { imageApp :: !Text + , imageImageID :: !Text + + -- , imageIsolators + -- , imageAnnotations + } deriving (Show, Eq) + +data App = App + { appExec :: ![Text] + , appUser :: !Text + , appGroup :: !Text + , appEventHandlers :: ![EventHandler] + , appEnvironment :: !(Map Text Text) + , appMountPoints :: ![MountPoint] + , appPorts :: ![Port] + } deriving (Show, Eq) + +instance FromJSON App where + parseJSON (Object o) = App + <$> o .: "exec" + <*> o .: "user" + <*> o .: "group" + <*> o .:? "eventHandlers" .!= [] + <*> o .:? "environment" .!= M.empty + <*> o .:? "mountPoints" .!= [] + <*> o .:? "ports" .!= [] + + parseJSON _ = fail "App" + +data EventHandler = EventHandler + { ehName :: !Text + , ehExec :: ![Text] + } deriving (Show, Eq) + +data MountPoint = MountPoint + { mpName :: !Text + , mpPath :: !Text + , mpReadOnly :: !Bool + } deriving (Show, Eq) + +data Volume = Volume + { volKind :: !Text + } deriving (Show, Eq) + +data Port = Port + { portName :: !Text + , portProtocol :: !Text + , portPort :: !Int + , portSocketActivated :: !Bool + } deriving (Show, Eq) + +instance FromJSON Port where + parseJSON (Object o) = Port + <$> o .: "name" + <*> o .: "protocol" + <*> o .: "port" + <*> o .:? "socketActivated" .!= False + + parseJSON _ = fail "Port" + +data Dependency = Dependency + { depName :: !Text + , depLabels :: ![Label] + , depHash :: !Text + , depRoot :: !Text + } deriving (Show, Eq) + + +parseVersion :: Text -> Parser Version +parseVersion text = case fromText text of + Left e -> fail e + Right v -> pure v + + +instance ToJSON UUID where + toJSON = toJSON . Data.UUID.toString + +instance FromJSON UUID where + parseJSON x = parseJSON x >>= \str -> case Data.UUID.fromString str of + Nothing -> fail "UUID" + Just uuid -> pure uuid + + +$(deriveToJSON (deriveJSONOptions "app") ''App) +$(deriveJSON (deriveJSONOptions "dep") ''Dependency) +$(deriveJSON (deriveJSONOptions "eh") ''EventHandler) +$(deriveJSON (deriveJSONOptions "label") ''Label) +$(deriveJSON (deriveJSONOptions "mp") ''MountPoint) +$(deriveJSON (deriveJSONOptions "vol") ''Volume) +$(deriveToJSON (deriveJSONOptions "port") ''Port) +$(deriveJSON (deriveJSONOptions "image") ''Image) diff --git a/src/Main.hs b/src/Main.hs new file mode 100644 --- /dev/null +++ b/src/Main.hs @@ -0,0 +1,76 @@ +{-# LANGUAGE RecordWildCards #-} + +module Main where + + +import Data.Aeson +import qualified Data.ByteString.Lazy as LBS +import Data.SemVer +import Data.Monoid +import Options.Applicative +import System.Exit + +import Data.AppContainer +import Data.AppContainer.Types + + + +main :: IO () +main = run =<< execParser + (parseOptions `withInfo` "AppContainer tool") + + +run :: Options -> IO () +run (Options (VerifyImageManifest path)) = do + ok <- verifyImageManifest path + if ok + then exitSuccess + else exitFailure + + +run (Options (VerifyContainerRuntimeManifest path)) = do + ok <- verifyContainerRuntimeManifest path + if ok + then exitSuccess + else exitFailure + + +run (Options (BuildImage path output)) = do + buildImage path output + + +data Command + = VerifyImageManifest !String + | VerifyContainerRuntimeManifest !String + | BuildImage !String !String + +data Options = Options !Command + +parseOptions :: Parser Options +parseOptions = Options <$> parseCommand + +parseCommand :: Parser Command +parseCommand = subparser $ mconcat + [ command "verify-image-manifest" + (parseVerifyImageManifest `withInfo` "Verify an image manifest") + , command "verify-container-runtime-manifest" + (parseVerifyContainerRuntimeManifest `withInfo` "Verify a container runtime manifest") + , command "build-image" + (parseBuildImage `withInfo` "Build an image") + ] + +parseVerifyImageManifest :: Parser Command +parseVerifyImageManifest = VerifyImageManifest + <$> argument str (metavar "PATH") + +parseVerifyContainerRuntimeManifest :: Parser Command +parseVerifyContainerRuntimeManifest = VerifyContainerRuntimeManifest + <$> argument str (metavar "PATH") + +parseBuildImage :: Parser Command +parseBuildImage = BuildImage + <$> argument str (metavar "PATH") + <*> argument str (metavar "OUTPUT") + +withInfo :: Parser a -> String -> ParserInfo a +withInfo opts desc = info (helper <*> opts) $ progDesc desc diff --git a/test/Test.hs b/test/Test.hs new file mode 100644 --- /dev/null +++ b/test/Test.hs @@ -0,0 +1,85 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Main where + +import Control.Applicative + +import Test.Hspec +import Test.SmallCheck +import Test.SmallCheck.Series +import Test.Hspec.SmallCheck + +import Data.Monoid ((<>)) +import Data.Function +import Data.List +import Data.Aeson +import Data.Text (Text) +import Data.Text as T +import Data.SemVer +import Data.UUID + +import GHC.Word + +import Data.AppContainer.Types + + +instance Monad m => Serial m Word32 where + series = decDepth $ fromIntegral <$> (series :: Series m Int) + +instance Monad m => Serial m UUID where + series = decDepth $ fromWords + <$> series + <*> series + <*> series + <*> series + +instance Monad m => Serial m Text where + series = decDepth $ T.pack + <$> series + +instance Monad m => Serial m Version where + series = decDepth $ version + <$> fmap getPositive series + <*> fmap getPositive series + <*> fmap getPositive series + <*> pure [] + <*> pure [] + +instance Monad m => Serial m Label where + series = decDepth $ Label + <$> series <*> series + +instance Monad m => Serial m ImageManifest where + series = decDepth $ ImageManifest + <$> series <*> series <*> series <*> pure Nothing <*> pure [] + +instance Monad m => Serial m ContainerRuntimeManifest where + series = decDepth $ ContainerRuntimeManifest + <$> series + <*> series + <*> pure [] + <*> pure [] + + + +main :: IO () +main = do + hspec spec + + +spec :: Spec +spec = do + + describe "ImageManifest" $ do + it "x ≡ fromJSON (toJSON x)" $ property $ \(im :: ImageManifest) -> + Success im == fromJSON (toJSON im) + + + describe "ContainerRuntimeManifest" $ do + it "x ≡ fromJSON (toJSON x)" $ property $ \(im :: ContainerRuntimeManifest) -> + Success im == fromJSON (toJSON im)