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