70 lines
2.1 KiB
Haskell
70 lines
2.1 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.Exit
|
|
import System.Cmd
|
|
import Control.Monad
|
|
import System.Directory
|
|
import Data.Maybe (mapMaybe)
|
|
import qualified Filesystem.Path.CurrentOS as F
|
|
import qualified Filesystem as F
|
|
import qualified Codec.Archive.Tar as Tar
|
|
import Control.Exception
|
|
import qualified Data.ByteString.Lazy as L
|
|
import Codec.Compression.GZip (compress)
|
|
|
|
run :: String -> [String] -> IO ()
|
|
run a b = do
|
|
ec <- rawSystem a b
|
|
unless (ec == ExitSuccess) $ exitWith ec
|
|
|
|
keter :: String -- ^ cabal command
|
|
-> Bool -- ^ no build?
|
|
-> IO ()
|
|
keter cabal noBuild = do
|
|
mvalue <- decodeFile "config/keter.yaml"
|
|
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 config/keter.yaml"
|
|
_ -> return value
|
|
Just _ -> error "config/keter.yaml is not an object"
|
|
|
|
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"
|
|
|
|
exec <-
|
|
case Map.lookup "exec" value of
|
|
Just (String s) -> return $ F.collapse $ "config" F.</> F.fromText s
|
|
_ -> error "exec not found in config/keter.yaml"
|
|
|
|
unless noBuild $ do
|
|
run cabal ["clean"]
|
|
run cabal ["configure"]
|
|
run cabal ["build"]
|
|
|
|
_ <- try' $ F.removeTree "static/tmp"
|
|
|
|
archive <- Tar.pack "" [F.encodeString exec, "config", "static"]
|
|
let fp = T.unpack project ++ ".keter"
|
|
L.writeFile fp $ compress $ Tar.write archive
|
|
|
|
case Map.lookup "copy-to" value of
|
|
Just (String s) -> run "scp" [fp, T.unpack s]
|
|
_ -> return ()
|
|
|
|
try' :: IO a -> IO (Either SomeException a)
|
|
try' = try
|