1{-# LANGUAGE OverloadedStrings #-} 2module Keter 3 ( keter 4 ) where 5 6import Data.Yaml 7import qualified Data.HashMap.Strict as Map 8import qualified Data.Text as T 9import System.Environment (getEnvironment) 10import System.Exit 11import System.Process 12import Control.Monad 13import System.Directory hiding (findFiles) 14import Data.Maybe (mapMaybe,isJust,maybeToList) 15import Data.Monoid 16import System.FilePath ((</>)) 17import qualified Codec.Archive.Tar as Tar 18import Control.Exception 19import qualified Data.ByteString.Lazy as L 20import Codec.Compression.GZip (compress) 21import qualified Data.Foldable as Fold 22import Control.Monad.Trans.Writer (tell, execWriter) 23 24run :: String -> [String] -> IO () 25run a b = do 26 ec <- rawSystem a b 27 unless (ec == ExitSuccess) $ exitWith ec 28 29keter :: String -- ^ cabal command 30 -> Bool -- ^ no build? 31 -> Bool -- ^ no copy to? 32 -> [String] -- ^ build args 33 -> IO () 34keter cabal noBuild noCopyTo buildArgs = do 35 ketercfg <- keterConfig 36 mvalue <- decodeFile ketercfg 37 value <- 38 case mvalue of 39 Nothing -> error "No config/keter.yaml found" 40 Just (Object value) -> 41 case Map.lookup "host" value of 42 Just (String s) | "<<" `T.isPrefixOf` s -> 43 error $ "Please set your hostname in " ++ ketercfg 44 _ -> 45 case Map.lookup "user-edited" value of 46 Just (Bool False) -> 47 error $ "Please edit your Keter config file at " 48 ++ ketercfg 49 _ -> return value 50 Just _ -> error $ ketercfg ++ " is not an object" 51 52 env' <- getEnvironment 53 cwd' <- getCurrentDirectory 54 files <- getDirectoryContents "." 55 project <- 56 case mapMaybe (T.stripSuffix ".cabal" . T.pack) files of 57 [x] -> return x 58 [] -> error "No cabal file found" 59 _ -> error "Too many cabal files found" 60 61 let findFiles (Object v) = 62 mapM_ go $ Map.toList v 63 where 64 go ("exec", String s) = tellFile s 65 go ("extraFiles", Array a) = Fold.mapM_ tellExtra a 66 go (_, v') = findFiles v' 67 tellFile s = tell [collapse $ "config" </> T.unpack s] 68 tellExtra (String s) = tellFile s 69 tellExtra _ = error "extraFiles should be a flat array" 70 findFiles (Array v) = Fold.mapM_ findFiles v 71 findFiles _ = return () 72 bundleFiles = execWriter $ findFiles $ Object value 73 74 collapse = T.unpack . T.intercalate "/" . collapse' . T.splitOn "/" . T.pack 75 collapse' (_:"..":rest) = collapse' rest 76 collapse' (".":xs) = collapse' xs 77 collapse' (x:xs) = x : collapse' xs 78 collapse' [] = [] 79 80 unless noBuild $ do 81 stackQueryRunSuccess <- do 82 eres <- try $ readProcessWithExitCode "stack" ["query"] "" :: IO (Either IOException (ExitCode, String, String)) 83 return $ either (\_ -> False) (\(ec, _, _) -> (ec == ExitSuccess)) eres 84 85 let inStackExec = isJust $ lookup "STACK_EXE" env' 86 mStackYaml = lookup "STACK_YAML" env' 87 useStack = inStackExec || isJust mStackYaml || stackQueryRunSuccess 88 89 if useStack 90 then do let stackYaml = maybeToList $ fmap ("--stack-yaml="<>) mStackYaml 91 localBinPath = cwd' </> "dist/bin" 92 run "stack" $ stackYaml <> ["clean"] 93 createDirectoryIfMissing True localBinPath 94 run "stack" 95 (stackYaml 96 <> ["--local-bin-path",localBinPath,"build","--copy-bins"] 97 <> buildArgs) 98 else do run cabal ["clean"] 99 run cabal ["configure"] 100 run cabal ("build" : buildArgs) 101 102 _ <- try' $ removeDirectoryRecursive "static/tmp" 103 104 archive <- Tar.pack "" $ 105 "config" : "static" : bundleFiles 106 let fp = T.unpack project ++ ".keter" 107 L.writeFile fp $ compress $ Tar.write archive 108 109 unless noCopyTo $ case Map.lookup "copy-to" value of 110 Just (String s) -> 111 let baseArgs = [fp, T.unpack s] :: [String] 112 113 scpArgs = 114 case parseMaybe (.: "copy-to-args") value of 115 Just as -> as ++ baseArgs 116 Nothing -> baseArgs 117 118 args = 119 case parseMaybe (.: "copy-to-port") value of 120 Just i -> "-P" : show (i :: Int) : scpArgs 121 Nothing -> scpArgs 122 123 in run "scp" args 124 125 _ -> return () 126 where 127 -- Test for alternative config file extension (yaml or yml). 128 keterConfig = do 129 let yml = "config/keter.yml" 130 ymlExists <- doesFileExist yml 131 return $ if ymlExists then yml else "config/keter.yaml" 132 133try' :: IO a -> IO (Either SomeException a) 134try' = try 135