134 lines
4.9 KiB
Haskell
134 lines
4.9 KiB
Haskell
{-# LANGUAGE OverloadedStrings #-}
|
|
module Keter
|
|
( keter
|
|
) where
|
|
|
|
import Data.Yaml
|
|
import qualified Data.HashMap.Strict as Map
|
|
import qualified Data.Text as T
|
|
import System.Environment (getEnvironment)
|
|
import System.Exit
|
|
import System.Process
|
|
import Control.Monad
|
|
import System.Directory hiding (findFiles)
|
|
import Data.Maybe (mapMaybe,isJust,maybeToList)
|
|
import Data.Monoid
|
|
import System.FilePath ((</>))
|
|
import qualified Codec.Archive.Tar as Tar
|
|
import Control.Exception
|
|
import qualified Data.ByteString.Lazy as L
|
|
import Codec.Compression.GZip (compress)
|
|
import qualified Data.Foldable as Fold
|
|
import Control.Monad.Trans.Writer (tell, execWriter)
|
|
|
|
run :: String -> [String] -> IO ()
|
|
run a b = do
|
|
ec <- rawSystem a b
|
|
unless (ec == ExitSuccess) $ exitWith ec
|
|
|
|
keter :: String -- ^ cabal command
|
|
-> Bool -- ^ no build?
|
|
-> Bool -- ^ no copy to?
|
|
-> [String] -- ^ build args
|
|
-> IO ()
|
|
keter cabal noBuild noCopyTo buildArgs = do
|
|
ketercfg <- keterConfig
|
|
mvalue <- decodeFile ketercfg
|
|
value <-
|
|
case mvalue of
|
|
Nothing -> error "No config/keter.yaml found"
|
|
Just (Object value) ->
|
|
case Map.lookup "host" value of
|
|
Just (String s) | "<<" `T.isPrefixOf` s ->
|
|
error $ "Please set your hostname in " ++ ketercfg
|
|
_ ->
|
|
case Map.lookup "user-edited" value of
|
|
Just (Bool False) ->
|
|
error $ "Please edit your Keter config file at "
|
|
++ ketercfg
|
|
_ -> return value
|
|
Just _ -> error $ ketercfg ++ " is not an object"
|
|
|
|
env' <- getEnvironment
|
|
cwd' <- getCurrentDirectory
|
|
files <- getDirectoryContents "."
|
|
project <-
|
|
case mapMaybe (T.stripSuffix ".cabal" . T.pack) files of
|
|
[x] -> return x
|
|
[] -> error "No cabal file found"
|
|
_ -> error "Too many cabal files found"
|
|
|
|
let findFiles (Object v) =
|
|
mapM_ go $ Map.toList v
|
|
where
|
|
go ("exec", String s) = tellFile s
|
|
go ("extraFiles", Array a) = Fold.mapM_ tellExtra a
|
|
go (_, v') = findFiles v'
|
|
tellFile s = tell [collapse $ "config" </> T.unpack s]
|
|
tellExtra (String s) = tellFile s
|
|
tellExtra _ = error "extraFiles should be a flat array"
|
|
findFiles (Array v) = Fold.mapM_ findFiles v
|
|
findFiles _ = return ()
|
|
bundleFiles = execWriter $ findFiles $ Object value
|
|
|
|
collapse = T.unpack . T.intercalate "/" . collapse' . T.splitOn "/" . T.pack
|
|
collapse' (_:"..":rest) = collapse' rest
|
|
collapse' (".":xs) = collapse' xs
|
|
collapse' (x:xs) = x : collapse' xs
|
|
collapse' [] = []
|
|
|
|
unless noBuild $ do
|
|
stackQueryRunSuccess <- do
|
|
eres <- try $ readProcessWithExitCode "stack" ["query"] "" :: IO (Either IOException (ExitCode, String, String))
|
|
return $ either (\_ -> False) (\(ec, _, _) -> (ec == ExitSuccess)) eres
|
|
|
|
let inStackExec = isJust $ lookup "STACK_EXE" env'
|
|
mStackYaml = lookup "STACK_YAML" env'
|
|
useStack = inStackExec || isJust mStackYaml || stackQueryRunSuccess
|
|
|
|
if useStack
|
|
then do let stackYaml = maybeToList $ fmap ("--stack-yaml="<>) mStackYaml
|
|
localBinPath = cwd' </> "dist/bin"
|
|
run "stack" $ stackYaml <> ["clean"]
|
|
createDirectoryIfMissing True localBinPath
|
|
run "stack"
|
|
(stackYaml
|
|
<> ["--local-bin-path",localBinPath,"build","--copy-bins"]
|
|
<> buildArgs)
|
|
else do run cabal ["clean"]
|
|
run cabal ["configure"]
|
|
run cabal ("build" : buildArgs)
|
|
|
|
_ <- try' $ removeDirectoryRecursive "static/tmp"
|
|
|
|
archive <- Tar.pack "" $
|
|
"config" : "static" : bundleFiles
|
|
let fp = T.unpack project ++ ".keter"
|
|
L.writeFile fp $ compress $ Tar.write archive
|
|
|
|
unless noCopyTo $ case Map.lookup "copy-to" value of
|
|
Just (String s) ->
|
|
let baseArgs = [fp, T.unpack s] :: [String]
|
|
|
|
scpArgs =
|
|
case parseMaybe (.: "copy-to-args") value of
|
|
Just as -> as ++ baseArgs
|
|
Nothing -> baseArgs
|
|
|
|
args =
|
|
case parseMaybe (.: "copy-to-port") value of
|
|
Just i -> "-P" : show (i :: Int) : scpArgs
|
|
Nothing -> scpArgs
|
|
|
|
in run "scp" args
|
|
|
|
_ -> return ()
|
|
where
|
|
-- Test for alternative config file extension (yaml or yml).
|
|
keterConfig = do
|
|
let yml = "config/keter.yml"
|
|
ymlExists <- doesFileExist yml
|
|
return $ if ymlExists then yml else "config/keter.yaml"
|
|
|
|
try' :: IO a -> IO (Either SomeException a)
|
|
try' = try
|