123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135 |
- {-# 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
|