diff --git a/default.nix b/default.nix index a953f06f5..244f08eaa 100644 --- a/default.nix +++ b/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") {}; diff --git a/dep/reflex-platform/github.json b/dep/reflex-platform/github.json index 17960950b..f1d4d9610 100644 --- a/dep/reflex-platform/github.json +++ b/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" } diff --git a/lib/command/src/Obelisk/Command/Deploy.hs b/lib/command/src/Obelisk/Command/Deploy.hs index 1d39ed0d8..40d5b2b59 100644 --- a/lib/command/src/Obelisk/Command/Deploy.hs +++ b/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 diff --git a/lib/route/src/Obelisk/Route.hs b/lib/route/src/Obelisk/Route.hs index 207c56748..f1a510baa 100644 --- a/lib/route/src/Obelisk/Route.hs +++ b/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