git.iko.soy/obelisk
on master help sign in
Merge branch 'routes' into ts-routes-fix
commit0464c420f695736d0f0dfc0d4eb6c35baef26d37 authorRyan Trinkle <ryan.trinkle@gmail.com> dateThu 11 Oct 2018, 15:39 (8 years ago) parent262e4d8addb3ea
8 files changed+73−43
compare with master
unifiedsplit
default.nix+16−11 dep/reflex-platform/github.json+3−3 lib/command/src/Obelisk/Command/Project.hs+1−1 lib/executable-config/default.nix+2−1 lib/frontend/src/Obelisk/Frontend.hs−4 lib/route/src/Obelisk/Route.hs+13−7 lib/route/src/Obelisk/Route/Frontend.hs+33−7 skeleton/common/src/Common/Route.hs+5−9
default.nix+16−11
@@ -88,7 +88,20 @@ let
8888 obelisk-asset-serve-snap = self.callCabal2nix "obelisk-asset-serve-snap" (hackGet ./lib/asset + "/serve-snap") {};
8989 obelisk-backend = self.callCabal2nix "obelisk-backend" (cleanSource ./lib/backend) {};
9090 obelisk-cliapp = self.callCabal2nix "obelisk-cliapp" (cleanSource ./lib/cliapp) {};
91− obelisk-command = (self.callCabal2nix "obelisk-command" (cleanSource ./lib/command) {});
91+ obelisk-command = (self.callCabal2nix "obelisk-command" (cleanSource ./lib/command) {}).overrideAttrs
92+ (drv: {
93+ buildInputs = drv.buildInputs ++ [ pkgs.makeWrapper ];
94+ postInstall = ''
95+ ${drv.postInstall or ""}
96+ # Install migrations
97+ cp -r ${./migration} $out/migration;
98+ '';
99+ postFixup = ''
100+ ${drv.postFixup or ""}
101+ # Make `ob` reference its runtime dependencies.
102+ wrapProgram "$out"/bin/ob --prefix PATH : ${pkgs.lib.makeBinPath (commandRuntimeDeps pkgs)}
103+ '';
104+ });
92105 obelisk-executable-config = executableConfig.haskellPackage self;
93106 obelisk-executable-config-inject = executableConfig.platforms.web.inject self;
94107 obelisk-frontend = self.callCabal2nix "obelisk-frontend" (cleanSource ./lib/frontend) {};
@@ -111,15 +124,7 @@ rec {
111124 pathGit = ./.; # Used in CI by the migration graph hash algorithm to correctly ignore files.
112125 path = reflex-platform.filterGit ./.;
113126 obelisk = ghcObelisk;
114− commandWithMigration = ghcObelisk.obelisk-command.overrideAttrs (drv: {
115− postInstall = (drv.postInstall or "") +
116− ''cp -r ${./migration} $out/migration;'';
117− });
118− command = pkgs.runCommand commandWithMigration.name { nativeBuildInputs = [pkgs.makeWrapper]; } ''
119− mkdir -p "$out/bin"
120− ln -s '${commandWithMigration}/bin/ob' "$out/bin/ob"
121− wrapProgram "$out"/bin/ob --prefix PATH : ${pkgs.lib.makeBinPath (commandRuntimeDeps pkgs)}
122− '';
127+ command = ghcObelisk.obelisk-command;
123128 shell = pinBuildInputs "obelisk-shell" ([command] ++ commandRuntimeDeps pkgs) [];
124129
125130 selftest = pkgs.writeScript "selftest" ''
@@ -236,7 +241,7 @@ rec {
236241 ln -s ${mkAssets (compressedJs frontend)} $out/frontend.jsexe.assets
237242 '';
238243
239− server = { exe, hostName, adminEmail, routeHost, enableHttps }@args:
244+ server = { exe, hostName, adminEmail, routeHost, enableHttps, config }@args:
240245 let
241246 nixos = import (pkgs.path + /nixos);
242247 in nixos {
dep/reflex-platform/github.json+3−3
@@ -1,7 +1,7 @@
11{
22 "owner": "reflex-frp",
33 "repo": "reflex-platform",
4− "branch": "template-haskell",
5− "rev": "975e98d984b8acbe1eda04cb60fede46b13e6f9b",
6− "sha256": "0ri7ll9c5k9pp213jrr4hka5vi4dwpxxa0pxh54gcvz7qsaj247a"
4+ "branch": "develop",
5+ "rev": "2f09cea8aea453969172fe1f499905af5afb4719",
6+ "sha256": "1v7v2fwahq4mcywjvg1i44jyqimpxd4kgn4x4a24lcdgw9yll9wg"
77}
lib/command/src/Obelisk/Command/Project.hs+1−1
@@ -110,7 +110,7 @@ initProject source = withSystemTempDirectory "ob-init" $ \tmpDir -> do
110110--TODO: Allow the user to ignore our security concerns
111111-- | Find the Obelisk implementation for the project at the given path
112112findProjectObeliskCommand :: MonadObelisk m => FilePath -> m (Maybe FilePath)
113−findProjectObeliskCommand target = withSpinnerNoTrail "Locating project obelisk" $ do
113+findProjectObeliskCommand target = do
114114 myUid <- liftIO getRealUserID
115115 targetStat <- liftIO $ getFileStatus target
116116 (result, insecurePaths) <- flip runStateT [] $ walkToProjectRoot target targetStat myUid >>= \case
lib/executable-config/default.nix+2−1
@@ -7,7 +7,8 @@
77}:
88let injectConfig = config: assets: nixpkgs.runCommand "inject-config" {} ''
99 set -x
10− cp -a "${assets}" $out
10+ mkdir -p $out
11+ cp --no-preserve=mode -Lr "${assets}" $out/static
1112 chmod +w "$out"
1213 if ! mkdir $out/config; then
1314 2>&1 echo config directory already exists or could not be created
lib/frontend/src/Obelisk/Frontend.hs−4
@@ -149,10 +149,6 @@ runFrontend validFullEncoder frontend = do
149149 mapRoutedT (mapSetRouteT appendHead) $ _frontend_head frontend
150150 mapRoutedT (mapSetRouteT appendBody) $ _frontend_body frontend
151151
152−instance PrimMonad m => PrimMonad (EventWriterT t w m) where
153− type PrimState (EventWriterT t w m) = PrimState m
154− primitive = lift . primitive
155−
156152renderFrontendHtml
157153 :: (t ~ SpiderTimeline Global)
158154 => r
lib/route/src/Obelisk/Route.hs+13−7
@@ -21,7 +21,8 @@ module Obelisk.Route
2121 , pattern (:/)
2222 , PageName
2323 , PathQuery
24− , Encoder (..)
24+ , Encoder
25+ , unsafeEncoder
2526 , checkEncoder
2627 , EncoderImpl (..)
2728 , EncoderFunc (..)
@@ -156,6 +157,9 @@ mapSome f (Some.This a) = Some.This $ f a
156157newtype Encoder check parse decoded encoded =
157158 Encoder { unEncoder :: check (EncoderImpl parse decoded encoded) }
158159
160+unsafeEncoder :: check (EncoderImpl parse decoded encoded) -> Encoder check parse decoded encoded
161+unsafeEncoder = Encoder
162+
159163-- | The internal type used to construct primitive 'Encoder' values.
160164-- Law:
161165-- forall p. _encoderImpl_decode ve . _encoderImpl_encode ve p == pure
@@ -362,7 +366,7 @@ pathComponentEncoder
362366 -> Encoder check parse (R p) PageName
363367pathComponentEncoder f = Encoder $ do
364368 let extractEncoder = \case
365− PathEnd e -> first (unitEncoder []) . coidl . e
369+ PathEnd e -> first (unitEncoder []) . coidl . e
366370 PathSegment _ e -> e
367371 extractPathSegment = \case
368372 PathEnd _ -> Nothing
@@ -701,16 +705,18 @@ obeliskRouteEncoder :: forall check parse appRoute.
701705 )
702706 => (forall a. appRoute a -> SegmentResult check parse a)
703707 -> Encoder check parse (R (ObeliskRoute appRoute)) PageName
704−obeliskRouteEncoder appRouteSegment = pathComponentEncoder (obeliskRouteSegment appRouteSegment)
708+obeliskRouteEncoder appRouteSegment = pathComponentEncoder $ \r ->
709+ obeliskRouteSegment r appRouteSegment
705710
706711-- | From a function which explains how app-specific frontend routes translate into segments, produce a function which does the
707712-- same for ObeliskRoute. This uses the given function for the 'ObeliskRoute_App' case, and 'resourceRouteSegment' for the
708713-- 'ObeliskRoute_Resource' case.
709−obeliskRouteSegment :: forall check parse appRoute.
714+obeliskRouteSegment :: forall check parse appRoute a.
710715 (MonadError Text check, MonadError Text parse)
711− => (forall a. appRoute a -> SegmentResult check parse a)
712− -> (forall a. ObeliskRoute appRoute a -> SegmentResult check parse a)
713−obeliskRouteSegment appRouteSegment = \case
716+ => ObeliskRoute appRoute a
717+ -> (forall a. appRoute a -> SegmentResult check parse a)
718+ -> SegmentResult check parse a
719+obeliskRouteSegment r appRouteSegment = case r of
714720 ObeliskRoute_App appRoute -> appRouteSegment appRoute
715721 ObeliskRoute_Resource resourceRoute -> resourceRouteSegment resourceRoute
716722
lib/route/src/Obelisk/Route/Frontend.hs+33−7
@@ -74,6 +74,10 @@ import Language.Javascript.JSaddle --TODO: Get rid of this - other platforms can
7474import Reflex.Dom.Core
7575import qualified GHCJS.DOM.Types as DOM
7676import Network.URI
77+#if defined(ios_HOST_OS)
78+import Data.Maybe (fromMaybe)
79+import qualified Data.List as L
80+#endif
7781
7882import Unsafe.Coerce
7983
@@ -201,7 +205,7 @@ class Reflex t => SetRoute t r m | m -> t r where
201205instance (Reflex t, Monad m) => SetRoute t r (SetRouteT t r m) where
202206 modifyRoute = SetRouteT . tellEvent . fmap Endo
203207
204−instance (Monad m, SetRoute t r m) => SetRoute t r (RoutedT t r m) where
208+instance (Monad m, SetRoute t r m) => SetRoute t r (RoutedT t r' m) where
205209 modifyRoute = lift . modifyRoute
206210
207211instance Prerender js m => Prerender js (SetRouteT t r m) where
@@ -266,12 +270,12 @@ runRouteViewT routeEncoder a = do
266270 -- is nonempty, but begins with a character that isn't '?'. Since we don't expect
267271 -- this ever to happen, we'll just handle it by failing completely with 'error'.
268272 route :: Dynamic t r
269− route = fmap (errorLeft . tryDecode theEncoder . (uriPath &&& uriQuery) . _historyItem_uri) historyState
273+ route = fmap (errorLeft . tryDecode theEncoder . (adaptedUriPath &&& uriQuery) . _historyItem_uri) historyState
270274 where
271275 errorLeft (Left e) = error (T.unpack e)
272276 errorLeft (Right x) = x
273277 (result, changeState) <- runSetRouteT $ runRoutedT a route
274− let f oldRoute change =
278+ let f (currentHistoryState, oldRoute) change =
275279 let newRoute = appEndo change oldRoute
276280 (newPath, newQuery) = encode theEncoder newRoute
277281 in HistoryStateUpdate
@@ -287,10 +291,32 @@ runRouteViewT routeEncoder a = do
287291 -- we can change this function later to accommodate.
288292 -- See: https://github.com/whatwg/html/issues/2174
289293 , _historyStateUpdate_title = ""
290− , _historyStateUpdate_uri = Just $ nullURI
291− { uriPath = newPath
292− , uriQuery = newQuery
294+ , _historyStateUpdate_uri = Just $ setAdaptedUriPath newPath $ (_historyItem_uri currentHistoryState)
295+ { uriQuery = newQuery
293296 }
294297 }
295− setState = attachWith f (current route) changeState
298+ setState = attachWith f ((,) <$> current historyState <*> current route) changeState
296299 return result
300+
301+-- On ios due to sandboxing when loading the page from a file adapt the
302+-- path to be based on the hash.
303+
304+adaptedUriPath :: URI -> String
305+#if defined(ios_HOST_OS)
306+adaptedUriPath = hashToPath . uriFragment
307+
308+hashToPath :: String -> String
309+hashToPath = ('/' :) . fromMaybe "" . L.stripPrefix "#"
310+#else
311+adaptedUriPath = uriPath
312+#endif
313+
314+setAdaptedUriPath :: String -> URI -> URI
315+#if defined(ios_HOST_OS)
316+setAdaptedUriPath s u = u { uriFragment = pathToHash s }
317+
318+pathToHash :: String -> String
319+pathToHash = ('#' :) . fromMaybe "" . L.stripPrefix "/"
320+#else
321+setAdaptedUriPath s u = u { uriPath = s }
322+#endif
skeleton/common/src/Common/Route.hs+5−9
@@ -17,7 +17,6 @@ import Prelude hiding (id, (.))
1717import Control.Category
1818-}
1919
20−import Control.Monad.Except
2120import Data.Text (Text)
2221import Data.Functor.Identity
2322import Data.Functor.Sum
@@ -41,16 +40,13 @@ backendRouteEncoder = handleEncoder (const (InL BackendRoute_Missing :/ ())) $
4140 pathComponentEncoder $ \case
4241 InL backendRoute -> case backendRoute of
4342 BackendRoute_Missing -> PathSegment "missing" $ unitEncoder mempty
44− InR obeliskRoute -> obeliskRouteSegment frontendRouteSegment obeliskRoute
43+ InR obeliskRoute -> obeliskRouteSegment obeliskRoute $ \case
44+ -- The encoder given to PathEnd determines how to parse query parameters,
45+ -- in this example, we have none, so we insist on it.
46+ FrontendRoute_Main -> PathEnd $ unitEncoder mempty
4547
46−frontendRouteSegment :: (Applicative check, MonadError Text parse)
47− => FrontendRoute a -> SegmentResult check parse a
48−frontendRouteSegment = \case
49− FrontendRoute_Main -> PathEnd $ unitEncoder mempty
50− -- The encoder given to PathEnd determines how to parse query parameters,
51− -- in this example, we have none, so we insist on it.
5248
5349concat <$> mapM deriveRouteComponent
5450 [ ''BackendRoute
5551 , ''FrontendRoute
56− ]
52+ ]