WIP: Deployments refactor

default.nix

@@ -226,17 +226,21 @@ in rec {
       static-assets = exeAssets;
     };
 
-  server = { exe, hostName, adminEmail, routeHost, enableHttps, version, module ? serverModules.mkBaseEc2, redirectHosts ? [], configHash ? "" }@args:
+  serverModule = { exe, hostName, adminEmail, routeHost, enableHttps, version, redirectHosts ? [], configHash ? "", ... }@args: {...}: {
+    imports = [
+      ((args.module or (serverModules.mkBaseEc2)) { inherit (args) exe hostName adminEmail routeHost enableHttps version; nixosPkgs = pkgs; })
+      (serverModules.mkDefaultNetworking args)
+      (serverModules.mkObeliskApp args)
+    ];
+  };
+
+  server = args:
     let
       nixos = import (pkgs.path + /nixos);
     in nixos {
       system = "x86_64-linux";
       configuration = {
-        imports = [
-          (module { inherit exe hostName adminEmail routeHost enableHttps version; nixosPkgs = pkgs; })
-          (serverModules.mkDefaultNetworking args)
-          (serverModules.mkObeliskApp args)
-        ];
+        imports = [(serverModule args)];
       };
     };
 
@@ -410,6 +414,16 @@ in rec {
       linuxExeConfigurable = linuxExe;
       linuxExe = linuxExe dummyVersion;
       exe = serverOn mainProjectOut dummyVersion;
+      # the "classic flavor", as a "deployable" module
+      deployLinuxServerModule = {version, buildConfigs, redirectHosts ? [], configHash ? ""}: serverModule ({
+        inherit version redirectHosts configHash;
+        exe = linuxExe version;
+      } // buildConfigs);
+
+      # the "classic flavor", as a module
+      linuxServerModule = args@{ hostName, adminEmail, routeHost, enableHttps, version, redirectHosts ? [], configHash ? "", ...}:
+        serverModule ({ module = serverModules.mkBaseEc2; exe = linuxExe version; } // args);
+      # the "classic flavor", as a full nixos configuration
       server = args@{ hostName, adminEmail, routeHost, enableHttps, version, module ? serverModules.mkBaseEc2, redirectHosts ? [], configHash ? "" }:
         server (args // { exe = linuxExe version; });
       obelisk = import (base' + "/.obelisk/impl") {};

lib/command/src/Obelisk/Command/Deploy.hs

@@ -182,8 +182,9 @@ deployPush deployPath builders = do
   let version = show . _thunkRev_commit $ _thunkPtr_rev thunkPtr
   let moduleFile = deployPath </> "module.nix"
   moduleFileExists <- liftIO $ doesFileExist moduleFile
-
   configHash <- getGitHash deployPath "config"
+  let knownHostsPath = deployPath </> "backend_known_hosts"
+      sshOpts = sshArgs knownHostsPath (deployPath </> "ssh_key") False
   buildOutputByHost <- ifor (Map.fromSet (const ()) hosts) $ \host () -> do
     --TODO: What does it mean if this returns more or less than 1 line of output?
     [result] <- fmap lines $ nixCmd $ NixCmd_Build $ def
@@ -203,14 +204,27 @@ deployPush deployPath builders = do
         , strArg "configHash" $ T.unpack $ T.strip (_gitHash_text configHash)
         ] <> [rawArg "module" ("import " <> toNixPath moduleFile) | moduleFileExists ])
       & nixCmdConfig_builders .~ builders
-    pure result
-  let knownHostsPath = deployPath </> "backend_known_hosts"
-      sshOpts = sshArgs knownHostsPath (deployPath </> "ssh_key") False
-  withSpinner "Uploading closures" $ ifor_ buildOutputByHost $ \host outputPath -> do
+    pure (DeployBuildOutput sshOpts result)
+  deployPushImpl deployPath buildOutputByHost
+  putLog Notice $ "Deployed => " <> T.pack route
+
+
+data DeployBuildOutput = DeployBuildOutput
+  { _deployBuildOutput_sshOpts :: [String]
+  , _deployBuildOutput_outputPath :: String
+  }
+
+deployPushImpl
+  :: MonadObelisk m
+  => FilePath -- ^ Deploy Path
+  -> Map.Map String DeployBuildOutput
+  -> m ()
+deployPushImpl deployPath buildOutputByHost = do
+  withSpinner "Uploading closures" $ ifor_ buildOutputByHost $ \host (DeployBuildOutput sshOpts outputPath) -> do
     callProcess'
       (Map.fromList [("NIX_SSHOPTS", unwords sshOpts)])
       "nix-copy-closure" ["-v", "--to", "--use-substitutes", "root@" <> host, "--gzip", outputPath]
-  withSpinner "Uploading config" $ ifor_ buildOutputByHost $ \host _ -> do
+  withSpinner "Uploading config" $ ifor_ buildOutputByHost $ \host (DeployBuildOutput sshOpts _) -> do
     callProcessAndLogOutput (Notice, Warning) $
       proc rsyncPath
         [ "-e " <> sshPath <> " " <> unwords sshOpts
@@ -219,7 +233,7 @@ deployPush deployPath builders = do
         , "root@" <> host <> ":/var/lib/backend"
         ]
   --TODO: Create GC root so we're sure our closure won't go away during this time period
-  withSpinner "Switching to new configuration" $ ifor_ buildOutputByHost $ \host outputPath -> do
+  withSpinner "Switching to new configuration" $ ifor_ buildOutputByHost $ \host (DeployBuildOutput sshOpts outputPath) -> do
     callProcessAndLogOutput (Notice, Warning) $
       proc sshPath $ sshOpts <>
         [ "root@" <> host
@@ -235,7 +249,6 @@ deployPush deployPath builders = do
         gitProc deployPath ["add", "."]
       callProcessAndLogOutput (Debug, Error) $
         gitProc deployPath ["commit", "-m", "New deployment"]
-  putLog Notice $ "Deployed => " <> T.pack route
   where
     callProcess' envMap cmd args = do
       let p = setEnvOverride (envMap <>) $ setDelegateCtlc True $ proc cmd args

lib/route/src/Obelisk/Route.hs

@@ -111,6 +111,7 @@ module Obelisk.Route
   , obeliskRouteEncoder
   , obeliskRouteSegment
   , pageNameEncoder
+  , pathQueryEncoder
   , handleEncoder
   , someSumEncoder
   , Void1
@@ -181,6 +182,7 @@ import Data.Functor.Sum
 import Data.GADT.Compare
 import Data.GADT.Compare.TH
 import Data.GADT.Show
+import Data.List (stripPrefix)
 import Data.List.NonEmpty (NonEmpty (..))
 import Data.Map (Map)
 import qualified Data.Map as Map
@@ -197,6 +199,7 @@ import Data.Text.Lens (IsText, packed, unpacked)
 import Data.Type.Equality
 import Data.Universe
 import Data.Universe.Some
+import Network.URI (URI (..))
 import Network.HTTP.Types.URI
 import qualified Numeric.Lens
 import Obelisk.Route.TH
@@ -930,6 +933,34 @@ pageNameEncoder = bimap
   (unpackTextEncoder . prefixTextEncoder "/" . pathSegmentsTextEncoder . listToNonEmptyEncoder)
   (unpackTextEncoder . prefixNonemptyTextEncoder "?" . queryParametersTextEncoder . toListMapEncoder)
 
+-- | Encode a PathQuery into a URI based on a given base URI
+--
+-- WARNING: We don't deal with query or fragment components here at all.  If
+-- the supplied base URI has either one, they will be silently ignored in both
+-- encoding and decoding.
+pathQueryEncoder
+  :: ( Applicative check
+     , MonadError Text parse
+     )
+  => URI
+  -> Encoder check parse PathQuery URI
+pathQueryEncoder baseUri =
+  let -- basePath has trailing slashes removed
+      basePath = reverse $ dropWhile (== '/') $ reverse $ uriPath baseUri
+  in unsafeMkEncoder $ EncoderImpl
+       { _encoderImpl_encode = \(path, query) -> URI
+         { uriScheme = uriScheme baseUri
+         , uriAuthority = uriAuthority baseUri
+         , uriPath = basePath <> path
+         , uriQuery = query
+         , uriFragment = ""
+         }
+       , _encoderImpl_decode = \uri ->
+           case (uriScheme uri /= uriScheme baseUri, uriAuthority uri /= uriAuthority baseUri, Data.List.stripPrefix basePath (uriPath uri)) of
+             (True, True, Just remainingPath) -> pure (remainingPath, uriQuery uri)
+             _ -> throwError $ "pathQueryEncodering: wrong base uri; expected " <> T.pack (show baseUri) <> " got " <> T.pack (show uri)
+       }
+
 -- | Handle an error in parsing, for example, in order to redirect to a 404 page.
 handleEncoder
   :: (Functor check)