1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
|
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE CPP #-}
module Keter
( keter
) where
import Data.Yaml
#if MIN_VERSION_aeson(2, 0, 0)
import qualified Data.Aeson.KeyMap as Map
#else
import qualified Data.HashMap.Strict as Map
#endif
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
|
