WIP: Deployments refactor

default.nix

@@ -214,33 +214,37 @@ in rec {
       exeFrontend = compressedJs frontend optimizationLevel externjs;
       exeFrontendAssets = mkAssets exeFrontend;
       exeAssets = mkAssets assets;
-    in pkgs.runCommand "serverExe" {} ''
+    in pkgs.runCommand "serverExe" {
+          backend = exeBackend;
+          frontend = exeFrontend;
+          frontendassets = exeFrontendAssets;
+          staticassets = exeAssets;
+    } ''
       mkdir $out
       set -eux
-      ln -s '${exeBackend}'/bin/* $out/
-      ln -s '${exeAssets}' $out/static.assets
-      for d in '${exeFrontendAssets}'/*/; do
+      ln -s "$backend"/bin/* $out/
+      ln -s "$staticassets" $out/static.assets
+      for d in "$frontendassets"/*/; do
         ln -s "$d" "$out"/"$(basename "$d").assets"
       done
       echo ${version} > $out/version
-    '' // {
-      backend = exeBackend;
-      frontend = exeFrontend;
-      frontend-assets = exeFrontendAssets;
-      static-assets = exeAssets;
-    };
+    '';
+
+  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 = { exe, hostName, adminEmail, routeHost, enableHttps, version, module ? serverModules.mkBaseEc2, redirectHosts ? [], configHash ? "" }@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)];
       };
     };
 
@@ -411,6 +415,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") {};

dep/reflex-platform/github.json

@@ -1,8 +1,8 @@
 {
   "owner": "reflex-frp",
   "repo": "reflex-platform",
-  "branch": "develop",
+  "branch": "expose-requester-internals",
   "private": false,
-  "rev": "6c8830e059a6d2859cb1b65acefed3c2f1d216d3",
-  "sha256": "sha256:06kv45yq8qan0p22wzj5c9mx11ns1wddyqjr1xasjjkf6gaf0080"
+  "rev": "f3da1ff04393b18dec06740c27f583e535419f3d",
+  "sha256": "0x5mkfwr89yp7zhrx0lzgfx4ysi6jf4sdv680ynrljqnj5c4cz7b"
 }

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

@@ -112,8 +112,10 @@ module Obelisk.Route
   , obeliskRouteEncoder
   , obeliskRouteSegment
   , pageNameEncoder
+  , pathQueryEncoder
   , handleEncoder
   , someSumEncoder
+  , voidEncoder
   , Void1
   , void1Encoder
   , pathSegmentsTextEncoder
@@ -182,6 +184,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
@@ -198,6 +201,8 @@ import Data.Text.Lens (IsText, packed, unpacked)
 import Data.Type.Equality
 import Data.Universe
 import Data.Universe.Some
+import Data.Void (Void, absurd)
+import Network.URI (URI (..))
 import Network.HTTP.Types.URI
 import qualified Numeric.Lens
 import Obelisk.Route.TH
@@ -928,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)
@@ -1092,6 +1125,12 @@ someSumEncoder = Encoder $ pure $ EncoderImpl
       Right (Some r) -> Some (InR r)
   }
 
+voidEncoder :: Encoder (Either Text) (Either Text) Void b
+voidEncoder = unsafeMkEncoder $ EncoderImpl
+  { _encoderImpl_encode = absurd
+  , _encoderImpl_decode = \_ -> throwError "voidEncoder: can't decode anything"
+  }
+
 data Void1 :: * -> * where {}
 
 instance UniverseSome Void1 where