yesod keter (#359)

yesod/Keter.hs

@@ -0,0 +1,69 @@
+{-# 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

yesod/main.hs

@@ -12,6 +12,7 @@ import Build (touch)
 #endif
 import Devel (devel)
 import AddHandler (addHandler)
+import Keter (keter)
 
 windowsWarning :: String
 #ifdef WINDOWS
@@ -48,6 +49,8 @@ main = do
         ["version"] -> putStrLn $ "yesod-core version:" ++ yesodVersion
         "configure":rest -> rawSystem cmd ("configure":rest) >>= exitWith
         ["add-handler"] -> addHandler
+        ["keter"] -> keter cmd False
+        ["keter", "--nobuild"] -> keter cmd True
         _ -> do
             putStrLn "Usage: yesod <command>"
             putStrLn "Available commands:"
@@ -62,6 +65,9 @@ main = do
             putStrLn "    test         Build and run the integration tests"
             putStrLn "                    use --dev devel to build with cabal-dev"
             putStrLn "    add-handler  Add a new handler and module to your project"
+            putStrLn "    keter        Build a keter bundle"
+            putStrLn "                    use --dev devel to build with cabal-dev"
+            putStrLn "                    use --nobuild to skip rebuilding"
             putStrLn "    version      Print the version of Yesod"
 
 -- | Like @rawSystem@, but exits if it receives a non-success result.

yesod/scaffold/config/keter.yaml.cg

@@ -1,4 +1,8 @@
 exec: ../dist/build/~project~/~project~
 args:
     - production
-host: ~project~.yesodweb.com
+host: <<HOST-NOT-SET>>
+
+# Use the following to automatically copy your bundle upon creation via `yesod
+# keter`. Uses `scp` internally, so you can set it to a remote destination
+# copy-to: user@host:/opt/keter/incoming

yesod/yesod.cabal

@@ -103,12 +103,19 @@ executable             yesod
                      , blaze-builder      >= 0.2.1.4      && < 0.4
                      , filepath           >= 1.1
                      , process
+                     , zlib               >= 0.5          && < 0.6
+                     , tar                >= 0.4          && < 0.5
+                     , system-filepath    >= 0.4          && < 0.5
+                     , system-fileio      >= 0.3          && < 0.4
+                     , unordered-containers
+                     , yaml               >= 0.8          && < 0.9
     ghc-options:       -Wall -threaded
     main-is:           main.hs
     other-modules:     Scaffolding.CodeGen
                        Scaffolding.Scaffolder
                        Devel
                        Build
+                       Keter
                        AddHandler
 
 source-repository head