craft (empty) → 0.0.0.1
raw patch · 61 files changed
+5227/−0 lines, 61 filesdep +MissingHdep +QuickCheckdep +aesonsetup-changed
Dependencies added: MissingH, QuickCheck, aeson, aeson-pretty, ansi-terminal, async, base, bytestring, conduit, conduit-combinators, conduit-extra, containers, craft, cryptonite, derive, directory, exceptions, fast-logger, filepath, formatting, free, hspec, hspec-megaparsec, ini, lens, lifted-base, megaparsec, memory, monad-logger, mtl, path, path-io, process, process-extras, pureMD5, random, split, streaming-commons, template-haskell, text, transformers, unix, unordered-containers, versions, wreq, yaml
Files
- LICENSE +13/−0
- Setup.hs +2/−0
- craft.cabal +154/−0
- src/Craft.hs +27/−0
- src/Craft/Apt.hs +193/−0
- src/Craft/Checksum.hs +66/−0
- src/Craft/Config.hs +74/−0
- src/Craft/Config/Ini.hs +54/−0
- src/Craft/Config/Json.hs +34/−0
- src/Craft/Config/SSH.hs +146/−0
- src/Craft/Config/Shell.hs +87/−0
- src/Craft/Config/Yaml.hs +32/−0
- src/Craft/Craftable.hs +408/−0
- src/Craft/DSL.hs +167/−0
- src/Craft/Daemontools.hs +120/−0
- src/Craft/Directory.hs +65/−0
- src/Craft/Directory/Parser.hs +34/−0
- src/Craft/Error.hs +28/−0
- src/Craft/Facter.hs +15/−0
- src/Craft/File.hs +92/−0
- src/Craft/File/Link.hs +70/−0
- src/Craft/File/Mode.hs +239/−0
- src/Craft/File/Sourced.hs +66/−0
- src/Craft/Git.hs +165/−0
- src/Craft/Group.hs +50/−0
- src/Craft/Helpers.hs +37/−0
- src/Craft/Hostname.hs +47/−0
- src/Craft/Hosts.hs +120/−0
- src/Craft/Hosts/Parser.hs +91/−0
- src/Craft/Hosts/Types.hs +29/−0
- src/Craft/Internal.hs +8/−0
- src/Craft/Internal/Helpers.hs +47/−0
- src/Craft/Internal/Helpers/Parsing.hs +10/−0
- src/Craft/Internal/UserGroup.hs +117/−0
- src/Craft/Nginx.hs +176/−0
- src/Craft/Package.hs +12/−0
- src/Craft/Pip.hs +114/−0
- src/Craft/Run.hs +4/−0
- src/Craft/Run/Internal.hs +70/−0
- src/Craft/Run/Local.hs +51/−0
- src/Craft/Run/Nspawn.hs +55/−0
- src/Craft/Run/SSH.hs +212/−0
- src/Craft/Run/Vagrant.hs +66/−0
- src/Craft/S3File.hs +150/−0
- src/Craft/SSH.hs +51/−0
- src/Craft/SSH/AuthorizedKey.hs +68/−0
- src/Craft/SSH/PrivateKey.hs +33/−0
- src/Craft/SSH/PublicKey.hs +50/−0
- src/Craft/SysV.hs +135/−0
- src/Craft/Types.hs +458/−0
- src/Craft/Ubuntu.hs +49/−0
- src/Craft/Upstart.hs +37/−0
- src/Craft/User.hs +216/−0
- src/Craft/Wget.hs +70/−0
- test/Craft/Config/ShellSpec.hs +89/−0
- test/Craft/File/ModeSpec.hs +16/−0
- test/Craft/S3FileSpec.hs +49/−0
- test/Craft/SSH/AuthorizedKeySpec.hs +30/−0
- test/Craft/SSH/PublicKeySpec.hs +26/−0
- test/Craft/SSHSpec.hs +32/−0
- test/Spec.hs +1/−0
+ LICENSE view
@@ -0,0 +1,13 @@+Copyright 2016 Joe Hillenbrand++Licensed under the Apache License, Version 2.0 (the "License");+you may not use this file except in compliance with the License.+You may obtain a copy of the License at++ http://www.apache.org/licenses/LICENSE-2.0++Unless required by applicable law or agreed to in writing, software+distributed under the License is distributed on an "AS IS" BASIS,+WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.+See the License for the specific language governing permissions and+limitations under the License.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ craft.cabal view
@@ -0,0 +1,154 @@+name: craft++-- The package version. See the Haskell package versioning policy (PVP)+-- for standards guiding when and how versions should be incremented.+-- http://www.haskell.org/haskellwiki/Package_versioning_policy+-- PVP summary: +-+------- breaking API changes+-- | | +----- non-breaking API additions+-- | | | +--- code changes with no API change+version: 0.0.0.1+synopsis: A UNIX configuration management library in Haskell+description: A UNIX configuration management EDSL/library in Haskell+license: Apache-2.0+license-file: LICENSE+author: Joe Hillenbrand+maintainer: joehillen@gmail.com+-- copyright:+-- category:+build-type: Simple+-- Extra files to be distributed with the package, such as examples or a+-- README.+-- extra-source-files:+cabal-version: >=1.10++library+ ghc-options: -Wall+ hs-source-dirs: src+ , src/Craft+ exposed-modules: Craft+ , Craft.Apt+ , Craft.Checksum+ , Craft.Craftable+ , Craft.Config+ , Craft.Config.Ini+ , Craft.Config.Json+ , Craft.Config.SSH+ , Craft.Config.Shell+ , Craft.Config.Yaml+ , Craft.DSL+ , Craft.Daemontools+ , Craft.Directory+ , Craft.Facter+ , Craft.File+ , Craft.File.Link+ , Craft.File.Mode+ , Craft.File.Sourced+ , Craft.Git+ , Craft.Group+ , Craft.Helpers+ , Craft.Hostname+ , Craft.Hosts+ , Craft.Internal.Helpers+ , Craft.Internal.Helpers.Parsing+ , Craft.Internal.UserGroup+ , Craft.Nginx+ , Craft.Package+ , Craft.Pip+ , Craft.Run+ , Craft.Run.Internal+ , Craft.Run.Local+ , Craft.Run.Nspawn+ , Craft.Run.SSH+ , Craft.Run.Vagrant+ , Craft.S3File+ , Craft.SSH+ , Craft.SSH.AuthorizedKey+ , Craft.SSH.PrivateKey+ , Craft.SSH.PublicKey+ , Craft.SysV+ , Craft.Types+ , Craft.Ubuntu+ , Craft.Upstart+ , Craft.User+ , Craft.Wget++ other-modules: Craft.Internal+ , Craft.Hosts.Parser+ , Craft.Hosts.Types+ , Craft.Directory.Parser+ , Craft.Error++ default-language: Haskell2010+ default-extensions: BangPatterns+ , LambdaCase+ , MultiParamTypeClasses+ , OverloadedStrings+ , QuasiQuotes+ , RankNTypes+ , RecordWildCards+ , TemplateHaskell+ , TypeFamilies++ build-depends: base >= 4.8 && < 4.9+ , aeson+ , aeson-pretty+ , ansi-terminal+ , async+ , bytestring+ , conduit+ , conduit-combinators+ , conduit-extra+ , containers+ , cryptonite+ , derive+ , directory+ , exceptions+ , fast-logger+ , monad-logger+ , filepath+ , formatting+ , free+ , unordered-containers+ , ini+ , lifted-base+ , lens+ , megaparsec+ , MissingH+ , memory+ , monad-logger+ , mtl+ , path+ , path-io+ , process+ , process-extras+ , pureMD5+ , QuickCheck+ , random+ , split+ , streaming-commons+ , template-haskell+ , text+ , transformers+ , unix+ , versions+ , wreq+ , yaml++test-suite craft-test+ type: exitcode-stdio-1.0+ hs-source-dirs: test+ main-is: Spec.hs+ other-modules: Craft.File.ModeSpec+ , Craft.Config.ShellSpec+ , Craft.S3FileSpec+ , Craft.SSHSpec+ , Craft.SSH.PublicKeySpec+ , Craft.SSH.AuthorizedKeySpec+ build-depends: base+ , craft+ , hspec >= 1.3+ , hspec-megaparsec+ , megaparsec+ , QuickCheck+ ghc-options: -threaded -rtsopts -with-rtsopts=-N -Wall+ default-language: Haskell2010
+ src/Craft.hs view
@@ -0,0 +1,27 @@+module Craft+( ExitCode(..)+, module X+-- Control.Monad.Reader+, ask+, asks+, local+-- Control.Lens+, (&)+, (.~)+, (^.)+, (%~)+, (?~)+, view+, to+)+where++import Control.Lens+import Control.Monad.Reader (ask, asks, local)++-- |Re-exports+import Control.Monad.Catch as X+import System.Exit (ExitCode (..))++import Craft.Craftable as X+import Craft.Internal as X
+ src/Craft/Apt.hs view
@@ -0,0 +1,193 @@+module Craft.Apt where++import Control.Lens+import Control.Monad+import Formatting++import Craft+import qualified Craft.Package as Package++++apt :: PackageManager+apt =+ PackageManager+ { _pmGetter = getAptPackage+ , _pmInstaller = aptInstall+ , _pmUpgrader = aptInstall+ , _pmUninstaller = aptPurge+ }+++aptGet :: [String] -> Craft ()+aptGet args = exec_ "apt-get" $ ["-q", "-y"] ++ args+++update :: Craft ()+update = aptGet ["update"]+++autoremove :: Craft ()+autoremove = aptGet ["autoremove"]+++dpkgQuery :: [String] -> Craft ExecResult+dpkgQuery = exec dpkgQueryBin+++dpkgQueryBin :: String+dpkgQueryBin = "dpkg-query"+++dpkgQueryStatus :: String -> Craft ExecResult+dpkgQueryStatus pn = dpkgQuery ["-s", pn]+++expectOutput :: String -> [String] -> Craft String+expectOutput cmd args = do+ r <- $stdoutOrError =<< exec cmd args+ when (null r) $ $craftError $ formatToString ("'"%string%"' returned an empty result!")+ (unwords $ cmd:args)+ return r+++dpkgQueryShow :: String -> String -> Craft String+dpkgQueryShow pattern n = expectOutput dpkgQueryBin [ "--show", "--showformat", pattern, n ]+++dpkgQueryVersion :: String -> Craft String+dpkgQueryVersion = dpkgQueryShow "${Version}"+++dpkgQueryPackage :: String -> Craft String+dpkgQueryPackage = dpkgQueryShow "${Package}"+++getAptPackage :: PackageName -> Craft (Maybe Package)+getAptPackage pn =+ dpkgQueryStatus pn >>= \case+ ExecFail _ -> return Nothing+ ExecSucc _ -> Just <$> do+ r <- dpkgQueryVersion pn+ return $ Package pn (Version r)+++aptInstallArgs :: [String]+aptInstallArgs = ["-o", "DPkg::Options::=--force-confold", "install"]+++aptInstall :: Package -> Craft ()+aptInstall pkg = aptGet $ aptInstallArgs ++ [pkgArg pkg]+++aptInstallMult :: [Package] -> Craft ()+aptInstallMult [] = return ()+aptInstallMult pkgs = aptGet $ aptInstallArgs ++ map pkgArg pkgs+++pkgArg :: Package -> String+pkgArg (Package pn AnyVersion) = pn+pkgArg (Package pn Latest) = pn+pkgArg (Package pn (Version v)) = pn ++ "=" ++ v+++aptRemove :: Package -> Craft ()+aptRemove Package{..} = aptGet ["remove", _pkgName]+++aptPurge :: Package -> Craft ()+aptPurge Package{..} = aptGet ["remove", _pkgName, "--purge"]+++data Deb = Deb+ { _debFile :: File+ , _debPkg :: Package+ }+ deriving (Eq, Show)+makeLenses ''Deb+++debName :: Lens' Deb String+debName = debPkg . pkgName+++debVersion :: Lens' Deb Version+debVersion = debPkg . pkgVersion+++deb :: File -> Craft Deb+deb f = do+ pkg <- packageFromDebFile f+ return $ Deb f pkg+++packageFromDebFile :: File -> Craft Package+packageFromDebFile f = do+ name <- dpkgDebPackage f+ version <- dpkgDebVersion f+ return $ Package name (Version version)+++dpkgInstall :: File -> Craft ()+dpkgInstall f =+ withEnvVar "DEBIAN_FRONTEND" "noninteractive" $+ exec_ "dpkg" ["-i", fromAbsFile $ f^.path]+++dpkgDebBin :: String+dpkgDebBin = "dpkg-deb"+++dpkgDebShow :: String -> File -> Craft String+dpkgDebShow pattern f =+ expectOutput dpkgDebBin ["--show", "--showformat", pattern, fromAbsFile $ f^.path]+++dpkgDebVersion :: File -> Craft String+dpkgDebVersion = dpkgDebShow "${Version}"+++dpkgDebPackage :: File -> Craft String+dpkgDebPackage = dpkgDebShow "${Package}"+++instance Craftable Deb Deb where+ watchCraft d = do+ let name = d ^. debName+ let expectedVersion = d ^. debVersion+ let get = getAptPackage name+ let error' = formatToString ("craft Deb `"%shown%"` failed! "%string) d+ let installAndVerify = do+ dpkgInstall $ d ^. debFile+ get >>= \case+ Nothing -> $craftError $ error' "Package Not Found."+ Just installedPkg ->+ when (expectedVersion /= installedPkg ^. pkgVersion) $+ $craftError . error' $ formatToString ("Wrong Version: "%shown%" Expected: "%shown) (installedPkg ^. pkgVersion) expectedVersion+ get >>= \case+ Nothing -> do+ installAndVerify+ return (Created, d)+ Just installedPkg ->+ if expectedVersion == installedPkg ^. pkgVersion+ then return (Unchanged, d)+ else do+ installAndVerify+ return (Updated, d)+++-- |A function that installs a list of Apt packages,+-- |but that only runs "apt-get update" if a given package is not already installed.+-- TESTME+craftPackages :: [Package] -> Craft [Package]+craftPackages packages = do+ whenM ((any comparePackages . zip packages) <$> mapM (Package.get . _pkgName) packages)+ update+ craft packages+ where+ comparePackages (_, Nothing) = True+ comparePackages (Package _ expectedVersion, Just (Package _ actualVersion)) =+ case (expectedVersion, actualVersion) of+ (AnyVersion, _) -> False+ (Latest, _) -> True+ (x, y) -> x /= y
+ src/Craft/Checksum.hs view
@@ -0,0 +1,66 @@+module Craft.Checksum where++import Control.Lens++import Craft++data Checksum+ = CRC String+ | MD5 String+ | SHA1 String+ | SHA224 String+ | SHA256 String+ | SHA384 String+ | SHA512 String+ deriving (Show, Eq)+++command :: Checksum -> String+command (CRC _) = "cksum"+command (MD5 _) = "md5sum"+command (SHA1 _) = "sha1sum"+command (SHA224 _) = "sha224sum"+command (SHA256 _) = "sha256sum"+command (SHA384 _) = "sha384sum"+command (SHA512 _) = "sha512sum"+++toString :: Checksum -> String+toString (CRC x) = x+toString (MD5 x) = x+toString (SHA1 x) = x+toString (SHA224 x) = x+toString (SHA256 x) = x+toString (SHA384 x) = x+toString (SHA512 x) = x+++data Result+ = Failed FailResult+ | Matched+ | Mismatched Checksum+ deriving (Show)+++-- | Check a 'File' against the given 'Checksum'.+-- If the 'File' does not exist or the checksum command fails,+-- 'Failed' is returned.+-- If 'Checksum' does not match,+-- 'Mismatched' is returned containing the actual 'Checksum'.+-- Otherwise 'Matched' is returned.+check :: File -> Checksum -> Craft Result+check f chksum = exec (command chksum) [fromAbsFile $ f^.path] >>= \case+ ExecFail r -> return $ Failed r+ ExecSucc r -> return $+ let mk = case chksum of+ CRC _ -> CRC+ MD5 _ -> MD5+ SHA1 _ -> SHA1+ SHA224 _ -> SHA224+ SHA256 _ -> SHA256+ SHA384 _ -> SHA384+ SHA512 _ -> SHA512+ actual = mk $ r ^. stdout+ in if chksum == actual+ then Mismatched actual+ else Matched
+ src/Craft/Config.hs view
@@ -0,0 +1,74 @@+module Craft.Config where++import Control.Lens+import qualified Data.ByteString.Char8 as B8++import Craft+import qualified Craft.File as File+++data Config a+ = Config+ { _configFile :: File+ , _configs :: a+ }+++config :: ConfigFormat a => Path Abs FileP -> a -> Config a+config fp cfg =+ Config+ { _configFile = file fp & strContent .~ showConfig cfg+ , _configs = cfg+ }+++class ConfigFormat a where+ showConfig :: a -> String++ parseConfig :: Path Abs FileP -> String -> Craft a++ configFromFile :: File -> Craft (Config a)+ configFromFile f = do+ bs <- case f ^. fileContent of+ Nothing -> fileRead (f ^. path)+ Just bs -> return bs+ cfgs <- parseConfig (f^.path) (B8.unpack bs)+ return Config { _configFile = f+ , _configs = cfgs+ }++ fileFromConfig :: Config a -> Craft File+ fileFromConfig cfg =+ return $ _configFile cfg & strContent .~ showConfig (_configs cfg) ++ "\n"+++ {-# MINIMAL showConfig, parseConfig #-}++makeLenses ''Config+++instance FileLike (Config a) where+ type FileLikePath (Config a) = Path Abs FileP+ path = configFile . filePath+ mode = configFile . fileMode+ ownerID = configFile . fileOwnerID+ groupID = configFile . fileGroupID+++instance ConfigFormat a => Craftable (Config a) (Config a) where+ watchCraft cfg = do+ w <- watchCraft_ =<< fileFromConfig cfg+ return (w, cfg)+++instance ConfigFormat a => Show (Config a) where+ show cfg = "Config "+ ++ "{ _configFile = " ++ show (_configFile cfg)+ ++ ", _configs = \"" ++ showConfig (_configs cfg) ++ "\""+ ++ "}"+++get :: ConfigFormat a => Path Abs FileP -> Craft (Maybe (Config a))+get fp = File.getWithContent fp >>= \case+ Nothing -> return Nothing+ Just f -> Just <$> configFromFile f
+ src/Craft/Config/Ini.hs view
@@ -0,0 +1,54 @@+module Craft.Config.Ini+( module Craft.Config.Ini+, module Data.Ini+, Ini(..)+, HM.fromList+)+where++import Control.Lens+import qualified Data.HashMap.Strict as HM+import Data.Ini+import qualified Data.Text as T++import Craft.Config+import Craft.Types+++data IniFormat = IniFormat { _inifmt :: Ini+ , _settings :: WriteIniSettings+ }+++iniFormat :: [(T.Text, [(T.Text, T.Text)])] -> IniFormat+iniFormat ini = IniFormat (Ini (HM.fromList $ fmap (fmap HM.fromList) ini))+ (WriteIniSettings EqualsKeySeparator)+++config :: Path Abs FileP -> IniFormat -> Config IniFormat+config = Craft.Config.config+++instance ConfigFormat IniFormat where+ showConfig format = T.unpack . printIniWith (_settings format) $ _inifmt format+ parseConfig fp s =+ case parseIni (T.pack s) of+ Left err -> $craftError $ "Failed to parse ini file"++show fp++": "++err+ Right x -> return $ IniFormat+ { _inifmt = x+ , _settings = WriteIniSettings EqualsKeySeparator+ }+++get :: Path Abs FileP -> Craft (Maybe (Config IniFormat))+get = Craft.Config.get+++lookup :: String -> String -> IniFormat -> Maybe String+lookup section key (IniFormat ini _)=+ case lookupValue (T.pack section) (T.pack key) ini of+ Left _ -> Nothing+ Right r -> Just $ T.unpack r+++makeLenses ''IniFormat
+ src/Craft/Config/Json.hs view
@@ -0,0 +1,34 @@+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE GADTs #-}+module Craft.Config.Json where++import Control.Lens+import Data.Aeson+import Data.Aeson.Encode.Pretty (encodePretty)++import Craft+import Craft.Config+import qualified Data.ByteString.Char8 as B8+import qualified Data.ByteString.Lazy as BSL+++data JsonFormat a = (FromJSON a, ToJSON a) => JsonFormat { _jsonfmt :: a }+++instance (FromJSON a, ToJSON a) => ConfigFormat (JsonFormat a) where+ showConfig = B8.unpack . BSL.toStrict . encodePretty . _jsonfmt+ parseConfig fp s =+ case eitherDecodeStrict (B8.pack s) of+ Left err -> $craftError $ "Failed to parse "++show fp++" : "++err+ Right x -> return $ JsonFormat x+++get :: (FromJSON a, ToJSON a) => Path Abs FileP -> Craft (Maybe (Config (JsonFormat a)))+get = Craft.Config.get+++config :: (FromJSON a, ToJSON a) => Path Abs FileP -> a -> Config (JsonFormat a)+config fp = Craft.Config.config fp . JsonFormat+++makeLenses ''JsonFormat
+ src/Craft/Config/SSH.hs view
@@ -0,0 +1,146 @@+module Craft.Config.SSH where++import Control.Lens hiding (noneOf)+import Data.Char (toLower)+import Data.Maybe (catMaybes)+import Text.Megaparsec++import Craft hiding (try)+import Craft.Config+import Craft.Internal.Helpers+import Craft.Internal.Helpers.Parsing+import Craft.SSH+++data Section+ = Host String Body+ | Match String Body+ deriving Eq+++type Sections = [Section]+++type Body = [(String, String)]+++newtype SSHConfig = SSHConfig { _sshfmt :: Sections }+ deriving Eq+++instance Show SSHConfig where+ show sshcfg = unlines . map show $ _sshfmt sshcfg+++data UserConfig+ = UserConfig+ { _user :: User+ , _userConfigs :: SSHConfig+ }+ deriving Eq+makeLenses ''SSHConfig+makeLenses ''UserConfig++instance ConfigFormat SSHConfig where+ showConfig = show+ parseConfig = sshConfigParse+++userPath :: UserConfig -> Path Abs FileP+userPath uc = (userDir (uc ^. user) ^. path) </> $(mkRelFile "config")+++get :: Path Abs FileP -> Craft (Maybe (Config SSHConfig))+get = Craft.Config.get+++bodyLookup :: String -> Body -> Maybe String+bodyLookup key body =+ lookup (map toLower key) $ map ((,) <$> map toLower . fst <*> snd) body+++cfgLookup :: String -> String -> SSHConfig -> Maybe String+cfgLookup sectionName key (SSHConfig sections') =+ case body of+ Just b -> bodyLookup key b+ Nothing -> Nothing+ where+ body = maybeHead . catMaybes $ map f sections'+ f (Host name b) | name == sectionName = Just b+ | otherwise = Nothing+ f _ = Nothing+ maybeHead [] = Nothing+ maybeHead (x:_) = Just x+++instance Craftable UserConfig UserConfig where+ watchCraft cfg = do+ craft_ $ userDir $ cfg ^. user+ w <- watchCraft_ $ file (userPath cfg)+ & mode .~ Mode RW O O+ & ownerAndGroup .~ cfg ^. user+ & strContent .~ show cfg+ return (w, cfg)+++sshConfigParse :: Path Abs FileP -> String -> Craft SSHConfig+sshConfigParse fp s =+ case runParser parser (show fp) s of+ Left err -> $craftError $ show err+ Right secs -> return $ SSHConfig secs+++instance Show UserConfig where+ show uc = show $ uc ^. userConfigs+++showBody :: Body -> String+showBody body = indent 4 . unlines $ map (\(n, v) -> n ++ " " ++ v) body+++instance Show Section where+ show (Host hostname body) = "Host " ++ hostname ++ "\n" ++ showBody body+ show (Match match body) = "Match " ++ match ++ "\n" ++ showBody body+++parseTitle :: Parsec String (String, String)+parseTitle = do+ space+ type' <- try (string' "host") <|> string' "match"+ void spaceChar+ notFollowedBy eol+ space+ name <- anyChar `someTill` eol+ return (type', name)+++parseBody :: Parsec String [(String, String)]+parseBody = many bodyLine+++bodyLine :: Parsec String (String, String)+bodyLine = do+ notFollowedBy parseTitle+ space+ name <- someTill anyChar spaceChar+ notFollowedBy eol+ space+ val <- between (char '"') (char '"') (many $ noneOf "\"")+ <|> someTill anyChar end+ void $ optional (space <|> void (many eol))+ return (name, trim val)+++parseSection :: Parsec String Section+parseSection = do+ title <- parseTitle+ body <- parseBody+ return $ case map toLower (fst title) of+ "host" -> Host (snd title) body+ "match" -> Match (snd title) body+ _ -> error "Craft.Config.SSH.parse failed. This should be impossible."+++parser :: Parsec String Sections+parser = some parseSection+
+ src/Craft/Config/Shell.hs view
@@ -0,0 +1,87 @@+module Craft.Config.Shell where++import Control.Lens hiding (noneOf, set)+import Data.Maybe (catMaybes)+import Text.Megaparsec hiding (parse)++import Craft hiding (try)+import Craft.Config+import Craft.Internal.Helpers.Parsing+++newtype ShellFormat = ShellFormat { _shellfmt :: [(String, String)] }+ deriving (Eq, Show)+makeLenses ''ShellFormat+++instance ConfigFormat ShellFormat where+ showConfig (ShellFormat cfgs) = unlines $ map showkv cfgs+ where+ showkv :: (String, String) -> String+ showkv (k, v) = k++"="++v+ parseConfig fp s =+ case runParser parser (fromAbsFile fp) s of+ Left err -> $craftError $ show err+ Right cfgs -> return cfgs++-- | Replace an existing value if it is already set otherwise add it to the end.+set :: String -> String -> ShellFormat -> ShellFormat+set k v (ShellFormat cfgs) =+ case lookup k cfgs of+ Nothing -> ShellFormat $ cfgs++[(k,v)]+ Just _ -> ShellFormat $ map (replace k v) cfgs+ where+ replace ka va (kb, vb) | ka == kb = (ka, va)+ | otherwise = (kb, vb)+++unset :: String -> ShellFormat -> ShellFormat+unset k (ShellFormat cfgs) = ShellFormat $ filter ((/= k) . fst) cfgs+++get :: Path Abs FileP -> Craft (Maybe (Config ShellFormat))+get = Craft.Config.get+++config :: Path Abs FileP -> [(String, String)] -> Config ShellFormat+config fp = Craft.Config.config fp . ShellFormat+++dedup :: ShellFormat -> ShellFormat+dedup cfgs = go empty cfgs+ where+ go m (ShellFormat []) = m+ go m (ShellFormat ((k, v):xs)) = go (set k v m) (ShellFormat xs)+++empty :: ShellFormat+empty = ShellFormat []+++-- TESTME+parser :: Parsec String ShellFormat+parser = do+ items <- line `sepEndBy` eol+ return . ShellFormat $ catMaybes items+++line :: Parsec String (Maybe (String, String))+line = do+ try (comment >> return Nothing)+ <|> try (space >> end >> return Nothing)+ <|> (Just <$> item)+++comment :: Parsec String ()+comment = space >> char '#' >> manyTill anyChar end >> return ()+++item :: Parsec String (String, String)+item = do+ space+ name <- some $ noneOf " ="+ void $ char '='+ -- TODO: quoted values+ value <- try (someTill (noneOf " \r\n#") (lookAhead (oneOf " \r\n#")) <* manyTill anyChar end)+ <|> (many (oneOf " \t") >> manyTill anyChar end >> return "")+ return (name, value)
+ src/Craft/Config/Yaml.hs view
@@ -0,0 +1,32 @@+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE GADTs #-}+module Craft.Config.Yaml where++import Craft+import Craft.Config+import qualified Data.ByteString.Char8 as B8++import Control.Lens+import Data.Yaml+++data YamlFormat a = (FromJSON a, ToJSON a) => YamlFormat { _yamlfmt :: a }+++instance (FromJSON a, ToJSON a) => ConfigFormat (YamlFormat a) where+ showConfig = B8.unpack . encode . _yamlfmt+ parseConfig fp s =+ case decodeEither (B8.pack s) of+ Left err -> $craftError $ "Failed to parse " ++ show fp ++ " : " ++ err+ Right x -> return $ YamlFormat x+++get :: (FromJSON a, ToJSON a) => Path Abs FileP -> Craft (Maybe (Config (YamlFormat a)))+get = Craft.Config.get+++config :: (FromJSON a, ToJSON a) => Path Abs FileP -> a -> Config (YamlFormat a)+config fp = Craft.Config.config fp . YamlFormat+++makeLenses ''YamlFormat
+ src/Craft/Craftable.hs view
@@ -0,0 +1,408 @@+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE UndecidableInstances #-}+module Craft.Craftable where++import Control.Lens+import Control.Monad.Reader (ask)+import qualified Data.ByteString.Lazy as BL+import Data.List (intercalate)+import Data.Maybe (catMaybes, isJust)+import Formatting hiding (char)++import Craft.DSL+import qualified Craft.File as File+import Craft.Helpers+import Craft.Internal.Helpers+import Craft.Internal.UserGroup+import Craft.Types+import qualified Craft.User as User+++data Watched+ = Unchanged+ | Created+ | Updated+ | Removed+ deriving (Eq, Show)++makePrisms ''Watched++changed :: Watched -> Bool+changed = not . unchanged+++unchanged :: Watched -> Bool+unchanged Unchanged = True+unchanged _ = False+++created :: Watched -> Bool+created Created = True+created _ = False+++updated :: Watched -> Bool+updated Updated = True+updated _ = False+++removed :: Watched -> Bool+removed Removed = True+removed _ = False+++watch :: Eq a => Craft (Maybe a) -> Craft b -> Craft (Watched, Maybe a, b)+watch getter action = do+ !beforeMB <- getter+ !result <- action+ !afterMB <- getter+ let (w, x) = case (beforeMB, afterMB) of+ (Nothing, Nothing) -> (Unchanged, Nothing)+ (Just y, Nothing) -> (Removed, Just y)+ (Nothing, Just y) -> (Created, Just y)+ (Just before, Just after) -> if before == after+ then (Unchanged, Just after)+ else (Updated, Just after)+ return (w, x, result)+++watch_ :: Eq a => Craft (Maybe a) -> Craft b -> Craft Watched+watch_ getter action = do+ (w, _, _) <- watch getter action+ return w+++class Craftable a b | a -> b where+ watchCraft :: a -> Craft (Watched, b)++ craft :: a -> Craft b+ craft x = snd <$> watchCraft x++ craft_ :: a -> Craft ()+ craft_ = void . craft++ watchCraft_ :: a -> Craft Watched+ watchCraft_ x = fst <$> watchCraft x++ {-# MINIMAL watchCraft #-}+++class Destroyable a where+ watchDestroy :: a -> Craft (Watched, Maybe a)++ destroy :: a -> Craft (Maybe a)+ destroy x = snd <$> watchDestroy x++ destroy_ :: a -> Craft ()+ destroy_ = void . destroy++ watchDestroy_ :: a -> Craft Watched+ watchDestroy_ x = fst <$> watchDestroy x++ {-# MINIMAL watchDestroy #-}+++instance Craftable a b => Craftable [a] [b] where+ craft_ = mapM_ craft_+ craft = mapM craft+ watchCraft as = do+ (ws, bs) <- unzip <$> mapM watchCraft as+ let w = if all (== Unchanged) ws then+ Unchanged+ else if all (== Created) ws then+ Created+ else+ Updated+ return (w, bs)+++instance Destroyable a => Destroyable [a] where+ destroy_ = mapM_ destroy_+ destroy xs = do+ rs <- mapM destroy xs+ return $ case catMaybes rs of+ [] -> Nothing+ rs' -> Just rs'+ watchDestroy xs = do+ (ws, rs) <- unzip <$> mapM watchDestroy xs+ let w = if all (== Unchanged) ws then+ Unchanged+ else if all (== Removed) ws then+ Removed+ else+ Updated+ let res = case catMaybes rs of+ [] -> Nothing+ rs' -> Just rs'+ return (w, res)+++instance Craftable User.UserOptions User where+ watchCraft uopts = do+ let notfound = "craft `"++uopts ^. User.optName++"` failed. Not Found!"+ let name = UserName $ uopts ^. User.optName+ User.fromName name >>= \case+ Nothing -> do+ User.createUser uopts+ User.fromName name >>= \case+ Nothing -> $craftError notfound+ Just createdUser -> do+ madeChanges <- User.ensureUserOpts createdUser uopts+ if not madeChanges+ then return (Created, createdUser)+ else User.fromName name >>= \case+ Nothing -> $craftError notfound+ Just u -> return (Created, u)+ Just existingUser -> do+ madeChanges <- User.ensureUserOpts existingUser uopts+ if not madeChanges+ then return (Unchanged, existingUser)+ else User.fromName name >>= \case+ Nothing -> $craftError notfound+ Just u -> return (Updated, u)++instance Craftable Package Package where+ watchCraft pkg = do+ ce <- ask+ let pm = ce ^. craftPackageManager+ let name = pkg ^. pkgName+ let version = pkg ^. pkgVersion+ let get = (pm ^. pmGetter) name+ let install = (pm ^. pmInstaller) pkg+ let upgrade = (pm ^. pmUpgrader) pkg+ let pkgError = "craft Package `" ++ name ++ "` failed! "+ let notFound = pkgError ++ "Not Found."+ let wrongVersion got = pkgError ++ "Wrong Version: " ++ show got ++ " Excepted: " ++ show version+ get >>= \case -- Is the package installed?+ Nothing -> do -- It's not installed.+ install -- Install it.+ get >>= \case -- Verify the installation.+ Nothing -> $craftError notFound -- Not Found. The install failed!+ Just installedPkg ->+ let ok = return (Created, installedPkg)+ in case version of -- Make sure it's the right version+ AnyVersion -> ok+ Latest -> ok+ Version _ -> if version == installedPkg ^. pkgVersion+ then ok+ else $craftError $ wrongVersion (installedPkg ^. pkgVersion)+ Just installedPkg -> do -- Package was already installed.+ let installedVersion = installedPkg ^. pkgVersion+ case version of+ AnyVersion -> return (Unchanged, installedPkg)+ Latest -> do -- Ensure it's the latest version.+ upgrade+ get >>= \case+ Nothing -> $craftError notFound -- Not found. Where did it go?+ Just upgradedPkg ->+ return $ if upgradedPkg ^. pkgVersion > installedPkg ^. pkgVersion -- If the package version increased,+ then (Updated, upgradedPkg) -- Then the package was upgraded+ else (Unchanged, upgradedPkg) -- Else it was already the latest.+ Version _ -> -- Expecting a specific version+ if version == installedVersion -- Is the correct version installed?+ then return (Unchanged, installedPkg)+ else do+ upgrade -- Try upgrading to the correct version.+ get >>= \case+ Nothing -> $craftError notFound -- Where did it go?+ Just upgradedPkg -> if version == upgradedPkg ^. pkgVersion -- Is the correct version installed?+ then return (Updated, upgradedPkg)+ else $craftError $ wrongVersion (upgradedPkg ^. pkgVersion)+++instance Destroyable Package where+ watchDestroy pkg = do+ ce <- ask+ let pm = ce ^. craftPackageManager+ let name = pkg ^. pkgName+ let get = (pm ^. pmGetter) name+ get >>= \case+ Nothing -> return (Unchanged, Nothing)+ Just installedPkg -> do+ (pm ^. pmUninstaller) pkg+ get >>= \case+ Nothing -> return (Removed, Just installedPkg)+ Just unexpectedPkg -> $craftError $ "destroy Package `" ++ name ++ "` failed! " ++ "Found: " ++ show unexpectedPkg+++instance Craftable User User where+ watchCraft user = do+ let name = show $ user ^. userName+ let notFound = $craftError $ "User `" ++ name ++ "` not found!"+ userFromStr name >>= \case+ Nothing -> do+ useradd user+ userFromStr name >>= \case+ Nothing -> notFound+ Just actualUser -> do+ verify user actualUser+ return (Created, actualUser)+ Just existingUser -> do+ res <- mapM (\(test', act) -> if test' user existingUser+ then return True+ else act >> return False)+ [ (test userName, $notImplemented "set username")+ , (test uid, $notImplemented "set uid")+ , (test (userGroup . groupName), $notImplemented "set group")+ , (test userGroups, $notImplemented "set groups")+ , (test userHome, $notImplemented "set home")+ , (test userPasswordHash, $notImplemented "set passwordHash")+ , (test userShell, $notImplemented "set shell")+ ]+ if and res+ then return (Unchanged, existingUser)+ else+ userFromStr (show name) >>= \case+ Nothing -> notFound+ Just user'' -> do+ verify user'' user+ return (Updated, user'')++ where+ test :: Eq a => Lens' b a -> b -> b -> Bool+ test l a b = a ^. l == b ^. l+ verify :: User -> User -> Craft ()+ verify _expectedUser _actualUser = $notImplemented "verify User"+++instance Craftable Group Group where+ watchCraft grp = do+ _ <- $notImplemented "craft Group"+ -- groupFromName . groupname+ exec_ "groupadd" $ toArg "--gid" (grp ^. Craft.Types.gid) ++ [show $ grp ^. groupName]+ exec_ "gpasswd" ["--members", intercalate "," (map show (grp ^. groupMembers))+ , show $ grp ^. groupName]+ return (Unchanged, grp)+++instance Craftable File File where+ watchCraft f = do+ let fp = f ^. path+ -- FIXME: Don't use _Just+ let expectedMD5 = show . md5 . BL.fromStrict $ f ^. fileContent . _Just+ let err :: String -> Craft a+ err str = $craftError $ "craft File `"++show fp++"` failed! "++str+ let verifyMode m =+ when (m /= f ^. mode) $+ err $ "Wrong Mode: " ++ show m ++ " Expected: " ++ show (f ^. mode)+ let verifyOwner o =+ when (o /= f ^. ownerID) $+ err $ "Wrong OwnerID: " ++ show o ++ " Expected: " ++ show (f ^. ownerID)+ let verifyGroup g =+ when (g /= f ^. groupID) $+ err $ "Wrong GroupID: " ++ show g ++ " Expected: " ++ show (f ^. groupID)+ let verifyStats (m, o, g) = verifyMode m >> verifyOwner o >> verifyGroup g+ getStats fp >>= \case+ Nothing -> do+ case f ^. fileContent of+ Nothing -> exec_ "touch" [fromAbsFile fp]+ Just c -> File.write fp c+ File.setStats f+ when (isJust $ f ^. fileContent) $ do+ actualMD5 <- File.md5sum fp+ unless (actualMD5 == expectedMD5) $+ err "Content Mismatch."+ return (Created, f)+ Just (m', o', g') -> do+ let checks = [ (f ^. mode == m', setMode (f ^. mode) fp)+ , (f ^. ownerID == o', setOwnerID (f ^. ownerID) fp)+ , (f ^. groupID == g', setGroupID (f ^. groupID) fp)+ ]+ mapM_ (uncurry unless) checks+ case f ^. fileContent of+ Nothing -> if all fst checks+ then return (Unchanged, f)+ else do+ getStats fp >>= \case+ Nothing -> err "Not Found."+ Just stats -> verifyStats stats+ return (Updated, f)+ Just c -> do+ actualMD5 <- File.md5sum fp+ if actualMD5 == expectedMD5+ then return $ if all fst checks+ then (Unchanged, f)+ else (Updated, f)+ else do+ File.write fp c+ md5AfterWrite <- File.md5sum fp+ if md5AfterWrite == expectedMD5+ then return (Updated, f)+ else err "Content Mismatch."++ craft f = do+ let fp = f^.path+ exec_ "touch" ["-a", fromAbsFile fp]+ case f ^. fileContent of+ Nothing -> return ()+ Just c -> do+ let expectedMD5 = show . md5 $ BL.fromStrict c+ actualMD5 <- File.md5sum fp+ unless (actualMD5 == expectedMD5) $ do+ File.write fp c+ md5AfterWrite <- File.md5sum fp+ unless (expectedMD5 == md5AfterWrite) $+ $craftError $ "craft File `"++show fp++"` failed! Content Mismatch."+ File.setStats f+ return f+++instance Destroyable File where+ watchDestroy f =+ File.get (f ^. path) >>= \case+ Nothing -> return (Unchanged, Nothing)+ Just f' -> do+ destroy_ f+ return (Removed, Just f')++ destroy_ f = do+ let fp = f^.path+ exec_ "rm" ["-f", fromAbsFile fp]+ File.exists fp >>= flip when (+ $craftError $ "destroy File `"++show fp++"` failed! Found.")+++instance Craftable Directory Directory where+ watchCraft d = do+ let dp = d ^. path+ setMode' = setMode (d ^. mode) dp+ setOwner' = setOwnerID (d ^. ownerID) dp+ setGroup' = setGroupID (d ^. groupID) dp+ error' :: String -> Craft a+ error' str = $craftError+ $ formatToString ("craft Directory `"%string%"` failed! "%string)+ (show dp) str+ verifyMode m =+ when (m /= d ^. mode) $+ error' $ formatToString ("Wrong Mode: "%shown%" Expected: "%shown)+ m (d ^. mode)+ verifyOwner o =+ when (o /= d ^. ownerID) $+ error' $ formatToString ("Wrong Owner ID: "%shown%" Expected: "%shown)+ o (d ^. ownerID)+ verifyGroup g =+ when (g /= d ^. groupID) $+ error' $ formatToString ("Wrong Group ID: "%shown%" Expected: "%shown)+ g (d ^. groupID)+ verifyStats (m, o, g) =+ verifyMode m >> verifyOwner o >> verifyGroup g+ getStats dp >>= \case+ Nothing -> do+ exec_ "mkdir" ["-p", fromAbsDir dp]+ setMode' >> setOwner' >> setGroup'+ getStats dp >>= \case+ Nothing -> error' "Not Found."+ Just stats' -> verifyStats stats' >> return (Created, d)+ Just (m', o', g') -> do+ let checks = [ (d^.mode == m', setMode')+ , (d^.ownerID == o', setOwner')+ , (d^.groupID == g', setGroup')+ ]+ mapM_ (uncurry unless) checks+ if all fst checks then+ return (Unchanged, d)+ else+ getStats dp >>= \case+ Nothing -> error' "Not Found."+ Just stats' -> verifyStats stats' >> return (Updated, d)
+ src/Craft/DSL.hs view
@@ -0,0 +1,167 @@+module Craft.DSL where++import Control.Lens+import Control.Monad.Free+import Control.Monad.Logger (logDebugNS)+import Control.Monad.Reader+import qualified Data.ByteString as BS+import qualified Data.ByteString.Char8 as B8+import Data.List (intercalate)+import Data.List.Split (splitOn)+import qualified Data.Map.Strict as Map+import qualified Data.Text as T+import Text.Megaparsec+import Text.Megaparsec.String++import Craft.Types+++-- | Craft DSL+exec :: Command -> Args -> Craft ExecResult+exec cmd args = do+ logDebugNS "exec" $ T.unwords $ map T.pack (cmd:args)+ ce <- ask+ liftF $ Exec ce cmd args id+++exec_ :: Command -> Args -> Craft ()+exec_ cmd args = do+ ce <- ask+ liftF $ Exec_ ce cmd args ()+++fileRead :: Path Abs FileP -> Craft BS.ByteString+fileRead fp =+ liftF $ FileRead fp id+++fileWrite :: Path Abs FileP -> BS.ByteString -> Craft ()+fileWrite fp content =+ liftF $ FileWrite fp content ()+++sourceFile :: (IO FilePath) -> Path Abs FileP -> Craft ()+sourceFile sourcer dest = liftF $ SourceFile sourcer dest ()+++parseExecResult :: ExecResult -> Parsec String a -> String -> Craft a+parseExecResult execr parser str =+ case parse parser (showProc $ execResultProc execr) str of+ Right x -> return x+ Left err -> $craftError $+ unlines+ [ "parseExecResult error:"+ , "<<<< process >>>>"+ , showProc $ execResultProc execr+ , "<<<< output >>>>"+ , str+ , "<<<< parse error >>>>"+ , show err+ ]+++-- | better than grep+parseExecStdout :: Parsec StdOut a -> Command -> Args -> Craft a+parseExecStdout parser cmd args = do+ r <- exec cmd args+ s <- $stdoutOrError r+ parseExecResult r parser s+++-- XXX: What if the file doesn't exist?+parseFile :: Parser a -> Path Abs FileP -> Craft a+parseFile parser fp = do+ str <- B8.unpack <$> fileRead fp+ case runParser parser (show fp) str of+ Right x -> return x+ Left err -> $craftError $ "parseFile `"++show fp++"` failed: "++show err+++craftExecPath :: CraftEnv -> Craft [Path Abs Dir]+craftExecPath ce = do+ let dps = maybe [] (splitOn ":") . Map.lookup "PATH" $ ce^.craftExecEnv+ mapM parseAbsDir dps+++-- TESTME+prependPath :: Path Abs Dir -> Craft a -> Craft a+prependPath newpath go = do+ ce <- ask+ execpath <- craftExecPath ce+ withPath (newpath:execpath) go+++-- TESTME+withPath :: [Path Abs Dir] -> Craft a -> Craft a+withPath = withEnvVar "PATH" . intercalate ":" . map fromAbsDir+++withEnv :: ExecEnv -> Craft a -> Craft a+withEnv env = local (\r -> r & craftExecEnv .~ env)+++withCWD :: Directory -> Craft a -> Craft a+withCWD dir = local (\r -> r & craftExecCWD .~ dir ^. directoryPath)+++-- TESTME+withEnvVar :: String -> String -> Craft a -> Craft a+withEnvVar name val go = do+ ce <- ask+ let env = Map.insert name val $ ce ^. craftExecEnv+ withEnv env go+++isExecSucc :: ExecResult -> Bool+isExecSucc (ExecSucc _) = True+isExecSucc (ExecFail _) = False++setMode :: Mode -> Path b t -> Craft ()+setMode m fp = exec_ "chmod" [toOctalString m, toFilePath fp]++setOwnerID :: UserID -> Path b t -> Craft ()+setOwnerID (UserID i) fp = exec_ "chown" [show i, toFilePath fp]+++setGroupID :: GroupID -> Path b t -> Craft ()+setGroupID (GroupID i) fp = exec_ "chgrp" [show i, toFilePath fp]+++stat :: Command+stat = "stat"++getMode :: Path Abs t -> Craft Mode+getMode fp = parseExecStdout modeParser stat ["-c", "%a", toFilePath fp]+++getOwnerID :: Path Abs t -> Craft UserID+getOwnerID fp = UserID <$> parseExecStdout digitParser stat ["-c", "%u", toFilePath fp]+++getGroupID :: Path Abs t -> Craft GroupID+getGroupID fp = GroupID <$> parseExecStdout digitParser stat ["-c", "%g", toFilePath fp]+++getStats :: Path Abs t -> Craft (Maybe (Mode, UserID, GroupID))+getStats fp =+ exec stat ["-c", "%a:%u:%g", toFilePath fp] >>= \case+ ExecFail _ -> return Nothing+ ExecSucc r -> Just <$> parseExecResult (ExecSucc r) statsParser (r^.stdout)+++statsParser :: Parser (Mode, UserID, GroupID)+statsParser = do+ mode' <- modeParser+ void $ char ':'+ owner' <- UserID <$> digitParser+ void $ char ':'+ group' <- GroupID <$> digitParser+ return (mode', owner', group')+++modeParser :: Parser Mode+modeParser = fromOctalString <$> some digitChar+++digitParser :: Parser Int+digitParser = read <$> some digitChar
+ src/Craft/Daemontools.hs view
@@ -0,0 +1,120 @@+module Craft.Daemontools where++import Control.Lens+import Data.ByteString (ByteString)++import Craft+import qualified Craft.Upstart as Upstart+++data Service+ = Service+ { _name :: String+ , _home :: Path Abs Dir+ , _env :: [(String, String)]+ , _runFile :: ByteString+ , _restarts :: Bool+ }+ deriving (Eq, Show)+makeLenses ''Service+++service :: String -> Service+service name' =+ Service { _name = name'+ , _home = $(mkAbsDir "/etc/svc")+ , _env = []+ , _runFile = ""+ , _restarts = True+ }+++setup :: Path Abs Dir -> Craft ()+setup home' = do+ craft_ $ map package [ "daemontools"+ , "daemontools-run"+ ]+ craft_ $ directory home'+ Upstart.get "svscan" >>= \case+ Nothing -> $craftError "Upstart service `svscan` not found!"+ Just svscan -> Upstart.start svscan+++path :: Service -> Craft (Path Abs Dir)+path Service{..} = do+ sn <- parseRelDir _name+ return $ _home </> sn+++restart :: Service -> Craft ()+restart s = do+ sp <- Craft.Daemontools.path s+ execRestart sp+++execRestart :: Path Abs Dir -> Craft ()+execRestart fp = exec_ "svc" ["-t", fromAbsDir fp]+++logRunDefault :: Path Abs FileP -> String+logRunDefault logdest =+ "#!/bin/sh\nexec setuidgid nobody multilog t "++fromAbsFile logdest++" s10000000 n10\n"+++envFile :: Path Abs Dir -> (String, String) -> Craft File+envFile envDir (varname, varval) = do+ fn <- parseRelFile varname+ return $ file (envDir</>fn)+ & mode .~ Mode RW O O+ & strContent .~ varval+++{-+getEnv :: Service -> Craft [(String, String)]+getEnv svc = do+ sp <- Craft.Daemontools.path svc+ fs <- Directory.getFiles sp+ return $ map go fs+ where+ go f = (f ^. File.name, f ^. strContent)+++instance Craftable Service where+ checker svc = File.get (path svc </> "run") >>= \case+ Nothing -> return Nothing+ Just f -> do+ env' <- getEnv svc+ return . Just $+ svc { runFile = fromJust $ File.content f+ , env = env'+ }++ crafter s@Service{..} _ = do+ craft_ $ directory home++ let svcdir = path s+ craft_ $ directory svcdir+ craft_ $ Link svcdir $ "/etc/service" </> name++ runW <- fst <$> watchCraft ((file $ svcdir </> "run")+ { File.mode = Mode RWX RX RX+ , File.content = Just runFile+ })++ let logDir = svcdir </> "log"+ craft_ $ directory logDir++ let logDest = logDir </> "main"+ nobody <- fromJust <$> User.fromName "nobody"+ nogroup <- fromJust <$> Group.fromName "nogroup"+ craft_ $ (directory logDest)+ { Directory.ownerID = User.uid nobody+ , Directory.groupID = Group.gid nogroup+ }++ let envDir = svcdir </> "env"+ craft_ $ directory envDir+ mapM_ (craft . envFile envDir) env++ when (restarts && updated runW) $ restart s+-}
+ src/Craft/Directory.hs view
@@ -0,0 +1,65 @@+module Craft.Directory+( module Craft.Directory+, setGroupID+, setOwnerID+, getOwnerID+, getGroupID+, getMode+)+where++import Control.Lens+import Data.Maybe (catMaybes)+import Formatting++import Craft.Directory.Parser+import qualified Craft.File as File+import Craft.File.Mode+import qualified Craft.Group as Group+import Craft.Internal+import qualified Craft.User as User+++getOwner :: Directory -> Craft User+getOwner d =+ User.fromID (d ^. ownerID) >>= \case+ Nothing -> $craftError $ formatToString ("No such owner with `"%shown%"` for: "%shown)+ (d ^. ownerID) d+ Just g -> return g+++getGroup :: Directory -> Craft Group+getGroup d =+ Group.fromID (d ^. groupID) >>= \case+ Nothing -> $craftError $ formatToString ("No such group with `"%shown%"` for: "%shown)+ (d ^. groupID) d+ Just g -> return g+++multiple :: [Path Abs Dir] -> Mode -> User -> Group -> [Directory]+multiple paths mode' owner' group' = map go paths+ where+ go p = Directory p mode' (owner'^.uid) (group'^.gid)+++multipleRootOwned :: [Path Abs Dir] -> Mode -> [Directory]+multipleRootOwned paths m = map go paths+ where+ go p = directory p & mode .~ m+++exists :: Path Abs Dir -> Craft Bool+exists p = isExecSucc <$> exec "test" ["-d", fromAbsDir p]+++get :: Path Abs Dir -> Craft (Maybe Directory)+get dp =+ getStats dp >>= \case+ Nothing -> return Nothing+ Just (m, o, g) -> return . Just $ Directory dp m o g+++getFiles :: Path Abs Dir -> Craft [File]+getFiles dp = do+ fns <- mapM parseRelFile =<< parseExecStdout getFilesParser "ls" ["-a", "-1", fromAbsDir dp]+ catMaybes <$> mapM (File.get . (dp </>)) fns
+ src/Craft/Directory/Parser.hs view
@@ -0,0 +1,34 @@+module Craft.Directory.Parser where++-- |This file is just to keep Megaparsec from conflicting with other modules++import Control.Monad (void)+import Text.Megaparsec+++getFilesParser :: Parsec String [String]+getFilesParser = stuff `sepBy` newline <* optional newline+ where+ stuff :: Parsec String String+ stuff = do+ void $ optional $ string "." >> newline+ void $ optional $ string ".." >> newline+ line+ line :: Parsec String String+ line = many $ noneOf "\n"+++testGetFilesParser :: IO Bool+testGetFilesParser = do+ let expected = ["ab", "lkjasd", "912 12391", " ", "~"] :: [String]+ let resultE = parse getFilesParser "testGetFilesParser" $ unlines (".":"..":expected)+ case resultE of+ Left err -> do+ putStrLn $ "FAILED: error " ++ show err+ return False+ Right result ->+ if result /= expected then do+ putStrLn $ "FAILED: got " ++ show expected+ return False+ else+ return True
+ src/Craft/Error.hs view
@@ -0,0 +1,28 @@+module Craft.Error where++import Control.Monad.Catch+import Control.Monad.Logger (logError)+import Data.Monoid ((<>))+import qualified Data.Text as T+import Language.Haskell.TH.Syntax (Exp, Q)++data CraftError = CraftError String+ deriving Show++data CraftNotImplemented = CraftNotImplemented+ deriving Show++instance Exception CraftError++instance Exception CraftNotImplemented++-- |Log an error and throw a runtime exception+craftError :: Q Exp+craftError = [|\s -> $(logError) (T.pack s) >> throwM (CraftError s) |]+++notImplemented :: Q Exp+notImplemented = [| \s -> do+ $(logError) $ "Not Implemented: " <> T.pack s+ throwM CraftNotImplemented+ |]
+ src/Craft/Facter.hs view
@@ -0,0 +1,15 @@+module Craft.Facter where++import Craft+++setup :: Craft ()+setup = craft_ $ package "facter"+++fact :: String -> Craft String+fact f = rmTrailingNL <$> ($stdoutOrError =<< exec "facter" [f])+++rmTrailingNL :: String -> String+rmTrailingNL = reverse . dropWhile (=='\n') . reverse
+ src/Craft/File.hs view
@@ -0,0 +1,92 @@+module Craft.File+( module Craft.File+, setGroupID+, setOwnerID+, getOwnerID+, getGroupID+, getMode+)+where++import Control.Lens+import Data.ByteString (ByteString)+import Data.Maybe+import Formatting++import qualified Craft.Group as Group+import Craft.Internal+import qualified Craft.User as User+++getOwner :: File -> Craft User+getOwner f =+ User.fromID (f ^. ownerID) >>= \case+ Nothing -> $craftError $ formatToString ("No such owner with `"%shown%"` for: "%shown)+ (f ^. ownerID) f+ Just g -> return g+++getGroup :: File -> Craft Group+getGroup f =+ Group.fromID (f ^. groupID) >>= \case+ Nothing -> $craftError $ formatToString ("No such group with `"%shown%"` for: "%shown)+ (f ^. groupID) f+ Just g -> return g+++-- TODO: name :: Lens' File (Path Rel FileP)+name :: Getter File (Path Rel FileP)+name = filePath . to filename+++multiple :: [Path Abs FileP] -> Mode -> User -> Group -> Maybe ByteString -> [File]+multiple paths mode' owner' group' content' = map go paths+ where+ go path' = File path' mode' (owner'^.uid) (group'^.gid) content'+++setStats :: File -> Craft ()+setStats f = do+ let fp = f^.path+ setMode (f^.mode) fp+ setOwnerID (f^.ownerID) fp+ setGroupID (f^.groupID) fp+++write :: Path Abs FileP -> ByteString -> Craft ()+write = fileWrite+++exists :: Path Abs FileP -> Craft Bool+exists fp = isExecSucc <$> exec "test" ["-f", fromAbsFile fp]+++get :: Path Abs FileP -> Craft (Maybe File)+get fp =+ getStats fp >>= \case+ Nothing -> return Nothing+ Just (m, o, g) -> do+ return . Just $ file fp & mode .~ m+ & ownerID .~ o+ & groupID .~ g+ & fileContent .~ Nothing+++getWithContent :: Path Abs FileP -> Craft (Maybe File)+getWithContent fp =+ get fp >>= \case+ Nothing -> return Nothing+ Just f -> do+ content' <- fileRead fp+ return . Just $ f & fileContent ?~ content'+++md5sum :: Path Abs FileP -> Craft String+md5sum fp = head . words <$> ($stdoutOrError =<< exec "md5sum" [fromAbsFile fp])+++-- | A thin wrapper over the Unix find program.+find :: Path Abs Dir -> Args -> Craft [File]+find dir args = do+ fs <- mapM parseAbsFile . lines =<< $stdoutOrError =<< exec "find" ([fromAbsDir dir, "-type", "f"] ++ args)+ catMaybes <$> (mapM get fs)
+ src/Craft/File/Link.hs view
@@ -0,0 +1,70 @@+module Craft.File.Link where++import Control.Lens++import Craft+++newtype TargetPath = TargetPath FilePath+ deriving (Show, Eq)++newtype LinkPath = LinkPath (Path Abs FileP)+ deriving (Show, Eq)++data Link+ = Link+ { _linkTarget :: TargetPath+ , _linkPath :: LinkPath+ }+ deriving (Eq, Show)+makeLenses ''Link++-- TODO: intsance FileLike Link where+++link :: TargetPath -> LinkPath -> Link+link = Link+++exists :: Path Abs FileP -> Craft Bool+exists lp = isExecSucc <$> exec "test" ["-L", fromAbsFile lp]+++readlink :: LinkPath -> Craft (Maybe TargetPath)+readlink (LinkPath lp) =+ exec "readlink" [fromAbsFile lp] >>= \case+ ExecFail _ -> return Nothing+ ExecSucc r -> return . Just . TargetPath . trimTrailing $ r^.stdout+++create :: Link -> Craft ()+create (Link t p) = justdoit t p+ where+ justdoit (TargetPath tp) (LinkPath lp) = exec_ "ln" ["-snf", tp, fromAbsFile lp]+++instance Craftable Link Link where+ watchCraft l = do+ let lp = l ^. linkPath+ readlink lp >>= \case+ Nothing -> do+ craft_ l+ return (Created, l)+ Just target' ->+ if target' == l^.linkTarget then+ return (Unchanged, l)+ else do+ craft_ l+ return (Updated, l)++ craft_ l = do+ let lp = l ^. linkPath+ let tp = l ^. linkTarget+ create l+ readlink lp >>= \case+ Nothing -> $craftError $ "craft `" ++ show l ++ "` failed! Not Found."+ Just target' ->+ when (target' /= tp) $+ $craftError $ "craft `" ++ show l ++ "` failed! "+ ++ "Wrong Target: " ++ show target' ++ " "+ ++ "Expected: " ++ show (l ^. linkTarget)
+ src/Craft/File/Mode.hs view
@@ -0,0 +1,239 @@+module Craft.File.Mode+( Mode(..)+, ModeSet(..)+, toFileMode+, toMode+, toHuman+, fileModeFromString+, toOctalString+, fromOctalString+)+where++import Data.Bits ((.&.), (.|.))+import Data.Char (digitToInt)+import Data.DeriveTH+import Data.List+import System.Posix (FileMode)+import qualified System.Posix+import Test.QuickCheck (Arbitrary, arbitrary, choose)+++toHuman :: Mode -> String+toHuman (Mode u g o) =+ modeSetToHuman u ++ modeSetToHuman g ++ s2t (modeSetToHuman o)+ where+ s2t = map tr+ tr 's' = 't'+ tr 'S' = 'T'+ tr c = c+++data ModeSet+ = O -- ^ O was chosen because it looks like a zero.+ | R+ | W+ | X+ | S+ | RW+ | RX+ | RS+ | WX+ | WS+ | XS+ | RWX+ | RWS+ | RXS+ | WXS+ | RWXS+ deriving (Eq, Enum, Show)++data Mode+ = Mode ModeSet ModeSet ModeSet+ deriving (Eq, Show)+++toOctalString :: Mode -> String+toOctalString (Mode u g o) =+ concatMap show $ stickies : map modeSetToOctal l+ where+ stickies = sum $ zipWith (\n m -> n * modeSetToOctalSticky m) [4,2,1] l+ l = [u,g,o]+++modeSetToOctal :: ModeSet -> Int+modeSetToOctal O = 0+modeSetToOctal R = 4+modeSetToOctal W = 2+modeSetToOctal X = 1+modeSetToOctal S = 0+modeSetToOctal RW = 6+modeSetToOctal RX = 5+modeSetToOctal RS = 4+modeSetToOctal WX = 3+modeSetToOctal WS = 2+modeSetToOctal XS = 1+modeSetToOctal RWX = 7+modeSetToOctal RWS = 6+modeSetToOctal RXS = 5+modeSetToOctal WXS = 3+modeSetToOctal RWXS = 7+++modeSetToOctalSticky :: ModeSet -> Int+modeSetToOctalSticky O = 0+modeSetToOctalSticky R = 0+modeSetToOctalSticky W = 0+modeSetToOctalSticky X = 0+modeSetToOctalSticky S = 1+modeSetToOctalSticky RW = 0+modeSetToOctalSticky RX = 0+modeSetToOctalSticky RS = 1+modeSetToOctalSticky WX = 0+modeSetToOctalSticky WS = 1+modeSetToOctalSticky XS = 1+modeSetToOctalSticky RWX = 0+modeSetToOctalSticky RWS = 1+modeSetToOctalSticky RXS = 1+modeSetToOctalSticky WXS = 1+modeSetToOctalSticky RWXS = 1+++modeSetToHuman :: ModeSet -> String+modeSetToHuman O = "---"+modeSetToHuman R = "r--"+modeSetToHuman W = "-w-"+modeSetToHuman X = "--x"+modeSetToHuman S = "--S"+modeSetToHuman RW = "rw-"+modeSetToHuman RX = "r-x"+modeSetToHuman RS = "r-S"+modeSetToHuman WX = "-wx"+modeSetToHuman WS = "-wS"+modeSetToHuman XS = "--s"+modeSetToHuman RWX = "rwx"+modeSetToHuman RWS = "rwS"+modeSetToHuman RXS = "r-s"+modeSetToHuman WXS = "-ws"+modeSetToHuman RWXS = "rws"+++fromOctalString :: String -> Mode+fromOctalString = toMode . fileModeFromString . filter (`elem` ['0'..'7'])+++fileModeFromString :: String -> FileMode+fileModeFromString [] = error "Cannot get Mode from empty string."+fileModeFromString s@[_] = error $ "Mode `" ++ s ++ "` not long enough."+fileModeFromString s@[_,_] = error $ "Mode `" ++ s ++ "` not long enough."+fileModeFromString [u,g,o] =+ fromIntegral $ digitToInt u * (8*8) .|. digitToInt g * 8 .|. digitToInt o+fileModeFromString [s,u,g,o] =+ fromIntegral $ digitToInt s * (8*8*8) .|. digitToInt u * (8*8) .|. digitToInt g * 8 .|. digitToInt o+fileModeFromString s = error $ "Mode `" ++ s ++ "` is too long"+++toFileMode :: Mode -> FileMode+toFileMode (Mode u g o)+ = uFM u .|. gFM g .|. oFM o+++toMode :: FileMode -> Mode+toMode fm = Mode ownerSet groupSet otherSet+ where+ convertSet f m =+ case find (\t -> m == f t) [O ..] of+ Nothing -> error $ "toMode: Unsupported mode: " ++ show m+ Just r -> r+ ownerSet = convertSet uFM (fm .&. (System.Posix.ownerModes .|. uS))+ groupSet = convertSet gFM (fm .&. (System.Posix.groupModes .|. gS))+ otherSet = convertSet oFM (fm .&. (System.Posix.otherModes .|. oT))+++----------------------------------------+-- ____ _ _ --+-- | _ \ _ __(_)_ ____ _| |_ ___ --+-- | |_) | '__| \ \ / / _` | __/ _ \ --+-- | __/| | | |\ V / (_| | || __/ --+-- |_| |_| |_| \_/ \__,_|\__\___| --+----------------------------------------++uR, uW, uX, uS :: FileMode+uR = System.Posix.ownerReadMode+uW = System.Posix.ownerWriteMode+uX = System.Posix.ownerExecuteMode+uS = System.Posix.setUserIDMode+++uFM :: ModeSet -> FileMode+uFM O = System.Posix.nullFileMode+uFM R = uR+uFM W = uW+uFM X = uX+uFM S = uS+uFM RW = uR .|. uW+uFM RX = uR .|. uX+uFM RS = uR .|. uS+uFM WX = uW .|. uX+uFM WS = uW .|. uS+uFM XS = uX .|. uS+uFM RWX = uR .|. uW .|. uX+uFM RWS = uR .|. uW .|. uS+uFM RXS = uR .|. uX .|. uS+uFM WXS = uW .|. uX .|. uS+uFM RWXS = uR .|. uW .|. uX .|. uS+++gR, gW, gX, gS :: FileMode+gR = System.Posix.groupReadMode+gW = System.Posix.groupWriteMode+gX = System.Posix.groupExecuteMode+gS = System.Posix.setGroupIDMode++gFM :: ModeSet -> FileMode+gFM O = System.Posix.nullFileMode+gFM R = gR+gFM W = gW+gFM X = gX+gFM S = gS+gFM RW = gR .|. gW+gFM RX = gR .|. gX+gFM RS = gR .|. gS+gFM WX = gW .|. gX+gFM WS = gW .|. gS+gFM XS = gX .|. gS+gFM RWX = gR .|. gW .|. gX+gFM RWS = gR .|. gW .|. gS+gFM RXS = gR .|. gX .|. gS+gFM WXS = gW .|. gX .|. gS+gFM RWXS = gR .|. gW .|. gX .|. gS+++oR, oW, oX, oT :: FileMode+oR = System.Posix.otherReadMode+oW = System.Posix.otherWriteMode+oX = System.Posix.otherExecuteMode+oT = (512)+++oFM :: ModeSet -> FileMode+oFM O = System.Posix.nullFileMode+oFM R = oR+oFM W = oW+oFM X = oX+oFM S = oT+oFM RW = oR .|. oW+oFM RX = oR .|. oX+oFM RS = oR .|. oT+oFM WX = oW .|. oX+oFM WS = oW .|. oT+oFM XS = oX .|. oT+oFM RWX = oR .|. oW .|. oX+oFM RWS = oR .|. oW .|. oT+oFM RXS = oR .|. oX .|. oT+oFM WXS = oW .|. oX .|. oT+oFM RWXS = oR .|. oW .|. oX .|. oT+++derive makeArbitrary ''ModeSet+derive makeArbitrary ''Mode
+ src/Craft/File/Sourced.hs view
@@ -0,0 +1,66 @@+module Craft.File.Sourced where++import Control.Lens++import Craft+import qualified Craft.File as File+++data SourcedFile+ = SourcedFile+ { _destination :: File+ , _sourcer :: IO FilePath+ }++makeLenses ''SourcedFile+++sourcedFile :: (IO FilePath) -> Path Abs FileP -> SourcedFile+sourcedFile sourcer' dest =+ SourcedFile+ { _destination = Craft.file dest+ , _sourcer = sourcer'+ }+++instance FileLike SourcedFile where+ type FileLikePath SourcedFile = Path Abs FileP+ path = destination . filePath+ mode = destination . fileMode+ ownerID = destination . fileOwnerID+ groupID = destination . fileGroupID+++instance Craftable SourcedFile SourcedFile where+ craft sf = do+ let sf' = sf & destination . fileContent .~ Nothing+ sourceFile (sf'^.sourcer) (sf'^.path)+ craft_ $ sf' ^. destination+ return sf'++ watchCraft sf = do+ let fp = sf ^. destination . filePath+ let sf' = sf & destination . fileContent .~ Nothing+ exists <- File.exists fp+ if exists then do+ oldsum <- File.md5sum fp+ sourceFile (sf^.sourcer) fp+ fw <- watchCraft_ $ sf' ^. destination+ newsum <- File.md5sum fp+ if oldsum /= newsum then+ return (Updated, sf')+ else+ return (fw, sf')+ else do+ sourceFile (sf^.sourcer) fp+ craft_ $ sf' ^. destination+ return (Created, sf')+++instance Destroyable SourcedFile where+ watchDestroy sf = do+ (w, mbf) <- watchDestroy $ sf^.destination+ let res = case mbf of+ Nothing -> Nothing+ Just f -> Just $ sf & destination .~ f+ return (w, res)
+ src/Craft/Git.hs view
@@ -0,0 +1,165 @@+module Craft.Git where++import Control.Lens hiding (noneOf)+import Formatting hiding (char)+import Text.Megaparsec+import Text.Megaparsec.String++import Craft hiding (Version (..))+import qualified Craft.Directory as Dir+++type BranchName = String+type TagName = String+type SHA = String+++data Version+ = Branch BranchName+ | Latest BranchName+ | Tag TagName+ | Commit SHA+ deriving (Eq)+++instance Show Version where+ show (Branch name) = name+ show (Latest name) = name+ show (Tag name) = "tags/" ++ name+ show (Commit sha) = sha+++origin :: String+origin = "origin"+++type URL = String+++data Repo+ = Repo+ { _gitUrl :: URL+ , _gitDirectory :: Directory+ , _gitVersion :: Version+ , _gitDepth :: Maybe Int+ }+ deriving (Eq, Show)+makeLenses ''Repo+++repo :: URL -> Path Abs Dir -> Repo+repo url' dirpath =+ Repo+ { _gitUrl = url'+ , _gitDirectory = directory dirpath+ , _gitVersion = Latest "master"+ , _gitDepth = Nothing+ }+++gitBin :: String+gitBin = "git"+++git :: String -> [String] -> Craft ()+git cmd args = exec_ gitBin $ cmd : args+++remotes :: Craft [String]+remotes = lines <$> ($stdoutOrError =<< exec gitBin ["remote"])+++setURL :: URL -> Craft ()+setURL url' = do+ rs <- remotes+ if origin `elem` rs then+ git "remote" ["set-url", origin, url']+ else+ git "remote" ["add", origin, url']+++getURL :: Craft URL+getURL = do+ results <- parseExecStdout repoURLParser gitBin ["remote", "-v"]+ case lookup (origin, "fetch") results of+ Nothing -> $craftError $ "git remote `" ++ origin ++ "` not found."+ Just x -> return x+++-- TESTME+repoURLParser :: Parser [((String, String), String)]+repoURLParser = some $ do+ remote <- word+ url' <- word+ direction <- char '(' *> some alphaNumChar <* char ')' <* newline+ return ((remote, direction), url')+ where+ word :: Parser String+ word = some (noneOf " \t") <* some (spaceChar <|> tab)+++getVersion :: Craft Version+getVersion = Commit <$> parseExecStdout (some alphaNumChar) gitBin ["rev-parse", "HEAD"]+++get :: Path Abs Dir -> Craft (Maybe Repo)+get dp =+ Dir.get dp >>= \case+ Nothing -> return Nothing+ Just dir -> withCWD dir $ do+ !url' <- getURL+ !version' <- getVersion+ return . Just+ $ Repo { _gitDirectory = dir+ , _gitUrl = url'+ , _gitVersion = version'+ , _gitDepth = Nothing+ }+++instance Craftable Repo Repo where+ watchCraft r = do+ let dp = r ^. gitDirectory . path+ ver = r ^. gitVersion+ verify ver' =+ case ver of+ Commit _ ->+ when (ver' /= ver) $+ $craftError+ $ formatToString ("craft Git.Repo `"%shown%"` failed! Wrong Commit: "%shown%" Got: "%shown)+ r ver ver'+ _ -> return ()+ checkoutCommit :: Craft Version+ checkoutCommit = do+ setURL $ r ^. gitUrl+ git "fetch" [origin]+ git "checkout" ["--force", show ver]+ git "reset" ["--hard"]+ ver' <- getVersion+ verify ver'+ return ver'++ Dir.get dp >>= \case+ Nothing -> do+ case r ^. gitDepth of+ Nothing -> git "clone" [r ^. gitUrl, fromAbsDir dp]+ Just d -> git "clone" ["--depth", show d, r ^. gitUrl, fromAbsDir dp]+ Dir.get dp >>= \case+ Nothing -> $craftError $ "craft Git.Repo `"++show r++"` failed! "+ ++ "Clone Failed. Directory `"++show dp++"` not found."+ Just dir -> do+ craft_ $ r ^. gitDirectory+ withCWD dir $ do+ ver' <- checkoutCommit+ return (Created, r & gitVersion .~ ver' )++ Just dir -> do+ craft_ $ r ^. gitDirectory+ withCWD dir $ do+ !beforeVersion <- getVersion+ ver' <- checkoutCommit+ case ver of+ Latest branchName -> git "pull" [origin, branchName]+ _ -> return ()+ return ( if beforeVersion == ver' then Unchanged else Updated+ , r & gitVersion .~ ver')
+ src/Craft/Group.hs view
@@ -0,0 +1,50 @@+module Craft.Group where++import Control.Lens+import Data.List (intercalate)++import Craft.Internal+import Craft.Internal.Helpers+import Craft.Internal.UserGroup++type Name = GroupName++name :: Lens' Group GroupName+name = groupName++data Options =+ Options+ { optGID :: Maybe GroupID+ , optAllowdupe :: Bool+ , optUsers :: [UserName]+ , optSystem :: Bool+ }++opts :: Options+opts =+ Options+ { optGID = Nothing+ , optAllowdupe = False+ , optUsers = []+ , optSystem = False+ }++createGroup :: Name -> Options -> Craft Group+createGroup gn Options{..} = do+ exec_ "groupadd" args+ exec_ "gpasswd" ["--members", intercalate "," (map show optUsers), show gn]+ fromName gn >>= \case+ Nothing -> $craftError $ "createGroup `" ++ show gn ++ "` failed. Not Found!"+ Just g -> return g+ where+ args = concat+ [ toArg "--gid" optGID+ , toArg "--non-unique" optAllowdupe+ , toArg "--system" optSystem+ ]++fromName :: GroupName -> Craft (Maybe Group)+fromName (GroupName s) = groupFromStr s++fromID :: GroupID -> Craft (Maybe Group)+fromID = groupFromID
+ src/Craft/Helpers.hs view
@@ -0,0 +1,37 @@+module Craft.Helpers+( module Craft.Helpers+, when+, unless+, void+, md5+)+where++import Control.Monad (unless, void, when)+import Data.Digest.Pure.MD5 (md5)+import System.Console.ANSI+++color :: Color -> IO a -> IO a+color c action = do+ setSGR [SetColor Foreground Vivid c]+ r <- action+ setSGR [Reset]+ return r+++trimTrailing :: String -> String+trimTrailing = reverse . dropWhile (`elem` ("\n\r\t " :: String)) . reverse+++whenM :: Monad m => m Bool -> m () -> m ()+whenM mbool action = mbool >>= flip when action+++unlessM :: Monad m => m Bool -> m () -> m ()+unlessM mbool action = mbool >>= flip unless action+++whenJust :: Monad m => Maybe a -> (a -> m ()) -> m ()+whenJust Nothing _ = return ()+whenJust (Just v) act = act v
+ src/Craft/Hostname.hs view
@@ -0,0 +1,47 @@+module Craft.Hostname where++import Control.Monad.Logger (logInfo)+import qualified Data.Text as T++import Craft+import qualified Craft.Hosts as Hosts+++data Hostname = Hostname String+ deriving (Eq, Show)+++get :: Craft Hostname+get = Hostname <$> ($stdoutOrError =<< exec "hostname" [])++hostnamePath :: Path Abs FileP+hostnamePath = $(mkAbsFile "/etc/hostname")+++instance Craftable Hostname Hostname where+ watchCraft (Hostname hn) = do+ (Hostname oldhn) <- get+ hosts <- Hosts.get+ if oldhn /= hn then do+ $logInfo . T.pack $ "Hostname " ++ oldhn ++ " /= " ++ hn+ hosts' <- craft $ Hosts.set (Hosts.Name hn) (Hosts.IP "127.0.1.1") hosts+ craft_ $ file hostnamePath & strContent .~ hn+ exec_ "hostname" [hn]+ craft_ $ Hosts.deleteName (Hosts.Name oldhn) hosts'+ (Hostname newhn) <- get+ when (newhn /= hn) $+ $craftError $ "craft Hostname failed! Expected: " ++ hn+ ++ " Got: " ++ newhn+ return (Updated, Hostname hn)+ else do+ craft_ $ file hostnamePath & strContent .~ hn+ case Hosts.lookup (Hosts.IP "127.0.1.1") hosts of+ Just names ->+ if Hosts.Name hn `elem` names then+ return (Unchanged, Hostname hn)+ else do+ w <- watchCraft_ $ Hosts.set (Hosts.Name hn) (Hosts.IP "127.0.1.1") hosts+ return (w, Hostname hn)+ Nothing -> do+ w <- watchCraft_ $ Hosts.set (Hosts.Name hn) (Hosts.IP "127.0.1.1") hosts+ return (w, Hostname hn)
+ src/Craft/Hosts.hs view
@@ -0,0 +1,120 @@+{-# OPTIONS_GHC -fno-warn-orphans #-}+module Craft.Hosts+( IP(..)+, Name(..)+, Configs+, Hosts(..)+, Craft.Hosts.lookup+, hostsfp+, get+, parse+, showConfigs+, toFile+, fromFile+, insert+, deleteIP+, deleteName+, delete+, set+)+where+++import Control.Lens hiding (noneOf, set)+import Control.Monad (zipWithM)+import qualified Data.ByteString.Char8 as B8+import qualified Data.List as L+import Data.Maybe (catMaybes)++import Craft+import qualified Craft.File as File+import Craft.Hosts.Parser+import Craft.Hosts.Types+++lookup :: IP -> Hosts -> Maybe [Name]+lookup ip hosts = L.lookup ip $ configs hosts+++hostsMap :: ((IP, [Name]) -> (IP, [Name])) -> Hosts -> Hosts+hostsMap f (Hosts cfgs) = Hosts $ Prelude.map f cfgs+++get :: Craft Hosts+get =+ File.getWithContent hostsfp >>= \case+ Nothing -> $craftError $ fromAbsFile hostsfp ++ " not found!"+ Just f -> case f ^. fileContent of+ Nothing -> $craftError $ show hostsfp ++ " not found!"+ Just bs -> parse $ B8.unpack bs+++parse :: String -> Craft Hosts+parse s = do+ r <- zipWithM parseLine [1..] $ lines s+ return . Hosts $ catMaybes r+++instance Craftable Hosts Hosts where+ watchCraft hosts = do+ (w, f) <- watchCraft $ toFile hosts+ r <- fromFile f+ return (w, r)+++showConfigs :: Configs -> String+showConfigs = unlines . map (\(ip, as) -> unwords (show ip:map show as))+++toFile :: Hosts -> File+toFile (Hosts cfgs) = file hostsfp & strContent .~ showConfigs cfgs+++fromFile :: File -> Craft Hosts+fromFile f =+ case f ^. fileContent of+ Nothing -> return $ Hosts []+ Just c -> parse $ B8.unpack c+++insert :: IP -> Name -> Hosts -> Hosts+insert newip name (Hosts cfgs) = fixUp $ Hosts go+ where+ go | any ((== newip) . fst) cfgs = map f cfgs+ | otherwise = cfgs ++ [(newip, [name])]+ f (ip, names) | ip == newip && name `notElem` names = (ip, name:names)+ | otherwise = (ip, names)+++deleteIP :: IP -> Hosts -> Hosts+deleteIP ip (Hosts cfgs) = fixUp . Hosts $ filter (\(ip', _) -> ip' /= ip) cfgs+++deleteName :: Name -> Hosts -> Hosts+deleteName name = fixUp . hostsMap f+ where+ f (ip', names) = (ip', filter (/= name) names)+++delete :: IP -> Name -> Hosts -> Hosts+delete ip name = fixUp . hostsMap f+ where+ f (ip', names) | ip' == ip = (ip', filter (/= name) names)+ | otherwise = (ip', names)+++set :: Name -> IP -> Hosts -> Hosts+set name ip hosts = fixUp . insert ip name $ deleteName name hosts++----------------------------------------+-- ____ _ _ --+-- | _ \ _ __(_)_ ____ _| |_ ___ --+-- | |_) | '__| \ \ / / _` | __/ _ \ --+-- | __/| | | |\ V / (_| | || __/ --+-- |_| |_| |_| \_/ \__,_|\__\___| --+----------------------------------------+fixUp :: Hosts -> Hosts+fixUp (Hosts cfgs) = Hosts $ filter f cfgs+ where+ f (IP ip, names) = not (null ip) && not (null names)+
+ src/Craft/Hosts/Parser.hs view
@@ -0,0 +1,91 @@+module Craft.Hosts.Parser where++-- |This file is just to keep Megaparsec from conflicting with other modules++import Control.Monad (void)+import Data.List (intercalate)+import Text.Megaparsec+import Text.Megaparsec.String++import Craft.Hosts.Types+import Craft.Internal.Helpers.Parsing+import Craft.Types+++parseLine :: Int -> String -> Craft (Maybe (IP, [Name]))+parseLine ln s =+ case runParser lineParser (fromAbsFile hostsfp) s of+ Right x -> return x+ Left err -> $craftError $ show err+ where+ lineParser :: Parser (Maybe (IP, [Name]))+ lineParser = do+ pos <- getPosition+ setPosition $ pos {sourceLine = ln}+ space+ try (comment >> return Nothing) <|> try (Just <$> item)+ <|> (end >> return Nothing)+++comment :: Parser ()+comment = label "comment" $ do+ void $ char '#'+ void $ manyTill (noneOf "\r\n") end+ return ()+++item :: Parser (IP, [Name])+item = do+ ip <- try ipv4 <|> ipv6+ skipSome white+ name <- hostname+ skipMany white+ as <- aliases+ void $ optional comment+ return (ip, name:as)+++aliases :: Parser [Name]+aliases = label "aliases" $ hostname `sepEndBy` many white+++num :: Parser String+num = choice [ string "0", nonzero ]+++nonzero :: Parser String+nonzero = do+ a <- oneOf ['1'..'9'] <?> "non-zero digit with non-zero part"+ rest <- count' 0 2 digitChar+ if (read (a:rest) :: Int) > 255+ then fail "IP address parts must be 0 <= x <= 255"+ else return (a:rest)+++hostname :: Parser Name+hostname = Name <$> some (alphaNumChar <|> oneOf ".-")+++dot :: Parser ()+dot = void $ char '.'+++ipv4 :: Parser IP+ipv4 = label "ipv4 address" $ do+ p1 <- nonzero+ dot+ p2 <- num+ dot+ p3 <- num+ dot+ p4 <- num+ notFollowedBy digitChar+ return . IP $ intercalate "." [p1, p2, p3, p4]+++ipv6 :: Parser IP+ipv6 = IP <$> some (hexDigitChar <|> char ':') <?> "ipv6 address"+++white :: Parser ()+white = void $ (char ' ' <?> "space character") <|> tab
+ src/Craft/Hosts/Types.hs view
@@ -0,0 +1,29 @@+module Craft.Hosts.Types where++-- | This file is just to prevent a cyclic import between Hosts.hs+-- and Hosts/Parser.hs+import Craft.Types++newtype IP = IP String+ deriving (Eq)+++instance Show IP where+ show (IP ip) = ip+++newtype Name = Name String+ deriving (Eq)+++instance Show Name where+ show (Name name) = name+++type Configs = [(IP, [Name])]+data Hosts = Hosts { configs :: Configs }+ deriving (Eq, Show)+++hostsfp :: Path Abs FileP+hostsfp = $(mkAbsFile "/etc/hosts")
+ src/Craft/Internal.hs view
@@ -0,0 +1,8 @@+module Craft.Internal+(module X)+where++import Craft.DSL as X+import Craft.Helpers as X+import Craft.Run as X+import Craft.Types as X
+ src/Craft/Internal/Helpers.hs view
@@ -0,0 +1,47 @@+{-# LANGUAGE FlexibleInstances #-}+module Craft.Internal.Helpers where++import Data.Char (isSpace)+import Path+++indent :: Int -> String -> String+indent len text =+ unlines $ map (replicate len ' ' ++) $ lines text++trim :: String -> String+trim = f . f+ where f = reverse . dropWhile isSpace++class ToArg a where+ toArg :: String -> a -> [String]++instance ToArg String where+ toArg arg s+ | s == "" = []+ | otherwise = [arg, s]++instance ToArg Bool where+ toArg _ False = []+ toArg arg True = [arg]++instance ToArg a => ToArg (Maybe a) where+ toArg _ Nothing = []+ toArg arg (Just v) = toArg arg v++instance ToArg Int where+ toArg = showArg++instance ToArg (Path b t) where+ toArg arg v = [arg, toFilePath v]++toArgBool :: String -> String -> Bool -> [String]+toArgBool a _ True = [a]+toArgBool _ b False = [b]++showArg :: Show a => String -> a -> [String]+showArg arg v = [arg, show v]++toArgs :: ToArg a => String -> [a] -> [String]+toArgs arg = Prelude.concatMap (toArg arg)+
+ src/Craft/Internal/Helpers/Parsing.hs view
@@ -0,0 +1,10 @@+module Craft.Internal.Helpers.Parsing where++import Control.Monad (void)++import Text.Megaparsec hiding (parse)+import Text.Megaparsec.String+++end :: Parser ()+end = try (void $ lookAhead eol) <|> eof
+ src/Craft/Internal/UserGroup.hs view
@@ -0,0 +1,117 @@+module Craft.Internal.UserGroup where++import Control.Lens+import Data.List (intercalate)+import Data.Maybe (fromJust)+import Text.Megaparsec+import Text.Megaparsec.String++import Craft.Internal+import Craft.Internal.Helpers+import Craft.Internal.Helpers.Parsing+++colon :: Parser Char+colon = char ':'+++-- TESTME+passwdParser :: Parser (UserName, UserID, GroupID, String, String, String)+passwdParser = do+ name <- UserName <$> someTill anyChar colon+ _password <- manyTill anyChar colon+ uid' <- UserID . read <$> someTill digitChar colon+ gid' <- GroupID . read <$> someTill digitChar colon+ comment' <- manyTill anyChar colon+ home' <- manyTill anyChar colon+ shell' <- manyTill anyChar end+ return (name, uid', gid', comment', home', shell')+++-- TESTME+shadowParser :: Parser String+shadowParser = do+ _name <- someTill anyChar colon+ manyTill anyChar colon+++userFromStr :: String -> Craft (Maybe User)+userFromStr nameOrIdStr =+ getent "passwd" nameOrIdStr >>= \case+ ExecFail _ -> return Nothing+ ExecSucc r -> do+ (nameS, uid', gid', comment', home', shell') <-+ parseGetent passwdParser "passwd" nameOrIdStr (r ^. stdout)+ home'' <- parseAbsDir home'+ shell'' <- parseAbsFile shell'+ grp <- fromJust <$> groupFromID gid'+ grps <- getGroups nameS+ s <- $stdoutOrError =<< getent "shadow" (show nameS)+ passwordHash' <- parseGetent shadowParser "shadow" (show nameS) s+ return . Just $ User { _userName = nameS+ , _uid = uid'+ , _userGroup = grp+ , _userGroups = grps+ , _userPasswordHash = passwordHash'+ , _userHome = home''+ , _userShell = shell''+ , _userComment = comment'+ }+++getGroups :: UserName -> Craft [GroupName]+getGroups (UserName name) = do+ s <- $stdoutOrError =<< exec "id" ["-nG", name]+ return . map GroupName $ words s+++getent :: String -> String -> Craft ExecResult+getent dbase key = exec "getent" [dbase, key]+++parseGetent :: Parsec String a -> String -> String -> String -> Craft a+parseGetent parser dbase key input =+ case parse parser (unwords ["getent", dbase, key]) input of+ Left err -> $craftError $ show err+ Right r -> return r+++userFromID :: UserID -> Craft (Maybe User)+userFromID (UserID n) = userFromStr $ show n+++useradd :: User -> Craft ()+useradd User{..} =+ exec_ "useradd" $ args ++ toArg "--gid" (_gid _userGroup)+ where+ args = Prelude.concat+ [ toArg "--uid" _uid+ , toArg "--comment" _userComment+ , toArg "--groups" $ intercalate "," $ map show _userGroups+ , toArg "--home" (fromAbsDir _userHome)+ , toArg "--password" _userPasswordHash+ , toArg "--shell" (fromAbsFile _userShell)+ ]+++-- TESTME+groupParser :: Parser Group+groupParser = do+ name <- GroupName <$> someTill anyChar colon+ _ <- manyTill anyChar colon+ gid' <- GroupID . read <$> someTill digitChar colon+ members' <- map UserName <$> some alphaNumChar `sepBy` char ','+ return $ Group name gid' members'+++groupFromStr :: String -> Craft (Maybe Group)+groupFromStr nameOrIdStr =+ getent "group" nameOrIdStr >>= \case+ ExecFail _ -> return Nothing+ ExecSucc r -> Just <$> parseGetent groupParser "group" nameOrIdStr (r ^. stdout)+++groupFromID :: GroupID -> Craft (Maybe Group)+groupFromID (GroupID n )= groupFromStr $ show n++
+ src/Craft/Nginx.hs view
@@ -0,0 +1,176 @@+module Craft.Nginx where++import Control.Lens++import Craft+import Craft.Internal.Helpers+import qualified Craft.SysV as SysV+++setup :: Craft ()+setup =+ craft_ $ package "nginx"+++baseDir, sitesDir :: Path Abs Dir+baseDir = $(mkAbsDir "/etc/nginx")+sitesDir = baseDir </> $(mkRelDir "sites-enabled")+++data Config+ = Config+ { _configName :: Name+ , _configDirectives :: [Directive]+ , _configServers :: Servers+ , _configPriority :: Int+ }+++type Servers = [Server]+++data Server+ = Server+ { _serverNames :: [Name]+ , _listen :: (Address, Port, Args)+ , _serverDirectives :: [Directive]+ , _locations :: [Location]+ }+++data SSL+ = SSL+ { _sslKey :: File+ , _sslCert :: File+ }+++data Address+ = Address String+ | AnyAddress+++instance Show Address where+ show AnyAddress = "*"+ show (Address t) = t+++type Port = Int+data Location = Location URL [Directive] [Location]+type URL = String+type Directive = (Name, Args)+type Name = String+++makeLenses ''Config+makeLenses ''Server+makeLenses ''SSL+++config :: Name -> Config+config name =+ Config+ { _configName = name+ , _configPriority = 10+ , _configDirectives = []+ , _configServers = []+ }+++server :: Server+server =+ Server+ { _serverNames = []+ , _listen = (AnyAddress, 80, [])+ , _serverDirectives = []+ , _locations = []+ }+++sslServer :: SSL -> Server+sslServer ssl =+ Server+ { _serverNames = []+ , _listen = (AnyAddress, 443, ["ssl"])+ , _serverDirectives =+ [ ("ssl", ["on"])+ , ("ssl_certificate", [fromAbsFile $ ssl^.sslCert.path])+ , ("ssl_certificate_key", [fromAbsFile $ ssl^.sslKey.path])+ , ("ssl_session_cache", ["shared:SSL:10m"])+ , ("ssl_session_timeout", ["5m"])+ , ("ssl_protocols", ["TLSv1", "TLSv1.1", "TLSv1.2"])+ , ("ssl_ciphers", ["ECDHE-RSA-AES128-GCM-SHA256:ECDHE-ECDSA-AES128-GCM-SHA256:ECDHE-RSA-AES256-GCM-SHA384:ECDHE-ECDSA-AES256-GCM-SHA384:DHE-RSA-AES128-GCM-SHA256:DHE-DSS-AES128-GCM-SHA256:kEDH+AESGCM:ECDHE-RSA-AES128-SHA256:ECDHE-ECDSA-AES128-SHA256:ECDHE-RSA-AES128-SHA:ECDHE-ECDSA-AES128-SHA:ECDHE-RSA-AES256-SHA384:ECDHE-ECDSA-AES256-SHA384:ECDHE-RSA-AES256-SHA:ECDHE-ECDSA-AES256-SHA:DHE-RSA-AES128-SHA256:DHE-RSA-AES128-SHA:DHE-DSS-AES128-SHA256:DHE-RSA-AES256-SHA256:DHE-DSS-AES256-SHA:DHE-RSA-AES256-SHA:AES128-GCM-SHA256:AES256-GCM-SHA384:AES128-SHA:AES256-SHA:AES:CAMELLIA:DES-CBC3-SHA:!aNULL:!eNULL:!EXPORT:!DES:!RC4:!MD5:!PSK:!aECDH:!EDH-DSS-DES-CBC3-SHA:!EDH-RSA-DES-CBC3-SHA:!KRB5-DES-CBC3-SHA"])+ , ("ssl_prefer_server_ciphers", ["on"])+ ]+ , _locations = []+ }++++redirectWWWtoNoWWW :: [Server] -> [Server]+redirectWWWtoNoWWW servers =+ map go servers ++ servers+ where+ go s =+ s & serverNames .~ map ("www." ++) (s ^. serverNames)+ & locations .~ []+ & serverDirectives .~ s ^. serverDirectives +++ [ ("return", ["301", "http://" ++ s ^. serverNames . _head ++ "$uri"]) ]+++logs :: Path Abs Dir -> Path Rel FileP -> [Directive]+logs logdir name =+ [ ("access_log", [ logprefix ++ ".access.log", "combined"])+ , ("error_log", [ logprefix ++ ".error.log" ])+ ]+ where+ logprefix = fromAbsFile $ logdir </> name+++root :: [Directive] -> Location+root dirs = Location "/" dirs []+++instance Show Config where+ show cfg = dirs ++ servers+ where+ dirs = concatMap showDirective $ cfg ^. configDirectives+ servers = concatMap show $ cfg ^. configServers+++showDirective :: Directive -> String+showDirective (name, args) =+ name ++ " " ++ unwords args ++ ";"+++instance Show Server where+ show Server{..} = "\n" +++ "server {\n" ++ indent 2 (+ "listen " ++ showListen _listen ++ ";\n" +++ "server_name " ++ unwords _serverNames ++ ";\n" +++ unlines ( map showDirective _serverDirectives ++ map show _locations)) +++ "}\n"+++instance Show Location where+ show (Location fp dirs sublocations) =+ "location " ++ fp ++ " {\n" ++ indent 2 (+ unlines $ map showDirective dirs+ ++ map show sublocations) +++ "}\n"+++showListen :: (Address, Port, Args) -> String+showListen (addr, port, args) =+ show addr ++ ":" ++ show port ++ " " ++ unwords args+++toFile :: Config -> Craft File+toFile c = do+ fn <- parseRelFile $ (show $ c^.configPriority)++"_"++(c^.configName)++".conf"+ return $ file (sitesDir</>fn)+ & strContent .~ show c+++reload :: Craft ()+reload = SysV.reload $ SysV.service "nginx"
+ src/Craft/Package.hs view
@@ -0,0 +1,12 @@+module Craft.Package where++import Control.Lens+import Control.Monad.Reader++import Craft.Types+++get :: PackageName -> Craft (Maybe Package)+get name = do+ pm <- asks _craftPackageManager+ (pm ^. pmGetter) name
+ src/Craft/Pip.hs view
@@ -0,0 +1,114 @@+module Craft.Pip where++import Formatting hiding (char)+import qualified Formatting as F+import Text.Megaparsec++import Craft hiding (latest, package)+import qualified Craft+import qualified Craft.File as File+++newtype PipPackage = PipPackage Package+ deriving (Eq, Show)++pipfp :: Path Abs FileP+pipfp = $(mkAbsFile "/usr/local/bin/pip")++setup :: Craft ()+setup = do+ craft_ $ map Craft.package ["libffi-dev", "libssl-dev", "python-dev"]+ let pippkg = Craft.package "python-pip"+ File.exists pipfp >>= flip unless (craft_ pippkg)+ craft_ $ map package ["pyopenssl", "ndg-httpsclient", "pyasn1"]+ craft_ $ latest "pip"+ destroy_ pippkg+ craft_ $ latest "setuptools"+ destroy_ $ Craft.package "python-requests"+++package :: PackageName -> PipPackage+package pn = PipPackage $ Package pn AnyVersion+++latest :: PackageName -> PipPackage+latest pn = PipPackage $ Package pn Latest+++get :: PackageName -> Craft (Maybe PipPackage)+get pn = do+ r <- withPath [$(mkAbsDir "/usr/local/bin"), $(mkAbsDir "/usr/bin")] $ exec "pip" ["show", pn]+ case r of+ ExecFail _ -> return Nothing+ ExecSucc succr -> do+ results <- parseExecResult r pipShowParser (succr ^. stdout)+ if null results then+ return Nothing+ else case lookup "Version" results of+ Nothing -> $craftError "`pip show` did not return a version"+ Just version -> return . Just+ . PipPackage+ $ Package pn $ Version version+++-- TESTME+pipShowParser :: Parsec String [(String, String)]+pipShowParser = many $ kv <* many eol+ where+ kv :: Parsec String (String, String)+ kv = do+ key <- some $ noneOf ":"+ char ':' >> space+ value <- many $ noneOf "\n"+ return (key, value)+++pip :: [String] -> Craft ()+pip args = withPath [$(mkAbsDir "/usr/local/bin"), $(mkAbsDir "/usr/bin")] $ exec_ "pip" args+++pkgArgs :: PipPackage -> [String]+pkgArgs (PipPackage (Package pn pv)) = go pv+ where+ go AnyVersion = [pn]+ go Latest = ["--upgrade", pn]+ go (Version v) = ["--ignore-installed", pn ++ "==" ++ v]+++pipInstall :: PipPackage -> Craft ()+pipInstall pkg = pip $ "install" : pkgArgs pkg+++instance Craftable PipPackage PipPackage where+ watchCraft ppkg@(PipPackage pkg) = do+ let name = pkg ^. pkgName+ ver = pkg ^. pkgVersion+ verify =+ get name >>= \case+ Nothing -> $craftError $+ "craft PipPackage `"++name++"` failed! Not Found."+ Just ppkg'@(PipPackage pkg') -> do+ let newver = pkg' ^. pkgVersion+ case ver of+ Version _ ->+ when (newver /= ver) $+ $craftError+ $ formatToString+ ("craft PipPackage `"%F.string%"` failed! Wrong Version: "%shown%" Expected: "%shown)+ name newver ver+ _ -> return ()+ return ppkg'++ get name >>= \case+ Nothing -> do+ pipInstall ppkg+ ppkg' <- verify+ return (Created, ppkg')+ Just (PipPackage pkg') -> do+ let ver' = pkg' ^. pkgVersion+ if ver' == ver then+ return (Unchanged, ppkg)+ else do+ pipInstall ppkg+ ppkg' <- verify+ return (Updated, ppkg')
+ src/Craft/Run.hs view
@@ -0,0 +1,4 @@+module Craft.Run (module X) where++import Craft.Run.Local as X+import Craft.Run.SSH as X
+ src/Craft/Run/Internal.hs view
@@ -0,0 +1,70 @@+module Craft.Run.Internal where++import Conduit as C+import Control.Monad.Logger (LoggingT, askLoggerIO, logDebugNS,+ runLoggingT)+import qualified Control.Monad.Trans as Trans+import qualified Data.Conduit.List as CL+import Data.Conduit.Process (sourceProcessWithStreams)+import Data.Conduit.Text as CT+import Data.Monoid ((<>))+import qualified Data.Text as T+import System.Exit+import System.Process+import qualified System.Process.ListLike as SPLL++import Craft.Types+++isSuccessCode :: ExitCode -> Bool+isSuccessCode ExitSuccess = True+isSuccessCode (ExitFailure _) = False+++execProc :: CreateProcess -> LoggingT IO ExecResult+execProc p = do+ logDebugNS "exec|process" $ T.pack $ showProc p+ (exit', stdoutRaw, stderrRaw) <- Trans.lift $ SPLL.readCreateProcessWithExitCode p "" {- stdin -}+ let stdout' = trimNL stdoutRaw+ let stderr' = trimNL stderrRaw+ return $ case exit' of+ ExitSuccess -> ExecSucc $ SuccResult stdout' stderr' p+ ExitFailure code -> ExecFail $ FailResult code stdout' stderr' p+++execProc_ :: String -> CreateProcess -> LoggingT IO ()+execProc_ src p = do+ let p' = p { std_in = CreatePipe+ , std_out = CreatePipe+ , std_err = CreatePipe+ }+ logDebugNS "exec_|process" $ T.pack $ showProc p++ logger <- askLoggerIO+ let src' = "exec_|" <> T.pack src+ srcOut = src' <> "|stdout"+ srcErr = src' <> "|stderr"++ (ec, _, _) <- Trans.lift $ sourceProcessWithStreams+ p'+ (CL.sourceNull)+ (pipeConsumer logger srcOut)+ (pipeConsumer logger srcErr)+ case ec of+ ExitFailure n -> $craftError $ "exec_ `" ++ src ++ "` failed with code: " ++ show n+ ExitSuccess -> return ()+ where+ pipeConsumer logger s = decodeUtf8C =$= CT.lines =$ awaitForever (\txt ->+ (`runLoggingT` logger) (logDebugNS s txt))+++-- | Remove a single trailing newline character from the end of the String+trimNL :: String -> String+trimNL = reverse . rmNL . reverse+ where+ rmNL [] = []+ rmNL ('\n':xs) = rmCR xs+ rmNL xs = xs+ rmCR [] = []+ rmCR ('\r':xs) = xs+ rmCR xs = xs
+ src/Craft/Run/Local.hs view
@@ -0,0 +1,51 @@+module Craft.Run.Local where++import Control.Lens+import qualified Control.Monad.Trans as Trans+import qualified Data.ByteString as BS+import qualified Data.Map.Strict as Map+import System.Process hiding (readCreateProcessWithExitCode,+ readProcessWithExitCode)++import Craft.Run.Internal+import Craft.Types+++runLocal :: CraftRunner+runLocal =+ CraftRunner+ { runExec =+ \ce command args ->+ let p = localProc ce command args+ in execProc p+ , runExec_ =+ \ce command args ->+ let p = localProc ce command args+ in execProc_ (showProc p) p+ , runFileRead =+ Trans.lift . BS.readFile . fromAbsFile+ , runFileWrite =+ \fp content ->+ Trans.lift (BS.writeFile (fromAbsFile fp) content)+ , runSourceFile =+ \src dest ->+ let p = (proc "/bin/cp" [src, (fromAbsFile dest)])+ { env = Nothing+ , cwd = Nothing+ , close_fds = True+ , create_group = True+ , delegate_ctlc = False+ }+ in execProc_ (showProc p) p+ }+++localProc :: CraftEnv -> Command -> Args -> CreateProcess+localProc ce prog args =+ (proc prog args)+ { env = Just . Map.toList $ ce^.craftExecEnv+ , cwd = Just . fromAbsDir $ ce^.craftExecCWD+ , close_fds = True+ , create_group = True+ , delegate_ctlc = False+ }
+ src/Craft/Run/Nspawn.hs view
@@ -0,0 +1,55 @@+module Craft.Run.Nspawn where++import Control.Lens+import qualified Control.Monad.Trans as Trans+import qualified Data.ByteString as BS+import qualified Data.Map.Strict as Map+import System.Process hiding (readCreateProcessWithExitCode,+ readProcessWithExitCode)++import Craft.Run.Internal+import Craft.Types+++runNspawn :: Path Abs Dir -> CraftRunner+runNspawn dir =+ CraftRunner+ { runExec =+ \ce command args ->+ let p = nspawnProc dir ce command args+ in execProc p+ , runExec_ =+ \ce command args ->+ let p = nspawnProc dir ce command args+ in execProc_ (showProc p) p+ , runFileRead =+ \fp -> do+ fp' <- stripDir $(mkAbsDir "/") fp+ Trans.lift . BS.readFile . fromAbsFile $ dir</>fp'+ , runFileWrite =+ \fp content -> do+ fp' <- stripDir $(mkAbsDir "/") fp+ Trans.lift (BS.writeFile (fromAbsFile (dir</>fp')) content)+ , runSourceFile =+ \src dest -> do+ dest' <- stripDir $(mkAbsDir "/") dest+ let p = (proc "/bin/cp" [src, fromAbsFile (dir</>dest')])+ { env = Nothing+ , cwd = Nothing+ , close_fds = True+ , create_group = True+ , delegate_ctlc = False+ }+ execProc_ (showProc p) p+ }+++nspawnProc :: Path Abs Dir -> CraftEnv -> Command -> Args -> CreateProcess+nspawnProc dir ce cmd args =+ (proc "systemd-nspawn" ("-D":(fromAbsDir dir):"-q":cmd:args))+ { env = Just $ Map.toList (ce ^. craftExecEnv)+ , cwd = Just $ fromAbsDir (ce^.craftExecCWD)+ , close_fds = True+ , create_group = True+ , delegate_ctlc = False+ }
+ src/Craft/Run/SSH.hs view
@@ -0,0 +1,212 @@+module Craft.Run.SSH where++import Control.Exception.Lifted (bracket)+import Control.Lens+import Control.Monad.Logger (LoggingT)+import Control.Monad.Reader+import qualified Control.Monad.Trans as Trans+import qualified Data.ByteString.Char8 as B8+import Data.List (intersperse)+import qualified Data.Map.Strict as Map+import Data.Maybe (fromMaybe)+import Data.String.Utils (replace)+import Path.IO+import System.Process (ProcessHandle)+import qualified System.Process as Process+import qualified System.Process.ByteString as Proc.BS+import System.Random hiding (next)++import Craft.Helpers+import Craft.Run.Internal+import Craft.Types+++data SSHEnv = SSHEnv+ { _sshKey :: Path Abs FileP+ , _sshAddr :: String+ , _sshPort :: Int+ , _sshUser :: String+ , _sshSudo :: Bool+ , _sshControlPath :: Maybe (Path Rel FileP)+ , _sshOptions :: [String]+ }+makeLenses ''SSHEnv+++connStr :: Optic' (->) (Const String) SSHEnv String+connStr = to (\env -> concat [env ^. sshUser, "@", env ^. sshAddr])+++sshEnv :: String -> Path Abs FileP -> SSHEnv+sshEnv addr key =+ SSHEnv+ { _sshAddr = addr+ , _sshPort = 22+ , _sshKey = key+ , _sshUser = "root"+ , _sshSudo = True+ , _sshControlPath = Nothing+ , _sshOptions = sshDefaultOptions+ }+++sshDefaultOptions :: [String]+sshDefaultOptions =+ [ "UserKnownHostsFile=/dev/null"+ , "StrictHostKeyChecking=no"+ , "LogLevel=ERROR"+ ]+++data Session+ = Session+ { _sessionMasterProcHandle :: ProcessHandle+ , _sessionMasterProc :: Process.CreateProcess+ , _sessionControlPath :: Path Rel FileP+ , _sessionEnv :: SSHEnv+ , _sessionArgs :: Args+ }+makeLenses ''Session+++prependEachWith :: String -> [String] -> [String]+prependEachWith _ [] = []+prependEachWith flag opts = flag:(intersperse flag opts)+++newSession :: SSHEnv -> IO Session+newSession env = do+ defaultControlPath <- parseRelFile =<< ((".craft-ssh-session-"++) . show . abs <$> (randomIO :: IO Int))+ let controlPath = fromMaybe defaultControlPath (env^.sshControlPath)+ let args = [ "-p", show $ env^.sshPort ] -- port+ ++ [ "-i", fromAbsFile $ env^.sshKey ] -- private key+ ++ prependEachWith "-o"+ ((env ^. sshOptions)+ ++ [ "ControlPath=" ++ (fromRelFile controlPath)+ , "BatchMode=yes" -- never prompt for a password+ ])+ let masterProc = (Process.proc "ssh"+ (args+ ++ (prependEachWith "-o" [ "ControlMaster=yes"+ , "ControlPersist=yes" ])+ ++ [env ^. connStr]))+ { Process.std_in = Process.NoStream+ , Process.std_out = Process.NoStream+ , Process.std_err = Process.NoStream+ }+ (_, _, _, ph) <- Process.createProcess masterProc+ return Session { _sessionEnv = env+ , _sessionMasterProc = masterProc+ , _sessionMasterProcHandle = ph+ , _sessionControlPath = controlPath+ , _sessionArgs = args+ }+++closeSession :: Session -> IO ()+closeSession Session{..} = do+ Process.terminateProcess _sessionMasterProcHandle+ whenM (doesFileExist _sessionControlPath) $+ removeFile _sessionControlPath+++withSession :: SSHEnv -> (Session -> LoggingT IO a) -> LoggingT IO a+withSession env =+ bracket (Trans.lift $ newSession env)+ (Trans.lift . closeSession)+++runSSHSession :: Session -> CraftRunner+runSSHSession session =+ CraftRunner+ { runExec =+ \ce command args ->+ execProc $ sshProc session ce command args+ , runExec_ =+ \ce command args ->+ let p = sshProc session ce command args+ in execProc_ (unwords (command:args)) p+ , runFileRead =+ \fp -> do+ let p = sshProc session craftEnvOverride "cat" [fromAbsFile fp]+ (ec, content, stderr') <-+ Trans.lift $ Proc.BS.readCreateProcessWithExitCode p ""+ unless (isSuccessCode ec) $+ $craftError $ "Failed to read file '"++ fromAbsFile fp ++"': " ++ B8.unpack stderr'+ return content+ , runFileWrite =+ \fp content -> do+ let p = sshProc session craftEnvOverride "tee" [fromAbsFile fp]+ (ec, _, stderr') <-+ Trans.lift $ Proc.BS.readCreateProcessWithExitCode p content+ unless (isSuccessCode ec) $+ $craftError $ "Failed to write file '" ++ fromAbsFile fp ++ "': " ++ B8.unpack stderr'+ , runSourceFile =+ \src dest ->+ let p = Process.proc "rsync"+ ( [ "--quiet" -- suppress non-error messages+ , "--checksum" -- skip based on checksum, not mod-time & size+ , "--compress" -- compress file data during the transfer+ -- specify the remote shell to use+ , "--rsh=ssh " ++ unwords (session ^. sessionArgs)]+ ++ (if session ^. sessionEnv . sshSudo+ then ["--super", "--rsync-path=sudo rsync"]+ else [])+ ++ [ src , (session ^. sessionEnv . connStr) ++ ":" ++ fromAbsFile dest ])+ in execProc_ (showProc p) p+ }+ where+ craftEnvOverride :: CraftEnv+ craftEnvOverride =+ craftEnv noPackageManager+ & craftExecEnv .~ Map.empty+ & craftExecCWD .~ $(mkAbsDir "/")+++runCraftSSH :: SSHEnv -> CraftEnv -> Craft a -> LoggingT IO a+runCraftSSH env ce configs =+ withSession env $ \session -> runCraft (runSSHSession session) ce configs+++sshProc :: Session -> CraftEnv -> Command -> Args+ -> Process.CreateProcess+sshProc session ce command args =+ Process.proc "ssh" $ session ^. sessionArgs+ ++ (prependEachWith "-o" [ "ControlMaster=auto"+ , "ControlPersist=no"+ ])+ ++ [ session ^. sessionEnv . connStr+ , fullExecStr+ ]+ where+ fullExecStr :: String+ fullExecStr = unwords (sudoArgs ++ ["sh", "-c", "'", shellStr, "'"])++ sudoArgs :: [String]+ sudoArgs = if session ^. sessionEnv . sshSudo+ then ["sudo", "-n", "-H"]+ else []++ shellStr :: String+ shellStr = unwords (cdArgs ++ execEnvArgs ++ (command : map (escape specialChars) args))++ specialChars :: [String]+ specialChars = [" ", "*", "$", "'"]++ execEnvArgs :: [String]+ execEnvArgs = map (escape specialChars) . renderEnv $ ce ^. craftExecEnv++ cdArgs :: [String]+ cdArgs = ["cd", (fromAbsDir $ ce^.craftExecCWD), ";"]++ escape :: [String] -> String -> String+ escape = recur backslash++ recur _ [] s = s+ recur f (a:as) s = recur f as $ f a s++ backslash x = replace x ('\\':x)+++renderEnv :: ExecEnv -> [String]+renderEnv = map (\(k, v) -> k++"="++v) . Map.toList
+ src/Craft/Run/Vagrant.hs view
@@ -0,0 +1,66 @@+module Craft.Run.Vagrant where++import Control.Lens+import Control.Monad.Logger (LoggingT)+import qualified Control.Monad.Trans as Trans+import qualified Data.Map.Strict as Map+import Data.Maybe (fromMaybe)+import qualified System.Directory+import qualified System.Environment++import Craft+import Craft.Config.SSH (SSHConfig (..), cfgLookup, parser)+++data VagrantSettings+ = VagrantSettings+ { vagrantUp :: Bool+ , vagrantBox :: String+ }+++vagrantSettings :: VagrantSettings+vagrantSettings =+ VagrantSettings+ { vagrantUp = False+ , vagrantBox = "default"+ }+++runCraftVagrant :: VagrantSettings -> CraftEnv -> Craft a -> LoggingT IO a+runCraftVagrant settings env configs = do+ let box = vagrantBox settings+ sysEnv <- Trans.lift System.Environment.getEnvironment+ cwd <- parseAbsDir =<< Trans.lift System.Directory.getCurrentDirectory+ -- vagrant ssh-config+ sshcfg <-+ runCraft+ runLocal+ (craftEnv (env ^. craftPackageManager)+ & craftExecEnv .~ Map.fromList sysEnv+ & craftExecCWD .~ cwd)+ $ do+ when (vagrantUp settings) $ exec_ "vagrant" ["up", box]+ SSHConfig <$> parseExecStdout parser "vagrant" ["ssh-config", box]+ let addr = cfgLookupOrError box "hostname" sshcfg+ let port = read $ cfgLookupOrError box "port" sshcfg+ let user = cfgLookupOrError box "user" sshcfg+ key <- parseAbsFile $ cfgLookupOrError box "identityfile" sshcfg+ -- vagrant ssh+ withSession+ (sshEnv addr key+ & sshUser .~ user+ & sshPort .~ port+ & sshSudo .~ True)+ $ \session ->+ runCraft+ (runSSHSession session)+ env+ configs+++cfgLookupOrError :: String -> String -> SSHConfig -> String+cfgLookupOrError box name sshcfg =+ fromMaybe+ (error $ "'"++name++"' not found in output of 'vagrant ssh-config "++box++"'")+ (cfgLookup box name sshcfg)
+ src/Craft/S3File.hs view
@@ -0,0 +1,150 @@+module Craft.S3File where++import Control.Lens hiding (noneOf)+import Control.Monad.Logger (logDebug)+import Crypto.Hash (SHA1)+import Crypto.MAC.HMAC (HMAC, hmac)+import Data.ByteArray.Encoding+import qualified Data.ByteString.Char8 as B8+import qualified Data.Text as T+import Text.Megaparsec+import Text.Megaparsec.String++import Craft hiding (try)+import qualified Craft.File as File+++data S3File+ = S3File+ { _file :: File+ , _source :: String+ , _domain :: String+ , _version :: Version+ , _auth :: Maybe (String, String) -- ^ (AWSAccessKeyId, AWSSecretAccessKey)+ }+ deriving (Eq, Show)++makeLenses ''S3File++-- TODO: instance FileLike S3File+++s3file :: Path Abs FileP -> String -> S3File+s3file fp source' =+ S3File+ { _file = Craft.file fp+ , _domain = "s3.amazonaws.com"+ , _source = source'+ , _version = AnyVersion+ , _auth = Nothing+ }+++url :: Getter S3File String+url = to (\f -> "https://" ++ f ^. domain ++ "/" ++ f ^. source)+++-- | Add AWS Authentication Headers to curl commands+-- http://docs.aws.amazon.com/AmazonS3/latest/dev/RESTAuthentication.html#ConstructingTheAuthenticationHeader+authHeaders :: String -> S3File -> Craft [String]+authHeaders method s3f =+ case s3f ^. auth of+ Nothing -> return []+ Just (awsKeyID, awsSecretKey) -> do+ date <- $stdoutOrError =<< exec "date" ["-u", "--rfc-2822"]+ sourceUrl <- case s3f ^. source of+ [] -> $craftError $ "S3File.source is empty! " ++ show s3f+ '/':_ -> return $ s3f ^. source+ s3source -> return $ '/':s3source+ let contentMD5 = ""+ contentType = ""+ canonicalizedAmzHeaders = ""+ toSign = method ++ "\n"+ ++ contentMD5 ++ "\n"+ ++ contentType ++ "\n"+ ++ date ++ "\n"+ ++ canonicalizedAmzHeaders+ ++ sourceUrl+ sigHMAC :: HMAC SHA1+ sigHMAC = hmac (B8.pack awsSecretKey)+ (B8.pack toSign)+ sig = B8.unpack $ convertToBase Base64 sigHMAC+ $logDebug . T.pack $ "awsSecretKey == " ++ awsSecretKey+ $logDebug . T.pack $ "awsKeyID == " ++ awsKeyID+ $logDebug . T.pack $ "toSign == " ++ show toSign++ return [ "--header", "Date:" ++ date+ , "--header", "Authorization:AWS " ++ awsKeyID ++ ":" ++ sig+ ]+++getS3Sum :: S3File -> Craft (Maybe String)+getS3Sum f = do+ hdrs <- authHeaders "HEAD" f+ headers <- parseExecStdout httpHeaders "curl" (hdrs ++ ["-s", "-XHEAD", "-I", f ^. url])+ return $ filter ('"' /=) <$> lookup "ETag" headers+++httpHeaders :: Parser [(String, String)]+httpHeaders = do+ _ <- string "HTTP/1." >> oneOf "01" >> string " 200 OK" >> eol+ headers <- header `sepEndBy1` eol+ return headers+++header :: Parser (String, String)+header = do+ k <- noneOf ":\r\n" `someTill` string ": "+ v <- many $ noneOf "\r\n"+ return (k,v)+++instance Craftable S3File S3File where+ watchCraft s3f = do+ let s3f' = s3f & Craft.S3File.file . fileContent .~ Nothing+ let fp = s3f' ^. Craft.S3File.file . path+ let downloadFile = do+ hdrs <- authHeaders "GET" s3f+ exec_ "curl" $ hdrs ++ ["-XGET", "-s", "-L", "-o", fromAbsFile fp, s3f'^.url]+ let verify expected = do+ md5chksum <- File.md5sum fp+ when (md5chksum /= expected) (+ $craftError $ "verify S3File failed! Expected `" ++ expected ++ "` "+ ++ "Got `" ++ md5chksum ++ "` for " ++ show s3f')++ getS3Sum s3f' >>= \case+ Nothing -> $craftError $ "Failed to get chksum from S3 for: " ++ show s3f'+ Just etag -> do+ exists <- File.exists fp+ w <- if exists then do+ curSum <- File.md5sum fp+ case s3f' ^. version of+ AnyVersion -> return Unchanged+ Latest+ | etag == curSum -> return Unchanged+ | otherwise -> do+ downloadFile+ verify etag+ return Updated+ Version verStr+ | curSum == verStr -> return Unchanged+ | verStr /= etag ->+ $craftError $+ "Cannot download specific file version from S3. "+ ++ "Found version " ++ etag ++ " for " ++ show s3f'+ | otherwise -> do+ downloadFile+ verify verStr+ return Updated+ else do+ downloadFile+ case s3f' ^. version of+ Version verStr -> verify verStr+ _ -> verify etag+ return Created++ fw <- watchCraft_ $ s3f' ^. Craft.S3File.file+ if changed w then+ return (w, s3f')+ else+ return (fw, s3f')
+ src/Craft/SSH.hs view
@@ -0,0 +1,51 @@+module Craft.SSH where++import Control.Lens+import Data.Char (toLower)+import Text.Megaparsec+import Text.Megaparsec.String++import Craft+++data KeyType+ = DSA+ | RSA+ | RSA1+ | ECDSA+ | ED25519+ | KeyType String+ deriving (Eq)+++instance Show KeyType where+ show DSA = "ssh-dsa"+ show RSA = "ssh-rsa"+ show RSA1 = "ssh-rsa1"+ show ECDSA = "ssh-ecdsa"+ show ED25519 = "ssh-ed25519"+ show (KeyType s) = s+++userDir :: User -> Directory+userDir user =+ directory ((user^.userHome) </> $(mkRelDir ".ssh"))+ & mode .~ Mode RWX O O+ & ownerAndGroup .~ user+++parseKeyType :: Parser KeyType+parseKeyType = do+ void $ string "ssh-"+ s <- alphaNumChar `someTill` (void spaceChar <|> eof)+ -- The reason for converting the string to lowercase is because+ -- KeyType is allowed to be any string.+ -- This prevents "ssh-rSa" from parsing to `KeyType "ssh-rSa"` instead of `RSA`+ -- even if "ssh-rSa" is not technically valid.+ return $ case map toLower s of+ "dsa" -> DSA+ "rsa" -> RSA+ "rsa1" -> RSA1+ "ecdsa" -> ECDSA+ "ed25519" -> ED25519+ x -> KeyType ("ssh-"++x)
+ src/Craft/SSH/AuthorizedKey.hs view
@@ -0,0 +1,68 @@+module Craft.SSH.AuthorizedKey where++import Control.Lens+import qualified Data.Map.Strict as Map+import Data.Maybe (catMaybes)+import Text.Megaparsec+import Text.Megaparsec.String++import Craft hiding (try)+import qualified Craft.File as File+import Craft.SSH+import Craft.SSH.PublicKey as PK+++data AuthorizedKey+ = AuthorizedKey+ { _authkeyUser :: User+ , _authkey :: PublicKey+ }+ deriving (Show, Eq)+makeLenses ''AuthorizedKey+++instance Craftable AuthorizedKey AuthorizedKey where+ watchCraft ak@(AuthorizedKey user pk) = do+ pubKeys <- Map.elems . Map.insert (pk^.pubkeyValue) pk+ . authkeysToMap+ <$> get user+ craft_ $ userDir user+ w <- watchCraft_ $ userFile user+ & strContent .~ (unlines $ map PK.toString pubKeys)+ return (w, ak)+++instance Destroyable AuthorizedKey where+ watchDestroy (AuthorizedKey user pk) = do+ pubKeysMap <- authkeysToMap <$> get user+ let val = pk^.pubkeyValue+ let newPubKeys = Map.elems $ Map.delete val pubKeysMap+ craft_ $ userDir user+ craft_ $ userFile user+ & strContent .~ (unlines $ map PK.toString newPubKeys)+ return $ case Map.lookup val pubKeysMap of+ Nothing -> (Unchanged, Nothing)+ Just x -> (Removed, Just (AuthorizedKey user x))+++userFile :: User -> File+userFile user =+ file ((user^.to userDir.path) </> $(mkRelFile "authorized_keys"))+ & mode .~ Mode RW O O+ & ownerAndGroup .~ user+++get :: User -> Craft [AuthorizedKey]+get user = File.get (user ^. to userFile . path) >>= \case+ Nothing -> return []+ Just f -> map (AuthorizedKey user) <$> parseFile parsePublicKeys (f^.path)+++authkeysToMap :: [AuthorizedKey] -> Map.Map String PublicKey+authkeysToMap = Map.fromList . map (((,)<$>_pubkeyValue<*>id) . _authkey)+++parsePublicKeys :: Parser [PublicKey]+parsePublicKeys = do+ keys <- (try (Just <$> parsePublicKey) <|> (space >> return Nothing)) `sepEndBy` eol+ return $ catMaybes keys
+ src/Craft/SSH/PrivateKey.hs view
@@ -0,0 +1,33 @@+module Craft.SSH.PrivateKey where++import Control.Lens++import Craft+import Craft.SSH+++data PrivateKey+ = PrivateKey+ { _user :: User+ , _name :: String+ , _content :: String+ }+ deriving (Eq, Show)+makeLenses ''PrivateKey+++path :: PrivateKey -> Craft (Path Abs FileP)+path pk = do+ n <- parseRelFile $ pk^.name+ return $ (pk^.user.to userDir.Craft.path)</>n+++instance Craftable PrivateKey PrivateKey where+ watchCraft pk = do+ craft_ $ userDir $ pk^.user+ pkPath <- Craft.SSH.PrivateKey.path pk+ w <- watchCraft_ $ file pkPath+ & mode .~ Mode RW O O+ & ownerAndGroup .~ pk ^. user+ & strContent .~ pk ^. content+ return (w, pk)
+ src/Craft/SSH/PublicKey.hs view
@@ -0,0 +1,50 @@+module Craft.SSH.PublicKey where++import Control.Lens+import Text.Megaparsec+import Text.Megaparsec.String++import Craft+import Craft.Internal.Helpers.Parsing+import Craft.SSH+++data PublicKey+ = PublicKey+ { _pubkeyType :: KeyType+ , _pubkeyValue :: String+ , _pubkeyComment :: String+ }+ deriving (Show, Eq)+makeLenses ''PublicKey+++publicKey :: KeyType -> String -> PublicKey+publicKey pktype pkval =+ PublicKey+ { _pubkeyType = pktype+ , _pubkeyValue = pkval+ , _pubkeyComment = ""+ }+++toString :: PublicKey -> String+toString pk =+ let comment = pk ^. pubkeyComment+ in show (pk ^. pubkeyType) ++ " " ++ pk ^. pubkeyValue+ ++ if null comment then "" else " " ++ comment+++parsePublicKey :: Parser PublicKey+parsePublicKey = do+ space+ kt <- parseKeyType+ space+ key <- base64Char `someTill` (void spaceChar <|> eof)+ space+ comment <- anyChar `manyTill` end+ return $ PublicKey kt key comment+++base64Char :: Parser Char+base64Char = alphaNumChar <|> char '+' <|> char '/' <|> char '='
+ src/Craft/SysV.hs view
@@ -0,0 +1,135 @@+module Craft.SysV where++import Control.Lens++import Craft+import qualified Craft.File as File+++data Status = Running+ | Stopped+ deriving (Eq, Show)+++data RunLevel = RunLevel0+ | RunLevel1+ | RunLevel2+ | RunLevel3+ | Runlevel4+ | Runlevel5+ | Runlevel6+ | RunlevelS+ deriving (Eq)+++instance Show RunLevel where+ show RunLevel0 = "0"+ show RunLevel1 = "1"+ show RunLevel2 = "2"+ show RunLevel3 = "3"+ show Runlevel4 = "4"+ show Runlevel5 = "5"+ show Runlevel6 = "6"+ show RunlevelS = "S"+++defaults :: [RunLevel]+defaults = [ RunLevel0+ , RunLevel1+ , RunLevel2+ , RunLevel3+ , Runlevel4+ , Runlevel5+ , Runlevel6+ ]+++data Service = Service+ { _serviceName :: String+ , _serviceStatus :: Status+ , _serviceAtBoot :: Maybe Bool+ }+ deriving (Eq, Show)+makeLenses ''Service+++service :: String -> Service+service sn =+ Service+ { _serviceName = sn+ , _serviceStatus = Running+ , _serviceAtBoot = Just True+ }+++servicePath :: String -> Craft (Path Abs FileP)+servicePath sn = do+ fn <- parseRelFile sn+ return $ $(mkAbsDir "/etc/init.d")</>fn+++get :: String -> Craft (Maybe Service)+get sn = do+ sp <- servicePath sn+ exists <- File.exists sp+ if exists then do+ status' <- exec (fromAbsFile sp) ["status"]>>= \case+ (ExecFail _) -> return Stopped+ (ExecSucc _) -> return Running+ return . Just $ Service { _serviceName = sn+ , _serviceStatus = status'+ , _serviceAtBoot = Nothing+ }+ else+ return Nothing+++status :: Service -> Craft Status+status svc = do+ sp <- servicePath $ svc^.serviceName+ exec (fromAbsFile sp) ["status"] >>= \case+ (ExecFail _) -> return Stopped+ (ExecSucc _) -> return Running+++run_ :: String -> Service -> Craft ()+run_ cmd svc = do+ sp <- servicePath $ svc^.serviceName+ exec_ (fromAbsFile sp) [cmd]+++start :: Service -> Craft ()+start = run_ "start"+++stop :: Service -> Craft ()+stop = run_ "stop"+++restart :: Service -> Craft ()+restart = run_ "restart"+++reload :: Service -> Craft ()+reload = run_ "reload"+++updateRcD :: Service -> String -> Craft ()+updateRcD svc cmd =+ exec_ "update-rc.d" ["-f", svc^.serviceName, cmd]+++instance Craftable Service Service where+ watchCraft svc = do+ whenJust (svc^.serviceAtBoot) $ \x ->+ updateRcD svc (if x then "defaults" else "remove")+ status' <- status svc+ case (svc^.serviceStatus, status') of+ (Running, Running) -> return (Unchanged, svc)+ (Stopped, Stopped) -> return (Unchanged, svc)+ (Running, Stopped) -> do+ start svc+ return (Updated, svc)+ (Stopped, Running) -> do+ stop svc+ return (Updated, svc)
+ src/Craft/Types.hs view
@@ -0,0 +1,458 @@+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE TypeFamilies #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+module Craft.Types+( module Craft.Types+, module Craft.Error+, module Craft.File.Mode+, module Path+)+where++import Control.Lens+import Control.Monad.Catch (MonadCatch, MonadThrow)+import Control.Monad.IO.Class (MonadIO)+import Control.Monad.Logger (LoggingT, MonadLogger, logDebugN,+ monadLoggerLog)+import Control.Monad.Reader (MonadReader, ReaderT, runReaderT)+import qualified Control.Monad.Trans.Class as Trans+import Control.Monad.Trans.Free (FreeT, MonadFree, iterT)+import Data.ByteString (ByteString)+import qualified Data.ByteString as BS+import qualified Data.ByteString.Char8 as B8+import Data.ByteString.Lens (unpackedChars)+import Data.Map.Strict (Map)+import qualified Data.Map.Strict as Map+import Data.Maybe (isNothing)+import qualified Data.Text as T+import Data.Versions (parseV)+import Formatting+import Language.Haskell.TH.Syntax (Exp, Q)+import Path hiding (File)+import qualified Path+import Prelude hiding (FilePath)+import qualified Prelude+import System.Process++import Craft.Error+import Craft.File.Mode+import Craft.Internal.Helpers+++-- | FileP is an alias because 'Path.File' collides with 'Craft.File'.+-- The alias was not named FilePath because it would conflict with Prelude.+type FileP = Path.File++data CraftEnv+ = CraftEnv+ { _craftPackageManager :: PackageManager+ , _craftExecEnv :: ExecEnv+ , _craftExecCWD :: Path Abs Dir+ }+++craftEnv :: PackageManager -> CraftEnv+craftEnv pm =+ CraftEnv+ { _craftPackageManager = pm+ , _craftExecEnv = Map.fromList [("PATH", "/usr/local/sbin:/usr/local/bin:/usr/sbin:/usr/bin:/sbin:/bin")]+ , _craftExecCWD = $(mkAbsDir "/")+ }+++newtype Craft a = Craft { unCraft :: ReaderT CraftEnv (FreeT CraftDSL (LoggingT IO)) a }+ deriving ( Functor, Monad, MonadIO, Applicative, MonadReader CraftEnv+ , MonadFree CraftDSL, MonadThrow, MonadCatch, MonadLogger)+++instance (MonadLogger m, Functor f) => MonadLogger (FreeT f m) where+ monadLoggerLog a b c d = Trans.lift $ monadLoggerLog a b c d+++interpretCraft :: CraftEnv -> (CraftDSL (LoggingT IO a) -> LoggingT IO a) -> Craft a -> LoggingT IO a+interpretCraft ce interpreter = iterT interpreter . flip runReaderT ce . unCraft+++data CraftRunner = CraftRunner+ { runExec :: CraftEnv -> Command -> Args -> LoggingT IO ExecResult+ , runExec_ :: CraftEnv -> Command -> Args -> LoggingT IO ()+ , runFileRead :: Path Abs FileP -> LoggingT IO ByteString+ , runFileWrite :: Path Abs FileP -> ByteString -> LoggingT IO ()+ , runSourceFile :: Prelude.FilePath -> Path Abs FileP -> LoggingT IO ()+ }+++runCraft :: CraftRunner -> CraftEnv -> Craft a -> LoggingT IO a+runCraft runner ce dsl = do+ iterT interpreter $ flip runReaderT ce $ unCraft dsl+ where+ interpreter (Exec ce' cmd args next) = do+ logDebugN $ sformat ("Exec "%string%" "%string) cmd (unwords args)+ (runExec runner) ce' cmd args >>= next+ interpreter (Exec_ ce' cmd args next) = do+ logDebugN $ sformat ("Exec_ "%string%" "%string) cmd (unwords args)+ (runExec_ runner) ce' cmd args >> next+ interpreter (FileRead fp next) = do+ logDebugN $ sformat ("FileRead "%shown) fp+ (runFileRead runner) fp >>= next+ interpreter (FileWrite fp content next) = do+ logDebugN $ sformat ("FileWrite "%shown) fp+ (runFileWrite runner) fp content >> next+ interpreter (SourceFile sourcer dest next) = do+ src <- Trans.lift sourcer+ logDebugN $ sformat ("SourceFile "%string%" "%shown) src dest+ (runSourceFile runner) src dest >> next+++type StdOut = String+type StdErr = String+type Args = [String]+type Command = String+++data SuccResult+ = SuccResult+ { _stdout :: StdOut+ , _stderr :: StdErr+ , _succProc :: CreateProcess+ }+++data FailResult+ = FailResult+ { _exitcode :: Int+ , _failStdout :: StdOut+ , _failStderr :: StdErr+ , _failProc :: CreateProcess+ }+++data ExecResult+ = ExecFail FailResult+ | ExecSucc SuccResult+++isSuccess :: ExecResult -> Bool+isSuccess (ExecSucc _) = True+isSuccess (ExecFail _) = False+++isFailure :: ExecResult -> Bool+isFailure = not . isSuccess+++errorOnFail :: Q Exp+errorOnFail = [|+ \case+ ExecSucc r -> return r+ ExecFail r -> $craftError $ show r|]+++-- | Try to get STDOUT from a process.+-- If the command exits with an error code, throw a CraftError.+stdoutOrError :: Q Exp+stdoutOrError = [|+ \case+ ExecSucc r -> return $ _stdout r+ ExecFail r -> $craftError $ show r|]+++type ExecEnv = Map String String+type CWD = Path Abs FileP+type PackageName = String++newtype UserName = UserName String+ deriving (Eq, Ord)+newtype UserID = UserID Int+ deriving (Eq, Show, Ord)+newtype GroupName = GroupName String+ deriving (Eq, Ord)+newtype GroupID = GroupID Int+ deriving (Eq, Show, Ord)++instance Show GroupName where+ show (GroupName n) = n++instance Show UserName where+ show (UserName n) = n++instance ToArg UserID where+ toArg arg (UserID n) = [arg, show n]++instance ToArg GroupID where+ toArg arg (GroupID n) = [arg, show n]++++class Eq (FileLikePath a) => FileLike a where+ type FileLikePath a :: *+ path :: Lens' a (FileLikePath a)+ mode :: Lens' a Mode+ ownerID :: Lens' a UserID+ groupID :: Lens' a GroupID+++data File+ = File+ { _filePath :: Path Abs FileP+ , _fileMode :: Mode+ , _fileOwnerID :: UserID+ , _fileGroupID :: GroupID+ , _fileContent :: Maybe ByteString+ }+++file :: Path Abs FileP -> File+file fp =+ File+ { _filePath = fp+ , _fileMode = Mode RW R R+ , _fileOwnerID = UserID 0+ , _fileGroupID = GroupID 0+ , _fileContent = Nothing+ }++++data Directory+ = Directory+ { _directoryPath :: Path Abs Dir+ , _directoryMode :: Mode+ , _directoryOwnerID :: UserID+ , _directoryGroupID :: GroupID+ }+ deriving (Show, Eq)+++directory :: Path Abs Dir -> Directory+directory dp =+ Directory+ { _directoryPath = dp+ , _directoryMode = Mode RWX RX RX+ , _directoryOwnerID = UserID 0+ , _directoryGroupID = GroupID 0+ }+++data Version+ = Version String+ | AnyVersion+ | Latest+ deriving (Show)+++-- Note: This may or may not make sense.+-- Open to suggestions if any of this seems incorrect.+instance Eq Version where+ (==) AnyVersion _ = True+ (==) _ AnyVersion = True+ (==) Latest Latest = True+ (==) Latest (Version _) = False+ (==) (Version _) Latest = False+ (==) (Version a) (Version b) = a == b+++data Package+ = Package+ { _pkgName :: PackageName+ , _pkgVersion :: Version+ }+ deriving (Eq, Show)+++data PackageManager+ = PackageManager+ { _pmGetter :: PackageName -> Craft (Maybe Package)+ , _pmInstaller :: Package -> Craft ()+ , _pmUpgrader :: Package -> Craft ()+ , _pmUninstaller :: Package -> Craft ()+ }+++noPackageManager :: PackageManager+noPackageManager =+ let err _ = $craftError "No Package Manager" in+ PackageManager+ { _pmGetter = err+ , _pmInstaller = err+ , _pmUpgrader = err+ , _pmUninstaller = err+ }+++data CraftDSL next+ = Exec CraftEnv Command Args (ExecResult -> next)+ | Exec_ CraftEnv Command Args next+ | FileRead (Path Abs FileP) (ByteString -> next)+ | FileWrite (Path Abs FileP) ByteString next+ | SourceFile (IO Prelude.FilePath) (Path Abs FileP) next+ deriving Functor+++data CraftRunDSL next+ = CraftRunDSL (CraftDSL next)+++makeLenses ''PackageManager+makeLenses ''CraftEnv+makeLenses ''Package+makePrisms ''Version+makeLenses ''FailResult+makeLenses ''SuccResult+makeLenses ''File+makeLenses ''Directory++++strContent :: Lens' File String+strContent = lens (view $ fileContent . _Just . unpackedChars)+ (\f s -> f & fileContent .~ Just (B8.pack s))++instance Eq File where+ (==) a b = (a ^. filePath == b ^. filePath)+ && (a ^. fileMode == b ^. fileMode)+ && (a ^. fileOwnerID == b ^. fileOwnerID)+ && (a ^. fileGroupID == b ^. fileGroupID)+ && ( isNothing (a ^. fileContent)+ || isNothing (b ^. fileContent)+ || (a ^. fileContent == b ^. fileContent))+++instance Show File where+ show f = "File { _filePath = " ++ show (f ^. filePath) +++ ", _fileMode = " ++ show (f ^. fileMode) +++ ", _fileOwnerID = " ++ show (f ^. fileOwnerID) +++ ", _fileGroupID = " ++ show (f ^. fileGroupID) +++ ", _fileContent = " ++ showContent (f ^. fileContent) +++ " }"+ where+ maxlen = 30+ showContent Nothing = "Nothing"+ showContent (Just c)+ | BS.length c > maxlen = "Just " ++ show (BS.take maxlen c) ++ "..."+ | otherwise = "Just " ++ show c++++++instance FileLike File where+ type FileLikePath File = Path Abs FileP+ path = filePath+ mode = fileMode+ ownerID = fileOwnerID+ groupID = fileGroupID+++instance FileLike Directory where+ type FileLikePath Directory = Path Abs Dir+ path = directoryPath+ mode = directoryMode+ ownerID = directoryOwnerID+ groupID = directoryGroupID+++data User+ = User+ { _userName :: UserName+ , _uid :: UserID+ , _userComment :: String+ , _userGroup :: Group+ , _userGroups :: [GroupName]+ , _userHome :: Path Abs Dir+ , _userPasswordHash :: String+ --, _salt :: String+ --, _locked :: Bool+ , _userShell :: Path Abs FileP+ --, system :: Bool+ }+ deriving (Eq, Show)+++data Group+ = Group+ { _groupName :: GroupName+ , _gid :: GroupID+ , _groupMembers :: [UserName]+ }+ deriving (Eq, Show)+++makeLenses ''User+makeLenses ''Group+++++owner :: FileLike a => Setter a a () User+owner = sets (\functor filelike -> doit filelike (functor ()))+ where doit filelike o = filelike & ownerID .~ (o ^. uid)+++group :: FileLike a => Setter a a () Group+group = sets (\functor filelike -> doit filelike (functor ()))+ where doit filelike g = filelike & groupID .~ (g ^. gid)+++ownerAndGroup :: FileLike a => Setter a a () User+ownerAndGroup = sets (\functor filelike -> doit filelike (functor ()))+ where doit filelike u = filelike & owner .~ u+ & group .~ (u ^. userGroup)+++execResultProc :: ExecResult -> CreateProcess+execResultProc (ExecFail failr) = failr ^. failProc+execResultProc (ExecSucc succr) = succr ^. succProc+++instance Show FailResult where+ show r = unlines+ [ "exec failed!"+ , "<<<< process >>>>"+ , showProc (r ^. failProc)+ , "<<<< exit code >>>>"+ , show (r ^. exitcode)+ , "<<<< stdout >>>>"+ , r ^. failStdout+ , "<<<< stderr >>>>"+ , r ^. failStderr+ ]+++showProc :: CreateProcess -> String+showProc p =+ case cmdspec p of+ ShellCommand s -> s+ RawCommand fp args -> unwords [fp, unwords args]+++instance Ord Version where+ compare AnyVersion AnyVersion = EQ+ compare AnyVersion Latest = LT+ compare AnyVersion (Version _) = EQ+ compare Latest AnyVersion = GT+ compare Latest Latest = EQ+ compare Latest (Version _) = GT+ compare (Version _) AnyVersion = EQ+ compare (Version _) Latest = LT+ compare (Version a) (Version b) = compareVersions a b+++compareVersions :: String -> String -> Ordering+compareVersions a b = compare (ver a) (ver b)+ where+ ver x = case parseV (T.pack x) of+ Left err -> error $ "Failed to parse version '" ++ x ++ "': " ++ show err+ Right v -> v+++package :: PackageName -> Package+package n = Package n AnyVersion+++latest :: PackageName -> Package+latest n = Package n Latest++
+ src/Craft/Ubuntu.hs view
@@ -0,0 +1,49 @@+module Craft.Ubuntu where++import Control.Lens+import Data.ByteString.Lens+import Data.String.Utils (replace)+import Formatting++import Craft+import Craft.Apt as Apt+import qualified Craft.File as File+++data PPA = PPA { _ppaURL :: String }+ deriving (Eq, Show)+makeLenses ''PPA+++findPPAFiles :: PPA -> Craft [File]+findPPAFiles (PPA url) = do+ fs <- File.find $(mkAbsDir "/etc/apt/sources.list.d") ["-name", "*" ++ replace "/" "*" url ++ "*.list"]+ let nonEmpty = (> 0) . length . view (fileContent . _Just . unpackedChars)+ return $ filter nonEmpty fs+++instance Craftable PPA PPA where+ watchCraft ppa@(PPA url) = do+ fs <- findPPAFiles ppa+ if null fs+ then do+ craft_ $ package "software-properties-common"+ exec_ "add-apt-repository" ["-y", "ppa:" ++ url]+ Apt.update+ return (Created, ppa)+ else return (Unchanged, ppa)+++instance Destroyable PPA where+ watchDestroy ppa@(PPA url) = do+ fsBefore <- findPPAFiles ppa+ if null fsBefore+ then return (Unchanged, Nothing)+ else do+ craft_ $ package "software-properties-common"+ exec_ "add-apt-repository" ["-y", "-r", "ppa:" ++ url]+ fsAfter <- findPPAFiles ppa+ unless (null fsAfter) $+ $craftError $ formatToString ("destroy PPA `"%shown%"` failed! Found: "%shown) ppa fsAfter+ Apt.update+ return (Removed, Just ppa)
+ src/Craft/Upstart.hs view
@@ -0,0 +1,37 @@+module Craft.Upstart where++import Craft++import Control.Lens hiding (noneOf)+import Text.Megaparsec++type ServiceName = String++data Service+ = Service+ { _name :: String+ , _status :: String+ }++makeLenses ''Service+++get :: ServiceName -> Craft (Maybe Service)+get sn =+ exec "/sbin/status" [sn] >>= \case+ ExecFail _ -> return Nothing+ ExecSucc r -> Just . Service sn <$> parseExecResult (ExecSucc r) (statusParser sn) (r ^. stdout)+++statusParser :: String -> Parsec String String+statusParser sn = do+ void $ string sn >> space >> some (noneOf "/") >> char '/'+ some $ noneOf ","+++start :: Service -> Craft ()+start Service{..} = when (_status /= "running") $ exec_ "/sbin/start" [_name]+++restart :: Service -> Craft ()+restart Service{..} = exec_ "/sbin/restart" [_name]
+ src/Craft/User.hs view
@@ -0,0 +1,216 @@+module Craft.User where++import Control.Lens hiding (un)+import Data.List (intercalate)+import qualified Data.Set as S+import Formatting++import qualified Craft.Group as Group+import Craft.Internal+import Craft.Internal.Helpers+import Craft.Internal.UserGroup+++type Name = UserName+++name :: Lens' User Name+name = userName+++gid :: Lens' User GroupID+gid = userGroup . Craft.Internal.gid+++data UserOptions =+ UserOptions+ { _optName :: String+ , _optUID :: Maybe UserID+ , _optComment :: String++ --, optAllowdupe :: Bool+ -- Whether to allow duplicate UIDs. Default: False++ , _optGroup :: Maybe GroupName+ -- ^ The default group for a user++ , _optUserGroup :: Bool+ -- ^ Create a user group for this user. Default: True++ , _optGroups :: [GroupName]+ -- ^ Other groups++ , _optHome :: Path Abs Dir++ , _optCreateHome :: Bool+ -- ^ Create the user's home directory when creating user++ , _optPassword :: Maybe String++ , _optSalt :: Maybe String+ -- ^ The salt to use when creating the user's password+++ --, password_max_age :: Maybe Int+ --, password_min_age :: Maybe Int++ --, _optLocked :: Bool+ -- Lock the user's account++ , _optShell :: Maybe (Path Abs FileP)+ -- User's shell++ , _optSystem :: Bool+ -- Is the user a system user. Default: False+ }+ deriving (Eq, Show)+makeLenses ''UserOptions+++-- Nothing means rely on the system's default behavior+userOptions :: String -> Craft UserOptions+userOptions n = do+ dirName <- parseRelDir n+ return UserOptions+ { _optName = n+ , _optUID = Nothing+ , _optComment = n+ , _optGroup = Nothing+ , _optUserGroup = True+ , _optGroups = []+ , _optHome = $(mkAbsDir "/home")</>dirName+ , _optCreateHome = True+ , _optPassword = Nothing+ , _optSalt = Nothing+ , _optShell = Nothing+ , _optSystem = False+ --, _optLocked = False+ }++systemUserOptions :: String -> Craft UserOptions+systemUserOptions n = do+ uo <- userOptions n+ return $ uo & optHome .~ $(mkAbsDir "/")+ & optShell ?~ $(mkAbsFile "/usr/sbin/nologin")+ & optCreateHome .~ False+ & optPassword ?~ ""+ & optSystem .~ True+ -- & optLocked .~ True+++userMod :: UserName -> [String] -> Craft ()+userMod (UserName un) args =+ exec_ "usermod" $ args ++ [un]+++getUID :: UserName -> Craft (Maybe UserID)+getUID (UserName "root") = return . Just $ UserID 0+getUID (UserName un) =+ exec "id" ["--user", un] >>= \case+ ExecSucc r -> return . Just . UserID . read $ r ^. stdout+ ExecFail _ -> return Nothing+++setUID :: UserName -> UserID -> Craft ()+setUID un uid' = userMod un ["--uid", show uid']+++setShell :: UserName -> Path Abs FileP -> Craft ()+setShell un shell' = userMod un ["--shell", fromAbsFile shell']+++setComment :: UserName -> String -> Craft ()+setComment un comment' = userMod un ["--comment", comment']+++setGroup :: UserName -> GroupName -> Craft ()+setGroup un gn =+ Group.fromName gn >>= \case+ Just g -> userMod un $ toArg "--gid" (g ^. Craft.Internal.gid)+ Nothing -> $craftError $ formatToString ("setGroup `"%shown%"` `"%shown%"` failed. Group `"%shown%"` not found!") un gn gn+++setGroups :: UserName -> [GroupName] -> Craft ()+setGroups _ [] = return ()+setGroups un gns = userMod un ["--groups", intercalate "," $ map show gns]+++setHome :: UserName -> Path Abs Dir -> Craft ()+setHome un homepath = userMod un ["--home", fromAbsDir homepath]+++ensureUserOpts :: User -> UserOptions -> Craft Bool+ensureUserOpts user UserOptions{..} = do+ let checks =+ [ maybeOpt _optUID (user^.uid) setUID+ , opt _optComment (user^.userComment) setComment+ , maybeOpt _optGroup (user^.userGroup . groupName) setGroup+ , opt _optHome (user^.userHome) setHome+ , maybeOpt _optShell (user^.userShell) setShell+ , if sameElems _optGroups (user^.userGroups)+ then setGroups username _optGroups >> return True+ else return False+ --TODO: password, salt, lock+ ] :: [Craft Bool]+ or <$> sequence checks+ where+ username = UserName _optName+ opt :: Eq a => a -> a -> (UserName -> a -> Craft ()) -> Craft Bool+ opt expected actual setter+ | expected == actual = return False+ | otherwise = setter username expected >> return True+ maybeOpt :: Eq a => Maybe a -> a -> (UserName -> a -> Craft ()) -> Craft Bool+ maybeOpt Nothing _ _ = return False+ maybeOpt (Just expected) actual setter = opt expected actual setter+++sameElems :: Ord a => [a] -> [a] -> Bool+sameElems xs ys = S.fromList xs == S.fromList ys+++createUser :: UserOptions -> Craft ()+createUser UserOptions{..} = do+ groupArg <- getGroupArg _optGroup+ exec_ "useradd" $ optsToArgs ++ groupArg ++ groupsArg ++ [show _optName]+ where+ getGroupArg :: Maybe GroupName -> Craft [String]+ getGroupArg Nothing = return []+ getGroupArg (Just gn) =+ Group.fromName gn >>= \case+ Just g -> return $ toArg "--gid" $ g ^. Craft.Internal.gid+ Nothing -> $craftError $ "Failed to create User `"++_optName++"` " ++ "with group `"++show gn++"`. Group not found!"+ groupsArg = toArg "--groups" $ intercalate "," (map show _optGroups)+ optsToArgs =+ concat+ [ toArg "--uid" _optUID+ , toArg "--comment" _optComment+ , toArg "--home" _optHome+ , toArg "--create-home" _optCreateHome+ , toArgBool "--user-group" "--no-user-group" _optUserGroup+ , toArg "--password" (encrypt _optSalt _optPassword)+ , toArg "--shell" _optShell+ , toArg "--system" _optSystem+ ]+++lock :: UserName -> Craft ()+lock un = userMod un ["--lock"]+++fromName :: Name -> Craft (Maybe User)+fromName (UserName n) = userFromStr n+++fromID :: UserID -> Craft (Maybe User)+fromID = userFromID+++-- ___ ___ _____ ___ _____ ___+-- | _ \ _ \_ _\ \ / /_\_ _| __|+-- | _/ /| | \ V / _ \| | | _|+-- |_| |_|_\___| \_/_/ \_\_| |___|+++-- TODO+encrypt :: Maybe String -> Maybe String -> Maybe String+encrypt _ _ = Nothing
+ src/Craft/Wget.hs view
@@ -0,0 +1,70 @@+module Craft.Wget where++import Control.Lens+import Data.Monoid ((<>))++import Craft+import Craft.Checksum (Checksum)+import qualified Craft.Checksum as Checksum+import qualified Craft.File as File++data Wget = Wget+ { _url :: String+ , _dest :: File+ , _chksum :: Maybe Checksum+ , _args :: Args -- ^Additional arguments to add to the wget command, such as timeouts.+ }+ deriving (Show, Eq)+makeLenses ''Wget+++wget :: String -> Path Abs FileP -> Wget+wget url' destfp =+ Wget+ { _url = url'+ , _dest = file destfp+ , _chksum = Nothing+ , _args = []+ }+++instance Craftable Wget Wget where+ watchCraft wg = do+ let destf = wg ^. dest & fileContent .~ Nothing+ let destfp = wg ^. dest . path+ let mismatchError actual = "Checksum Mismatch for `"<>wg^.url<>"`. "+ <> "Expected `"<>show (wg^.chksum)<>"` "+ <> "Got `"<>show actual<>"`"+ let check = Checksum.check destf+ let watchDest = do+ w <- watchCraft_ destf+ return (w, wg)+ File.exists destfp >>= \case+ True ->+ case wg ^. chksum of+ Nothing -> watchDest+ Just chksum' ->+ check chksum' >>= \case+ Checksum.Matched -> watchDest+ Checksum.Failed r -> $craftError $ show r+ Checksum.Mismatched _ -> do+ run wg -- Try redownloading the file if the checksum doesn't match.+ check chksum' >>= \case+ Checksum.Matched -> watchDest+ Checksum.Failed r -> $craftError $ show r+ Checksum.Mismatched actual -> $craftError $ mismatchError actual+ False -> do+ run wg+ case wg ^. chksum of+ Nothing -> return ()+ Just chksum' ->+ check chksum' >>= \case+ Checksum.Matched -> return ()+ Checksum.Failed r -> $craftError $ show r+ Checksum.Mismatched actual -> $craftError $ mismatchError actual+ void watchDest+ return (Created, wg)+++run :: Wget -> Craft ()+run wg = exec_ "wget" $ (wg^.args) ++ ["-O", (fromAbsFile $ wg^.dest.path), wg^.url]
+ test/Craft/Config/ShellSpec.hs view
@@ -0,0 +1,89 @@+module Craft.Config.ShellSpec (spec) where++import Test.Hspec+import Test.Hspec.Megaparsec+import Text.Megaparsec++import Craft.Config.Shell+++spec :: Spec+spec = do+ describe "set" $ do+ it "sets on empty" $ do+ set "a" "b" empty `shouldBe` ShellFormat [("a", "b")]+ it "replaces existing key" $ do+ set "a" "c" (ShellFormat [("a", "b")]) `shouldBe` ShellFormat [("a", "c")]+ it "appends a new keys" $ do+ set "a" "b" (ShellFormat [("b", "c")])+ `shouldBe` ShellFormat [("b", "c"), ("a", "b")]+ it "replaces multiple keys" $ do+ set "a" "c" (ShellFormat [("a", "foo"), ("a", "bar")])+ `shouldBe` ShellFormat [("a", "c"), ("a", "c")]++ describe "unset" $ do+ it "preserves empty" $ do+ unset "foo" empty `shouldBe` empty+ it "preserves unmatched keys" $ do+ unset "a" (ShellFormat [("foo", "")]) `shouldBe` ShellFormat [("foo", "")]+ it "unsets" $ do+ unset "a" (ShellFormat [("a", "b")]) `shouldBe` empty+ it "unsets multiple keys" $ do+ unset "a" (ShellFormat [("a", "b"), ("a", "c")]) `shouldBe` empty+ it "unsets multiple keys and leaves unmatched" $ do+ unset "a" (ShellFormat [("a", "b"), ("b", "foo"), ("a", "c")])+ `shouldBe` (ShellFormat [("b", "foo")])++ describe "dedup" $ do+ it "supports empty" $ do+ dedup empty `shouldBe` empty+ it "preserves single item lists" $ do+ dedup (ShellFormat [("a", "b")]) `shouldBe` ShellFormat [("a", "b")]+ it "dedup uses the final value" $ do+ dedup (ShellFormat [("a", "b"), ("a", "c")]) `shouldBe` ShellFormat [("a", "c")]+ it "dedups and preserves order" $ do+ dedup (ShellFormat [("a", "b"), ("b", ""), ("a", "c")]) `shouldBe` ShellFormat [("a", "c"), ("b", "")]++ describe "parser" $ do+ it "reads empty files" $ do+ parse parser "" "" `shouldParse` empty+ it "ignores empty lines" $ do+ parse parser "" "\n\n\n" `shouldParse` empty+ it "ignores empty lines with spaces" $ do+ parse parser "" "\n \n\n" `shouldParse` empty+ it "ignores empty comment" $ do+ parse parser "" "#" `shouldParse` empty+ it "ignores comment" $ do+ parse parser "" "# lkajs # akjsd\n#lkjaslkdj" `shouldParse` empty+ it "ignores comment with leading space" $ do+ parse parser "" " # foo bar" `shouldParse` empty+ it "accepts an empty value" $ do+ parse parser "" "foo=" `shouldParse` ShellFormat [("foo", "")]+ it "accepts an value with a space in it" $ do+ parse parser "" "foo=a b " `shouldParse` ShellFormat [("foo", "a")]+ it "accepts space after equals" $ do+ parse parser "" "foo= foo" `shouldParse` ShellFormat [("foo", "")]+ it "ignores comment after a value" $ do+ parse parser "" "FOO_BAR=foobar # a comment" `shouldParse` ShellFormat [("FOO_BAR", "foobar")]+ it "ignores comment after a value with no spaces" $ do+ parse parser "" "FOO_BAR=foobar#comment" `shouldParse` ShellFormat [("FOO_BAR", "foobar")]+ it "ignores comment after empty value with no spaces" $ do+ parse parser "" "FOO_BAR=#comment" `shouldParse` ShellFormat [("FOO_BAR", "")]+ it "parses multiple values" $ do+ parse parser "" "a=a\nb=b\nc=c\n"+ `shouldParse` ShellFormat [ ("a", "a")+ , ("b", "b")+ , ("c", "c")+ ]+ it "parses multiple values with an empty field" $ do+ parse parser "" "a=a\nb=\nc=c\n"+ `shouldParse` ShellFormat [ ("a", "a")+ , ("b", "")+ , ("c", "c")+ ]+ it "works" $ do+ parse parser "" "#foo\na=a\nb=\n#c=c\nd= foo"+ `shouldParse` ShellFormat [ ("a", "a")+ , ("b", "")+ , ("d", "")+ ]
+ test/Craft/File/ModeSpec.hs view
@@ -0,0 +1,16 @@+module Craft.File.ModeSpec (spec) where++import Test.Hspec+import Test.Hspec.QuickCheck++import Craft.File.Mode+++spec :: Spec+spec = do+ describe "toFileMode" $+ prop "is inverse of toMode" $+ \x -> (x :: Mode) == (toMode . toFileMode) x+ describe "toOctalString" $+ prop "is inverse of fromOctalString" $+ \x -> (x :: Mode) == (fromOctalString . toOctalString) x
+ test/Craft/S3FileSpec.hs view
@@ -0,0 +1,49 @@+module Craft.S3FileSpec (spec) where++import Data.List (intercalate)+import Test.Hspec+import Test.Hspec.Megaparsec+import qualified Text.Megaparsec as MP++import Craft.S3File++respCRLF :: String+respCRLF = intercalate "\r\n" $ status:headerLines++respNL :: String+respNL = unlines $ status:headerLines++headerLines :: [String]+headerLines = map (\(k,v)->k++": "++v) expected++status :: String+status = "HTTP/1.1 200 OK"+++expected :: [(String, String)]+expected =+ [ ("x-amz-id-2", "3PEnvyK2lmZYO2eOcG31YV7cMtrIHh4LVkIHma4vTLUSlTp2MHWYVytfbv6KwtDcfpjv9mKmdZE=")+ , ("x-amz-request-id", "534CFEB94E255448")+ , ("Date", "Wed, 13 Jul 2016 21:08:41 GMT")+ , ("Last-Modified", "Wed, 13 Jul 2016 21:04:12 GMT")+ , ("ETag", "\"0d329bab9fe82cae99a6777767efc144\"")+ , ("x-amz-storage-class", "REDUCED_REDUNDANCY")+ , ("Accept-Ranges", "bytes")+ , ("Content-Type", "binary/octet-stream")+ , ("Content-Length", "29323142")+ , ("Server", "AmazonS3")+ ]+++spec :: Spec+spec = do+ describe "httpHeaders" $ do+ let parse = MP.parse httpHeaders ""+ it "parses response separated by newlines" $+ parse respNL `shouldParse` expected+ it "parses response with trailing newline" $+ parse (respNL++"\n") `shouldParse` expected+ it "parses response separated by crlf" $+ parse respCRLF `shouldParse` expected+ it "parses response with trailing crlf" $+ parse (respCRLF++"\r\n") `shouldParse` expected
+ test/Craft/SSH/AuthorizedKeySpec.hs view
@@ -0,0 +1,30 @@+module Craft.SSH.AuthorizedKeySpec (spec) where++import Test.Hspec+import Test.Hspec.Megaparsec+import qualified Text.Megaparsec as MP++import Craft.SSH+import Craft.SSH.AuthorizedKey+import Craft.SSH.PublicKey+++spec :: Spec+spec = do+ describe "parsePublicKeys" $ do+ let parse = MP.parse parsePublicKeys ""+ it "reads empty file" $+ parse "" `shouldParse` []+ it "reads empty lines" $+ parse "\n\n\n" `shouldParse` []+ it "reads single RSA public key with no eol or comment" $+ parse "ssh-rsa AAAiumas98dada8ud9m8ad" `shouldParse` [PublicKey RSA "AAAiumas98dada8ud9m8ad" ""]+ it "reads single DSA public key ending in newline" $+ parse "ssh-dsa AAAiumas98dada8ud9m8ad\n" `shouldParse` [PublicKey DSA "AAAiumas98dada8ud9m8ad" ""]+ it "reads single public key with comment ending in newline" $+ parse "ssh-ed25519 AAAiumas98dada8ud9m8ad ED25519\n" `shouldParse` [PublicKey ED25519 "AAAiumas98dada8ud9m8ad" "ED25519"]+ it "reads multiple keys" $ do+ parse "ssh-rsa AAAiumas98dada8ud9m8ad a comment\nssh-dsa M123YMOSDlkjsadiuasoim8asdoum"+ `shouldParse` [ PublicKey RSA "AAAiumas98dada8ud9m8ad" "a comment"+ , PublicKey DSA "M123YMOSDlkjsadiuasoim8asdoum" ""+ ]
+ test/Craft/SSH/PublicKeySpec.hs view
@@ -0,0 +1,26 @@+module Craft.SSH.PublicKeySpec (spec) where++import Test.Hspec+import Test.Hspec.Megaparsec+import qualified Text.Megaparsec as MP++import Craft.SSH+import Craft.SSH.PublicKey+++spec :: Spec+spec = do+ describe "parsePublicKey" $ do+ let parse = MP.parse parsePublicKey ""+ it "fails to read empty string" $+ parse `shouldFailOn` ""+ it "fails to read just keytype" $+ parse `shouldFailOn` "ssh-rsa "+ it "reads RSA public key with no eol or comment" $+ parse "ssh-rsa AAAiumas98dada8ud9m8ad" `shouldParse` (PublicKey RSA "AAAiumas98dada8ud9m8ad" "")+ it "reads RSA public key with comment and no eol" $+ parse "ssh-rsa AAA/umas98dad+8ud9m8ad foo@bar" `shouldParse` (PublicKey RSA "AAA/umas98dad+8ud9m8ad" "foo@bar")+ it "reads DSA public key ending in newline" $+ parse "ssh-dsa AAAiumas98dad/8ud9m8ad=\n" `shouldParse` (PublicKey DSA "AAAiumas98dad/8ud9m8ad=" "")+ it "reads public key with comment ending in newline" $+ parse "ssh-ed25519 AAAiumas9+dada8ud9m8ad== ED25519\n" `shouldParse` (PublicKey ED25519 "AAAiumas9+dada8ud9m8ad==" "ED25519")
+ test/Craft/SSHSpec.hs view
@@ -0,0 +1,32 @@+module Craft.SSHSpec (spec) where++import Test.Hspec+import Test.Hspec.Megaparsec+import qualified Text.Megaparsec as MP++import Craft.SSH++spec :: Spec+spec = do+ describe "parseKeyType" $ do+ let parse = MP.parse parseKeyType ""+ it "fails on empty string" $+ parse `shouldFailOn` ""+ it "fails on just prefix" $+ parse `shouldFailOn` "ssh-"+ it "fails on uppercase prefix" $+ parse `shouldFailOn` "SSH-RSA"+ it "parses DSA" $+ parse "ssh-dsa" `shouldParse` DSA+ it "parses RSA" $+ parse "ssh-rsa" `shouldParse` RSA+ it "parses RSA1" $+ parse "ssh-rsa1" `shouldParse` RSA1+ it "parses ECDSA" $+ parse "ssh-ecdsa" `shouldParse` ECDSA+ it "parses ED25519" $+ parse "ssh-ed25519" `shouldParse` ED25519+ it "parses other keytypes" $+ parse "ssh-foobar" `shouldParse` (KeyType "ssh-foobar")+ it "parses mixed case" $+ parse "ssh-rSa" `shouldParse` RSA
+ test/Spec.hs view
@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}